src/HOL/Tools/BNF/bnf_gfp_grec.ML
author blanchet
Mon, 24 Oct 2016 20:32:02 +0200
changeset 64382 2a75139b5931
parent 63859 dca6fabd8060
child 64627 8d7cb22482e3
permissions -rw-r--r--
more accurate error message
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     1
(*  Title:      HOL/Tools/BNF/bnf_gfp_grec.ML
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     2
    Author:     Jasmin Blanchette, Inria, LORIA, MPII
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     3
    Author:     Aymeric Bouzy, Ecole polytechnique
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     4
    Author:     Dmitriy Traytel, ETH Z├╝rich
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     5
    Copyright   2015, 2016
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     6
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     7
Generalized corecursor construction.
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     8
*)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
     9
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    10
signature BNF_GFP_GREC =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    11
sig
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    12
  val Tsubst: typ -> typ -> typ -> typ
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    13
  val substT: typ -> typ -> term -> term
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    14
  val freeze_types: Proof.context -> (indexname * sort) list -> typ list -> typ list
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    15
  val dummify_atomic_types: term -> term
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    16
  val define_const: bool -> binding -> int -> string -> term -> local_theory ->
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    17
    (term * thm) * local_theory
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    18
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    19
  type buffer =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    20
    {Oper: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    21
     VLeaf: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    22
     CLeaf: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    23
     ctr_wrapper: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    24
     friends: (typ * term) Symtab.table}
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    25
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    26
  val map_buffer: (term -> term) -> buffer -> buffer
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    27
  val specialize_buffer_types: buffer -> buffer
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    28
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    29
  type dtor_coinduct_info =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    30
    {dtor_coinduct: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    31
     cong_def: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    32
     cong_locale: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    33
     cong_base: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    34
     cong_refl: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    35
     cong_sym: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    36
     cong_trans: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    37
     cong_alg_intros: thm list}
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    38
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    39
  type corec_info =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    40
    {fp_b: binding,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    41
     version: int,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    42
     fpT: typ,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    43
     Y: typ,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    44
     Z: typ,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    45
     friend_names: string list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    46
     sig_fp_sugars: BNF_FP_Def_Sugar.fp_sugar list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    47
     ssig_fp_sugar: BNF_FP_Def_Sugar.fp_sugar,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    48
     Lam: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    49
     proto_sctr: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    50
     flat: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    51
     eval_core: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    52
     eval: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    53
     algLam: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    54
     corecUU: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    55
     dtor_transfer: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    56
     Lam_transfer: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    57
     Lam_pointful_natural: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    58
     proto_sctr_transfer: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    59
     flat_simps: thm list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    60
     eval_core_simps: thm list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    61
     eval_thm: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    62
     eval_simps: thm list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    63
     all_algLam_algs: thm list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    64
     algLam_thm: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    65
     dtor_algLam: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    66
     corecUU_thm: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    67
     corecUU_unique: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    68
     corecUU_transfer: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    69
     buffer: buffer,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    70
     all_dead_k_bnfs: BNF_Def.bnf list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    71
     Retr: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    72
     equivp_Retr: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    73
     Retr_coinduct: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    74
     dtor_coinduct_info: dtor_coinduct_info}
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    75
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    76
  type friend_info =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    77
    {algrho: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    78
     dtor_algrho: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    79
     algLam_algrho: thm}
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    80
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    81
  val not_codatatype: Proof.context -> typ -> 'a
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    82
  val mk_fp_binding: binding -> string -> binding
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    83
  val bnf_kill_all_but: int -> BNF_Def.bnf -> local_theory -> BNF_Def.bnf * local_theory
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    84
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    85
  val print_corec_infos: Proof.context -> unit
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    86
  val has_no_corec_info: Proof.context -> string -> bool
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    87
  val corec_info_of: typ -> local_theory -> corec_info * local_theory
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    88
  val maybe_corec_info_of: Proof.context -> typ -> corec_info option
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    89
  val corec_infos_of: Proof.context -> string -> corec_info list
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    90
  val corec_infos_of_generic: Context.generic -> Symtab.key -> corec_info list
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    91
  val prepare_friend_corec: string -> typ -> local_theory ->
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    92
    (corec_info * binding * int * typ * typ * typ * typ * typ * BNF_Def.bnf * BNF_Def.bnf
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    93
     * BNF_FP_Def_Sugar.fp_sugar * BNF_FP_Def_Sugar.fp_sugar * buffer) * local_theory
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    94
  val register_friend_corec: string -> binding -> int -> typ -> typ -> typ -> BNF_Def.bnf ->
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    95
    BNF_FP_Def_Sugar.fp_sugar -> BNF_FP_Def_Sugar.fp_sugar -> term -> term -> thm -> corec_info ->
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    96
    local_theory -> friend_info * local_theory
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    97
end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    98
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
    99
structure BNF_GFP_Grec : BNF_GFP_GREC =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   100
struct
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   101
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   102
open Ctr_Sugar
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   103
open BNF_Util
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   104
open BNF_Def
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   105
open BNF_Comp
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   106
open BNF_FP_Util
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   107
open BNF_LFP
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   108
open BNF_FP_Def_Sugar
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   109
open BNF_LFP_Rec_Sugar
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   110
open BNF_GFP_Grec_Tactics
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   111
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   112
val algLamN = "algLam";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   113
val algLam_algLamN = "algLam_algLam";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   114
val algLam_algrhoN = "algLam_algrho";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   115
val algrhoN = "algrho";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   116
val CLeafN = "CLeaf";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   117
val congN = "congclp";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   118
val cong_alg_introsN = "cong_alg_intros";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   119
val cong_localeN = "cong_locale";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   120
val corecUUN = "corecUU";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   121
val corecUU_transferN = "corecUU_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   122
val corecUU_uniqueN = "corecUU_unique";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   123
val cutSsigN = "cutSsig";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   124
val dtor_algLamN = "dtor_algLam";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   125
val dtor_algrhoN = "dtor_algrho";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   126
val dtor_coinductN = "dtor_coinduct";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   127
val dtor_transferN = "dtor_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   128
val embLN = "embL";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   129
val embLLN = "embLL";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   130
val embLRN = "embLR";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   131
val embL_pointful_naturalN = "embL_pointful_natural";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   132
val embL_transferN = "embL_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   133
val equivp_RetrN = "equivp_Retr";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   134
val evalN = "eval";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   135
val eval_coreN = "eval_core";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   136
val eval_core_pointful_naturalN = "eval_core_pointful_natural";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   137
val eval_core_transferN = "eval_core_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   138
val eval_flatN = "eval_flat";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   139
val eval_simpsN = "eval_simps";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   140
val flatN = "flat";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   141
val flat_pointful_naturalN = "flat_pointful_natural";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   142
val flat_transferN = "flat_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   143
val k_as_ssig_naturalN = "k_as_ssig_natural";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   144
val k_as_ssig_transferN = "k_as_ssig_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   145
val LamN = "Lam";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   146
val Lam_transferN = "Lam_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   147
val Lam_pointful_naturalN = "Lam_pointful_natural";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   148
val OperN = "Oper";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   149
val proto_sctrN = "proto_sctr";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   150
val proto_sctr_pointful_naturalN = "proto_sctr_pointful_natural";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   151
val proto_sctr_transferN = "proto_sctr_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   152
val rho_transferN = "rho_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   153
val Retr_coinductN = "Retr_coinduct";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   154
val sctrN = "sctr";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   155
val sctr_transferN = "sctr_transfer";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   156
val sctr_pointful_naturalN = "sctr_pointful_natural";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   157
val sigN = "sig";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   158
val SigN = "Sig";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   159
val Sig_pointful_naturalN = "Sig_pointful_natural";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   160
val corecUN = "corecU";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   161
val corecU_ctorN = "corecU_ctor";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   162
val corecU_uniqueN = "corecU_unique";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   163
val unsigN = "unsig";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   164
val VLeafN = "VLeaf";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   165
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   166
val s_prefix = "s"; (* transforms "sig" into "ssig" *)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   167
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   168
fun not_codatatype ctxt T =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   169
  error ("Not a codatatype: " ^ Syntax.string_of_typ ctxt T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   170
fun mutual_codatatype () =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   171
  error ("Mutually corecursive codatatypes are not supported (try " ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   172
    quote (#1 @{command_keyword primcorec}) ^ " instead of " ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   173
    quote (#1 @{command_keyword corec}) ^ ")");
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   174
fun noncorecursive_codatatype () =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   175
  error ("Noncorecursive codatatypes are not supported (try " ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   176
    quote (#1 @{command_keyword definition}) ^ " instead of " ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   177
    quote (#1 @{command_keyword corec}) ^ ")");
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   178
fun singleton_codatatype ctxt =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   179
  error ("Singleton corecursive codatatypes are not supported (use " ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   180
    quote (Syntax.string_of_typ ctxt @{typ unit}) ^ " instead)");
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   181
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   182
fun merge_lists eq old1 old2 = (old1 |> subtract eq old2) @ old2;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   183
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   184
fun add_type_namesT (Type (s, Ts)) = insert (op =) s #> fold add_type_namesT Ts
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   185
  | add_type_namesT _ = I;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   186
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   187
fun Tsubst Y T = Term.typ_subst_atomic [(Y, T)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   188
fun substT Y T = Term.subst_atomic_types [(Y, T)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   189
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   190
fun freeze_types ctxt except_tvars Ts =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   191
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   192
    val As = fold Term.add_tvarsT Ts [] |> subtract (op =) except_tvars;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   193
    val (Bs, _) = ctxt |> mk_TFrees' (map snd As);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   194
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   195
    map (Term.typ_subst_TVars (map fst As ~~ Bs)) Ts
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   196
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   197
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   198
fun typ_unify_disjointly thy (T, T') =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   199
  if T = T' then
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   200
    T
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   201
  else
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   202
    let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   203
      val tvars = Term.add_tvar_namesT T [];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   204
      val tvars' = Term.add_tvar_namesT T' [];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   205
      val maxidx' = maxidx_of_typ T';
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   206
      val T = T |> exists (member (op =) tvars') tvars ? Logic.incr_tvar (maxidx' + 1);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   207
      val maxidx = Integer.max (maxidx_of_typ T) maxidx';
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   208
      val (tyenv, _) = Sign.typ_unify thy (T, T') (Vartab.empty, maxidx);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   209
    in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   210
      Envir.subst_type tyenv T
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   211
    end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   212
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   213
val dummify_atomic_types = Term.map_types (Term.map_atyps (K Term.dummyT));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   214
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   215
fun mk_internal internal ctxt f =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   216
  if internal andalso not (Config.get ctxt bnf_internals) then f else I
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   217
fun mk_fp_binding fp_b pre = Binding.map_name (K pre) fp_b
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   218
  |> Binding.qualify true (Binding.name_of fp_b);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   219
fun mk_version_binding version = Binding.qualify false ("v" ^ string_of_int version);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   220
fun mk_version_fp_binding internal ctxt =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   221
  mk_internal internal ctxt Binding.concealed ooo (mk_fp_binding oo mk_version_binding);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   222
(*FIXME: get rid of ugly names when typedef and primrec respect qualification*)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   223
fun mk_version_binding_ugly version = Binding.suffix_name ("_v" ^ string_of_int version);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   224
fun mk_version_fp_binding_ugly internal ctxt version fp_b pre =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   225
  Binding.prefix_name (pre ^ "_") fp_b
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   226
  |> mk_version_binding_ugly version
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   227
  |> mk_internal internal ctxt Binding.concealed;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   228
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   229
fun mk_mapN ctxt live_AsBs TA bnf =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   230
  let val TB = Term.typ_subst_atomic live_AsBs TA in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   231
    enforce_type ctxt (snd o strip_typeN (length live_AsBs)) (TA --> TB) (map_of_bnf bnf)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   232
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   233
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   234
fun mk_relN ctxt live_AsBs TA bnf =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   235
  let val TB = Term.typ_subst_atomic live_AsBs TA in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   236
    enforce_type ctxt (snd o strip_typeN (length live_AsBs)) (mk_pred2T TA TB) (rel_of_bnf bnf)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   237
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   238
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   239
fun mk_map1 ctxt Y Z = mk_mapN ctxt [(Y, Z)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   240
fun mk_rel1 ctxt Y Z = mk_relN ctxt [(Y, Z)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   241
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   242
fun define_const internal fp_b version name rhs lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   243
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   244
    val b = mk_version_fp_binding internal lthy version fp_b name;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   245
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   246
    val ((free, (_, def_free)), (lthy, lthy_old)) = lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   247
      |> Local_Theory.open_target |> snd
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   248
      |> Local_Theory.define ((b, NoSyn), ((Thm.def_binding b |> Binding.concealed, []), rhs))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   249
      ||> `Local_Theory.close_target;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   250
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   251
    val phi = Proof_Context.export_morphism lthy_old lthy;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   252
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   253
    val const = Morphism.term phi free;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   254
    val const' = enforce_type lthy I (fastype_of free) const;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   255
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   256
    ((const', Morphism.thm phi def_free), lthy)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   257
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   258
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   259
fun define_single_primrec b eqs lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   260
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   261
    val (([free], [def_free], [simps_free]), (lthy, lthy_old)) = lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   262
      |> Local_Theory.open_target |> snd
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   263
      |> Local_Theory.map_background_naming (mk_internal true lthy Name_Space.concealed) (*TODO check*)
63719
9084d77f1119 tuned signature
traytel
parents: 63691
diff changeset
   264
      |> primrec [] [(b, NONE, NoSyn)] (map (fn eq => ((Binding.empty_atts, eq), [], [])) eqs)
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   265
      ||> `Local_Theory.close_target;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   266
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   267
    val phi = Proof_Context.export_morphism lthy_old lthy;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   268
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   269
    val const = Morphism.term phi free;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   270
    val const' = enforce_type lthy I (fastype_of free) const;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   271
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   272
    ((const', Morphism.thm phi def_free, map (Morphism.thm phi) simps_free), lthy)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   273
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   274
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   275
type buffer =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   276
  {Oper: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   277
   VLeaf: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   278
   CLeaf: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   279
   ctr_wrapper: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   280
   friends: (typ * term) Symtab.table};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   281
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   282
fun map_buffer f {Oper, VLeaf, CLeaf, ctr_wrapper, friends} =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   283
  {Oper = f Oper, VLeaf = f VLeaf, CLeaf = f CLeaf, ctr_wrapper = f ctr_wrapper,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   284
   friends = Symtab.map (K (apsnd f)) friends};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   285
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   286
fun morph_buffer phi = map_buffer (Morphism.term phi);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   287
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   288
fun specialize_buffer_types {Oper, VLeaf, CLeaf, ctr_wrapper, friends} =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   289
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   290
    val ssig_T as Type (_, Ts) = body_type (fastype_of VLeaf);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   291
    val Y = List.last Ts;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   292
    val ssigifyT = substT Y ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   293
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   294
    {Oper = Oper, VLeaf = VLeaf, CLeaf = CLeaf, ctr_wrapper = ssigifyT ctr_wrapper,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   295
     friends = Symtab.map (K (apsnd ssigifyT)) friends}
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   296
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   297
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   298
type dtor_coinduct_info =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   299
  {dtor_coinduct: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   300
   cong_def: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   301
   cong_locale: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   302
   cong_base: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   303
   cong_refl: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   304
   cong_sym: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   305
   cong_trans: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   306
   cong_alg_intros: thm list};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   307
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   308
fun map_dtor_coinduct_info f {dtor_coinduct, cong_def, cong_locale, cong_base, cong_refl, cong_sym,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   309
    cong_trans, cong_alg_intros} =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   310
  {dtor_coinduct = f dtor_coinduct, cong_def = f cong_def, cong_locale = f cong_locale,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   311
   cong_base = f cong_base, cong_refl = f cong_refl, cong_sym = f cong_sym,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   312
   cong_trans = f cong_trans, cong_alg_intros = map f cong_alg_intros};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   313
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   314
fun morph_dtor_coinduct_info phi = map_dtor_coinduct_info (Morphism.thm phi);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   315
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   316
type corec_ad =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   317
  {fpT: typ,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   318
   friend_names: string list};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   319
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   320
fun morph_corec_ad phi {fpT, friend_names} =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   321
  {fpT = Morphism.typ phi fpT, friend_names = friend_names};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   322
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   323
type corec_info =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   324
  {fp_b: binding,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   325
   version: int,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   326
   fpT: typ,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   327
   Y: typ,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   328
   Z: typ,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   329
   friend_names: string list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   330
   sig_fp_sugars: fp_sugar list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   331
   ssig_fp_sugar: fp_sugar,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   332
   Lam: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   333
   proto_sctr: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   334
   flat: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   335
   eval_core: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   336
   eval: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   337
   algLam: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   338
   corecUU: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   339
   dtor_transfer: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   340
   Lam_transfer: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   341
   Lam_pointful_natural: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   342
   proto_sctr_transfer: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   343
   flat_simps: thm list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   344
   eval_core_simps: thm list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   345
   eval_thm: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   346
   eval_simps: thm list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   347
   all_algLam_algs: thm list,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   348
   algLam_thm: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   349
   dtor_algLam: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   350
   corecUU_thm: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   351
   corecUU_unique: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   352
   corecUU_transfer: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   353
   buffer: buffer,
62746
blanchet
parents: 62729
diff changeset
   354
   all_dead_k_bnfs: bnf list,
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   355
   Retr: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   356
   equivp_Retr: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   357
   Retr_coinduct: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   358
   dtor_coinduct_info: dtor_coinduct_info};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   359
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   360
fun morph_corec_info phi
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   361
    ({fp_b, version, fpT, Y, Z, friend_names, sig_fp_sugars, ssig_fp_sugar, Lam, proto_sctr, flat,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   362
      eval_core, eval, algLam, corecUU, dtor_transfer, Lam_transfer, Lam_pointful_natural,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   363
      proto_sctr_transfer, flat_simps, eval_core_simps, eval_thm, eval_simps, all_algLam_algs,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   364
      algLam_thm, dtor_algLam, corecUU_thm, corecUU_unique, corecUU_transfer, buffer,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   365
      all_dead_k_bnfs, Retr, equivp_Retr, Retr_coinduct, dtor_coinduct_info} : corec_info) =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   366
  {fp_b = fp_b, version = version, fpT = Morphism.typ phi fpT, Y = Morphism.typ phi Y,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   367
   Z = Morphism.typ phi Z, friend_names = friend_names, sig_fp_sugars = sig_fp_sugars (*no morph*),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   368
   ssig_fp_sugar = ssig_fp_sugar (*no morph*), Lam = Morphism.term phi Lam,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   369
   proto_sctr = Morphism.term phi proto_sctr, flat = Morphism.term phi flat,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   370
   eval_core = Morphism.term phi eval_core, eval = Morphism.term phi eval,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   371
   algLam = Morphism.term phi algLam, corecUU = Morphism.term phi corecUU,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   372
   dtor_transfer = dtor_transfer, Lam_transfer = Morphism.thm phi Lam_transfer,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   373
   Lam_pointful_natural = Morphism.thm phi Lam_pointful_natural,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   374
   proto_sctr_transfer = Morphism.thm phi proto_sctr_transfer,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   375
   flat_simps = map (Morphism.thm phi) flat_simps,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   376
   eval_core_simps = map (Morphism.thm phi) eval_core_simps, eval_thm = Morphism.thm phi eval_thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   377
   eval_simps = map (Morphism.thm phi) eval_simps,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   378
   all_algLam_algs = map (Morphism.thm phi) all_algLam_algs,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   379
   algLam_thm = Morphism.thm phi algLam_thm, dtor_algLam = Morphism.thm phi dtor_algLam,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   380
   corecUU_thm = Morphism.thm phi corecUU_thm, corecUU_unique = Morphism.thm phi corecUU_unique,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   381
   corecUU_transfer = Morphism.thm phi corecUU_transfer, buffer = morph_buffer phi buffer,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   382
   all_dead_k_bnfs = map (morph_bnf phi) all_dead_k_bnfs, Retr = Morphism.term phi Retr,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   383
   equivp_Retr = Morphism.thm phi equivp_Retr, Retr_coinduct = Morphism.thm phi Retr_coinduct,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   384
   dtor_coinduct_info = morph_dtor_coinduct_info phi dtor_coinduct_info};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   385
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   386
datatype ('a, 'b) expr =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   387
  Ad of 'a * (local_theory -> 'b * local_theory) |
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   388
  Info of 'b;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   389
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   390
fun is_Ad (Ad _) = true
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   391
  | is_Ad _ = false;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   392
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   393
fun is_Info (Info _) = true
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   394
  | is_Info _ = false;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   395
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   396
type corec_info_expr = (corec_ad, corec_info) expr;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   397
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   398
fun morph_corec_info_expr phi (Ad (ad, f)) = Ad (morph_corec_ad phi ad, f)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   399
  | morph_corec_info_expr phi (Info info) = Info (morph_corec_info phi info);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   400
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   401
val transfer_corec_info_expr = morph_corec_info_expr o Morphism.transfer_morphism;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   402
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   403
type corec_data = int Symtab.table * corec_info_expr list Symtab.table list;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   404
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   405
structure Data = Generic_Data
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   406
(
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   407
  type T = corec_data;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   408
  val empty = (Symtab.empty, [Symtab.empty]);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   409
  val extend = I;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   410
  fun merge ((version_tab1, info_tabs1), (version_tab2, info_tabs2)) : T =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   411
    (Symtab.join (K Int.max) (version_tab1, version_tab2), info_tabs1 @ info_tabs2);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   412
);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   413
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   414
fun corec_ad_of_expr (Ad (ad, _)) = ad
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   415
  | corec_ad_of_expr (Info {fpT, friend_names, ...}) = {fpT = fpT, friend_names = friend_names};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   416
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   417
fun corec_info_exprs_of_generic context fpT_name =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   418
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   419
    val thy = Context.theory_of context;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   420
    val info_tabs = snd (Data.get context);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   421
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   422
    maps (fn info_tab => these (Symtab.lookup info_tab fpT_name)) info_tabs
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   423
    |> map (transfer_corec_info_expr thy)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   424
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   425
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   426
val corec_info_exprs_of = corec_info_exprs_of_generic o Context.Proof;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   427
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   428
val keep_corec_infos = map_filter (fn Ad _ => NONE | Info info => SOME info);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   429
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   430
val corec_infos_of_generic = keep_corec_infos oo corec_info_exprs_of_generic;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   431
val corec_infos_of = keep_corec_infos oo corec_info_exprs_of;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   432
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   433
fun str_of_corec_ad ctxt {fpT, friend_names} =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   434
  "[" ^ Syntax.string_of_typ ctxt fpT ^ "; " ^ commas friend_names ^ "]";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   435
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   436
fun str_of_corec_info ctxt {fpT, version, friend_names, ...} =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   437
  "{" ^ Syntax.string_of_typ ctxt fpT ^ "; " ^ commas friend_names ^ "; v" ^ string_of_int version ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   438
  "}";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   439
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   440
fun str_of_corec_info_expr ctxt (Ad (ad, _)) = str_of_corec_ad ctxt ad
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   441
  | str_of_corec_info_expr ctxt (Info info) = str_of_corec_info ctxt info;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   442
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   443
fun print_corec_infos ctxt =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   444
  Symtab.fold (fn (fpT_name, exprs) => fn () =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   445
      writeln (fpT_name ^ ":\n" ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   446
        cat_lines (map (prefix "  " o str_of_corec_info_expr ctxt) exprs)))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   447
    (the_single (snd (Data.get (Context.Proof ctxt)))) ();
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   448
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   449
val has_no_corec_info = null oo corec_info_exprs_of;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   450
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   451
fun get_name_next_version_of fpT_name ctxt =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   452
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   453
    val (version_tab, info_tabs) = Data.get (Context.Theory (Proof_Context.theory_of ctxt));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   454
    val fp_base = Long_Name.base_name fpT_name;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   455
    val fp_b = Binding.name fp_base;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   456
    val version_tab' = Symtab.map_default (fp_base, ~1) (Integer.add 1) version_tab;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   457
    val SOME version = Symtab.lookup version_tab' fp_base;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   458
    val ctxt' = ctxt
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   459
      |> Local_Theory.background_theory (Context.theory_map (Data.put (version_tab', info_tabs)));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   460
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   461
    ((fp_b, version), ctxt')
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   462
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   463
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   464
type friend_info =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   465
  {algrho: term,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   466
   dtor_algrho: thm,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   467
   algLam_algrho: thm};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   468
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   469
fun morph_friend_info phi ({algrho, dtor_algrho, algLam_algrho} : friend_info) =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   470
  {algrho = Morphism.term phi algrho, dtor_algrho = Morphism.thm phi dtor_algrho,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   471
   algLam_algrho = Morphism.thm phi algLam_algrho};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   472
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   473
fun checked_fp_sugar_of ctxt fpT_name =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   474
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   475
    val fp_sugar as {X, fp_res = {Ts = fpTs, ...}, fp_ctr_sugar = {ctrXs_Tss, ...}, ...} =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   476
      (case fp_sugar_of ctxt fpT_name of
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   477
        SOME (fp_sugar as {fp = Greatest_FP, ...}) => fp_sugar
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   478
      | _ => not_codatatype ctxt (Type (fpT_name, [] (*yuck*))));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   479
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   480
    val _ =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   481
      if length fpTs > 1 then
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   482
        mutual_codatatype ()
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   483
      else if not (exists (exists (Term.exists_subtype (curry (op =) X))) ctrXs_Tss) then
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   484
        noncorecursive_codatatype ()
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   485
      else if ctrXs_Tss = [[X]] then
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   486
        singleton_codatatype ctxt
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   487
      else
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   488
        ();
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   489
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   490
    fp_sugar
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   491
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   492
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   493
fun bnf_kill_all_but nn bnf lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   494
  ((empty_comp_cache, empty_unfolds), lthy)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   495
  |> kill_bnf I (live_of_bnf bnf - nn) bnf
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   496
  ||> snd;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   497
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   498
fun bnf_with_deads_and_lives dead_Es live_As Y fpT T lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   499
   let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   500
     val qsoty = quote o Syntax.string_of_typ lthy;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   501
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   502
     val unfreeze_fp = Tsubst Y fpT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   503
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   504
    fun flatten_tyargs Ass =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   505
      map dest_TFree live_As
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   506
      |> filter (fn T => exists (fn Ts => member (op =) Ts T) Ass);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   507
63845
61a03e429cbd generalized code towards nonuniform (co)datatypes
blanchet
parents: 63824
diff changeset
   508
    val ((bnf, _), (_, lthy)) =
61a03e429cbd generalized code towards nonuniform (co)datatypes
blanchet
parents: 63824
diff changeset
   509
      bnf_of_typ false Do_Inline I flatten_tyargs [Term.dest_TFree Y] (map Term.dest_TFree dead_Es)
61a03e429cbd generalized code towards nonuniform (co)datatypes
blanchet
parents: 63824
diff changeset
   510
        T ((empty_comp_cache, empty_unfolds), lthy)
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   511
      handle BAD_DEAD (Y, Y_backdrop) =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   512
        (case Y_backdrop of
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   513
          Type (bad_tc, _) =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   514
          let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   515
            val T = qsoty (unfreeze_fp Y);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   516
            val T_backdrop = qsoty (unfreeze_fp Y_backdrop);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   517
            fun register_hint () =
63342
wenzelm
parents: 63222
diff changeset
   518
              "\nUse the " ^ quote (#1 @{command_keyword bnf}) ^ " command to register " ^
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   519
              quote bad_tc ^ " as a bounded natural functor to allow nested (co)recursion through \
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   520
              \it";
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   521
          in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   522
            if is_some (bnf_of lthy bad_tc) orelse is_some (fp_sugar_of lthy bad_tc) then
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   523
              error ("Inadmissible occurrence of type " ^ T ^ " in type expression " ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   524
                T_backdrop)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   525
            else
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   526
              error ("Unsupported occurrence of type " ^ T ^ " via type constructor " ^
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   527
                quote bad_tc ^ " in type expression " ^ T_backdrop ^ register_hint ())
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   528
          end);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   529
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   530
    val phi =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   531
      Morphism.term_morphism "BNF" (Raw_Simplifier.rewrite_term (Proof_Context.theory_of lthy)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   532
        @{thms BNF_Composition.id_bnf_def} [])
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   533
      $> Morphism.thm_morphism "BNF" (unfold_thms lthy @{thms BNF_Composition.id_bnf_def});
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   534
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   535
    (morph_bnf phi bnf, lthy)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   536
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   537
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   538
fun define_sig_type fp_b version fp_alives Es Y rhsT lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   539
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   540
    val T_b = mk_version_fp_binding_ugly true lthy version fp_b sigN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   541
    val ctr_b = mk_version_fp_binding false lthy version fp_b SigN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   542
    val sel_b = mk_version_fp_binding true lthy version fp_b unsigN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   543
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   544
    val lthy = Local_Theory.open_target lthy |> snd;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   545
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   546
    val T_name = Local_Theory.full_name lthy T_b;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   547
62699
add334b71e16 sorted out type issue with sort constraints
blanchet
parents: 62692
diff changeset
   548
    val tyargs = map2 (fn alive => fn T =>
add334b71e16 sorted out type issue with sort constraints
blanchet
parents: 62692
diff changeset
   549
        (if alive then SOME Binding.empty else NONE, (T, Type.sort_of_atyp T)))
add334b71e16 sorted out type issue with sort constraints
blanchet
parents: 62692
diff changeset
   550
      (fp_alives @ [true]) (Es @ [Y]);
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   551
    val ctr_specs = [(((Binding.empty, ctr_b), [(sel_b, rhsT)]), NoSyn)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   552
    val spec = (((((tyargs, T_b), NoSyn), ctr_specs),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   553
      (Binding.empty, Binding.empty, Binding.empty)), []);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   554
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   555
    val plugins = Plugin_Name.make_filter lthy (K (curry (op =) transfer_plugin));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   556
    val discs_sels = true;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   557
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   558
    val lthy = lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   559
      |> Local_Theory.map_background_naming (mk_internal true lthy Name_Space.concealed) (*TODO check*)
63800
6489d85ecc98 extended ML signature
blanchet
parents: 63719
diff changeset
   560
      |> with_typedef_threshold ~1
6489d85ecc98 extended ML signature
blanchet
parents: 63719
diff changeset
   561
        (co_datatypes Least_FP construct_lfp ((plugins, discs_sels), [spec]))
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   562
      |> Local_Theory.close_target;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   563
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   564
    val SOME fp_sugar = fp_sugar_of lthy T_name;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   565
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   566
    (fp_sugar, lthy)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   567
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   568
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   569
fun define_ssig_type fp_b version fp_alives Es Y fpT lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   570
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   571
    val sig_T_b = mk_version_fp_binding_ugly true lthy version fp_b sigN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   572
    val T_b = Binding.prefix_name s_prefix sig_T_b;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   573
    val Oper_b = mk_version_fp_binding false lthy version fp_b OperN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   574
    val VLeaf_b = mk_version_fp_binding false lthy version fp_b VLeafN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   575
    val CLeaf_b = mk_version_fp_binding false lthy version fp_b CLeafN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   576
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   577
    val lthy = Local_Theory.open_target lthy |> snd;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   578
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   579
    val sig_T_name = Local_Theory.full_name lthy sig_T_b;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   580
    val T_name = Long_Name.map_base_name (prefix s_prefix) sig_T_name;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   581
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   582
    val As = Es @ [Y];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   583
    val ssig_sig_T = Type (sig_T_name, Es @ [Type (T_name, As)]);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   584
62699
add334b71e16 sorted out type issue with sort constraints
blanchet
parents: 62692
diff changeset
   585
    val tyargs = map2 (fn alive => fn T =>
add334b71e16 sorted out type issue with sort constraints
blanchet
parents: 62692
diff changeset
   586
        (if alive then SOME Binding.empty else NONE, (T, Type.sort_of_atyp T)))
add334b71e16 sorted out type issue with sort constraints
blanchet
parents: 62692
diff changeset
   587
      (fp_alives @ [true]) (Es @ [Y]);
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   588
    val ctr_specs =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   589
      [(((Binding.empty, Oper_b), [(Binding.empty, ssig_sig_T)]), NoSyn),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   590
       (((Binding.empty, VLeaf_b), [(Binding.empty, Y)]), NoSyn),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   591
       (((Binding.empty, CLeaf_b), [(Binding.empty, fpT)]), NoSyn)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   592
    val spec = (((((tyargs, T_b), NoSyn), ctr_specs),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   593
      (Binding.empty, Binding.empty, Binding.empty)), []);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   594
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   595
    val plugins = Plugin_Name.make_filter lthy (K (curry (op =) transfer_plugin));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   596
    val discs_sels = false;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   597
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   598
    val lthy = lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   599
      |> Local_Theory.map_background_naming (mk_internal true lthy Name_Space.concealed) (*TODO check*)
63800
6489d85ecc98 extended ML signature
blanchet
parents: 63719
diff changeset
   600
      |> with_typedef_threshold ~1
6489d85ecc98 extended ML signature
blanchet
parents: 63719
diff changeset
   601
        (co_datatypes Least_FP construct_lfp ((plugins, discs_sels), [spec]))
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   602
      |> Local_Theory.close_target;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   603
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   604
    val SOME fp_sugar = fp_sugar_of lthy T_name;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   605
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   606
    (fp_sugar, lthy)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   607
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   608
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   609
fun embed_Sig ctxt Sig inl_or_r t =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   610
  Library.foldl1 HOLogic.mk_comp [Sig, inl_or_r, dummify_atomic_types t]
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   611
  |> Syntax.check_term ctxt;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   612
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   613
fun mk_ctr_wrapper_friends ctxt friend_name friend_T old_sig_T k_T Sig old_buffer =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   614
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   615
    val embed_Sig_inl = embed_Sig ctxt Sig (Inl_const old_sig_T k_T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   616
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   617
    val ctr_wrapper = embed_Sig_inl (#ctr_wrapper old_buffer);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   618
    val friends = Symtab.map (K (apsnd embed_Sig_inl)) (#friends old_buffer)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   619
      |> Symtab.update_new (friend_name, (friend_T,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   620
        HOLogic.mk_comp (Sig, Inr_const old_sig_T k_T)));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   621
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   622
    (ctr_wrapper, friends)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   623
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   624
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   625
fun pre_type_of_ctor Y ctor =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   626
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   627
    val (fp_preT, fpT) = dest_funT (fastype_of ctor);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   628
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   629
    typ_subst_nonatomic [(fpT, Y)] fp_preT
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   630
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   631
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   632
fun mk_k_as_ssig Z old_sig_T k_T ssig_T Sig dead_sig_map Oper VLeaf =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   633
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   634
    val inr' = Inr_const old_sig_T k_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   635
    val dead_sig_map' = substT Z ssig_T dead_sig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   636
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   637
    Library.foldl1 HOLogic.mk_comp [Oper, dead_sig_map' $ VLeaf, Sig, inr']
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   638
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   639
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   640
fun define_embL name fp_b version Y Z fpT old_sig_T old_ssig_T other_summand_T ssig_T Inl_or_r_const
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   641
    dead_old_sig_map Sig old_Oper old_VLeaf old_CLeaf Oper VLeaf CLeaf lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   642
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   643
    val embL_b = mk_version_fp_binding true lthy version fp_b name;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   644
    val old_ssig_old_sig_T = Tsubst Y old_ssig_T old_sig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   645
    val ssig_old_sig_T = Tsubst Y ssig_T old_sig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   646
    val ssig_other_summand_T = Tsubst Y ssig_T other_summand_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   647
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   648
    val sigx = Var (("s", 0), old_ssig_old_sig_T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   649
    val x = Var (("x", 0), Y);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   650
    val j = Var (("j", 0), fpT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   651
    val embL = Free (Binding.name_of embL_b, old_ssig_T --> ssig_T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   652
    val dead_old_sig_map' = Term.subst_atomic_types [(Y, old_ssig_T), (Z, ssig_T)] dead_old_sig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   653
    val Sig' = substT Y ssig_T Sig;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   654
    val inl' = Inl_or_r_const ssig_old_sig_T ssig_other_summand_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   655
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   656
    val Oper_eq = mk_Trueprop_eq (embL $ (old_Oper $ sigx),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   657
        Oper $ (Sig' $ (inl' $ (dead_old_sig_map' $ embL $ sigx))))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   658
      |> Logic.all sigx;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   659
    val VLeaf_eq = mk_Trueprop_eq (embL $ (old_VLeaf $ x), VLeaf $ x)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   660
      |> Logic.all x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   661
    val CLeaf_eq = mk_Trueprop_eq (embL $ (old_CLeaf $ j), CLeaf $ j)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   662
      |> Logic.all j;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   663
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   664
    define_single_primrec embL_b [Oper_eq, VLeaf_eq, CLeaf_eq] lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   665
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   666
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   667
fun define_Lam_base fp_b version Y Z preT ssig_T dead_pre_map Sig unsig dead_sig_map Oper VLeaf
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   668
    lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   669
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   670
    val YpreT = HOLogic.mk_prodT (Y, preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   671
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   672
    val snd' = snd_const YpreT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   673
    val dead_pre_map' = substT Z ssig_T dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   674
    val Sig' = substT Y ssig_T Sig;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   675
    val unsig' = substT Y ssig_T unsig;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   676
    val dead_sig_map' = Term.subst_atomic_types [(Y, YpreT), (Z, ssig_T)] dead_sig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   677
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   678
    val rhs = HOLogic.mk_comp (unsig', dead_sig_map'
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   679
      $ Library.foldl1 HOLogic.mk_comp [Oper, Sig', dead_pre_map' $ VLeaf, snd']);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   680
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   681
    define_const true fp_b version LamN rhs lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   682
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   683
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   684
fun define_Lam_step_or_merge fp_b version Y preT unsig left_case right_case lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   685
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   686
    val YpreT = HOLogic.mk_prodT (Y, preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   687
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   688
    val unsig' = substT Y YpreT unsig;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   689
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   690
    val rhs = HOLogic.mk_comp (mk_case_sum (left_case, right_case), unsig');
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   691
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   692
    define_const true fp_b version LamN rhs lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   693
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   694
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   695
fun define_Lam_step fp_b version Y Z preT old_ssig_T ssig_T dead_pre_map unsig rho embL old_Lam
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   696
    lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   697
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   698
    val dead_pre_map' = Term.subst_atomic_types [(Y, old_ssig_T), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   699
    val left_case = HOLogic.mk_comp (dead_pre_map' $ embL, old_Lam);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   700
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   701
    define_Lam_step_or_merge fp_b version Y preT unsig left_case rho lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   702
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   703
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   704
fun define_Lam_merge fp_b version Y Z preT old1_ssig_T old2_ssig_T ssig_T dead_pre_map unsig embLL
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   705
    embLR old1_Lam old2_Lam lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   706
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   707
    val dead_pre_map' = Term.subst_atomic_types [(Y, old1_ssig_T), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   708
    val dead_pre_map'' = Term.subst_atomic_types [(Y, old2_ssig_T), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   709
    val left_case = HOLogic.mk_comp (dead_pre_map' $ embLL, old1_Lam);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   710
    val right_case = HOLogic.mk_comp (dead_pre_map'' $ embLR, old2_Lam);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   711
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   712
    define_Lam_step_or_merge fp_b version Y preT unsig left_case right_case lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   713
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   714
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   715
fun define_proto_sctr_step_or_merge fp_b version old_sig_T right_T Sig old_proto_sctr =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   716
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   717
    val rhs = Library.foldl1 HOLogic.mk_comp [Sig, Inl_const old_sig_T right_T, old_proto_sctr];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   718
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   719
    define_const true fp_b version proto_sctrN rhs
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   720
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   721
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   722
fun define_flat fp_b version Y Z fpT sig_T ssig_T Oper VLeaf CLeaf dead_sig_map lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   723
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   724
    val flat_b = mk_version_fp_binding true lthy version fp_b flatN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   725
    val ssig_sig_T = Tsubst Y ssig_T sig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   726
    val ssig_ssig_sig_T = Tsubst Y ssig_T ssig_sig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   727
    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   728
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   729
    val sigx = Var (("s", 0), ssig_ssig_sig_T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   730
    val x = Var (("x", 0), ssig_T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   731
    val j = Var (("j", 0), fpT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   732
    val flat = Free (Binding.name_of flat_b, ssig_ssig_T --> ssig_T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   733
    val Oper' = substT Y ssig_T Oper;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   734
    val VLeaf' = substT Y ssig_T VLeaf;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   735
    val CLeaf' = substT Y ssig_T CLeaf;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   736
    val dead_sig_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_sig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   737
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   738
    val Oper_eq = mk_Trueprop_eq (flat $ (Oper' $ sigx), Oper $ (dead_sig_map' $ flat $ sigx))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   739
      |> Logic.all sigx;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   740
    val VLeaf_eq = mk_Trueprop_eq (flat $ (VLeaf' $ x), x)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   741
      |> Logic.all x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   742
    val CLeaf_eq = mk_Trueprop_eq (flat $ (CLeaf' $ j), CLeaf $ j)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   743
      |> Logic.all j;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   744
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   745
    define_single_primrec flat_b [Oper_eq, VLeaf_eq, CLeaf_eq] lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   746
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   747
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   748
fun define_eval_core fp_b version Y Z preT fpT sig_T ssig_T dtor Oper VLeaf CLeaf dead_pre_map
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   749
    dead_sig_map dead_ssig_map flat Lam lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   750
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   751
    val eval_core_b = mk_version_fp_binding true lthy version fp_b eval_coreN;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   752
    val YpreT = HOLogic.mk_prodT (Y, preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   753
    val Ypre_ssig_T = Tsubst Y YpreT ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   754
    val Ypre_ssig_sig_T = Tsubst Y Ypre_ssig_T sig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   755
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   756
    val ssig_YpreT = Tsubst Y ssig_T YpreT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   757
    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   758
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   759
    val sigx = Var (("s", 0), Ypre_ssig_sig_T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   760
    val x = Var (("x", 0), YpreT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   761
    val j = Var (("j", 0), fpT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   762
    val eval_core = Free (Binding.name_of eval_core_b, Ypre_ssig_T --> ssig_preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   763
    val Oper' = substT Y YpreT Oper;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   764
    val VLeaf' = substT Y YpreT VLeaf;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   765
    val CLeaf' = substT Y YpreT CLeaf;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   766
    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   767
    val dead_pre_map'' = substT Z ssig_T dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   768
    val dead_pre_map''' = Term.subst_atomic_types [(Y, fpT), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   769
    val dead_sig_map' = Term.subst_atomic_types [(Y, Ypre_ssig_T), (Z, ssig_YpreT)] dead_sig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   770
    val dead_ssig_map' = Term.subst_atomic_types [(Y, YpreT), (Z, Y)] dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   771
    val Lam' = substT Y ssig_T Lam;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   772
    val fst' = fst_const YpreT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   773
    val snd' = snd_const YpreT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   774
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   775
    val Oper_eq = mk_Trueprop_eq (eval_core $ (Oper' $ sigx),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   776
        dead_pre_map' $ flat $ (Lam' $ (dead_sig_map' $ (Abs (Name.uu, Ypre_ssig_T,
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   777
          HOLogic.mk_prod (dead_ssig_map' $ fst' $ Bound 0, eval_core $ Bound 0))) $ sigx)))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   778
      |> Logic.all sigx;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   779
    val VLeaf_eq = mk_Trueprop_eq (eval_core $ (VLeaf' $ x), dead_pre_map'' $ VLeaf $ (snd' $ x))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   780
      |> Logic.all x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   781
    val CLeaf_eq = mk_Trueprop_eq (eval_core $ (CLeaf' $ j), dead_pre_map''' $ CLeaf $ (dtor $ j))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   782
      |> Logic.all j;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   783
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   784
    define_single_primrec eval_core_b [Oper_eq, VLeaf_eq, CLeaf_eq] lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   785
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   786
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   787
fun define_eval fp_b version Y Z preT fpT ssig_T dtor dtor_unfold dead_ssig_map eval_core lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   788
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   789
    val fp_preT = Tsubst Y fpT preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   790
    val fppreT = HOLogic.mk_prodT (fpT, fp_preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   791
    val fp_ssig_T = Tsubst Y fpT ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   792
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   793
    val dtor_unfold' = substT Z fp_ssig_T dtor_unfold;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   794
    val dead_ssig_map' = Term.subst_atomic_types [(Y, fpT), (Z, fppreT)] dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   795
    val eval_core' = substT Y fpT eval_core;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   796
    val id' = HOLogic.id_const fpT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   797
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   798
    val rhs = dtor_unfold' $ HOLogic.mk_comp (eval_core', dead_ssig_map' $ mk_convol (id', dtor));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   799
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   800
    define_const true fp_b version evalN rhs lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   801
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   802
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   803
fun define_cutSsig fp_b version Y Z preT ssig_T dead_pre_map VLeaf dead_ssig_map flat eval_core
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   804
    lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   805
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   806
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   807
    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   808
    val ssig_ssig_preT = HOLogic.mk_prodT (ssig_T, ssig_preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   809
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   810
    val h = Var (("h", 0), Y --> ssig_preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   811
    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   812
    val dead_ssig_map' = substT Z ssig_ssig_preT dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   813
    val eval_core' = substT Y ssig_T eval_core;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   814
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   815
    val rhs = Library.foldl1 HOLogic.mk_comp [dead_pre_map' $ flat, eval_core',
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   816
        dead_ssig_map' $ mk_convol (VLeaf, h)]
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   817
      |> Term.lambda h;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   818
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   819
    define_const true fp_b version cutSsigN rhs lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   820
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   821
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   822
fun define_algLam fp_b version Y Z fpT ssig_T Oper VLeaf dead_sig_map eval lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   823
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   824
    val fp_ssig_T = Tsubst Y fpT ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   825
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   826
    val Oper' = substT Y fpT Oper;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   827
    val VLeaf' = substT Y fpT VLeaf;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   828
    val dead_sig_map' = Term.subst_atomic_types [(Y, fpT), (Z, fp_ssig_T)] dead_sig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   829
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   830
    val rhs = Library.foldl1 HOLogic.mk_comp [eval, Oper', dead_sig_map' $ VLeaf'];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   831
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   832
    define_const true fp_b version algLamN rhs lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   833
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   834
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   835
fun define_corecU fp_b version Y Z preT ssig_T dtor_unfold VLeaf cutSsig lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   836
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   837
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   838
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   839
    val h = Var (("h", 0), Y --> ssig_preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   840
    val dtor_unfold' = substT Z ssig_T dtor_unfold;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   841
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   842
    val rhs = HOLogic.mk_comp (dtor_unfold' $ (cutSsig $ h), VLeaf)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   843
      |> Term.lambda h;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   844
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   845
    define_const true fp_b version corecUN rhs lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   846
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   847
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   848
fun define_corecUU fp_b version Y Z preT ssig_T dead_pre_map dead_ssig_map flat eval_core sctr
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   849
    corecU lthy =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   850
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   851
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   852
    val ssig_ssig_T = Tsubst Y ssig_T ssig_T
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   853
    val ssig_ssig_preT = HOLogic.mk_prodT (ssig_T, ssig_preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   854
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   855
    val ssig_pre_ssig_T = Tsubst Y ssig_preT ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   856
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   857
    val h = Var (("h", 0), Y --> ssig_pre_ssig_T);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   858
    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   859
    val eval_core' = substT Y ssig_T eval_core;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   860
    val dead_ssig_map' =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   861
      Term.subst_atomic_types [(Y, ssig_preT), (Z, ssig_ssig_preT)] dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   862
    val id' = HOLogic.id_const ssig_preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   863
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   864
    val rhs = corecU $ Library.foldl1 HOLogic.mk_comp
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   865
        [dead_pre_map' $ flat, eval_core', dead_ssig_map' $ mk_convol (sctr, id'), h]
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   866
      |> Term.lambda h;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   867
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   868
    define_const true fp_b version corecUUN rhs lthy
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   869
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   870
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   871
fun derive_sig_transfer maybe_swap ctxt live_AsBs pre_rel sig_rel Rs R const pre_rel_def
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   872
    preT_rel_eqs transfer_thm =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   873
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   874
    val RRpre_rel = list_comb (pre_rel, Rs) $ R;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   875
    val RRsig_rel = list_comb (sig_rel, Rs) $ R;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   876
    val constB = Term.subst_atomic_types live_AsBs const;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   877
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   878
    val goal = uncurry mk_rel_fun (maybe_swap (RRpre_rel, RRsig_rel)) $ const $ constB
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   879
      |> HOLogic.mk_Trueprop;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   880
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   881
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   882
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   883
      mk_sig_transfer_tac ctxt pre_rel_def preT_rel_eqs transfer_thm))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   884
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   885
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   886
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   887
fun derive_transfer_by_transfer_prover ctxt live_AsBs Rs R const const_defs rel_eqs transfers =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   888
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   889
    val constB = Term.subst_atomic_types live_AsBs const;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   890
    val goal = mk_parametricity_goal ctxt (Rs @ [R]) const constB;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   891
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   892
    Variable.add_free_names ctxt goal []
62729
b0bf94ccc59f avoid 'prove_sorry' for unreliable tactics
blanchet
parents: 62727
diff changeset
   893
    |> (fn vars => Goal.prove (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   894
      mk_transfer_by_transfer_prover_tac ctxt (const_defs @ map (fn thm => thm RS sym) rel_eqs)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   895
        rel_eqs transfers))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   896
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   897
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   898
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   899
fun derive_dtor_transfer ctxt live_EsFs Y Z pre_rel fp_rel Rs dtor dtor_rel_thm =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   900
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   901
    val Type (@{type_name fun}, [fpT, Type (@{type_name fun}, [fpTB, @{typ bool}])]) =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   902
      snd (strip_typeN (length live_EsFs) (fastype_of fp_rel));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   903
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   904
    val pre_rel' = Term.subst_atomic_types [(Y, fpT), (Z, fpTB)] pre_rel;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   905
    val Rpre_rel = list_comb (pre_rel', Rs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   906
    val Rfp_rel = list_comb (fp_rel, Rs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   907
    val dtorB = Term.subst_atomic_types live_EsFs dtor;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   908
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   909
    val goal = HOLogic.mk_Trueprop (mk_rel_fun Rfp_rel (Rpre_rel $ Rfp_rel) $ dtor $ dtorB);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   910
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   911
    Variable.add_free_names ctxt goal []
62729
b0bf94ccc59f avoid 'prove_sorry' for unreliable tactics
blanchet
parents: 62727
diff changeset
   912
    |> (fn vars => Goal.prove (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   913
      mk_dtor_transfer_tac ctxt dtor_rel_thm))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   914
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   915
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   916
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   917
fun derive_Lam_or_eval_core_transfer ctxt live_AsBs Y Z preT ssig_T Rs R pre_rel sig_or_ssig_rel
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   918
    ssig_rel const const_def rel_eqs transfers =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   919
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   920
    val YpreT = HOLogic.mk_prodT (Y, preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   921
    val ZpreTB = typ_subst_atomic live_AsBs YpreT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   922
    val ssig_TB = typ_subst_atomic live_AsBs ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   923
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   924
    val pre_rel' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssig_TB)] pre_rel;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   925
    val sig_or_ssig_rel' = Term.subst_atomic_types [(Y, YpreT), (Z, ZpreTB)] sig_or_ssig_rel;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   926
    val Rsig_or_ssig_rel' = list_comb (sig_or_ssig_rel', Rs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   927
    val RRpre_rel = list_comb (pre_rel, Rs) $ R;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   928
    val RRssig_rel = list_comb (ssig_rel, Rs) $ R;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   929
    val Rpre_rel' = list_comb (pre_rel', Rs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   930
    val constB = subst_atomic_types live_AsBs const;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   931
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   932
    val goal = mk_rel_fun (Rsig_or_ssig_rel' $ mk_rel_prod R RRpre_rel) (Rpre_rel' $ RRssig_rel)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   933
        $ const $ constB
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   934
      |> HOLogic.mk_Trueprop;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   935
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   936
    Variable.add_free_names ctxt goal []
62729
b0bf94ccc59f avoid 'prove_sorry' for unreliable tactics
blanchet
parents: 62727
diff changeset
   937
    |> (fn vars => Goal.prove (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   938
      mk_transfer_by_transfer_prover_tac ctxt [const_def] rel_eqs transfers))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   939
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   940
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   941
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   942
fun derive_proto_sctr_transfer_step_or_merge ctxt Y Z R dead_pre_rel dead_sig_rel proto_sctr
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   943
    proto_sctr_def fp_k_T_rel_eqs transfers =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   944
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   945
    val proto_sctrZ = substT Y Z proto_sctr;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   946
    val goal = mk_rel_fun (dead_pre_rel $ R) (dead_sig_rel $ R) $ proto_sctr $ proto_sctrZ
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   947
      |> HOLogic.mk_Trueprop;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   948
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   949
    Variable.add_free_names ctxt goal []
62729
b0bf94ccc59f avoid 'prove_sorry' for unreliable tactics
blanchet
parents: 62727
diff changeset
   950
    |> (fn vars => Goal.prove (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   951
      mk_transfer_by_transfer_prover_tac ctxt [proto_sctr_def] fp_k_T_rel_eqs transfers))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   952
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   953
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   954
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   955
fun derive_sctr_transfer ctxt live_AsBs Y Z ssig_T Rs R pre_rel ssig_rel sctr sctr_def
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   956
    fp_k_T_rel_eqs transfers =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   957
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   958
    val ssig_TB = typ_subst_atomic live_AsBs ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   959
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   960
    val pre_rel' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssig_TB)] pre_rel;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   961
    val Rpre_rel' = list_comb (pre_rel', Rs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   962
    val RRssig_rel = list_comb (ssig_rel, Rs) $ R;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   963
    val sctrB = subst_atomic_types live_AsBs sctr;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   964
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   965
    val goal = HOLogic.mk_Trueprop (mk_rel_fun (Rpre_rel' $ RRssig_rel) RRssig_rel $ sctr $ sctrB);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   966
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   967
    Variable.add_free_names ctxt goal []
62729
b0bf94ccc59f avoid 'prove_sorry' for unreliable tactics
blanchet
parents: 62727
diff changeset
   968
    |> (fn vars => Goal.prove (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   969
      mk_transfer_by_transfer_prover_tac ctxt [sctr_def] fp_k_T_rel_eqs transfers))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   970
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   971
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   972
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   973
fun derive_corecUU_transfer ctxt live_AsBs Y Z Rs R preT ssig_T pre_rel fp_rel ssig_rel corecUU
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   974
    cutSsig_def corecU_def corecUU_def fp_k_T_rel_eqs transfers =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   975
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   976
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   977
    val ssig_TB = typ_subst_atomic live_AsBs ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   978
    val ssig_preTB = typ_subst_atomic live_AsBs ssig_preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   979
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   980
    val pre_rel' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssig_TB)] pre_rel;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   981
    val ssig_rel' = Term.subst_atomic_types [(Y, ssig_preT), (Z, ssig_preTB)] ssig_rel;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   982
    val Rpre_rel' = list_comb (pre_rel', Rs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   983
    val Rfp_rel = list_comb (fp_rel, Rs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   984
    val RRssig_rel = list_comb (ssig_rel, Rs) $ R;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   985
    val Rssig_rel' = list_comb (ssig_rel', Rs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   986
    val corecUUB = subst_atomic_types live_AsBs corecUU;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   987
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   988
    val goal = mk_rel_fun (mk_rel_fun R (Rssig_rel' $ (Rpre_rel' $ RRssig_rel)))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   989
        (mk_rel_fun R Rfp_rel) $ corecUU $ corecUUB
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   990
      |> HOLogic.mk_Trueprop;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   991
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   992
    Variable.add_free_names ctxt goal []
62729
b0bf94ccc59f avoid 'prove_sorry' for unreliable tactics
blanchet
parents: 62727
diff changeset
   993
    |> (fn vars => Goal.prove (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   994
      mk_transfer_by_transfer_prover_tac ctxt [cutSsig_def, corecU_def, corecUU_def] fp_k_T_rel_eqs
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   995
        transfers))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   996
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   997
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   998
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
   999
fun mk_natural_goal ctxt simple_T_mapfs fs t u =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1000
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1001
    fun build_simple (T, _) =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1002
      (case AList.lookup (op =) simple_T_mapfs T of
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1003
        SOME mapf => mapf
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1004
      | NONE => the (find_first (fn f => domain_type (fastype_of f) = T) fs));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1005
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1006
    val simple_Ts = map fst simple_T_mapfs;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1007
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1008
    val t_map = build_map ctxt simple_Ts build_simple (apply2 (range_type o fastype_of) (t, u));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1009
    val u_map = build_map ctxt simple_Ts build_simple (apply2 (domain_type o fastype_of) (t, u));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1010
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1011
    mk_Trueprop_eq (HOLogic.mk_comp (u, u_map), HOLogic.mk_comp (t_map, t))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1012
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1013
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1014
fun derive_natural_by_unfolding ctxt live_AsBs preT pre_map fs f const map_thms =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1015
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1016
    val ffpre_map = list_comb (pre_map, fs) $ f;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1017
    val constB = subst_atomic_types live_AsBs const;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1018
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1019
    val goal = mk_natural_goal ctxt [(preT, ffpre_map)] (fs @ [f]) const constB;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1020
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1021
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1022
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1023
      mk_natural_by_unfolding_tac ctxt map_thms))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1024
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1025
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1026
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1027
fun derive_natural_from_transfer ctxt live_AsBs simple_T_mapfs fs f const transfer bnfs subst_bnfs =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1028
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1029
    val m = length live_AsBs;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1030
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1031
    val constB = Term.subst_atomic_types live_AsBs const;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1032
    val goal = mk_natural_goal ctxt simple_T_mapfs (fs @ [f]) const constB;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1033
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1034
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1035
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1036
      mk_natural_from_transfer_tac ctxt m (replicate m true) transfer [] (map rel_Grp_of_bnf bnfs)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1037
        (map rel_Grp_of_bnf subst_bnfs)))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1038
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1039
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1040
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1041
fun derive_natural_from_transfer_with_pre_type ctxt live_AsBs Y Z preT ssig_T pre_map ssig_map fs
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1042
    f =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1043
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1044
    val ssig_TB = typ_subst_atomic live_AsBs ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1045
    val preT' = Term.typ_subst_atomic [(Y, ssig_T), (Z, ssig_TB)] preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1046
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1047
    val ffpre_map = list_comb (pre_map, fs) $ f;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1048
    val pre_map' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssig_TB)] pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1049
    val fpre_map' = list_comb (pre_map', fs);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1050
    val ffssig_map = list_comb (ssig_map, fs) $ f;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1051
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1052
    val preT_mapfs = [(preT, ffpre_map), (preT', fpre_map' $ ffssig_map)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1053
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1054
    derive_natural_from_transfer ctxt live_AsBs preT_mapfs fs f
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1055
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1056
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1057
fun derive_Lam_Inl_Inr ctxt Y Z preT old_sig_T old_ssig_T k_T ssig_T dead_pre_map Sig embL old_Lam
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1058
    Lam rho unsig_thm Lam_def =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1059
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1060
    val YpreT = HOLogic.mk_prodT (Y, preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1061
    val Ypre_old_sig_T = Tsubst Y YpreT old_sig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1062
    val Ypre_k_T = Tsubst Y YpreT k_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1063
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1064
    val inl' = Inl_const Ypre_old_sig_T Ypre_k_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1065
    val inr' = Inr_const Ypre_old_sig_T Ypre_k_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1066
    val dead_pre_map' = Term.subst_atomic_types [(Y, old_ssig_T), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1067
    val Sig' = substT Y YpreT Sig;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1068
    val Lam_o_Sig = HOLogic.mk_comp (Lam, Sig');
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1069
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1070
    val inl_goal = mk_Trueprop_eq (HOLogic.mk_comp (Lam_o_Sig, inl'),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1071
      HOLogic.mk_comp (dead_pre_map' $ embL, old_Lam));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1072
    val inr_goal = mk_Trueprop_eq (HOLogic.mk_comp (Lam_o_Sig, inr'), rho);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1073
    val goals = [inl_goal, inr_goal];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1074
    val goal = Logic.mk_conjunction_balanced goals;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1075
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1076
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1077
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1078
      (fn {context = ctxt, prems = _} => mk_Lam_Inl_Inr_tac ctxt unsig_thm Lam_def))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1079
    |> Conjunction.elim_balanced (length goals)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1080
    |> map Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1081
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1082
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1083
fun derive_flat_VLeaf ctxt Y Z ssig_T x VLeaf dead_ssig_map flat ssig_induct fp_map_id sig_map_cong
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1084
    sig_map_ident sig_map_comp ssig_map_thms flat_simps =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1085
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1086
    val x' = substT Y ssig_T x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1087
    val dead_ssig_map' = substT Z ssig_T dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1088
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1089
    val goal = mk_Trueprop_eq (flat $ (dead_ssig_map' $ VLeaf $ x'), x');
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1090
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1091
    val ssig_induct' = infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt x')] ssig_induct;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1092
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1093
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1094
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1095
      mk_flat_VLeaf_or_flat_tac ctxt ssig_induct' sig_map_cong
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1096
        (fp_map_id :: sig_map_ident :: sig_map_comp :: ssig_map_thms @ flat_simps @
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1097
         @{thms o_apply id_apply id_def[symmetric]})))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1098
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1099
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1100
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1101
fun derive_flat_flat ctxt Y Z ssig_T x dead_ssig_map flat ssig_induct fp_map_id sig_map_cong
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1102
    sig_map_comp ssig_map_thms flat_simps =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1103
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1104
    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1105
    val ssig_ssig_ssig_T = Tsubst Y ssig_T ssig_ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1106
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1107
    val x' = substT Y ssig_ssig_ssig_T x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1108
    val dead_ssig_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1109
    val flat' = substT Y ssig_T flat;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1110
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1111
    val goal = mk_Trueprop_eq (flat $ (dead_ssig_map' $ flat $ x'), flat $ (flat' $ x'));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1112
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1113
    val ssig_induct' = infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt x')] ssig_induct;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1114
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1115
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1116
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1117
      mk_flat_VLeaf_or_flat_tac ctxt ssig_induct' sig_map_cong
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1118
        (o_apply :: fp_map_id :: sig_map_comp :: ssig_map_thms @ flat_simps)))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1119
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1120
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1121
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1122
fun derive_eval_core_flat ctxt Y Z preT ssig_T dead_pre_map dead_ssig_map flat eval_core x
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1123
    ssig_induct dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp fp_map_id sig_map_comp
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1124
    sig_map_cong ssig_map_thms ssig_map_comp flat_simps flat_pointful_natural flat_flat
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1125
    Lam_pointful_natural eval_core_simps =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1126
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1127
    val YpreT = HOLogic.mk_prodT (Y, preT);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1128
    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1129
    val Ypre_ssig_T = Tsubst Y YpreT ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1130
    val Ypre_ssig_ssig_T = Tsubst Y YpreT ssig_ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1131
    val ssig_YpreT = Tsubst Y ssig_T YpreT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1132
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1133
    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1134
    val dead_ssig_map' = Term.subst_atomic_types [(Y, Ypre_ssig_T), (Z, ssig_YpreT)] dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1135
    val dead_ssig_map'' = Term.subst_atomic_types [(Y, YpreT), (Z, Y)] dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1136
    val flat' = substT Y YpreT flat;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1137
    val eval_core' = substT Y ssig_T eval_core;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1138
    val x' = substT Y Ypre_ssig_ssig_T x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1139
    val fst' = fst_const YpreT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1140
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1141
    val goal = mk_Trueprop_eq (eval_core $ (flat' $ x'), dead_pre_map' $ flat
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1142
      $ (eval_core' $ (dead_ssig_map' $ mk_convol (dead_ssig_map'' $ fst', eval_core) $ x')));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1143
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1144
    val ssig_induct' = infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt x')] ssig_induct;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1145
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1146
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1147
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1148
      mk_eval_core_flat_tac ctxt ssig_induct' dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1149
        fp_map_id sig_map_comp sig_map_cong ssig_map_thms ssig_map_comp flat_simps
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1150
        flat_pointful_natural flat_flat Lam_pointful_natural eval_core_simps))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1151
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1152
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1153
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1154
fun derive_eval_thm ctxt dtor_inject dtor_unfold_thm eval_def =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1155
  (trans OF [iffD2 OF [dtor_inject, eval_def RS meta_eq_to_obj_eq RS fun_cong], dtor_unfold_thm])
62727
blanchet
parents: 62721
diff changeset
  1156
  |> unfold_thms ctxt [o_apply, eval_def RS symmetric_thm];
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1157
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1158
fun derive_eval_flat ctxt Y Z fpT ssig_T dead_ssig_map flat eval x dead_pre_map_comp0
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1159
    dtor_unfold_unique ssig_map_id ssig_map_comp flat_pointful_natural eval_core_pointful_natural
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1160
    eval_core_flat eval_thm =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1161
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1162
    val fp_ssig_T = Tsubst Y fpT ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1163
    val fp_ssig_ssig_T = Tsubst Y fp_ssig_T ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1164
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1165
    val dead_ssig_map' = Term.subst_atomic_types [(Y, fp_ssig_T), (Z, fpT)] dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1166
    val flat' = substT Y fpT flat;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1167
    val x' = substT Y fp_ssig_ssig_T x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1168
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1169
    val goal = mk_Trueprop_eq (eval $ (flat' $ x'), eval $ (dead_ssig_map' $ eval $ x'));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1170
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1171
    val cond_eval_o_flat =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1172
      infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (HOLogic.mk_comp (eval, flat')))]
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1173
        (trans OF [dtor_unfold_unique, dtor_unfold_unique RS sym] RS fun_cong)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1174
      OF [ext, ext];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1175
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1176
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1177
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1178
      mk_eval_flat_tac ctxt dead_pre_map_comp0 ssig_map_id ssig_map_comp flat_pointful_natural
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1179
        eval_core_pointful_natural eval_core_flat eval_thm cond_eval_o_flat))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1180
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1181
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1182
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1183
fun derive_eval_Oper ctxt live Y Z fpT sig_T ssig_T dead_sig_map Oper eval algLam x sig_map_ident
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1184
    sig_map_comp0 sig_map_comp Oper_natural_pointful VLeaf_natural flat_simps eval_flat algLam_def =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1185
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1186
    val fp_ssig_T = Tsubst Y fpT ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1187
    val fp_ssig_sig_T = Tsubst Y fp_ssig_T sig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1188
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1189
    val dead_sig_map' = Term.subst_atomic_types [(Y, fp_ssig_T), (Z, fpT)] dead_sig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1190
    val Oper' = substT Y fpT Oper;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1191
    val x' = substT Y fp_ssig_sig_T x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1192
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1193
    val goal = mk_Trueprop_eq (eval $ (Oper' $ x'), algLam $ (dead_sig_map' $ eval $ x'));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1194
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1195
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1196
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1197
      mk_eval_Oper_tac ctxt live sig_map_ident sig_map_comp0 sig_map_comp Oper_natural_pointful
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1198
        VLeaf_natural flat_simps eval_flat algLam_def))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1199
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1200
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1201
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1202
fun derive_eval_V_or_CLeaf ctxt Y fpT V_or_CLeaf eval x dead_pre_map_id dead_pre_map_comp fp_map_id
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1203
    dtor_unfold_unique V_or_CLeaf_map_thm eval_core_simps eval_thm =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1204
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1205
    val V_or_CLeaf' = substT Y fpT V_or_CLeaf;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1206
    val x' = substT Y fpT x;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1207
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1208
    val goal = mk_Trueprop_eq (eval $ (V_or_CLeaf' $ x'), x');
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1209
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1210
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1211
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1212
      mk_eval_V_or_CLeaf_tac ctxt dead_pre_map_id dead_pre_map_comp fp_map_id dtor_unfold_unique
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1213
        V_or_CLeaf_map_thm eval_core_simps eval_thm))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1214
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1215
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1216
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1217
fun derive_extdd_mor ctxt Y Z preT fpT ssig_T dead_pre_map dtor extdd cutSsig f g dead_pre_map_comp0
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1218
    dead_pre_map_comp VLeaf_map_thm ssig_map_comp flat_pointful_natural eval_core_pointful_natural
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1219
    eval_thm eval_flat eval_VLeaf cutSsig_def =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1220
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1221
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1222
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1223
    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)] dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1224
    val f' = substT Z fpT f;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1225
    val g' = substT Z ssig_preT g;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1226
    val extdd_f = extdd $ f';
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1227
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1228
    val prem = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ extdd_f, g'),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1229
      HOLogic.mk_comp (dtor, f'));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1230
    val goal = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ extdd_f, cutSsig $ g'),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1231
      HOLogic.mk_comp (dtor, extdd_f));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1232
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1233
    fold (Variable.add_free_names ctxt) [prem, goal] []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1234
    |> (fn vars => Goal.prove_sorry ctxt vars [prem] goal (fn {context = ctxt, prems = [prem]} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1235
      mk_extdd_mor_tac ctxt dead_pre_map_comp0 dead_pre_map_comp VLeaf_map_thm ssig_map_comp
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1236
        flat_pointful_natural eval_core_pointful_natural eval_thm eval_flat eval_VLeaf cutSsig_def
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1237
        prem))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1238
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1239
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1240
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1241
fun derive_mor_cutSsig_flat ctxt Y Z preT fpT ssig_T dead_pre_map dead_ssig_map dtor flat eval_core
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1242
    eval cutSsig f g dead_pre_map_comp0 dead_pre_map_comp dead_pre_map_cong dtor_unfold_unique
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1243
    dead_ssig_map_comp0 ssig_map_comp flat_simps flat_pointful_natural eval_core_pointful_natural
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1244
    flat_flat flat_VLeaf eval_core_flat cutSsig_def cutSsig_def_pointful_natural eval_thm =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1245
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1246
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1247
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1248
    val substYZ = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1249
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1250
    val dead_pre_map' = substYZ dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1251
    val dead_ssig_map' = substYZ dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1252
    val f' = substYZ f;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1253
    val g' = substT Z ssig_preT g;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1254
    val cutSsig_g = cutSsig $ g';
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1255
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1256
    val id' = HOLogic.id_const ssig_T;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1257
    val convol' = mk_convol (id', cutSsig_g);
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1258
    val dead_ssig_map'' =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1259
      Term.subst_atomic_types [(Y, ssig_T), (Z, range_type (fastype_of convol'))] dead_ssig_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1260
    val eval_core' = substT Y ssig_T eval_core;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1261
    val eval_core_o_map = HOLogic.mk_comp (eval_core', dead_ssig_map'' $ convol');
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1262
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1263
    val prem = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ f', cutSsig_g),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1264
      HOLogic.mk_comp (dtor, f'));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1265
    val goal = mk_Trueprop_eq (HOLogic.mk_comp (eval, dead_ssig_map' $ f'),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1266
      HOLogic.mk_comp (f', flat));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1267
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1268
    fold (Variable.add_free_names ctxt) [prem, goal] []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1269
    |> (fn vars => Goal.prove_sorry ctxt vars [prem] goal (fn {context = ctxt, prems = [prem]} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1270
      mk_mor_cutSsig_flat_tac ctxt eval_core_o_map dead_pre_map_comp0 dead_pre_map_comp
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1271
        dead_pre_map_cong dtor_unfold_unique dead_ssig_map_comp0 ssig_map_comp flat_simps
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1272
        flat_pointful_natural eval_core_pointful_natural flat_flat flat_VLeaf eval_core_flat
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1273
        cutSsig_def cutSsig_def_pointful_natural eval_thm prem))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1274
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1275
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1276
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1277
fun derive_extdd_o_VLeaf ctxt Y Z preT fpT ssig_T dead_pre_map dtor VLeaf extdd f g
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1278
    dead_pre_map_comp0 dead_pre_map_comp dtor_inject ssig_map_thms eval_core_simps eval_thm
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1279
    eval_VLeaf =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1280
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1281
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1282
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1283
    val substYZ = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1284
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1285
    val dead_pre_map' = substYZ dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1286
    val f' = substT Z fpT f;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1287
    val g' = substT Z ssig_preT g;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1288
    val extdd_f = extdd $ f';
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1289
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1290
    val prem = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ extdd_f, g'),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1291
      HOLogic.mk_comp (dtor, f'));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1292
    val goal = mk_Trueprop_eq (HOLogic.mk_comp (extdd_f, VLeaf), f');
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1293
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1294
    fold (Variable.add_free_names ctxt) [prem, goal] []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1295
    |> (fn vars => Goal.prove_sorry ctxt vars [prem] goal (fn {context = ctxt, prems = [prem]} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1296
      mk_extdd_o_VLeaf_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_inject ssig_map_thms
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1297
        eval_core_simps eval_thm eval_VLeaf prem))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1298
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1299
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1300
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1301
fun derive_corecU_pointfree ctxt Y Z preT fpT ssig_T dead_pre_map dtor extdd corecU g
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1302
    dead_pre_map_comp dtor_unfold_thm ssig_map_thms dead_ssig_map_comp0 flat_simps flat_VLeaf
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1303
    eval_core_simps cutSsig_def mor_cutSsig_flat corecU_def =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1304
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1305
    val ssig_preT = Tsubst Y ssig_T preT;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1306
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1307
    val substYZ = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1308
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1309
    val dead_pre_map' = substYZ dead_pre_map;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1310
    val g' = substT Z ssig_preT g;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1311
    val corecU_g = corecU $ g';
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1312
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1313
    val goal = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ (extdd $ corecU_g), g'),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1314
      HOLogic.mk_comp (dtor, corecU_g));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1315
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1316
    Variable.add_free_names ctxt goal []
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1317
    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1318
      mk_corecU_pointfree_tac ctxt dead_pre_map_comp dtor_unfold_thm ssig_map_thms
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1319
      dead_ssig_map_comp0 flat_simps flat_VLeaf eval_core_simps cutSsig_def mor_cutSsig_flat
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1320
      corecU_def))
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1321
    |> Thm.close_derivation
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1322
  end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1323
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1324
fun derive_corecU_ctor_unique ctxt Y Z preT fpT ssig_T dead_pre_map ctor dtor VLeaf extdd corecU f g
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1325
    dead_pre_map_comp ctor_dtor dtor_unfold_thm dtor_unfold_unique ssig_map_thms dead_ssig_map_comp0
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1326
    flat_simps flat_VLeaf eval_core_simps extdd_mor extdd_o_VLeaf cutSsig_def mor_cutSsig_flat
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1327
    corecU_def =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1328
  let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1329
    val corecU_pointfree = derive_corecU_pointfree ctxt Y Z preT fpT ssig_T dead_pre_map dtor extdd
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1330
      corecU g dead_pre_map_comp dtor_unfold_thm ssig_map_thms dead_ssig_map_comp0 flat_simps
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1331
      flat_VLeaf eval_core_simps cutSsig_def mor_cutSsig_flat corecU_def;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1332
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1333
    val corecU_thm = corecU_pointfree RS @{thm comp_eq_dest};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1334
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1335
    val corecU_ctor =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1336
      let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1337
        val arg_cong' =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1338
          infer_instantiate' ctxt [NONE, NONE, SOME (Thm.cterm_of ctxt ctor)] arg_cong;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1339
      in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1340
        unfold_thms ctxt [ctor_dtor] (corecU_thm RS arg_cong')
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1341
      end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1342
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1343
    val corecU_unique =
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1344
      let
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1345
        val substYZ = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)];
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1346
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1347
        val f' = substYZ f;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1348
        val abs_f_o_VLeaf = Term.lambda f' (HOLogic.mk_comp (f', VLeaf));
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1349
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1350
        val inject_refine' = infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt abs_f_o_VLeaf),
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1351
          SOME (Thm.cterm_of ctxt extdd)] @{thm inject_refine};
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1352
      in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1353
        unfold_thms ctxt @{thms atomize_imp}
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1354
          (((inject_refine' OF [extdd_o_VLeaf, extdd_o_VLeaf] RS iffD1)
62727
blanchet
parents: 62721
diff changeset
  1355
            OF [asm_rl, corecU_pointfree])
blanchet
parents: 62721
diff changeset
  1356
           OF [asm_rl, trans OF [dtor_unfold_unique, dtor_unfold_unique RS sym]
62692
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1357
             OF [extdd_mor, corecU_pointfree RS extdd_mor]])
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1358
        RS @{thm obj_distinct_prems}
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1359
      end;
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1360
  in
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1361
    (corecU_ctor, corecU_unique)
0701f25fac39 moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
blanchet
parents:
diff changeset
  1362
  end;