Quellcode-Bibliothek

^© Kompilation durch diese Firma

[Weder Korrektheit noch Funktionsfähigkeit der Software werden zugesichert.]

Datei: nitpick_hol.ML Sprache: SML

Original von: Isabelle^©

(*  Title:      HOL/Tools/Nitpick/nitpick_hol.ML
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2008, 2009, 2010

Auxiliary HOL-related functions used by Nitpick.
*)

signature NITPICK_HOL =
sig
  type const_table = term list Symtab.table
  type special_fun = ((string * typ) * int list * term list) * (string * typ)
  type unrolled = (string * typ) * (string * typ)
  type wf_cache = ((string * typ) * (bool * bool)) list

  type hol_context =
    {thy: theory,
     ctxt: Proof.context,
     max_bisim_depth: int,
     boxes: (typ option * bool option) list,
     wfs: ((string * typ) option * bool option) list,
     user_axioms: bool option,
     debug: bool,
     whacks: term list,
     binary_ints: bool option,
     destroy_constrs: bool,
     specialize: bool,
     star_linear_preds: bool,
     total_consts: bool option,
     needs: term list option,
     tac_timeout: Time.time,
     evals: term list,
     case_names: (string * int) list,
     def_tables: const_table * const_table,
     nondef_table: const_table,
     nondefs: term list,
     simp_table: const_table Unsynchronized.ref,
     psimp_table: const_table,
     choice_spec_table: const_table,
     intro_table: const_table,
     ground_thm_table: term list Inttab.table,
     ersatz_table: (string * string) list,
     skolems: (string * string list) list Unsynchronized.ref,
     special_funs: special_fun list Unsynchronized.ref,
     unrolled_preds: unrolled list Unsynchronized.ref,
     wf_cache: wf_cache Unsynchronized.ref,
     constr_cache: (typ * (string * typ) list) list Unsynchronized.ref}

  datatype fixpoint_kind = Lfp | Gfp | NoFp
  datatype boxability =
    InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2

  val name_sep : string
  val numeral_prefix : string
  val base_prefix : string
  val step_prefix : string
  val unrolled_prefix : string
  val ubfp_prefix : string
  val lbfp_prefix : string
  val quot_normal_prefix : string
  val skolem_prefix : string
  val special_prefix : string
  val uncurry_prefix : string
  val eval_prefix : string
  val iter_var_prefix : string
  val strip_first_name_sep : string -> string * string
  val original_name : string -> string
  val abs_var : indexname * typ -> term -> term
  val s_conj : term * term -> term
  val s_disj : term * term -> term
  val strip_any_connective : term -> term list * term
  val conjuncts_of : term -> term list
  val disjuncts_of : term -> term list
  val unarize_unbox_etc_type : typ -> typ
  val uniterize_unarize_unbox_etc_type : typ -> typ
  val string_for_type : Proof.context -> typ -> string
  val pretty_for_type : Proof.context -> typ -> Pretty.T
  val prefix_name : string -> string -> string
  val shortest_name : string -> string
  val short_name : string -> string
  val shorten_names_in_term : term -> term
  val strict_type_match : theory -> typ * typ -> bool
  val type_match : theory -> typ * typ -> bool
  val const_match : theory -> (string * typ) * (string * typ) -> bool
  val term_match : theory -> term * term -> bool
  val frac_from_term_pair : typ -> term -> term -> term
  val is_fun_type : typ -> bool
  val is_set_type : typ -> bool
  val is_fun_or_set_type : typ -> bool
  val is_set_like_type : typ -> bool
  val is_pair_type : typ -> bool
  val is_lfp_iterator_type : typ -> bool
  val is_gfp_iterator_type : typ -> bool
  val is_fp_iterator_type : typ -> bool
  val is_iterator_type : typ -> bool
  val is_boolean_type : typ -> bool
  val is_integer_type : typ -> bool
  val is_bit_type : typ -> bool
  val is_word_type : typ -> bool
  val is_integer_like_type : typ -> bool
  val is_number_type : Proof.context -> typ -> bool
  val is_higher_order_type : typ -> bool
  val elem_type : typ -> typ
  val pseudo_domain_type : typ -> typ
  val pseudo_range_type : typ -> typ
  val const_for_iterator_type : typ -> string * typ
  val strip_n_binders : int -> typ -> typ list * typ
  val nth_range_type : int -> typ -> typ
  val num_factors_in_type : typ -> int
  val curried_binder_types : typ -> typ list
  val mk_flat_tuple : typ -> term list -> term
  val dest_n_tuple : int -> term -> term list
  val is_codatatype : Proof.context -> typ -> bool
  val is_quot_type : Proof.context -> typ -> bool
  val is_pure_typedef : Proof.context -> typ -> bool
  val is_univ_typedef : Proof.context -> typ -> bool
  val is_data_type : Proof.context -> typ -> bool
  val is_record_get : theory -> string * typ -> bool
  val is_record_update : theory -> string * typ -> bool
  val is_abs_fun : Proof.context -> string * typ -> bool
  val is_rep_fun : Proof.context -> string * typ -> bool
  val is_quot_abs_fun : Proof.context -> string * typ -> bool
  val is_quot_rep_fun : Proof.context -> string * typ -> bool
  val mate_of_rep_fun : Proof.context -> string * typ -> string * typ
  val is_nonfree_constr : Proof.context -> string * typ -> bool
  val is_free_constr : Proof.context -> string * typ -> bool
  val is_constr : Proof.context -> string * typ -> bool
  val is_sel : string -> bool
  val is_sel_like_and_no_discr : string -> bool
  val box_type : hol_context -> boxability -> typ -> typ
  val binarize_nat_and_int_in_type : typ -> typ
  val binarize_nat_and_int_in_term : term -> term
  val discr_for_constr : string * typ -> string * typ
  val num_sels_for_constr_type : typ -> int
  val nth_sel_name_for_constr_name : string -> int -> string
  val nth_sel_for_constr : string * typ -> int -> string * typ
  val binarized_and_boxed_nth_sel_for_constr :
    hol_context -> bool -> string * typ -> int -> string * typ
  val sel_no_from_name : string -> int
  val close_form : term -> term
  val distinctness_formula : typ -> term list -> term
  val register_frac_type :
    string -> (string * string) list -> morphism -> Context.generic
    -> Context.generic
  val register_frac_type_global :
    string -> (string * string) list -> theory -> theory
  val unregister_frac_type :
    string -> morphism -> Context.generic -> Context.generic
  val unregister_frac_type_global : string -> theory -> theory
  val register_ersatz :
    (string * string) list -> morphism -> Context.generic -> Context.generic
  val register_ersatz_global : (string * string) list -> theory -> theory
  val register_codatatype :
    typ -> string -> (string * typ) list -> morphism -> Context.generic ->
    Context.generic
  val register_codatatype_global :
    typ -> string -> (string * typ) list -> theory -> theory
  val unregister_codatatype :
    typ -> morphism -> Context.generic -> Context.generic
  val unregister_codatatype_global : typ -> theory -> theory
  val binarized_and_boxed_data_type_constrs :
    hol_context -> bool -> typ -> (string * typ) list
  val constr_name_for_sel_like : string -> string
  val binarized_and_boxed_constr_for_sel : hol_context -> bool ->
    string * typ -> string * typ
  val card_of_type : (typ * int) list -> typ -> int
  val bounded_card_of_type : int -> int -> (typ * int) list -> typ -> int
  val bounded_exact_card_of_type :
    hol_context -> typ list -> int -> int -> (typ * int) list -> typ -> int
  val typical_card_of_type : typ -> int
  val is_finite_type : hol_context -> typ -> bool
  val is_special_eligible_arg : bool -> typ list -> term -> bool
  val s_let :
    typ list -> string -> int -> typ -> typ -> (term -> term) -> term -> term
  val s_betapply : typ list -> term * term -> term
  val s_betapplys : typ list -> term * term list -> term
  val discriminate_value : hol_context -> string * typ -> term -> term
  val select_nth_constr_arg :
    Proof.context -> string * typ -> term -> int -> typ -> term
  val construct_value : Proof.context -> string * typ -> term list -> term
  val coerce_term : hol_context -> typ list -> typ -> typ -> term -> term
  val special_bounds : term list -> (indexname * typ) list
  val is_funky_typedef : Proof.context -> typ -> bool
  val all_defs_of : theory -> (term * term) list -> term list
  val all_nondefs_of : Proof.context -> (term * term) list -> term list
  val arity_of_built_in_const : string * typ -> int option
  val is_built_in_const : string * typ -> bool
  val term_under_def : term -> term
  val case_const_names : Proof.context -> (string * int) list
  val unfold_defs_in_term : hol_context -> term -> term
  val const_def_tables :
    Proof.context -> (term * term) list -> term list
    -> const_table * const_table
  val const_nondef_table : term list -> const_table
  val const_simp_table : Proof.context -> (term * term) list -> const_table
  val const_psimp_table : Proof.context -> (term * term) list -> const_table
  val const_choice_spec_table :
    Proof.context -> (term * term) list -> const_table
  val inductive_intro_table :
    Proof.context -> (term * term) list -> const_table * const_table
    -> const_table
  val ground_theorem_table : theory -> term list Inttab.table
  val ersatz_table : Proof.context -> (string * string) list
  val add_simps : const_table Unsynchronized.ref -> string -> term list -> unit
  val inverse_axioms_for_rep_fun : Proof.context -> string * typ -> term list
  val optimized_typedef_axioms : Proof.context -> string * typ list -> term list
  val optimized_quot_type_axioms :
    Proof.context -> string * typ list -> term list
  val def_of_const : theory -> const_table * const_table -> string * typ ->
    term option
  val fixpoint_kind_of_rhs : term -> fixpoint_kind
  val fixpoint_kind_of_const :
    theory -> const_table * const_table -> string * typ -> fixpoint_kind
  val is_raw_inductive_pred : hol_context -> string * typ -> bool
  val is_constr_pattern : Proof.context -> term -> bool
  val is_constr_pattern_lhs : Proof.context -> term -> bool
  val is_constr_pattern_formula : Proof.context -> term -> bool
  val nondef_props_for_const :
    theory -> bool -> const_table -> string * typ -> term list
  val is_choice_spec_fun : hol_context -> string * typ -> bool
  val is_choice_spec_axiom : Proof.context -> const_table -> term -> bool
  val is_raw_equational_fun : hol_context -> string * typ -> bool
  val is_equational_fun : hol_context -> string * typ -> bool
  val codatatype_bisim_axioms : hol_context -> typ -> term list
  val is_well_founded_inductive_pred : hol_context -> string * typ -> bool
  val unrolled_inductive_pred_const : hol_context -> bool -> string * typ ->
    term
  val equational_fun_axioms : hol_context -> string * typ -> term list
  val is_equational_fun_surely_complete : hol_context -> string * typ -> bool
  val merged_type_var_table_for_terms :
    theory -> term list -> (sort * string) list
  val merge_type_vars_in_term :
    theory -> bool -> (sort * string) list -> term -> term
  val ground_types_in_type : hol_context -> bool -> typ -> typ list
  val ground_types_in_terms : hol_context -> bool -> term list -> typ list
end;

structure Nitpick_HOL : NITPICK_HOL =
struct

open Nitpick_Util

type const_table = term list Symtab.table
type special_fun = ((string * typ) * int list * term list) * (string * typ)
type unrolled = (string * typ) * (string * typ)
type wf_cache = ((string * typ) * (bool * bool)) list

type hol_context =
  {thy: theory,
   ctxt: Proof.context,
   max_bisim_depth: int,
   boxes: (typ option * bool option) list,
   wfs: ((string * typ) option * bool option) list,
   user_axioms: bool option,
   debug: bool,
   whacks: term list,
   binary_ints: bool option,
   destroy_constrs: bool,
   specialize: bool,
   star_linear_preds: bool,
   total_consts: bool option,
   needs: term list option,
   tac_timeout: Time.time,
   evals: term list,
   case_names: (string * int) list,
   def_tables: const_table * const_table,
   nondef_table: const_table,
   nondefs: term list,
   simp_table: const_table Unsynchronized.ref,
   psimp_table: const_table,
   choice_spec_table: const_table,
   intro_table: const_table,
   ground_thm_table: term list Inttab.table,
   ersatz_table: (string * string) list,
   skolems: (string * string list) list Unsynchronized.ref,
   special_funs: special_fun list Unsynchronized.ref,
   unrolled_preds: unrolled list Unsynchronized.ref,
   wf_cache: wf_cache Unsynchronized.ref,
   constr_cache: (typ * (string * typ) list) list Unsynchronized.ref}

datatype fixpoint_kind = Lfp | Gfp | NoFp
datatype boxability =
  InConstr | InSel | InExpr | InPair | InFunLHS | InFunRHS1 | InFunRHS2

(* FIXME: Get rid of 'codatatypes' and related functionality *)
structure Data = Generic_Data
(
  type T = {frac_types: (string * (string * string) list) list,
            ersatz_table: (string * string) list,
            codatatypes: (string * (string * (string * typ) list)) list}
  val empty = {frac_types = [], ersatz_table = [], codatatypes = []}
  val extend = I
  fun merge ({frac_types = fs1, ersatz_table = et1, codatatypes = cs1},
             {frac_types = fs2, ersatz_table = et2, codatatypes = cs2}) : T =
    {frac_types = AList.merge (op =) (K true) (fs1, fs2),
     ersatz_table = AList.merge (op =) (K true) (et1, et2),
     codatatypes = AList.merge (op =) (K true) (cs1, cs2)}
)

val name_sep = "$"
val numeral_prefix = nitpick_prefix ^ "num" ^ name_sep
val sel_prefix = nitpick_prefix ^ "sel"
val discr_prefix = nitpick_prefix ^ "is" ^ name_sep
val lfp_iterator_prefix = nitpick_prefix ^ "lfpit" ^ name_sep
val gfp_iterator_prefix = nitpick_prefix ^ "gfpit" ^ name_sep
val unrolled_prefix = nitpick_prefix ^ "unroll" ^ name_sep
val base_prefix = nitpick_prefix ^ "base" ^ name_sep
val step_prefix = nitpick_prefix ^ "step" ^ name_sep
val ubfp_prefix = nitpick_prefix ^ "ubfp" ^ name_sep
val lbfp_prefix = nitpick_prefix ^ "lbfp" ^ name_sep
val quot_normal_prefix = nitpick_prefix ^ "qn" ^ name_sep
val skolem_prefix = nitpick_prefix ^ "sk"
val special_prefix = nitpick_prefix ^ "sp"
val uncurry_prefix = nitpick_prefix ^ "unc"
val eval_prefix = nitpick_prefix ^ "eval"
val iter_var_prefix = "i"

(** Constant/type information and term/type manipulation **)

fun sel_prefix_for j = sel_prefix ^ string_of_int j ^ name_sep

fun quot_normal_name_for_type ctxt T =
  quot_normal_prefix ^ YXML.content_of (Syntax.string_of_typ ctxt T)

val strip_first_name_sep =
  Substring.full #> Substring.position name_sep ##> Substring.triml 1
  #> apply2 Substring.string

fun original_name s =
  if String.isPrefix nitpick_prefix s then
    case strip_first_name_sep s of (s1, "") => s1 | (_, s2) => original_name s2
  else
    s

fun s_conj (t1, \<^const>\<open>True\<close>) = t1
  | s_conj (\<^const>\<open>True\<close>, t2) = t2
  | s_conj (t1, t2) =
    if t1 = \<^const>\<open>False\<close> orelse t2 = \<^const>\<open>False\<close> then \<^const>\<open>False\<close>
    else HOLogic.mk_conj (t1, t2)

fun s_disj (t1, \<^const>\<open>False\<close>) = t1
  | s_disj (\<^const>\<open>False\<close>, t2) = t2
  | s_disj (t1, t2) =
    if t1 = \<^const>\<open>True\<close> orelse t2 = \<^const>\<open>True\<close> then \<^const>\<open>True\<close>
    else HOLogic.mk_disj (t1, t2)

fun strip_connective conn_t (t as (t0 $ t1 $ t2)) =
    if t0 = conn_t then strip_connective t0 t2 @ strip_connective t0 t1 else [t]
  | strip_connective _ t = [t]

fun strip_any_connective (t as (t0 $ _ $ _)) =
    if t0 = \<^const>\<open>HOL.conj\<close> orelse t0 = \<^const>\<open>HOL.disj\<close> then
      (strip_connective t0 t, t0)
    else
      ([t], \<^const>\<open>Not\<close>)
  | strip_any_connective t = ([t], \<^const>\<open>Not\<close>)
val conjuncts_of = strip_connective \<^const>\<open>HOL.conj\<close>
val disjuncts_of = strip_connective \<^const>\<open>HOL.disj\<close>

(* When you add constants to these lists, make sure to handle them in
   "Nitpick_Nut.nut_from_term", and perhaps in "Nitpick_Mono.consider_term" as
   well. *)
val built_in_consts =
  [(\<^const_name>\<open>Pure.all\<close>, 1),
   (\<^const_name>\<open>Pure.eq\<close>, 2),
   (\<^const_name>\<open>Pure.imp\<close>, 2),
   (\<^const_name>\<open>Pure.conjunction\<close>, 2),
   (\<^const_name>\<open>Trueprop\<close>, 1),
   (\<^const_name>\<open>Not\<close>, 1),
   (\<^const_name>\<open>False\<close>, 0),
   (\<^const_name>\<open>True\<close>, 0),
   (\<^const_name>\<open>All\<close>, 1),
   (\<^const_name>\<open>Ex\<close>, 1),
   (\<^const_name>\<open>HOL.eq\<close>, 1),
   (\<^const_name>\<open>HOL.conj\<close>, 2),
   (\<^const_name>\<open>HOL.disj\<close>, 2),
   (\<^const_name>\<open>HOL.implies\<close>, 2),
   (\<^const_name>\<open>If\<close>, 3),
   (\<^const_name>\<open>Let\<close>, 2),
   (\<^const_name>\<open>Pair\<close>, 2),
   (\<^const_name>\<open>fst\<close>, 1),
   (\<^const_name>\<open>snd\<close>, 1),
   (\<^const_name>\<open>Set.member\<close>, 2),
   (\<^const_name>\<open>Collect\<close>, 1),
   (\<^const_name>\<open>Id\<close>, 0),
   (\<^const_name>\<open>converse\<close>, 1),
   (\<^const_name>\<open>trancl\<close>, 1),
   (\<^const_name>\<open>relcomp\<close>, 2),
   (\<^const_name>\<open>finite\<close>, 1),
   (\<^const_name>\<open>unknown\<close>, 0),
   (\<^const_name>\<open>is_unknown\<close>, 1),
   (\<^const_name>\<open>safe_The\<close>, 1),
   (\<^const_name>\<open>Frac\<close>, 0),
   (\<^const_name>\<open>norm_frac\<close>, 0),
   (\<^const_name>\<open>Suc\<close>, 0),
   (\<^const_name>\<open>nat\<close>, 0),
   (\<^const_name>\<open>nat_gcd\<close>, 0),
   (\<^const_name>\<open>nat_lcm\<close>, 0)]
val built_in_typed_consts =
  [((\<^const_name>\<open>zero_class.zero\<close>, nat_T), 0),
   ((\<^const_name>\<open>one_class.one\<close>, nat_T), 0),
   ((\<^const_name>\<open>plus_class.plus\<close>, nat_T --> nat_T --> nat_T), 0),
   ((\<^const_name>\<open>minus_class.minus\<close>, nat_T --> nat_T --> nat_T), 0),
   ((\<^const_name>\<open>times_class.times\<close>, nat_T --> nat_T --> nat_T), 0),
   ((\<^const_name>\<open>Rings.divide\<close>, nat_T --> nat_T --> nat_T), 0),
   ((\<^const_name>\<open>ord_class.less\<close>, nat_T --> nat_T --> bool_T), 2),
   ((\<^const_name>\<open>ord_class.less_eq\<close>, nat_T --> nat_T --> bool_T), 2),
   ((\<^const_name>\<open>of_nat\<close>, nat_T --> int_T), 0),
   ((\<^const_name>\<open>zero_class.zero\<close>, int_T), 0),
   ((\<^const_name>\<open>one_class.one\<close>, int_T), 0),
   ((\<^const_name>\<open>plus_class.plus\<close>, int_T --> int_T --> int_T), 0),
   ((\<^const_name>\<open>minus_class.minus\<close>, int_T --> int_T --> int_T), 0),
   ((\<^const_name>\<open>times_class.times\<close>, int_T --> int_T --> int_T), 0),
   ((\<^const_name>\<open>Rings.divide\<close>, int_T --> int_T --> int_T), 0),
   ((\<^const_name>\<open>uminus_class.uminus\<close>, int_T --> int_T), 0),
   ((\<^const_name>\<open>ord_class.less\<close>, int_T --> int_T --> bool_T), 2),
   ((\<^const_name>\<open>ord_class.less_eq\<close>, int_T --> int_T --> bool_T), 2)]

fun unarize_type \<^typ>\<open>unsigned_bit word\<close> = nat_T
  | unarize_type \<^typ>\<open>signed_bit word\<close> = int_T
  | unarize_type (Type (s, Ts as _ :: _)) = Type (s, map unarize_type Ts)
  | unarize_type T = T

fun unarize_unbox_etc_type (Type (\<^type_name>\<open>fun_box\<close>, Ts)) =
    unarize_unbox_etc_type (Type (\<^type_name>\<open>fun\<close>, Ts))
  | unarize_unbox_etc_type (Type (\<^type_name>\<open>pair_box\<close>, Ts)) =
    Type (\<^type_name>\<open>prod\<close>, map unarize_unbox_etc_type Ts)
  | unarize_unbox_etc_type \<^typ>\<open>unsigned_bit word\<close> = nat_T
  | unarize_unbox_etc_type \<^typ>\<open>signed_bit word\<close> = int_T
  | unarize_unbox_etc_type (Type (s, Ts as _ :: _)) =
    Type (s, map unarize_unbox_etc_type Ts)
  | unarize_unbox_etc_type T = T

fun uniterize_type (Type (s, Ts as _ :: _)) = Type (s, map uniterize_type Ts)
  | uniterize_type \<^typ>\<open>bisim_iterator\<close> = nat_T
  | uniterize_type T = T
val uniterize_unarize_unbox_etc_type = uniterize_type o unarize_unbox_etc_type

fun string_for_type ctxt = Syntax.string_of_typ ctxt o unarize_unbox_etc_type
fun pretty_for_type ctxt = Syntax.pretty_typ ctxt o unarize_unbox_etc_type

val prefix_name = Long_Name.qualify o Long_Name.base_name
val shortest_name = Long_Name.base_name
val prefix_abs_vars = Term.map_abs_vars o prefix_name

fun short_name s =
  case space_explode name_sep s of
    [_] => s |> String.isPrefix nitpick_prefix s ? unprefix nitpick_prefix
  | ss => map shortest_name ss |> space_implode "_"

fun shorten_names_in_type (Type (s, Ts)) =
    Type (short_name s, map shorten_names_in_type Ts)
  | shorten_names_in_type T = T

val shorten_names_in_term =
  map_aterms (fn Const (s, T) => Const (short_name s, T) | t => t)
  #> map_types shorten_names_in_type

fun strict_type_match thy (T1, T2) =
  (Sign.typ_match thy (T2, T1) Vartab.empty; true)
  handle Type.TYPE_MATCH => false

fun type_match thy = strict_type_match thy o apply2 unarize_unbox_etc_type

fun const_match thy ((s1, T1), (s2, T2)) =
  s1 = s2 andalso type_match thy (T1, T2)

fun term_match thy (Const x1, Const x2) = const_match thy (x1, x2)
  | term_match thy (Free (s1, T1), Free (s2, T2)) =
    const_match thy ((shortest_name s1, T1), (shortest_name s2, T2))
  | term_match _ (t1, t2) = t1 aconv t2

fun frac_from_term_pair T t1 t2 =
  case snd (HOLogic.dest_number t1) of
    0 => HOLogic.mk_number T 0
  | n1 => case snd (HOLogic.dest_number t2) of
            1 => HOLogic.mk_number T n1
          | n2 => Const (\<^const_name>\<open>divide\<close>, T --> T --> T)
                  $ HOLogic.mk_number T n1 $ HOLogic.mk_number T n2

fun is_fun_type (Type (\<^type_name>\<open>fun\<close>, _)) = true
  | is_fun_type _ = false

fun is_set_type (Type (\<^type_name>\<open>set\<close>, _)) = true
  | is_set_type _ = false

val is_fun_or_set_type = is_fun_type orf is_set_type

fun is_set_like_type (Type (\<^type_name>\<open>fun\<close>, [_, T'])) =
    (body_type T' = bool_T)
  | is_set_like_type (Type (\<^type_name>\<open>set\<close>, _)) = true
  | is_set_like_type _ = false

fun is_pair_type (Type (\<^type_name>\<open>prod\<close>, _)) = true
  | is_pair_type _ = false

fun is_lfp_iterator_type (Type (s, _)) = String.isPrefix lfp_iterator_prefix s
  | is_lfp_iterator_type _ = false

fun is_gfp_iterator_type (Type (s, _)) = String.isPrefix gfp_iterator_prefix s
  | is_gfp_iterator_type _ = false

val is_fp_iterator_type = is_lfp_iterator_type orf is_gfp_iterator_type

fun is_iterator_type T =
  (T = \<^typ>\<open>bisim_iterator\<close> orelse is_fp_iterator_type T)

fun is_boolean_type T = (T = prop_T orelse T = bool_T)

fun is_integer_type T = (T = nat_T orelse T = int_T)

fun is_bit_type T = (T = \<^typ>\<open>unsigned_bit\<close> orelse T = \<^typ>\<open>signed_bit\<close>)

fun is_word_type (Type (\<^type_name>\<open>word\<close>, _)) = true
  | is_word_type _ = false

val is_integer_like_type = is_iterator_type orf is_integer_type orf is_word_type

fun is_frac_type ctxt (Type (s, [])) =
    s |> AList.defined (op =) (#frac_types (Data.get (Context.Proof ctxt)))
  | is_frac_type _ _ = false

fun is_number_type ctxt = is_integer_like_type orf is_frac_type ctxt

fun is_higher_order_type (Type (\<^type_name>\<open>fun\<close>, _)) = true
  | is_higher_order_type (Type (\<^type_name>\<open>set\<close>, _)) = true
  | is_higher_order_type (Type (_, Ts)) = exists is_higher_order_type Ts
  | is_higher_order_type _ = false

fun elem_type (Type (\<^type_name>\<open>set\<close>, [T'])) = T'
  | elem_type T = raise TYPE ("Nitpick_HOL.elem_type", [T], [])

fun pseudo_domain_type (Type (\<^type_name>\<open>fun\<close>, [T1, _])) = T1
  | pseudo_domain_type T = elem_type T

fun pseudo_range_type (Type (\<^type_name>\<open>fun\<close>, [_, T2])) = T2
  | pseudo_range_type (Type (\<^type_name>\<open>set\<close>, _)) = bool_T
  | pseudo_range_type T = raise TYPE ("Nitpick_HOL.pseudo_range_type", [T], [])

fun iterator_type_for_const gfp (s, T) =
  Type ((if gfp then gfp_iterator_prefix else lfp_iterator_prefix) ^ s,
        binder_types T)

fun const_for_iterator_type (Type (s, Ts)) =
    (strip_first_name_sep s |> snd, Ts ---> bool_T)
  | const_for_iterator_type T =
    raise TYPE ("Nitpick_HOL.const_for_iterator_type", [T], [])

fun strip_n_binders 0 T = ([], T)
  | strip_n_binders n (Type (\<^type_name>\<open>fun\<close>, [T1, T2])) =
    strip_n_binders (n - 1) T2 |>> cons T1
  | strip_n_binders n (Type (\<^type_name>\<open>fun_box\<close>, Ts)) =
    strip_n_binders n (Type (\<^type_name>\<open>fun\<close>, Ts))
  | strip_n_binders _ T = raise TYPE ("Nitpick_HOL.strip_n_binders", [T], [])

val nth_range_type = snd oo strip_n_binders

fun num_factors_in_type (Type (\<^type_name>\<open>prod\<close>, [T1, T2])) =
    fold (Integer.add o num_factors_in_type) [T1, T2] 0
  | num_factors_in_type _ = 1

val curried_binder_types = maps HOLogic.flatten_tupleT o binder_types

fun maybe_curried_binder_types T =
  (if is_pair_type (body_type T) then binder_types else curried_binder_types) T

fun mk_flat_tuple _ [t] = t
  | mk_flat_tuple (Type (\<^type_name>\<open>prod\<close>, [T1, T2])) (t :: ts) =
    HOLogic.pair_const T1 T2 $ t $ (mk_flat_tuple T2 ts)
  | mk_flat_tuple T ts = raise TYPE ("Nitpick_HOL.mk_flat_tuple", [T], ts)

fun dest_n_tuple 1 t = [t]
  | dest_n_tuple n t = HOLogic.dest_prod t ||> dest_n_tuple (n - 1) |> op ::

fun typedef_info ctxt s =
  if is_frac_type ctxt (Type (s, [])) then
    SOME {abs_type = Type (s, []), rep_type = \<^typ>\<open>int * int\<close>,
          Abs_name = \<^const_name>\<open>Abs_Frac\<close>,
          Rep_name = \<^const_name>\<open>Rep_Frac\<close>,
          prop_of_Rep = \<^prop>\<open>Rep_Frac x \<in> Collect Frac\<close>
                        |> Logic.varify_global,
          Abs_inverse = NONE, Rep_inverse = NONE}
  else case Typedef.get_info ctxt s of
    (* When several entries are returned, it shouldn't matter much which one
       we take (according to Florian Haftmann). *)
    (* The "Logic.varifyT_global" calls are a temporary hack because these
       types's type variables sometimes clash with locally fixed type variables.
       Remove these calls once "Typedef" is fully localized. *)
    ({abs_type, rep_type, Abs_name, Rep_name, ...},
     {Rep, Abs_inverse, Rep_inverse, ...}) :: _ =>
    SOME {abs_type = Logic.varifyT_global abs_type,
          rep_type = Logic.varifyT_global rep_type, Abs_name = Abs_name,
          Rep_name = Rep_name, prop_of_Rep = Thm.prop_of Rep,
          Abs_inverse = SOME Abs_inverse, Rep_inverse = SOME Rep_inverse}
  | _ => NONE

val is_raw_typedef = is_some oo typedef_info
val is_raw_free_datatype = is_some oo Ctr_Sugar.ctr_sugar_of

val is_interpreted_type =
  member (op =) [\<^type_name>\<open>prod\<close>, \<^type_name>\<open>set\<close>, \<^type_name>\<open>bool\<close>,
                 \<^type_name>\<open>nat\<close>, \<^type_name>\<open>int\<close>, \<^type_name>\<open>natural\<close>,
                 \<^type_name>\<open>integer\<close>]

fun repair_constr_type (Type (_, Ts)) T =
  snd (dest_Const (Ctr_Sugar.mk_ctr Ts (Const (Name.uu, T))))

fun register_frac_type_generic frac_s ersaetze generic =
  let
    val {frac_types, ersatz_table, codatatypes} = Data.get generic
    val frac_types = AList.update (op =) (frac_s, ersaetze) frac_types
  in Data.put {frac_types = frac_types, ersatz_table = ersatz_table,
               codatatypes = codatatypes} generic end

(* TODO: Consider morphism. *)
fun register_frac_type frac_s ersaetze (_ : morphism) =
  register_frac_type_generic frac_s ersaetze

val register_frac_type_global = Context.theory_map oo register_frac_type_generic

fun unregister_frac_type_generic frac_s = register_frac_type_generic frac_s []
(* TODO: Consider morphism. *)

fun unregister_frac_type frac_s (_ : morphism) =
  unregister_frac_type_generic frac_s

val unregister_frac_type_global =
  Context.theory_map o unregister_frac_type_generic

fun register_ersatz_generic ersatz generic =
  let
    val {frac_types, ersatz_table, codatatypes} = Data.get generic
    val ersatz_table = AList.merge (op =) (K true) (ersatz_table, ersatz)
  in Data.put {frac_types = frac_types, ersatz_table = ersatz_table,
               codatatypes = codatatypes} generic end

(* TODO: Consider morphism. *)
fun register_ersatz ersatz (_ : morphism) =
  register_ersatz_generic ersatz

val register_ersatz_global = Context.theory_map o register_ersatz_generic

fun register_codatatype_generic coT case_name constr_xs generic =
  let
    val {frac_types, ersatz_table, codatatypes} = Data.get generic
    val constr_xs = map (apsnd (repair_constr_type coT)) constr_xs
    val (co_s, coTs) = dest_Type coT
    val _ =
      if forall is_TFree coTs andalso not (has_duplicates (op =) coTs) andalso
         co_s <> \<^type_name>\<open>fun\<close> andalso not (is_interpreted_type co_s) then
        ()
      else
        raise TYPE ("Nitpick_HOL.register_codatatype_generic", [coT], [])
    val codatatypes = AList.update (op =) (co_s, (case_name, constr_xs))
                                   codatatypes
  in Data.put {frac_types = frac_types, ersatz_table = ersatz_table,
               codatatypes = codatatypes} generic end

(* TODO: Consider morphism. *)
fun register_codatatype coT case_name constr_xs (_ : morphism) =
  register_codatatype_generic coT case_name constr_xs

val register_codatatype_global =
  Context.theory_map ooo register_codatatype_generic

fun unregister_codatatype_generic coT = register_codatatype_generic coT "" []
(* TODO: Consider morphism. *)

fun unregister_codatatype coT (_ : morphism) =
  unregister_codatatype_generic coT
val unregister_codatatype_global =
  Context.theory_map o unregister_codatatype_generic

fun is_raw_codatatype ctxt s =
  Option.map #fp (BNF_FP_Def_Sugar.fp_sugar_of ctxt s)
  = SOME BNF_Util.Greatest_FP

fun is_registered_codatatype ctxt s =
  not (null (these (Option.map snd (AList.lookup (op =)
    (#codatatypes (Data.get (Context.Proof ctxt))) s))))

fun is_codatatype ctxt (Type (s, _)) =
    is_raw_codatatype ctxt s orelse is_registered_codatatype ctxt s
  | is_codatatype _ _ = false

fun is_registered_type ctxt (T as Type (s, _)) =
    is_frac_type ctxt T orelse is_registered_codatatype ctxt s
  | is_registered_type _ _ = false

fun is_raw_quot_type ctxt (Type (s, _)) =
    is_some (Quotient_Info.lookup_quotients ctxt s)
  | is_raw_quot_type _ _ = false

fun is_quot_type ctxt T =
  is_raw_quot_type ctxt T andalso not (is_registered_type ctxt T) andalso
  T <> \<^typ>\<open>int\<close>

fun is_pure_typedef ctxt (T as Type (s, _)) =
    is_frac_type ctxt T orelse
    (is_raw_typedef ctxt s andalso
     not (is_raw_free_datatype ctxt s orelse is_raw_quot_type ctxt T orelse
       is_codatatype ctxt T orelse is_integer_like_type T))
  | is_pure_typedef _ _ = false

fun is_univ_typedef ctxt (Type (s, _)) =
    (case typedef_info ctxt s of
       SOME {prop_of_Rep, ...} =>
       let
         val t_opt =
           try (snd o HOLogic.dest_mem o HOLogic.dest_Trueprop) prop_of_Rep
       in
         case t_opt of
           SOME (Const (\<^const_name>\<open>top\<close>, _)) => true
           (* "Multiset.multiset" FIXME unchecked *)
         | SOME (Const (\<^const_name>\<open>Collect\<close>, _)
                 $ Abs (_, _, Const (\<^const_name>\<open>finite\<close>, _) $ _)) => true
           (* "FinFun.finfun" FIXME unchecked *)
         | SOME (Const (\<^const_name>\<open>Collect\<close>, _) $ Abs (_, _,
                     Const (\<^const_name>\<open>Ex\<close>, _) $ Abs (_, _,
                         Const (\<^const_name>\<open>finite\<close>, _) $ _))) => true
         | _ => false
       end
     | NONE => false)
  | is_univ_typedef _ _ = false

fun is_data_type ctxt (T as Type (s, _)) =
    (is_raw_typedef ctxt s orelse is_registered_type ctxt T orelse
     T = \<^typ>\<open>ind\<close> orelse is_raw_quot_type ctxt T) andalso
    not (is_interpreted_type s)
  | is_data_type _ _ = false

fun all_record_fields thy T =
  let val (recs, more) = Record.get_extT_fields thy T in
    recs @ more :: all_record_fields thy (snd more)
  end
  handle TYPE _ => []

val num_record_fields = Integer.add 1 o length o fst oo Record.get_extT_fields

fun no_of_record_field thy s T1 =
  find_index (curry (op =) s o fst) (Record.get_extT_fields thy T1 ||> single |> op @)

fun is_record_get thy (s, Type (\<^type_name>\<open>fun\<close>, [T1, _])) =
    exists (curry (op =) s o fst) (all_record_fields thy T1)
  | is_record_get _ _ = false

fun is_record_update thy (s, T) =
  String.isSuffix Record.updateN s andalso
  exists (curry (op =) (unsuffix Record.updateN s) o fst) (all_record_fields thy (body_type T))
  handle TYPE _ => false

fun is_abs_fun ctxt (s, Type (\<^type_name>\<open>fun\<close>, [_, Type (s', _)])) =
    (case typedef_info ctxt s' of
       SOME {Abs_name, ...} => s = Abs_name
     | NONE => false)
  | is_abs_fun _ _ = false

fun is_rep_fun ctxt (s, Type (\<^type_name>\<open>fun\<close>, [Type (s', _), _])) =
    (case typedef_info ctxt s' of
       SOME {Rep_name, ...} => s = Rep_name
     | NONE => false)
  | is_rep_fun _ _ = false

fun is_quot_abs_fun ctxt (x as (_, Type (\<^type_name>\<open>fun\<close>,
                                         [_, abs_T as Type (s', _)]))) =
    try (Quotient_Term.absrep_const_chk ctxt Quotient_Term.AbsF) s'
    = SOME (Const x) andalso not (is_registered_type ctxt abs_T)
  | is_quot_abs_fun _ _ = false

fun is_quot_rep_fun ctxt (s, Type (\<^type_name>\<open>fun\<close>,
                                   [abs_T as Type (abs_s, _), _])) =
    (case try (Quotient_Term.absrep_const_chk ctxt Quotient_Term.RepF) abs_s of
       SOME (Const (s', _)) =>
       s = s' andalso not (is_registered_type ctxt abs_T)
     | _ => false)
  | is_quot_rep_fun _ _ = false

fun mate_of_rep_fun ctxt (x as (_, Type (\<^type_name>\<open>fun\<close>,
                                         [T1 as Type (s', _), T2]))) =
    (case typedef_info ctxt s' of
       SOME {Abs_name, ...} => (Abs_name, Type (\<^type_name>\<open>fun\<close>, [T2, T1]))
     | NONE => raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x]))
  | mate_of_rep_fun _ x = raise TERM ("Nitpick_HOL.mate_of_rep_fun", [Const x])

fun rep_type_for_quot_type ctxt (T as Type (s, _)) =
    let
      val thy = Proof_Context.theory_of ctxt
      val {qtyp, rtyp, ...} = the (Quotient_Info.lookup_quotients ctxt s)
    in
      instantiate_type thy qtyp T rtyp
    end
  | rep_type_for_quot_type _ T =
    raise TYPE ("Nitpick_HOL.rep_type_for_quot_type", [T], [])

fun equiv_relation_for_quot_type thy (Type (s, Ts)) =
    let
      val {qtyp, equiv_rel, equiv_thm, ...} =
        the (Quotient_Info.lookup_quotients thy s)
      val partial =
        case Thm.prop_of equiv_thm of
          \<^const>\<open>Trueprop\<close> $ (Const (\<^const_name>\<open>equivp\<close>, _) $ _) => false
        | \<^const>\<open>Trueprop\<close> $ (Const (\<^const_name>\<open>part_equivp\<close>, _) $ _) => true
        | _ => raise NOT_SUPPORTED "Ill-formed quotient type equivalence \
                                   \relation theorem"
      val Ts' = qtyp |> dest_Type |> snd
    in (subst_atomic_types (Ts' ~~ Ts) equiv_rel, partial) end
  | equiv_relation_for_quot_type _ T =
    raise TYPE ("Nitpick_HOL.equiv_relation_for_quot_type", [T], [])

fun is_raw_free_datatype_constr ctxt (s, T) =
  case body_type T of
    dtT as Type (dt_s, _) =>
    let
      val ctrs =
        case Ctr_Sugar.ctr_sugar_of ctxt dt_s of
          SOME {ctrs, ...} => map dest_Const ctrs
        | _ => []
    in
      exists (fn (s', T') => s = s' andalso repair_constr_type dtT T' = T) ctrs
    end
  | _  => false

fun is_registered_coconstr ctxt (s, T) =
  case body_type T of
    coT as Type (co_s, _) =>
    let
      val ctrs =
        co_s
        |> AList.lookup (op =) (#codatatypes (Data.get (Context.Proof ctxt)))
        |> Option.map snd |> these
    in
      exists (fn (s', T') => s = s' andalso repair_constr_type coT T' = T) ctrs
    end
  | _ => false

fun is_nonfree_constr ctxt (s, T) =
  member (op =) [\<^const_name>\<open>FunBox\<close>, \<^const_name>\<open>PairBox\<close>,
                 \<^const_name>\<open>Quot\<close>, \<^const_name>\<open>Zero_Rep\<close>,
                 \<^const_name>\<open>Suc_Rep\<close>] s orelse
  let val (x as (_, T)) = (s, unarize_unbox_etc_type T) in
    is_raw_free_datatype_constr ctxt x orelse
    (is_abs_fun ctxt x andalso is_pure_typedef ctxt (range_type T)) orelse
    is_registered_coconstr ctxt x
  end

fun is_free_constr ctxt (s, T) =
  is_nonfree_constr ctxt (s, T) andalso
  let val (x as (_, T)) = (s, unarize_unbox_etc_type T) in
    not (is_abs_fun ctxt x) orelse is_univ_typedef ctxt (range_type T)
  end

fun is_stale_constr ctxt (x as (s, T)) =
  is_registered_type ctxt (body_type T) andalso is_nonfree_constr ctxt x andalso
  not (s = \<^const_name>\<open>Abs_Frac\<close> orelse is_registered_coconstr ctxt x)

fun is_constr ctxt (x as (_, T)) =
  is_nonfree_constr ctxt x andalso
  not (is_interpreted_type (fst (dest_Type (unarize_type (body_type T))))) andalso
  not (is_stale_constr ctxt x)

val is_sel = String.isPrefix discr_prefix orf String.isPrefix sel_prefix
val is_sel_like_and_no_discr =
  String.isPrefix sel_prefix orf
  (member (op =) [\<^const_name>\<open>fst\<close>, \<^const_name>\<open>snd\<close>])

fun in_fun_lhs_for InConstr = InSel
  | in_fun_lhs_for _ = InFunLHS

fun in_fun_rhs_for InConstr = InConstr
  | in_fun_rhs_for InSel = InSel
  | in_fun_rhs_for InFunRHS1 = InFunRHS2
  | in_fun_rhs_for _ = InFunRHS1

fun is_boxing_worth_it (hol_ctxt : hol_context) boxy T =
  case T of
    Type (\<^type_name>\<open>fun\<close>, _) =>
    (boxy = InPair orelse boxy = InFunLHS) andalso
    not (is_boolean_type (body_type T))
  | Type (\<^type_name>\<open>prod\<close>, Ts) =>
    boxy = InPair orelse boxy = InFunRHS1 orelse boxy = InFunRHS2 orelse
    ((boxy = InExpr orelse boxy = InFunLHS) andalso
     exists (is_boxing_worth_it hol_ctxt InPair)
            (map (box_type hol_ctxt InPair) Ts))
  | _ => false
and should_box_type (hol_ctxt as {thy, boxes, ...}) boxy z =
  case triple_lookup (type_match thy) boxes (Type z) of
    SOME (SOME box_me) => box_me
  | _ => is_boxing_worth_it hol_ctxt boxy (Type z)
and box_type hol_ctxt boxy T =
  case T of
    Type (z as (\<^type_name>\<open>fun\<close>, [T1, T2])) =>
    if boxy <> InConstr andalso boxy <> InSel andalso
       should_box_type hol_ctxt boxy z then
      Type (\<^type_name>\<open>fun_box\<close>,
            [box_type hol_ctxt InFunLHS T1, box_type hol_ctxt InFunRHS1 T2])
    else
      box_type hol_ctxt (in_fun_lhs_for boxy) T1
      --> box_type hol_ctxt (in_fun_rhs_for boxy) T2
  | Type (z as (\<^type_name>\<open>prod\<close>, Ts)) =>
    if boxy <> InConstr andalso boxy <> InSel
       andalso should_box_type hol_ctxt boxy z then
      Type (\<^type_name>\<open>pair_box\<close>, map (box_type hol_ctxt InSel) Ts)
    else
      Type (\<^type_name>\<open>prod\<close>,
            map (box_type hol_ctxt
                          (if boxy = InConstr orelse boxy = InSel then boxy
                           else InPair)) Ts)
  | _ => T

fun binarize_nat_and_int_in_type \<^typ>\<open>nat\<close> = \<^typ>\<open>unsigned_bit word\<close>
  | binarize_nat_and_int_in_type \<^typ>\<open>int\<close> = \<^typ>\<open>signed_bit word\<close>
  | binarize_nat_and_int_in_type (Type (s, Ts)) =
    Type (s, map binarize_nat_and_int_in_type Ts)
  | binarize_nat_and_int_in_type T = T
val binarize_nat_and_int_in_term = map_types binarize_nat_and_int_in_type

fun discr_for_constr (s, T) = (discr_prefix ^ s, body_type T --> bool_T)

fun num_sels_for_constr_type T = length (maybe_curried_binder_types T)

fun nth_sel_name_for_constr_name s n =
  if s = \<^const_name>\<open>Pair\<close> then
    if n = 0 then \<^const_name>\<open>fst\<close> else \<^const_name>\<open>snd\<close>
  else
    sel_prefix_for n ^ s

fun nth_sel_for_constr x ~1 = discr_for_constr x
  | nth_sel_for_constr (s, T) n =
    (nth_sel_name_for_constr_name s n,
     body_type T --> nth (maybe_curried_binder_types T) n)

fun binarized_and_boxed_nth_sel_for_constr hol_ctxt binarize =
  apsnd ((binarize ? binarize_nat_and_int_in_type) o box_type hol_ctxt InSel)
  oo nth_sel_for_constr

fun sel_no_from_name s =
  if String.isPrefix discr_prefix s then
    ~1
  else if String.isPrefix sel_prefix s then
    s |> unprefix sel_prefix |> Int.fromString |> the
  else if s = \<^const_name>\<open>snd\<close> then
    1
  else
    0

val close_form =
  let
    fun close_up zs zs' =
      fold (fn (z as ((s, _), T)) => fn t' =>
               Logic.all_const T $ Abs (s, T, abstract_over (Var z, t')))
           (take (length zs' - length zs) zs')
    fun aux zs (\<^const>\<open>Pure.imp\<close> $ t1 $ t2) =
        let val zs' = Term.add_vars t1 zs in
          close_up zs zs' (Logic.mk_implies (t1, aux zs' t2))
        end
      | aux zs t = close_up zs (Term.add_vars t zs) t
  in aux [] end

fun distinctness_formula T =
  all_distinct_unordered_pairs_of
  #> map (fn (t1, t2) => \<^const>\<open>Not\<close> $ (HOLogic.eq_const T $ t1 $ t2))
  #> List.foldr (s_conj o swap) \<^const>\<open>True\<close>

fun zero_const T = Const (\<^const_name>\<open>zero_class.zero\<close>, T)
fun suc_const T = Const (\<^const_name>\<open>Suc\<close>, T --> T)

fun uncached_data_type_constrs ({ctxt, ...} : hol_context) (T as Type (s, _)) =
    if is_interpreted_type s then
      []
    else
      (case AList.lookup (op =) (#codatatypes (Data.get (Context.Proof ctxt))) s of
         SOME (_, xs' as (_ :: _)) => map (apsnd (repair_constr_type T)) xs'
       | _ =>
         if is_frac_type ctxt T then
           case typedef_info ctxt s of
             SOME {abs_type, rep_type, Abs_name, ...} =>
             [(Abs_name, varify_and_instantiate_type ctxt abs_type T rep_type --> T)]
           | NONE => [] (* impossible *)
         else
           case Ctr_Sugar.ctr_sugar_of ctxt s of
             SOME {ctrs, ...} =>
             map (apsnd (repair_constr_type T) o dest_Const) ctrs
           | NONE =>
             if is_raw_quot_type ctxt T then
               [(\<^const_name>\<open>Quot\<close>, rep_type_for_quot_type ctxt T --> T)]
             else case typedef_info ctxt s of
               SOME {abs_type, rep_type, Abs_name, ...} =>
               [(Abs_name, varify_and_instantiate_type ctxt abs_type T rep_type --> T)]
             | NONE =>
               if T = \<^typ>\<open>ind\<close> then [dest_Const \<^const>\<open>Zero_Rep\<close>, dest_Const \<^const>\<open>Suc_Rep\<close>]
               else [])
  | uncached_data_type_constrs _ _ = []

fun data_type_constrs (hol_ctxt as {constr_cache, ...}) T =
  case AList.lookup (op =) (!constr_cache) T of
    SOME xs => xs
  | NONE =>
    let val xs = uncached_data_type_constrs hol_ctxt T in
      (Unsynchronized.change constr_cache (cons (T, xs)); xs)
    end

fun binarized_and_boxed_data_type_constrs hol_ctxt binarize =
  map (apsnd ((binarize ? binarize_nat_and_int_in_type)
              o box_type hol_ctxt InConstr)) o data_type_constrs hol_ctxt

fun constr_name_for_sel_like \<^const_name>\<open>fst\<close> = \<^const_name>\<open>Pair\<close>
  | constr_name_for_sel_like \<^const_name>\<open>snd\<close> = \<^const_name>\<open>Pair\<close>
  | constr_name_for_sel_like s' = original_name s'

fun binarized_and_boxed_constr_for_sel hol_ctxt binarize (s', T') =
  let val s = constr_name_for_sel_like s' in
    AList.lookup (op =)
        (binarized_and_boxed_data_type_constrs hol_ctxt binarize (domain_type T'))
        s
    |> the |> pair s
  end

fun card_of_type assigns (Type (\<^type_name>\<open>fun\<close>, [T1, T2])) =
    reasonable_power (card_of_type assigns T2) (card_of_type assigns T1)
  | card_of_type assigns (Type (\<^type_name>\<open>prod\<close>, [T1, T2])) =
    card_of_type assigns T1 * card_of_type assigns T2
  | card_of_type assigns (Type (\<^type_name>\<open>set\<close>, [T'])) =
    reasonable_power 2 (card_of_type assigns T')
  | card_of_type _ (Type (\<^type_name>\<open>itself\<close>, _)) = 1
  | card_of_type _ \<^typ>\<open>prop\<close> = 2
  | card_of_type _ \<^typ>\<open>bool\<close> = 2
  | card_of_type assigns T =
    case AList.lookup (op =) assigns T of
      SOME k => k
    | NONE => if T = \<^typ>\<open>bisim_iterator\<close> then 0
              else raise TYPE ("Nitpick_HOL.card_of_type", [T], [])

fun bounded_card_of_type max default_card assigns
                         (Type (\<^type_name>\<open>fun\<close>, [T1, T2])) =
    let
      val k1 = bounded_card_of_type max default_card assigns T1
      val k2 = bounded_card_of_type max default_card assigns T2
    in
      if k1 = max orelse k2 = max then max
      else Int.min (max, reasonable_power k2 k1)
      handle TOO_LARGE _ => max
    end
  | bounded_card_of_type max default_card assigns
                         (Type (\<^type_name>\<open>prod\<close>, [T1, T2])) =
    let
      val k1 = bounded_card_of_type max default_card assigns T1
      val k2 = bounded_card_of_type max default_card assigns T2
    in if k1 = max orelse k2 = max then max else Int.min (max, k1 * k2) end
  | bounded_card_of_type max default_card assigns
                         (Type (\<^type_name>\<open>set\<close>, [T'])) =
    bounded_card_of_type max default_card assigns (T' --> bool_T)
  | bounded_card_of_type max default_card assigns T =
    Int.min (max, if default_card = ~1 then
                    card_of_type assigns T
                  else
                    card_of_type assigns T
                    handle TYPE ("Nitpick_HOL.card_of_type", _, _) =>
                           default_card)

(* Similar to "ATP_Util.tiny_card_of_type". *)
fun bounded_exact_card_of_type hol_ctxt finitizable_dataTs max default_card
                               assigns T =
  let
    fun aux avoid T =
      (if member (op =) avoid T then
         0
       else if member (op =) finitizable_dataTs T then
         raise SAME ()
       else case T of
         Type (\<^type_name>\<open>fun\<close>, [T1, T2]) =>
         (case (aux avoid T1, aux avoid T2) of
            (_, 1) => 1
          | (0, _) => 0
          | (_, 0) => 0
          | (k1, k2) =>
            if k1 >= max orelse k2 >= max then max
            else Int.min (max, reasonable_power k2 k1))
       | Type (\<^type_name>\<open>prod\<close>, [T1, T2]) =>
         (case (aux avoid T1, aux avoid T2) of
            (0, _) => 0
          | (_, 0) => 0
          | (k1, k2) =>
            if k1 >= max orelse k2 >= max then max
            else Int.min (max, k1 * k2))
       | Type (\<^type_name>\<open>set\<close>, [T']) => aux avoid (T' --> bool_T)
       | Type (\<^type_name>\<open>itself\<close>, _) => 1
       | \<^typ>\<open>prop\<close> => 2
       | \<^typ>\<open>bool\<close> => 2
       | Type _ =>
         (case data_type_constrs hol_ctxt T of
            [] => if is_integer_type T orelse is_bit_type T then 0
                  else raise SAME ()
          | constrs =>
            let
              val constr_cards =
                map (Integer.prod o map (aux (T :: avoid)) o binder_types o snd)
                    constrs
            in
              if exists (curry (op =) 0) constr_cards then 0
              else Int.min (max, Integer.sum constr_cards)
            end)
       | _ => raise SAME ())
      handle SAME () =>
             AList.lookup (op =) assigns T |> the_default default_card
  in Int.min (max, aux [] T) end

val typical_atomic_card = 4
val typical_card_of_type = bounded_card_of_type 16777217 typical_atomic_card []

fun is_finite_type hol_ctxt T =
  bounded_exact_card_of_type hol_ctxt [] 1 2 [] T > 0

fun is_special_eligible_arg strict Ts t =
  case map snd (Term.add_vars t []) @ map (nth Ts) (loose_bnos t) of
    [] => true
  | bad_Ts =>
    let
      val bad_Ts_cost =
        if strict then fold (curry (op *) o typical_card_of_type) bad_Ts 1
        else fold (Integer.max o typical_card_of_type) bad_Ts 0
      val T_cost = typical_card_of_type (fastype_of1 (Ts, t))
    in (bad_Ts_cost, T_cost) |> (if strict then op < else op <=) end

fun abs_var ((s, j), T) body = Abs (s, T, abstract_over (Var ((s, j), T), body))

fun let_var s = (nitpick_prefix ^ s, 999)
val let_inline_threshold = 20

fun s_let Ts s n abs_T body_T f t =
  if (n - 1) * (size_of_term t - 1) <= let_inline_threshold orelse
     is_special_eligible_arg false Ts t then
    f t
  else
    let val z = (let_var s, abs_T) in
      Const (\<^const_name>\<open>Let\<close>, abs_T --> (abs_T --> body_T) --> body_T)
      $ t $ abs_var z (incr_boundvars 1 (f (Var z)))
    end

fun loose_bvar1_count (Bound i, k) = if i = k then 1 else 0
  | loose_bvar1_count (t1 $ t2, k) =
    loose_bvar1_count (t1, k) + loose_bvar1_count (t2, k)
  | loose_bvar1_count (Abs (_, _, t), k) = loose_bvar1_count (t, k + 1)
  | loose_bvar1_count _ = 0

fun s_betapply _ (t1 as Const (\<^const_name>\<open>Pure.eq\<close>, _) $ t1', t2) =
    if t1' aconv t2 then \<^prop>\True\ else t1 $ t2
  | s_betapply _ (t1 as Const (\<^const_name>\<open>HOL.eq\<close>, _) $ t1', t2) =
    if t1' aconv t2 then \<^term>\True\ else t1 $ t2
  | s_betapply _ (Const (\<^const_name>\<open>If\<close>, _) $ \<^const>\<open>True\<close> $ t1', _) = t1'
  | s_betapply _ (Const (\<^const_name>\<open>If\<close>, _) $ \<^const>\<open>False\<close> $ _, t2) = t2
  | s_betapply Ts (Const (\<^const_name>\<open>Let\<close>,
                          Type (_, [bound_T, Type (_, [_, body_T])]))
                   $ t12 $ Abs (s, T, t13'), t2) =
    let val body_T' = range_type body_T in
      Const (\<^const_name>\<open>Let\<close>, bound_T --> (bound_T --> body_T') --> body_T')
      $ t12 $ Abs (s, T, s_betapply (T :: Ts) (t13', incr_boundvars 1 t2))
    end
  | s_betapply Ts (t1 as Abs (s1, T1, t1'), t2) =
    (s_let Ts s1 (loose_bvar1_count (t1', 0)) T1 (fastype_of1 (T1 :: Ts, t1'))
           (curry betapply t1) t2
     (* FIXME: fix all "s_betapply []" calls *)
     handle TERM _ => betapply (t1, t2)
          | General.Subscript => betapply (t1, t2))
  | s_betapply _ (t1, t2) = t1 $ t2

fun s_betapplys Ts = Library.foldl (s_betapply Ts)

fun s_beta_norm Ts t =
  let
    fun aux _ (Var _) = raise Same.SAME
      | aux Ts (Abs (s, T, t')) = Abs (s, T, aux (T :: Ts) t')
      | aux Ts ((t1 as Abs _) $ t2) =
        Same.commit (aux Ts) (s_betapply Ts (t1, t2))
      | aux Ts (t1 $ t2) =
        ((case aux Ts t1 of
           t1 as Abs _ => Same.commit (aux Ts) (s_betapply Ts (t1, t2))
         | t1 => t1 $ Same.commit (aux Ts) t2)
        handle Same.SAME => t1 $ aux Ts t2)
      | aux _ _ = raise Same.SAME
  in aux Ts t handle Same.SAME => t end

fun discr_term_for_constr hol_ctxt (x as (s, T)) =
  let val dataT = body_type T in
    if s = \<^const_name>\<open>Suc\<close> then
      Abs (Name.uu, dataT, \<^const>\<open>Not\<close> $ HOLogic.mk_eq (zero_const dataT, Bound 0))
    else if length (data_type_constrs hol_ctxt dataT) >= 2 then
      Const (discr_for_constr x)
    else
      Abs (Name.uu, dataT, \<^const>\<open>True\<close>)
  end

fun discriminate_value (hol_ctxt as {ctxt, ...}) x t =
  case head_of t of
    Const x' =>
    if x = x' then \<^const>\True\
    else if is_nonfree_constr ctxt x' then \<^const>\False\
    else s_betapply [] (discr_term_for_constr hol_ctxt x, t)
  | _ => s_betapply [] (discr_term_for_constr hol_ctxt x, t)

fun nth_arg_sel_term_for_constr (x as (s, T)) n =
  let val (arg_Ts, dataT) = strip_type T in
    if dataT = nat_T then
      \<^term>\<open>%n::nat. n - 1\<close>
    else if is_pair_type dataT then
      Const (nth_sel_for_constr x n)
    else
      let
        fun aux m (Type (\<^type_name>\<open>prod\<close>, [T1, T2])) =
            let
              val (m, t1) = aux m T1
              val (m, t2) = aux m T2
            in (m, HOLogic.mk_prod (t1, t2)) end
          | aux m T =
            (m + 1, Const (nth_sel_name_for_constr_name s m, dataT --> T)
                    $ Bound 0)
        val m = fold (Integer.add o num_factors_in_type)
                     (List.take (arg_Ts, n)) 0
      in Abs ("x", dataT, aux m (nth arg_Ts n) |> snd) end
  end

fun select_nth_constr_arg ctxt x t n res_T =
  (case strip_comb t of
     (Const x', args) =>
     if x = x' then
        if is_free_constr ctxt x then nth args n else raise SAME ()
     else if is_nonfree_constr ctxt x' then
       Const (\<^const_name>\<open>unknown\<close>, res_T)
     else
       raise SAME ()
   | _ => raise SAME())
  handle SAME () => s_betapply [] (nth_arg_sel_term_for_constr x n, t)

fun construct_value _ x [] = Const x
  | construct_value ctxt (x as (s, _)) args =
    let val args = map Envir.eta_contract args in
      case hd args of
        Const (s', _) $ t =>
        if is_sel_like_and_no_discr s' andalso
           constr_name_for_sel_like s' = s andalso
           forall (fn (n, t') => select_nth_constr_arg ctxt x t n dummyT = t')
                  (index_seq 0 (length args) ~~ args) then
          t
        else
          list_comb (Const x, args)
      | _ => list_comb (Const x, args)
    end

fun constr_expand (hol_ctxt as {ctxt, ...}) T t =
  (case head_of t of
     Const x => if is_nonfree_constr ctxt x then t else raise SAME ()
   | _ => raise SAME ())
  handle SAME () =>
         let
           val x' as (_, T') =
             if is_pair_type T then
               let val (T1, T2) = HOLogic.dest_prodT T in
                 (\<^const_name>\<open>Pair\<close>, T1 --> T2 --> T)
               end
             else
               data_type_constrs hol_ctxt T |> hd
           val arg_Ts = binder_types T'
         in
           list_comb (Const x', map2 (select_nth_constr_arg ctxt x' t)
                                     (index_seq 0 (length arg_Ts)) arg_Ts)
         end

fun coerce_bound_no f j t =
  case t of
    t1 $ t2 => coerce_bound_no f j t1 $ coerce_bound_no f j t2
  | Abs (s, T, t') => Abs (s, T, coerce_bound_no f (j + 1) t')
  | Bound j' => if j' = j then f t else t
  | _ => t

fun coerce_bound_0_in_term hol_ctxt new_T old_T =
  old_T <> new_T ? coerce_bound_no (coerce_term hol_ctxt [new_T] old_T new_T) 0
and coerce_term (hol_ctxt as {ctxt, ...}) Ts new_T old_T t =
  if old_T = new_T then
    t
  else
    case (new_T, old_T) of
      (Type (new_s, new_Ts as [new_T1, new_T2]),
       Type (\<^type_name>\<open>fun\<close>, [old_T1, old_T2])) =>
      (case eta_expand Ts t 1 of
         Abs (s, _, t') =>
         Abs (s, new_T1,
              t' |> coerce_bound_0_in_term hol_ctxt new_T1 old_T1
                 |> coerce_term hol_ctxt (new_T1 :: Ts) new_T2 old_T2)
         |> Envir.eta_contract
         |> new_s <> \<^type_name>\<open>fun\<close>
            ? construct_value ctxt
                  (\<^const_name>\<open>FunBox\<close>,
                   Type (\<^type_name>\<open>fun\<close>, new_Ts) --> new_T)
              o single
       | t' => raise TERM ("Nitpick_HOL.coerce_term", [t']))
    | (Type (new_s, new_Ts as [new_T1, new_T2]),
       Type (old_s, old_Ts as [old_T1, old_T2])) =>
      if old_s = \<^type_name>\<open>fun_box\<close> orelse
         old_s = \<^type_name>\<open>pair_box\<close> orelse old_s = \<^type_name>\<open>prod\<close> then
        case constr_expand hol_ctxt old_T t of
          Const (old_s, _) $ t1 =>
          if new_s = \<^type_name>\<open>fun\<close> then
            coerce_term hol_ctxt Ts new_T (Type (\<^type_name>\<open>fun\<close>, old_Ts)) t1
          else
            construct_value ctxt
                (old_s, Type (\<^type_name>\<open>fun\<close>, new_Ts) --> new_T)
                [coerce_term hol_ctxt Ts (Type (\<^type_name>\<open>fun\<close>, new_Ts))
                             (Type (\<^type_name>\<open>fun\<close>, old_Ts)) t1]
        | Const _ $ t1 $ t2 =>
          construct_value ctxt
              (if new_s = \<^type_name>\<open>prod\<close> then \<^const_name>\<open>Pair\<close>
               else \<^const_name>\<open>PairBox\<close>, new_Ts ---> new_T)
              (@{map 3} (coerce_term hol_ctxt Ts) [new_T1, new_T2] [old_T1, old_T2]
                    [t1, t2])
        | t' => raise TERM ("Nitpick_HOL.coerce_term", [t'])
      else
        raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t])
    | _ => raise TYPE ("Nitpick_HOL.coerce_term", [new_T, old_T], [t])

fun is_ground_term (t1 $ t2) = is_ground_term t1 andalso is_ground_term t2
  | is_ground_term (Const _) = true
  | is_ground_term _ = false

fun special_bounds ts =
  fold Term.add_vars ts [] |> sort (Term_Ord.fast_indexname_ord o apply2 fst)

fun is_funky_typedef_name ctxt s =
  member (op =) [\<^type_name>\<open>unit\<close>, \<^type_name>\<open>prod\<close>, \<^type_name>\<open>set\<close>,
                 \<^type_name>\<open>Sum_Type.sum\<close>, \<^type_name>\<open>int\<close>] s orelse
  is_frac_type ctxt (Type (s, []))

fun is_funky_typedef ctxt (Type (s, _)) = is_funky_typedef_name ctxt s
  | is_funky_typedef _ _ = false

fun all_defs_of thy subst =
  let
    val def_names =
      thy |> Theory.defs_of
          |> Defs.all_specifications_of
          |> maps snd |> map_filter #def
          |> Ord_List.make fast_string_ord
  in
    Thm.all_axioms_of thy
    |> map (apsnd (subst_atomic subst o Thm.prop_of))
    |> sort (fast_string_ord o apply2 fst)
    |> Ord_List.inter (fast_string_ord o apsnd fst) def_names
    |> map snd
  end

(* Ideally we would check against "Complex_Main", not "Hilbert_Choice", but any
   theory will do as long as it contains all the "axioms" and "axiomatization"
   commands. *)
fun is_built_in_theory thy_id =
  Context.subthy_id (thy_id, Context.theory_id \<^theory>\<open>Hilbert_Choice\<close>)

fun all_nondefs_of ctxt subst =
  ctxt |> Spec_Rules.get
       |> filter (Spec_Rules.is_unknown o #rough_classification)
       |> maps #rules
       |> filter_out (is_built_in_theory o Thm.theory_id)
       |> map (subst_atomic subst o Thm.prop_of)

fun arity_of_built_in_const (s, T) =
  if s = \<^const_name>\<open>If\<close> then
    if nth_range_type 3 T = \<^typ>\<open>bool\<close> then NONE else SOME 3
  else
    case AList.lookup (op =) built_in_consts s of
      SOME n => SOME n
    | NONE =>
      case AList.lookup (op =) built_in_typed_consts (s, unarize_type T) of
        SOME n => SOME n
      | NONE =>
        case s of
          \<^const_name>\<open>zero_class.zero\<close> => if is_iterator_type T then SOME 0 else NONE
        | \<^const_name>\<open>Suc\<close> => if is_iterator_type (domain_type T) then SOME 0 else NONE
        | _ => NONE

val is_built_in_const = is_some o arity_of_built_in_const

(* This function is designed to work for both real definition axioms and
   simplification rules (equational specifications). *)
fun term_under_def t =
  case t of
    \<^const>\<open>Pure.imp\<close> $ _ $ t2 => term_under_def t2
  | Const (\<^const_name>\<open>Pure.eq\<close>, _) $ t1 $ _ => term_under_def t1
  | \<^const>\<open>Trueprop\<close> $ t1 => term_under_def t1
  | Const (\<^const_name>\<open>HOL.eq\<close>, _) $ t1 $ _ => term_under_def t1
  | Abs (_, _, t') => term_under_def t'
  | t1 $ _ => term_under_def t1
  | _ => t

(* Here we crucially rely on "specialize_type" performing a preorder traversal
   of the term, without which the wrong occurrence of a constant could be
   matched in the face of overloading. *)
fun def_props_for_const thy table (x as (s, _)) =
  if is_built_in_const x then
    []
  else
    these (Symtab.lookup table s)
    |> map_filter (try (specialize_type thy x))
    |> filter (curry (op =) (Const x) o term_under_def)

fun normalized_rhs_of t =
  let
    fun aux (v as Var _) (SOME t) = SOME (lambda v t)
      | aux (c as Const (\<^const_name>\<open>Pure.type\<close>, _)) (SOME t) = SOME (lambda c t)
      | aux _ _ = NONE
    val (lhs, rhs) =
      case t of
        Const (\<^const_name>\<open>Pure.eq\<close>, _) $ t1 $ t2 => (t1, t2)
      | \<^const>\<open>Trueprop\<close> $ (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ t1 $ t2) =>
        (t1, t2)
      | _ => raise TERM ("Nitpick_HOL.normalized_rhs_of", [t])
    val args = strip_comb lhs |> snd
  in fold_rev aux args (SOME rhs) end

fun get_def_of_const thy table (x as (s, _)) =
  x |> def_props_for_const thy table |> List.last
    |> normalized_rhs_of |> Option.map (prefix_abs_vars s)
  handle List.Empty => NONE
       | TERM _ => NONE

fun def_of_const_ext thy (unfold_table, fallback_table) (x as (s, _)) =
  if is_built_in_const x orelse original_name s <> s then
    NONE
  else case get_def_of_const thy unfold_table x of
    SOME def => SOME (true, def)
  | NONE => get_def_of_const thy fallback_table x |> Option.map (pair false)

val def_of_const = Option.map snd ooo def_of_const_ext

fun fixpoint_kind_of_rhs (Abs (_, _, t)) = fixpoint_kind_of_rhs t
  | fixpoint_kind_of_rhs (Const (\<^const_name>\<open>lfp\<close>, _) $ Abs _) = Lfp
  | fixpoint_kind_of_rhs (Const (\<^const_name>\<open>gfp\<close>, _) $ Abs _) = Gfp
  | fixpoint_kind_of_rhs _ = NoFp

fun is_mutually_inductive_pred_def thy table t =
  let
    fun is_good_arg (Bound _) = true
      | is_good_arg (Const (s, _)) =
        s = \<^const_name>\<open>True\<close> orelse s = \<^const_name>\<open>False\<close> orelse
        s = \<^const_name>\<open>undefined\<close>
      | is_good_arg _ = false
  in
    case t |> strip_abs_body |> strip_comb of
      (Const x, ts as (_ :: _)) =>
      (case def_of_const thy table x of
         SOME t' => fixpoint_kind_of_rhs t' <> NoFp andalso
                    forall is_good_arg ts
       | NONE => false)
    | _ => false
  end

fun unfold_mutually_inductive_preds thy table =
  map_aterms (fn t as Const x =>
      (case def_of_const thy table x of
         SOME t' =>
         let val t' = Envir.eta_contract t' in
           if is_mutually_inductive_pred_def thy table t' then t' else t
         end
      | NONE => t)
    | t => t)

fun case_const_names ctxt =
  map_filter (fn {casex = Const (s, T), ...} =>
      (case rev (binder_types T) of
        [] => NONE
      | T :: Ts => if is_data_type ctxt T then SOME (s, length Ts) else NONE))
    (Ctr_Sugar.ctr_sugars_of ctxt) @
  map (apsnd length o snd) (#codatatypes (Data.get (Context.Proof ctxt)))

fun fixpoint_kind_of_const thy table x =
  if is_built_in_const x then NoFp
  else fixpoint_kind_of_rhs (the (def_of_const thy table x))
  handle Option.Option => NoFp

fun is_raw_inductive_pred ({thy, def_tables, intro_table, ...} : hol_context) x =
  fixpoint_kind_of_const thy def_tables x <> NoFp andalso
  not (null (def_props_for_const thy intro_table x))

fun is_inductive_pred hol_ctxt (x as (s, _)) =
  String.isPrefix ubfp_prefix s orelse String.isPrefix lbfp_prefix s orelse
  is_raw_inductive_pred hol_ctxt x

fun lhs_of_equation t =
  case t of
    Const (\<^const_name>\<open>Pure.all\<close>, _) $ Abs (_, _, t1) => lhs_of_equation t1
  | Const (\<^const_name>\<open>Pure.eq\<close>, _) $ t1 $ _ => SOME t1
  | \<^const>\<open>Pure.imp\<close> $ _ $ t2 => lhs_of_equation t2
  | \<^const>\<open>Trueprop\<close> $ t1 => lhs_of_equation t1
  | Const (\<^const_name>\<open>All\<close>, _) $ Abs (_, _, t1) => lhs_of_equation t1
  | Const (\<^const_name>\<open>HOL.eq\<close>, _) $ t1 $ _ => SOME t1
  | \<^const>\<open>HOL.implies\<close> $ _ $ t2 => lhs_of_equation t2
  | _ => NONE

fun is_constr_pattern _ (Bound _) = true
  | is_constr_pattern _ (Var _) = true
  | is_constr_pattern ctxt t =
    case strip_comb t of
      (Const x, args) =>
      is_nonfree_constr ctxt x andalso forall (is_constr_pattern ctxt) args
    | _ => false

fun is_constr_pattern_lhs ctxt t =
  forall (is_constr_pattern ctxt) (snd (strip_comb t))

fun is_constr_pattern_formula ctxt t =
  case lhs_of_equation t of
    SOME t' => is_constr_pattern_lhs ctxt t'
  | NONE => false

(* Similar to "specialize_type" but returns all matches rather than only the
   first (preorder) match. *)
fun multi_specialize_type thy slack (s, T) t =
  let
    fun aux (Const (s', T')) ys =
        if s = s' then
          ys |> (if AList.defined (op =) ys T' then
                   I
                 else
                   cons (T', Envir.subst_term_types (Sign.typ_match thy (T', T)
                     Vartab.empty) t)
                   handle Type.TYPE_MATCH => I
                        | TERM _ =>
                          if slack then
                            I
                          else
                            raise NOT_SUPPORTED
                                      ("too much polymorphism in axiom \"" ^
                                       Syntax.string_of_term_global thy t ^
                                       "\" involving " ^ quote s))
        else
          ys
      | aux _ ys = ys
  in map snd (fold_aterms aux t []) end

fun nondef_props_for_const thy slack table (x as (s, _)) =
  these (Symtab.lookup table s) |> maps (multi_specialize_type thy slack x)

fun unvarify_term (t1 $ t2) = unvarify_term t1 $ unvarify_term t2
  | unvarify_term (Var ((s, 0), T)) = Free (s, T)
  | unvarify_term (Abs (s, T, t')) = Abs (s, T, unvarify_term t')
  | unvarify_term t = t

fun axiom_for_choice_spec ctxt =
  unvarify_term
  #> Object_Logic.atomize_term ctxt
  #> Choice_Specification.close_form
  #> HOLogic.mk_Trueprop

fun is_choice_spec_fun ({thy, ctxt, def_tables, nondef_table, choice_spec_table, ...}
                        : hol_context) x =
  case nondef_props_for_const thy true choice_spec_table x of
    [] => false
  | ts => case def_of_const thy def_tables x of
            SOME (Const (\<^const_name>\<open>Eps\<close>, _) $ _) => true
          | SOME _ => false
          | NONE =>
            let val ts' = nondef_props_for_const thy true nondef_table x in
              length ts' = length ts andalso
--> --------------------

--> maximum size reached

--> --------------------

¤ Dauer der Verarbeitung: 0.40 Sekunden (vorverarbeitet) ¤

Download des Quellennavigators
Download des sprechenden Kalenders
in der Quellcodebibliothek suchen

Haftungshinweis

Die Informationen auf dieser Webseite wurden nach bestem Wissen sorgfältig zusammengestellt. Es wird jedoch weder Vollständigkeit, noch Richtigkeit, noch Qualität der bereit gestellten Informationen zugesichert.

Bemerkung:

Die farbliche Syntaxdarstellung ist noch experimentell.