src/Tools/misc_legacy.ML
author wenzelm
Mon Mar 25 17:21:26 2019 +0100 (7 weeks ago)
changeset 69981 3dced198b9ec
parent 69593 3dda49e08b9d
permissions -rw-r--r--
more strict AFP properties;
wenzelm@37781
     1
(*  Title:      Tools/misc_legacy.ML
wenzelm@37781
     2
wenzelm@37781
     3
Misc legacy stuff -- to be phased out eventually.
wenzelm@37781
     4
*)
wenzelm@37781
     5
wenzelm@37781
     6
signature MISC_LEGACY =
wenzelm@37781
     7
sig
wenzelm@44121
     8
  val add_term_names: term * string list -> string list
wenzelm@44121
     9
  val add_term_tvars: term * (indexname * sort) list -> (indexname * sort) list
wenzelm@44121
    10
  val add_term_tfrees: term * (string * sort) list -> (string * sort) list
wenzelm@44121
    11
  val typ_tvars: typ -> (indexname * sort) list
wenzelm@44121
    12
  val term_tfrees: term -> (string * sort) list
wenzelm@44121
    13
  val term_tvars: term -> (indexname * sort) list
wenzelm@44121
    14
  val add_term_vars: term * term list -> term list
wenzelm@44121
    15
  val term_vars: term -> term list
wenzelm@44121
    16
  val add_term_frees: term * term list -> term list
wenzelm@44121
    17
  val term_frees: term -> term list
wenzelm@37781
    18
  val mk_defpair: term * term -> string * term
wenzelm@37781
    19
  val get_def: theory -> xstring -> thm
wenzelm@59165
    20
  val METAHYPS: Proof.context -> (thm list -> tactic) -> int -> tactic
wenzelm@60358
    21
  val freeze_thaw_robust: Proof.context -> thm -> thm * (int -> thm -> thm)
wenzelm@37781
    22
end;
wenzelm@37781
    23
wenzelm@37781
    24
structure Misc_Legacy: MISC_LEGACY =
wenzelm@37781
    25
struct
wenzelm@37781
    26
wenzelm@44121
    27
(*iterate a function over all types in a term*)
wenzelm@44121
    28
fun it_term_types f =
wenzelm@44121
    29
let fun iter(Const(_,T), a) = f(T,a)
wenzelm@44121
    30
      | iter(Free(_,T), a) = f(T,a)
wenzelm@44121
    31
      | iter(Var(_,T), a) = f(T,a)
wenzelm@44121
    32
      | iter(Abs(_,T,t), a) = iter(t,f(T,a))
wenzelm@44121
    33
      | iter(f$u, a) = iter(f, iter(u, a))
wenzelm@44121
    34
      | iter(Bound _, a) = a
wenzelm@44121
    35
in iter end
wenzelm@44121
    36
wenzelm@44121
    37
(*Accumulates the names in the term, suppressing duplicates.
wenzelm@44121
    38
  Includes Frees and Consts.  For choosing unambiguous bound var names.*)
wenzelm@44121
    39
fun add_term_names (Const(a,_), bs) = insert (op =) (Long_Name.base_name a) bs
wenzelm@44121
    40
  | add_term_names (Free(a,_), bs) = insert (op =) a bs
wenzelm@44121
    41
  | add_term_names (f$u, bs) = add_term_names (f, add_term_names(u, bs))
wenzelm@44121
    42
  | add_term_names (Abs(_,_,t), bs) = add_term_names(t,bs)
wenzelm@44121
    43
  | add_term_names (_, bs) = bs;
wenzelm@44121
    44
wenzelm@44121
    45
(*Accumulates the TVars in a type, suppressing duplicates.*)
wenzelm@44121
    46
fun add_typ_tvars(Type(_,Ts),vs) = List.foldr add_typ_tvars vs Ts
wenzelm@44121
    47
  | add_typ_tvars(TFree(_),vs) = vs
wenzelm@44121
    48
  | add_typ_tvars(TVar(v),vs) = insert (op =) v vs;
wenzelm@44121
    49
wenzelm@44121
    50
(*Accumulates the TFrees in a type, suppressing duplicates.*)
wenzelm@44121
    51
fun add_typ_tfree_names(Type(_,Ts),fs) = List.foldr add_typ_tfree_names fs Ts
wenzelm@44121
    52
  | add_typ_tfree_names(TFree(f,_),fs) = insert (op =) f fs
wenzelm@44121
    53
  | add_typ_tfree_names(TVar(_),fs) = fs;
wenzelm@44121
    54
wenzelm@44121
    55
fun add_typ_tfrees(Type(_,Ts),fs) = List.foldr add_typ_tfrees fs Ts
wenzelm@44121
    56
  | add_typ_tfrees(TFree(f),fs) = insert (op =) f fs
wenzelm@44121
    57
  | add_typ_tfrees(TVar(_),fs) = fs;
wenzelm@44121
    58
wenzelm@44121
    59
(*Accumulates the TVars in a term, suppressing duplicates.*)
wenzelm@44121
    60
val add_term_tvars = it_term_types add_typ_tvars;
wenzelm@44121
    61
wenzelm@44121
    62
(*Accumulates the TFrees in a term, suppressing duplicates.*)
wenzelm@44121
    63
val add_term_tfrees = it_term_types add_typ_tfrees;
wenzelm@44121
    64
val add_term_tfree_names = it_term_types add_typ_tfree_names;
wenzelm@44121
    65
wenzelm@44121
    66
(*Non-list versions*)
wenzelm@44121
    67
fun typ_tfrees T = add_typ_tfrees(T,[]);
wenzelm@44121
    68
fun typ_tvars T = add_typ_tvars(T,[]);
wenzelm@44121
    69
fun term_tfrees t = add_term_tfrees(t,[]);
wenzelm@44121
    70
fun term_tvars t = add_term_tvars(t,[]);
wenzelm@44121
    71
wenzelm@44121
    72
wenzelm@44121
    73
(*Accumulates the Vars in the term, suppressing duplicates.*)
wenzelm@44121
    74
fun add_term_vars (t, vars: term list) = case t of
wenzelm@44121
    75
    Var   _ => Ord_List.insert Term_Ord.term_ord t vars
wenzelm@44121
    76
  | Abs (_,_,body) => add_term_vars(body,vars)
wenzelm@44121
    77
  | f$t =>  add_term_vars (f, add_term_vars(t, vars))
wenzelm@44121
    78
  | _ => vars;
wenzelm@44121
    79
wenzelm@44121
    80
fun term_vars t = add_term_vars(t,[]);
wenzelm@44121
    81
wenzelm@44121
    82
(*Accumulates the Frees in the term, suppressing duplicates.*)
wenzelm@44121
    83
fun add_term_frees (t, frees: term list) = case t of
wenzelm@44121
    84
    Free   _ => Ord_List.insert Term_Ord.term_ord t frees
wenzelm@44121
    85
  | Abs (_,_,body) => add_term_frees(body,frees)
wenzelm@44121
    86
  | f$t =>  add_term_frees (f, add_term_frees(t, frees))
wenzelm@44121
    87
  | _ => frees;
wenzelm@44121
    88
wenzelm@44121
    89
fun term_frees t = add_term_frees(t,[]);
wenzelm@44121
    90
wenzelm@44121
    91
wenzelm@37781
    92
fun mk_defpair (lhs, rhs) =
wenzelm@37781
    93
  (case Term.head_of lhs of
wenzelm@37781
    94
    Const (name, _) =>
wenzelm@46909
    95
      (Thm.def_name (Long_Name.base_name name), Logic.mk_equals (lhs, rhs))
wenzelm@37781
    96
  | _ => raise TERM ("Malformed definition: head of lhs not a constant", [lhs, rhs]));
wenzelm@37781
    97
wenzelm@37781
    98
wenzelm@37781
    99
fun get_def thy = Thm.axiom thy o Name_Space.intern (Theory.axiom_space thy) o Thm.def_name;
wenzelm@37781
   100
wenzelm@37781
   101
wenzelm@37781
   102
(**** METAHYPS -- tactical for using hypotheses as meta-level assumptions
wenzelm@37781
   103
       METAHYPS (fn prems => tac prems) i
wenzelm@37781
   104
wenzelm@37781
   105
converts subgoal i, of the form !!x1...xm. [| A1;...;An] ==> A into a new
wenzelm@37781
   106
proof state A==>A, supplying A1,...,An as meta-level assumptions (in
wenzelm@37781
   107
"prems").  The parameters x1,...,xm become free variables.  If the
wenzelm@37781
   108
resulting proof state is [| B1;...;Bk] ==> C (possibly assuming A1,...,An)
wenzelm@37781
   109
then it is lifted back into the original context, yielding k subgoals.
wenzelm@37781
   110
wenzelm@37781
   111
Replaces unknowns in the context by Frees having the prefix METAHYP_
wenzelm@37781
   112
New unknowns in [| B1;...;Bk] ==> C are lifted over x1,...,xm.
wenzelm@37781
   113
DOES NOT HANDLE TYPE UNKNOWNS.
wenzelm@37781
   114
wenzelm@37781
   115
wenzelm@37781
   116
NOTE: This version does not observe the proof context, and thus cannot
wenzelm@37781
   117
work reliably.  See also Subgoal.SUBPROOF and Subgoal.FOCUS for
wenzelm@37781
   118
properly localized variants of the same idea.
wenzelm@37781
   119
****)
wenzelm@37781
   120
wenzelm@37781
   121
local
wenzelm@37781
   122
wenzelm@37781
   123
(*Strips assumptions in goal yielding  ( [x1,...,xm], [H1,...,Hn], B )
wenzelm@37781
   124
    H1,...,Hn are the hypotheses;  x1...xm are variants of the parameters.
wenzelm@37781
   125
  Main difference from strip_assums concerns parameters:
wenzelm@37781
   126
    it replaces the bound variables by free variables.  *)
wenzelm@69593
   127
fun strip_context_aux (params, Hs, Const (\<^const_name>\<open>Pure.imp\<close>, _) $ H $ B) =
wenzelm@37781
   128
      strip_context_aux (params, H :: Hs, B)
wenzelm@69593
   129
  | strip_context_aux (params, Hs, Const (\<^const_name>\<open>Pure.all\<close>,_) $ Abs (a, T, t)) =
wenzelm@42284
   130
      let val (b, u) = Syntax_Trans.variant_abs (a, T, t)
wenzelm@37781
   131
      in strip_context_aux ((b, T) :: params, Hs, u) end
wenzelm@37781
   132
  | strip_context_aux (params, Hs, B) = (rev params, rev Hs, B);
wenzelm@37781
   133
wenzelm@37781
   134
fun strip_context A = strip_context_aux ([], [], A);
wenzelm@37781
   135
wenzelm@37781
   136
(*Left-to-right replacements: ctpairs = [...,(vi,ti),...].
wenzelm@37781
   137
  Instantiates distinct free variables by terms of same type.*)
wenzelm@37781
   138
fun free_instantiate ctpairs =
wenzelm@37781
   139
  forall_elim_list (map snd ctpairs) o forall_intr_list (map fst ctpairs);
wenzelm@37781
   140
wenzelm@37781
   141
fun free_of s ((a, i), T) =
wenzelm@37781
   142
  Free (s ^ (case i of 0 => a | _ => a ^ "_" ^ string_of_int i), T)
wenzelm@37781
   143
wenzelm@37781
   144
fun mk_inst v = (Var v, free_of "METAHYP1_" v)
wenzelm@37781
   145
wenzelm@37781
   146
fun metahyps_split_prem prem =
wenzelm@37781
   147
  let (*find all vars in the hyps -- should find tvars also!*)
wenzelm@37781
   148
      val hyps_vars = fold Term.add_vars (Logic.strip_assums_hyp prem) []
wenzelm@37781
   149
      val insts = map mk_inst hyps_vars
wenzelm@37781
   150
      (*replace the hyps_vars by Frees*)
wenzelm@37781
   151
      val prem' = subst_atomic insts prem
wenzelm@37781
   152
      val (params,hyps,concl) = strip_context prem'
wenzelm@37781
   153
  in (insts,params,hyps,concl)  end;
wenzelm@37781
   154
wenzelm@59165
   155
fun metahyps_aux_tac ctxt tacf (prem,gno) state =
wenzelm@37781
   156
  let val (insts,params,hyps,concl) = metahyps_split_prem prem
wenzelm@37781
   157
      val maxidx = Thm.maxidx_of state
wenzelm@60358
   158
      val chyps = map (Thm.cterm_of ctxt) hyps
wenzelm@37781
   159
      val hypths = map Thm.assume chyps
wenzelm@37781
   160
      val subprems = map (Thm.forall_elim_vars 0) hypths
wenzelm@37781
   161
      val fparams = map Free params
wenzelm@60358
   162
      val cparams = map (Thm.cterm_of ctxt) fparams
wenzelm@60358
   163
      fun swap_ctpair (t, u) = apply2 (Thm.cterm_of ctxt) (u, t)
wenzelm@37781
   164
      (*Subgoal variables: make Free; lift type over params*)
wenzelm@37781
   165
      fun mk_subgoal_inst concl_vars (v, T) =
wenzelm@37781
   166
          if member (op =) concl_vars (v, T)
wenzelm@37781
   167
          then ((v, T), true, free_of "METAHYP2_" (v, T))
wenzelm@37781
   168
          else ((v, T), false, free_of "METAHYP2_" (v, map #2 params ---> T))
wenzelm@37781
   169
      (*Instantiate subgoal vars by Free applied to params*)
wenzelm@60642
   170
      fun mk_inst (v, in_concl, u) =
wenzelm@60642
   171
          if in_concl then (v, Thm.cterm_of ctxt u)
wenzelm@60642
   172
          else (v, Thm.cterm_of ctxt (list_comb (u, fparams)))
wenzelm@37781
   173
      (*Restore Vars with higher type and index*)
wenzelm@37781
   174
      fun mk_subgoal_swap_ctpair (((a, i), T), in_concl, u as Free (_, U)) =
wenzelm@60358
   175
          if in_concl then apply2 (Thm.cterm_of ctxt) (u, Var ((a, i), T))
wenzelm@60358
   176
          else apply2 (Thm.cterm_of ctxt) (u, Var ((a, i + maxidx), U))
wenzelm@37781
   177
      (*Embed B in the original context of params and hyps*)
wenzelm@46215
   178
      fun embed B = fold_rev Logic.all fparams (Logic.list_implies (hyps, B))
wenzelm@37781
   179
      (*Strip the context using elimination rules*)
wenzelm@37781
   180
      fun elim Bhyp = implies_elim_list (forall_elim_list cparams Bhyp) hypths
wenzelm@37781
   181
      (*A form of lifting that discharges assumptions.*)
wenzelm@37781
   182
      fun relift st =
wenzelm@37781
   183
        let val prop = Thm.prop_of st
wenzelm@37781
   184
            val subgoal_vars = (*Vars introduced in the subgoals*)
wenzelm@37781
   185
              fold Term.add_vars (Logic.strip_imp_prems prop) []
wenzelm@37781
   186
            and concl_vars = Term.add_vars (Logic.strip_imp_concl prop) []
wenzelm@37781
   187
            val subgoal_insts = map (mk_subgoal_inst concl_vars) subgoal_vars
wenzelm@60642
   188
            val st' = Thm.instantiate ([], map mk_inst subgoal_insts) st
wenzelm@60358
   189
            val emBs = map (Thm.cterm_of ctxt o embed) (Thm.prems_of st')
wenzelm@37781
   190
            val Cth  = implies_elim_list st' (map (elim o Thm.assume) emBs)
wenzelm@37781
   191
        in  (*restore the unknowns to the hypotheses*)
wenzelm@37781
   192
            free_instantiate (map swap_ctpair insts @
wenzelm@37781
   193
                              map mk_subgoal_swap_ctpair subgoal_insts)
wenzelm@37781
   194
                (*discharge assumptions from state in same order*)
wenzelm@37781
   195
                (implies_intr_list emBs
wenzelm@37781
   196
                  (forall_intr_list cparams (implies_intr_list chyps Cth)))
wenzelm@37781
   197
        end
wenzelm@37781
   198
      (*function to replace the current subgoal*)
wenzelm@52223
   199
      fun next st =
wenzelm@59165
   200
        Thm.bicompose (SOME ctxt) {flatten = true, match = false, incremented = false}
wenzelm@59582
   201
          (false, relift st, Thm.nprems_of st) gno state
wenzelm@60358
   202
  in Seq.maps next (tacf subprems (Thm.trivial (Thm.cterm_of ctxt concl))) end;
wenzelm@37781
   203
wenzelm@37781
   204
in
wenzelm@37781
   205
wenzelm@59165
   206
fun METAHYPS ctxt tacf n thm = SUBGOAL (metahyps_aux_tac ctxt tacf) n thm
wenzelm@64548
   207
  handle THM ("assume: variables", _, _) => Seq.empty
wenzelm@37781
   208
wenzelm@37781
   209
end;
wenzelm@37781
   210
wenzelm@47022
   211
wenzelm@47022
   212
(* generating identifiers -- often fresh *)
wenzelm@47022
   213
wenzelm@47022
   214
local
wenzelm@47022
   215
(*Maps 0-61 to A-Z, a-z, 0-9; exclude _ or ' to avoid clash with internal/unusual indentifiers*)
wenzelm@47022
   216
fun gensym_char i =
wenzelm@47022
   217
  if i<26 then chr (ord "A" + i)
wenzelm@47022
   218
  else if i<52 then chr (ord "a" + i - 26)
wenzelm@47022
   219
  else chr (ord "0" + i - 52);
wenzelm@47022
   220
wenzelm@47022
   221
val char_vec = Vector.tabulate (62, gensym_char);
wenzelm@47022
   222
fun newid n = implode (map (fn i => Vector.sub (char_vec, i)) (radixpand (62, n)));
wenzelm@47022
   223
wenzelm@56147
   224
val gensym_seed = Synchronized.var "gensym_seed" (0: int);
wenzelm@47022
   225
wenzelm@47022
   226
in
wenzelm@56147
   227
  fun gensym pre =
wenzelm@56147
   228
    Synchronized.change_result gensym_seed (fn i => (pre ^ newid i, i + 1));
wenzelm@37781
   229
end;
wenzelm@37781
   230
wenzelm@47022
   231
wenzelm@47022
   232
(*Convert all Vars in a theorem to Frees.  Also return a function for
wenzelm@47022
   233
  reversing that operation.  DOES NOT WORK FOR TYPE VARIABLES.*)
wenzelm@47022
   234
wenzelm@60358
   235
fun freeze_thaw_robust ctxt th =
wenzelm@47022
   236
 let val fth = Thm.legacy_freezeT th
wenzelm@47022
   237
 in
wenzelm@47022
   238
   case Thm.fold_terms Term.add_vars fth [] of
haftmann@47576
   239
       [] => (fth, fn _ => fn x => x)   (*No vars: nothing to do!*)
wenzelm@47022
   240
     | vars =>
wenzelm@47022
   241
         let fun newName (ix,_) = (ix, gensym (string_of_indexname ix))
wenzelm@47022
   242
             val alist = map newName vars
wenzelm@47022
   243
             fun mk_inst (v,T) =
wenzelm@60358
   244
                 apply2 (Thm.cterm_of ctxt)
wenzelm@60358
   245
                  (Var (v, T), Free (the (AList.lookup (op =) alist v), T))
wenzelm@47022
   246
             val insts = map mk_inst vars
wenzelm@47022
   247
             fun thaw i th' = (*i is non-negative increment for Var indexes*)
wenzelm@47022
   248
                 th' |> forall_intr_list (map #2 insts)
wenzelm@47022
   249
                     |> forall_elim_list (map (Thm.incr_indexes_cterm i o #1) insts)
wenzelm@60642
   250
         in  (Thm.instantiate ([], map (apfst (dest_Var o Thm.term_of)) insts) fth, thaw)  end
wenzelm@47022
   251
 end;
wenzelm@47022
   252
wenzelm@47022
   253
end;