rewrite: work purely conversion-based
authornoschinl
Fri Apr 17 16:59:43 2015 +0200 (2015-04-17)
changeset 601172712f40d6309
parent 60110 82f355352490
child 60118 3334ababa526
rewrite: work purely conversion-based
src/HOL/Library/rewrite.ML
src/HOL/ex/Rewrite_Examples.thy
     1.1 --- a/src/HOL/Library/rewrite.ML	Fri Apr 17 12:12:14 2015 +0200
     1.2 +++ b/src/HOL/Library/rewrite.ML	Fri Apr 17 16:59:43 2015 +0200
     1.3 @@ -15,23 +15,38 @@
     1.4  which can then be used to match arbitrary subterms inside abstractions.
     1.5  *)
     1.6  
     1.7 +infix 1 then_pconv;
     1.8 +infix 0 else_pconv;
     1.9 +
    1.10  signature REWRITE =
    1.11  sig
    1.12 +  type patconv = Proof.context -> Type.tyenv * (string * term) list -> cconv
    1.13 +  val then_pconv: patconv * patconv -> patconv
    1.14 +  val else_pconv: patconv * patconv -> patconv
    1.15 +  val abs_pconv:  patconv -> string option * typ -> patconv (*XXX*)
    1.16 +  val fun_pconv: patconv -> patconv
    1.17 +  val arg_pconv: patconv -> patconv
    1.18 +  val imp_pconv: patconv -> patconv
    1.19 +  val params_pconv: patconv -> patconv
    1.20 +  val forall_pconv: patconv -> string option * typ option -> patconv
    1.21 +  val all_pconv: patconv
    1.22 +  val for_pconv: patconv -> (string option * typ option) list -> patconv
    1.23 +  val concl_pconv: patconv -> patconv
    1.24 +  val asm_pconv: patconv -> patconv
    1.25 +  val asms_pconv: patconv -> patconv
    1.26 +  val judgment_pconv: patconv -> patconv
    1.27 +  val in_pconv: patconv -> patconv
    1.28 +  val match_pconv: patconv -> term * (string option * typ) list -> patconv
    1.29 +  val rewrs_pconv: term option -> thm list -> patconv
    1.30 +
    1.31    datatype ('a, 'b) pattern = At | In | Term of 'a | Concl | Asm | For of 'b list
    1.32  
    1.33    val mk_hole: int -> typ -> term
    1.34  
    1.35 -  val rewrite: Proof.context
    1.36 +  val rewrite_conv: Proof.context
    1.37      -> (term * (string * typ) list, string * typ option) pattern list * term option
    1.38      -> thm list
    1.39 -    -> cterm
    1.40 -    -> thm Seq.seq
    1.41 -
    1.42 -  val rewrite_tac: Proof.context
    1.43 -    -> (term * (string * typ) list, string * typ option) pattern list * term option
    1.44 -    -> thm list
    1.45 -    -> int
    1.46 -    -> tactic
    1.47 +    -> conv
    1.48  end
    1.49  
    1.50  structure Rewrite : REWRITE =
    1.51 @@ -39,166 +54,14 @@
    1.52  
    1.53  datatype ('a, 'b) pattern = At | In | Term of 'a | Concl | Asm | For of 'b list
    1.54  
    1.55 -fun map_term_pattern f (Term x) = f x
    1.56 -  | map_term_pattern _ (For ss) = (For ss)
    1.57 -  | map_term_pattern _ At = At
    1.58 -  | map_term_pattern _ In = In
    1.59 -  | map_term_pattern _ Concl = Concl
    1.60 -  | map_term_pattern _ Asm = Asm
    1.61 -
    1.62 -
    1.63  exception NO_TO_MATCH
    1.64  
    1.65 -fun SEQ_CONCAT (tacq : tactic Seq.seq) : tactic = fn st => Seq.maps (fn tac => tac st) tacq
    1.66 -
    1.67 -(* We rewrite subterms using rewrite conversions. These are conversions
    1.68 -   that also take a context and a list of identifiers for bound variables
    1.69 -   as parameters. *)
    1.70 -type rewrite_conv = Proof.context -> (string * term) list -> conv
    1.71 -
    1.72 -(* To apply such a rewrite conversion to a subterm of our goal, we use
    1.73 -   subterm positions, which are just functions that map a rewrite conversion,
    1.74 -   working on the top level, to a new rewrite conversion, working on
    1.75 -   a specific subterm.
    1.76 -
    1.77 -   During substitution, we are traversing the goal to find subterms that
    1.78 -   we can rewrite. For each of these subterms, a subterm position is
    1.79 -   created and later used in creating a conversion that we use to try and
    1.80 -   rewrite this subterm. *)
    1.81 -type subterm_position = rewrite_conv -> rewrite_conv
    1.82 -
    1.83 -(* A focusterm represents a subterm. It is a tuple (t, p), consisting
    1.84 -  of the subterm t itself and its subterm position p. *)
    1.85 -type focusterm = (Type.tyenv * Proof.context) * term * subterm_position
    1.86 -
    1.87 -val dummyN = Name.internal "__dummy"
    1.88  val holeN = Name.internal "_hole"
    1.89  
    1.90 -fun prep_meta_eq ctxt =
    1.91 -  Simplifier.mksimps ctxt #> map Drule.zero_var_indexes
    1.92 -
    1.93 -
    1.94 -(* rewrite conversions *)
    1.95 -
    1.96 -fun abs_rewr_cconv ident : subterm_position =
    1.97 -  let
    1.98 -    fun add_ident NONE _ l = l
    1.99 -      | add_ident (SOME name) ct l = (name, Thm.term_of ct) :: l
   1.100 -    fun inner rewr ctxt idents =
   1.101 -      CConv.abs_cconv (fn (ct, ctxt) => rewr ctxt (add_ident ident ct idents)) ctxt
   1.102 -  in inner end
   1.103 -
   1.104 -val fun_rewr_cconv : subterm_position = fn rewr => CConv.fun_cconv oo rewr
   1.105 -val arg_rewr_cconv : subterm_position = fn rewr => CConv.arg_cconv oo rewr
   1.106 -val imp_rewr_cconv : subterm_position = fn rewr => CConv.concl_cconv 1 oo rewr
   1.107 -val with_prems_rewr_cconv : subterm_position = fn rewr => CConv.with_prems_cconv ~1 oo rewr
   1.108 +fun prep_meta_eq ctxt = Simplifier.mksimps ctxt #> map Drule.zero_var_indexes
   1.109  
   1.110  
   1.111 -(* focus terms *)
   1.112 -
   1.113 -fun ft_abs ctxt (s,T) ((tyenv, u_ctxt), u, pos) =
   1.114 -  case try (fastype_of #> dest_funT) u of
   1.115 -    NONE => raise TERM ("ft_abs: no function type", [u])
   1.116 -  | SOME (U, _) =>
   1.117 -      let
   1.118 -        val tyenv' =
   1.119 -          if T = dummyT then tyenv
   1.120 -          else Sign.typ_match (Proof_Context.theory_of ctxt) (T, U) tyenv
   1.121 -        val (s', u_ctxt') =
   1.122 -          case s of
   1.123 -           NONE => yield_singleton Variable.variant_fixes (Name.internal dummyN) u_ctxt
   1.124 -          | SOME s => (s, u_ctxt)
   1.125 -        val x = Free (s', Envir.norm_type tyenv' T)
   1.126 -        val eta_expand_cconv = CConv.rewr_cconv @{thm eta_expand}
   1.127 -        fun eta_expand rewr ctxt bounds = eta_expand_cconv then_conv rewr ctxt bounds
   1.128 -        val (u', pos') =
   1.129 -          case u of
   1.130 -            Abs (_,_,t') => (subst_bound (x, t'), pos o abs_rewr_cconv s)
   1.131 -          | _ => (u $ x, pos o eta_expand o abs_rewr_cconv s)
   1.132 -      in ((tyenv', u_ctxt'), u', pos') end
   1.133 -      handle Pattern.MATCH => raise TYPE ("ft_abs: types don't match", [T,U], [u])
   1.134 -
   1.135 -fun ft_fun _ (tyenv, l $ _, pos) = (tyenv, l, pos o fun_rewr_cconv)
   1.136 -  | ft_fun ctxt (ft as (_, Abs (_, T, _ $ Bound 0), _)) = (ft_fun ctxt o ft_abs ctxt (NONE, T)) ft
   1.137 -  | ft_fun _ (_, t, _) = raise TERM ("ft_fun", [t])
   1.138 -
   1.139 -local
   1.140 -
   1.141 -fun ft_arg_gen cconv _ (tyenv, _ $ r, pos) = (tyenv, r, pos o cconv)
   1.142 -  | ft_arg_gen cconv ctxt (ft as (_, Abs (_, T, _ $ Bound 0), _)) = (ft_arg_gen cconv ctxt o ft_abs ctxt (NONE, T)) ft
   1.143 -  | ft_arg_gen _ _ (_, t, _) = raise TERM ("ft_arg", [t])
   1.144 -
   1.145 -in
   1.146 -
   1.147 -fun ft_arg ctxt = ft_arg_gen arg_rewr_cconv ctxt
   1.148 -fun ft_imp ctxt = ft_arg_gen imp_rewr_cconv ctxt
   1.149 -
   1.150 -end
   1.151 -
   1.152 -(* Move to B in !!x_1 ... x_n. B. Do not eta-expand *)
   1.153 -fun ft_params ctxt (ft as (_, t, _) : focusterm) =
   1.154 -  case t of
   1.155 -    Const (@{const_name "Pure.all"}, _) $ Abs (_,T,_) =>
   1.156 -      (ft_params ctxt o ft_abs ctxt (NONE, T) o ft_arg ctxt) ft
   1.157 -  | Const (@{const_name "Pure.all"}, _) =>
   1.158 -      (ft_params ctxt o ft_arg ctxt) ft
   1.159 -  | _ => ft
   1.160 -
   1.161 -fun ft_all ctxt ident (ft as (_, Const (@{const_name "Pure.all"}, T) $ _, _) : focusterm) =
   1.162 -    let
   1.163 -      val def_U = T |> dest_funT |> fst |> dest_funT |> fst
   1.164 -      val ident' = apsnd (the_default (def_U)) ident
   1.165 -    in (ft_abs ctxt ident' o ft_arg ctxt) ft end
   1.166 -  | ft_all _ _ (_, t, _) = raise TERM ("ft_all", [t])
   1.167 -
   1.168 -fun ft_for ctxt idents (ft as (_, t, _) : focusterm) =
   1.169 -  let
   1.170 -    fun f rev_idents (Const (@{const_name "Pure.all"}, _) $ t) =
   1.171 -        let
   1.172 -         val (rev_idents', desc) = f rev_idents (case t of Abs (_,_,u) => u | _ => t)
   1.173 -        in
   1.174 -          case rev_idents' of
   1.175 -            [] => ([], desc o ft_all ctxt (NONE, NONE))
   1.176 -          | (x :: xs) => (xs , desc o ft_all ctxt x)
   1.177 -        end
   1.178 -      | f rev_idents _ = (rev_idents, I)
   1.179 -  in
   1.180 -    case f (rev idents) t of
   1.181 -      ([], ft') => SOME (ft' ft)
   1.182 -    | _ => NONE
   1.183 -  end
   1.184 -
   1.185 -fun ft_concl ctxt (ft as (_, t, _) : focusterm) =
   1.186 -  case t of
   1.187 -    (Const (@{const_name "Pure.imp"}, _) $ _) $ _ => (ft_concl ctxt o ft_imp ctxt) ft
   1.188 -  | _ => ft
   1.189 -
   1.190 -fun ft_assm _ (tyenv, (Const (@{const_name "Pure.imp"}, _) $ l) $ _, pos) =
   1.191 -      (tyenv, l, pos o with_prems_rewr_cconv)
   1.192 -  | ft_assm _ (_, t, _) = raise TERM ("ft_assm", [t])
   1.193 -
   1.194 -fun ft_judgment ctxt (ft as (_, t, _) : focusterm) =
   1.195 -  if Object_Logic.is_judgment ctxt t
   1.196 -  then ft_arg ctxt ft
   1.197 -  else ft
   1.198 -
   1.199 -(* Find all subterms that might be a valid point to apply a rule. *)
   1.200 -fun valid_match_points ctxt (ft : focusterm) =
   1.201 -  let
   1.202 -    fun descend (_, _ $ _, _) = [ft_fun ctxt, ft_arg ctxt]
   1.203 -      | descend (_, Abs (_, T, _), _) = [ft_abs ctxt (NONE, T)]
   1.204 -      | descend _ = []
   1.205 -    fun subseq ft =
   1.206 -      descend ft |> Seq.of_list |> Seq.maps (fn f => ft |> f |> valid_match_points ctxt)
   1.207 -    fun is_valid (l $ _) = is_valid l
   1.208 -      | is_valid (Abs (_, _, a)) = is_valid a
   1.209 -      | is_valid (Var _) = false
   1.210 -      | is_valid (Bound _) = false
   1.211 -      | is_valid _ = true
   1.212 -  in
   1.213 -    Seq.make (fn () => SOME (ft, subseq ft))
   1.214 -    |> Seq.filter (#2 #> is_valid)
   1.215 -  end
   1.216 +(* holes *)
   1.217  
   1.218  fun mk_hole i T = Var ((holeN, i), T)
   1.219  
   1.220 @@ -228,167 +91,239 @@
   1.221      #> Proof_Context.set_mode Proof_Context.mode_pattern
   1.222    end
   1.223  
   1.224 -(* Find a subterm of the focusterm matching the pattern. *)
   1.225 -fun find_matches ctxt pattern_list =
   1.226 -  let
   1.227 -    fun move_term ctxt (t, off) (ft : focusterm) =
   1.228 -      let
   1.229 -        val thy = Proof_Context.theory_of ctxt
   1.230 +
   1.231 +(* pattern conversions *)
   1.232 +
   1.233 +type patconv = Proof.context -> Type.tyenv * (string * term) list -> cterm -> thm
   1.234 +
   1.235 +fun (cv1 then_pconv cv2) ctxt tytenv ct = (cv1 ctxt tytenv then_conv cv2 ctxt tytenv) ct
   1.236 +
   1.237 +fun (cv1 else_pconv cv2) ctxt tytenv ct = (cv1 ctxt tytenv else_conv cv2 ctxt tytenv) ct
   1.238  
   1.239 -        val eta_expands =
   1.240 -          let val (_, ts) = strip_comb t
   1.241 -          in map fastype_of (snd (take_suffix is_Var ts)) end
   1.242 +fun raw_abs_pconv cv ctxt tytenv ct =
   1.243 +  case Thm.term_of ct of
   1.244 +    Abs _ => CConv.abs_cconv (fn (x, ctxt') => cv x ctxt' tytenv) ctxt ct
   1.245 +  | t => raise TERM ("raw_abs_pconv", [t])
   1.246  
   1.247 -        fun do_match ((tyenv, u_ctxt), u, pos) =
   1.248 -          case try (Pattern.match thy (apply2 Logic.mk_term (t,u))) (tyenv, Vartab.empty) of
   1.249 -            NONE => NONE
   1.250 -          | SOME (tyenv', _) => SOME (off ((tyenv', u_ctxt), u, pos))
   1.251 -
   1.252 -        fun match_argT T u =
   1.253 -          let val (U, _) = dest_funT (fastype_of u)
   1.254 -          in try (Sign.typ_match thy (T,U)) end
   1.255 -          handle TYPE _ => K NONE
   1.256 +fun raw_fun_pconv cv ctxt tytenv ct =
   1.257 +  case Thm.term_of ct of
   1.258 +    _ $ _ => CConv.fun_cconv (cv ctxt tytenv) ct
   1.259 +  | t => raise TERM ("raw_fun_pconv", [t])
   1.260  
   1.261 -        fun desc [] ft = do_match ft
   1.262 -          | desc (T :: Ts) (ft as ((tyenv, u_ctxt) , u, pos)) =
   1.263 -            case do_match ft of
   1.264 -              NONE =>
   1.265 -                (case match_argT T u tyenv of
   1.266 -                  NONE => NONE
   1.267 -                | SOME tyenv' => desc Ts (ft_abs ctxt (NONE, T) ((tyenv', u_ctxt), u, pos)))
   1.268 -            | SOME ft => SOME ft
   1.269 -      in desc eta_expands ft end
   1.270 +fun raw_arg_pconv cv ctxt tytenv ct =
   1.271 +  case Thm.term_of ct of
   1.272 +    _ $ _ => CConv.arg_cconv (cv ctxt tytenv) ct
   1.273 +  | t => raise TERM ("raw_arg_pconv", [t])
   1.274  
   1.275 -    fun move_assms ctxt (ft: focusterm) =
   1.276 -      let
   1.277 -        fun f () = case try (ft_assm ctxt) ft of
   1.278 -            NONE => NONE
   1.279 -          | SOME ft' => SOME (ft', move_assms ctxt (ft_imp ctxt ft))
   1.280 -      in Seq.make f end
   1.281 -
   1.282 -    fun apply_pat At = Seq.map (ft_judgment ctxt)
   1.283 -      | apply_pat In = Seq.maps (valid_match_points ctxt)
   1.284 -      | apply_pat Asm = Seq.maps (move_assms ctxt o ft_params ctxt)
   1.285 -      | apply_pat Concl = Seq.map (ft_concl ctxt o ft_params ctxt)
   1.286 -      | apply_pat (For idents) = Seq.map_filter ((ft_for ctxt (map (apfst SOME) idents)))
   1.287 -      | apply_pat (Term x) = Seq.map_filter ( (move_term ctxt x))
   1.288 -
   1.289 -    fun apply_pats ft = ft
   1.290 -      |> Seq.single
   1.291 -      |> fold apply_pat pattern_list
   1.292 +fun abs_pconv cv (s,T) ctxt (tyenv, ts) ct =
   1.293 +  let val u = Thm.term_of ct
   1.294    in
   1.295 -    apply_pats
   1.296 +    case try (fastype_of #> dest_funT) u of
   1.297 +      NONE => raise TERM ("abs_pconv: no function type", [u])
   1.298 +    | SOME (U, _) =>
   1.299 +        let
   1.300 +          val tyenv' =
   1.301 +            if T = dummyT then tyenv
   1.302 +            else Sign.typ_match (Proof_Context.theory_of ctxt) (T, U) tyenv
   1.303 +          val eta_expand_cconv =
   1.304 +            case u of
   1.305 +              Abs _=> Thm.reflexive
   1.306 +            | _ => CConv.rewr_cconv @{thm eta_expand}
   1.307 +          fun add_ident NONE _ l = l
   1.308 +            | add_ident (SOME name) ct l = (name, Thm.term_of ct) :: l
   1.309 +          val abs_cv = CConv.abs_cconv (fn (ct, ctxt) => cv ctxt (tyenv', add_ident s ct ts)) ctxt
   1.310 +        in (eta_expand_cconv then_conv abs_cv) ct end
   1.311 +        handle Pattern.MATCH => raise TYPE ("abs_pconv: types don't match", [T,U], [u])
   1.312    end
   1.313  
   1.314 -fun instantiate_normalize_env ctxt env thm =
   1.315 -  let
   1.316 -    fun certs f = map (apply2 (f ctxt))
   1.317 -    val prop = Thm.prop_of thm
   1.318 -    val norm_type = Envir.norm_type o Envir.type_env
   1.319 -    val insts = Term.add_vars prop []
   1.320 -      |> map (fn x as (s,T) => (Var (s, norm_type env T), Envir.norm_term env (Var x)))
   1.321 -      |> certs Thm.cterm_of
   1.322 -    val tyinsts = Term.add_tvars prop []
   1.323 -      |> map (fn x => (TVar x, norm_type env (TVar x)))
   1.324 -      |> certs Thm.ctyp_of
   1.325 -  in Drule.instantiate_normalize (tyinsts, insts) thm end
   1.326 -
   1.327 -fun unify_with_rhs context to env thm =
   1.328 -  let
   1.329 -    val (_, rhs) = thm |> Thm.concl_of |> Logic.dest_equals
   1.330 -    val env' = Pattern.unify context (Logic.mk_term to, Logic.mk_term rhs) env
   1.331 -      handle Pattern.Unif => raise NO_TO_MATCH
   1.332 -  in env' end
   1.333 -
   1.334 -fun inst_thm_to _ (NONE, _) thm = thm
   1.335 -  | inst_thm_to (ctxt : Proof.context) (SOME to, env) thm =
   1.336 -      instantiate_normalize_env ctxt (unify_with_rhs (Context.Proof ctxt) to env thm) thm
   1.337 -
   1.338 -fun inst_thm ctxt idents (to, tyenv) thm =
   1.339 -  let
   1.340 -    (* Replace any identifiers with their corresponding bound variables. *)
   1.341 -    val maxidx = Term.maxidx_typs (map (snd o snd) (Vartab.dest tyenv)) 0
   1.342 -    val env = Envir.Envir {maxidx = maxidx, tenv = Vartab.empty, tyenv = tyenv}
   1.343 -    val replace_idents =
   1.344 -      let
   1.345 -        fun subst ((n1, s)::ss) (t as Free (n2, _)) = if n1 = n2 then s else subst ss t
   1.346 -          | subst _ t = t
   1.347 -      in Term.map_aterms (subst idents) end
   1.348 -
   1.349 -    val maxidx = Envir.maxidx_of env |> fold Term.maxidx_term (the_list to)
   1.350 -    val thm' = Thm.incr_indexes (maxidx + 1) thm
   1.351 -  in SOME (inst_thm_to ctxt (Option.map replace_idents to, env) thm') end
   1.352 -  handle NO_TO_MATCH => NONE
   1.353 +fun fun_pconv cv ctxt tytenv ct =
   1.354 +  case Thm.term_of ct of
   1.355 +    _ $ _ => CConv.fun_cconv (cv ctxt tytenv) ct
   1.356 +  | Abs (_, T, _ $ Bound 0) => abs_pconv (fun_pconv cv) (NONE, T) ctxt tytenv ct
   1.357 +  | t => raise TERM ("fun_pconv", [t])
   1.358  
   1.359  local
   1.360  
   1.361 -fun rewrite_raw ctxt (pattern, to) thms ct =
   1.362 +fun arg_pconv_gen cv0 cv ctxt tytenv ct =
   1.363 +  case Thm.term_of ct of
   1.364 +    _ $ _ => cv0 (cv ctxt tytenv) ct
   1.365 +  | Abs (_, T, _ $ Bound 0) => abs_pconv (arg_pconv_gen cv0 cv) (NONE, T) ctxt tytenv ct
   1.366 +  | t => raise TERM ("arg_pconv_gen", [t])
   1.367 +
   1.368 +in
   1.369 +
   1.370 +val arg_pconv = arg_pconv_gen CConv.arg_cconv
   1.371 +val imp_pconv = arg_pconv_gen (CConv.concl_cconv 1)
   1.372 +
   1.373 +end
   1.374 +
   1.375 +(* Move to B in !!x_1 ... x_n. B. Do not eta-expand *)
   1.376 +fun params_pconv cv ctxt tytenv ct =
   1.377 +  let val pconv =
   1.378 +    case Thm.term_of ct of
   1.379 +      Const (@{const_name "Pure.all"}, _) $ Abs _ => (raw_arg_pconv o raw_abs_pconv) (fn _ => params_pconv cv)
   1.380 +    | Const (@{const_name "Pure.all"}, _) => raw_arg_pconv (params_pconv cv)
   1.381 +    | _ => cv
   1.382 +  in pconv ctxt tytenv ct end
   1.383 +
   1.384 +fun forall_pconv cv ident ctxt tytenv ct =
   1.385 +  case Thm.term_of ct of
   1.386 +    Const (@{const_name "Pure.all"}, T) $ _ =>
   1.387 +      let
   1.388 +        val def_U = T |> dest_funT |> fst |> dest_funT |> fst
   1.389 +        val ident' = apsnd (the_default (def_U)) ident
   1.390 +      in arg_pconv (abs_pconv cv ident') ctxt tytenv ct end
   1.391 +  | t => raise TERM ("forall_pconv", [t])
   1.392 +
   1.393 +fun all_pconv _ _ = Thm.reflexive
   1.394 +
   1.395 +fun for_pconv cv idents ctxt tytenv ct =
   1.396    let
   1.397 -    fun interpret_term_patterns ctxt =
   1.398 +    fun f rev_idents (Const (@{const_name "Pure.all"}, _) $ t) =
   1.399 +        let val (rev_idents', cv') = f rev_idents (case t of Abs (_,_,u) => u | _ => t)
   1.400 +        in
   1.401 +          case rev_idents' of
   1.402 +            [] => ([], forall_pconv cv' (NONE, NONE))
   1.403 +          | (x :: xs) => (xs, forall_pconv cv' x)
   1.404 +        end
   1.405 +      | f rev_idents _ = (rev_idents, cv)
   1.406 +  in
   1.407 +    case f (rev idents) (Thm.term_of ct) of
   1.408 +      ([], cv') => cv' ctxt tytenv ct
   1.409 +    | _ => raise CTERM ("for_pconv", [ct])
   1.410 +  end
   1.411 +
   1.412 +fun concl_pconv cv ctxt tytenv ct =
   1.413 +  case Thm.term_of ct of
   1.414 +    (Const (@{const_name "Pure.imp"}, _) $ _) $ _ => imp_pconv (concl_pconv cv) ctxt tytenv ct
   1.415 +  | _ => cv ctxt tytenv ct
   1.416 +
   1.417 +fun asm_pconv cv ctxt tytenv ct =
   1.418 +  case Thm.term_of ct of
   1.419 +    (Const (@{const_name "Pure.imp"}, _) $ _) $ _ => CConv.with_prems_cconv ~1 (cv ctxt tytenv) ct
   1.420 +  | t => raise TERM ("asm_pconv", [t])
   1.421 +
   1.422 +fun asms_pconv cv ctxt tytenv ct =
   1.423 +  case Thm.term_of ct of
   1.424 +    (Const (@{const_name "Pure.imp"}, _) $ _) $ _ =>
   1.425 +      ((CConv.with_prems_cconv ~1 oo cv) else_pconv imp_pconv (asms_pconv cv)) ctxt tytenv ct
   1.426 +  | t => raise TERM ("asms_pconv", [t])
   1.427 +
   1.428 +fun judgment_pconv cv ctxt tytenv ct =
   1.429 +  if Object_Logic.is_judgment ctxt (Thm.term_of ct)
   1.430 +  then arg_pconv cv ctxt tytenv ct
   1.431 +  else cv ctxt tytenv ct
   1.432 +
   1.433 +fun in_pconv cv ctxt tytenv ct =
   1.434 +  (cv else_pconv 
   1.435 +   raw_fun_pconv (in_pconv cv) else_pconv
   1.436 +   raw_arg_pconv (in_pconv cv) else_pconv
   1.437 +   raw_abs_pconv (fn _  => in_pconv cv))
   1.438 +  ctxt tytenv ct
   1.439 +
   1.440 +fun replace_idents idents t =
   1.441 +  let
   1.442 +    fun subst ((n1, s)::ss) (t as Free (n2, _)) = if n1 = n2 then s else subst ss t
   1.443 +      | subst _ t = t
   1.444 +  in Term.map_aterms (subst idents) t end
   1.445 +
   1.446 +fun match_pconv cv (t,fixes) ctxt (tyenv, env_ts) ct =
   1.447 +  let
   1.448 +    val t' = replace_idents env_ts t
   1.449 +    val thy = Proof_Context.theory_of ctxt
   1.450 +    val u = Thm.term_of ct
   1.451 +
   1.452 +    fun descend_hole fixes (Abs (_, _, t)) =
   1.453 +        (case descend_hole fixes t of
   1.454 +          NONE => NONE
   1.455 +        | SOME (fix :: fixes', pos) => SOME (fixes', abs_pconv pos fix)
   1.456 +        | SOME ([], _) => raise Match (* less fixes than abstractions on path to hole *))
   1.457 +      | descend_hole fixes (t as l $ r) =
   1.458 +        let val (f, _) = strip_comb t
   1.459 +        in
   1.460 +          if is_hole f
   1.461 +          then SOME (fixes, cv)
   1.462 +          else
   1.463 +            (case descend_hole fixes l of
   1.464 +              SOME (fixes', pos) => SOME (fixes', fun_pconv pos)
   1.465 +            | NONE =>
   1.466 +              (case descend_hole fixes r of
   1.467 +                SOME (fixes', pos) => SOME (fixes', arg_pconv pos)
   1.468 +              | NONE => NONE))
   1.469 +        end
   1.470 +      | descend_hole fixes t =
   1.471 +        if is_hole t then SOME (fixes, cv) else NONE
   1.472 +
   1.473 +    val to_hole = descend_hole (rev fixes) #> the_default ([], cv) #> snd
   1.474 +  in
   1.475 +    case try (Pattern.match thy (apply2 Logic.mk_term (t',u))) (tyenv, Vartab.empty) of
   1.476 +      NONE => raise TERM ("match_pconv: Does not match pattern", [t, t',u])
   1.477 +    | SOME (tyenv', _) => to_hole t ctxt (tyenv', env_ts) ct
   1.478 +  end
   1.479 +
   1.480 +fun rewrs_pconv to thms ctxt (tyenv, env_ts) =
   1.481 +  let
   1.482 +    fun instantiate_normalize_env ctxt env thm =
   1.483        let
   1.484 +        fun certs f = map (apply2 (f ctxt))
   1.485 +        val prop = Thm.prop_of thm
   1.486 +        val norm_type = Envir.norm_type o Envir.type_env
   1.487 +        val insts = Term.add_vars prop []
   1.488 +          |> map (fn x as (s,T) => (Var (s, norm_type env T), Envir.norm_term env (Var x)))
   1.489 +          |> certs Thm.cterm_of
   1.490 +        val tyinsts = Term.add_tvars prop []
   1.491 +          |> map (fn x => (TVar x, norm_type env (TVar x)))
   1.492 +          |> certs Thm.ctyp_of
   1.493 +      in Drule.instantiate_normalize (tyinsts, insts) thm end
   1.494      
   1.495 -        fun descend_hole fixes (Abs (_, _, t)) =
   1.496 -            (case descend_hole fixes t of
   1.497 -              NONE => NONE
   1.498 -            | SOME (fix :: fixes', pos) => SOME (fixes', pos o ft_abs ctxt (apfst SOME fix))
   1.499 -            | SOME ([], _) => raise Match (* XXX -- check phases modified binding *))
   1.500 -          | descend_hole fixes (t as l $ r) =
   1.501 -            let val (f, _) = strip_comb t
   1.502 -            in
   1.503 -              if is_hole f
   1.504 -              then SOME (fixes, I)
   1.505 -              else
   1.506 -                (case descend_hole fixes l of
   1.507 -                  SOME (fixes', pos) => SOME (fixes', pos o ft_fun ctxt)
   1.508 -                | NONE =>
   1.509 -                  (case descend_hole fixes r of
   1.510 -                    SOME (fixes', pos) => SOME (fixes', pos o ft_arg ctxt)
   1.511 -                  | NONE => NONE))
   1.512 -            end
   1.513 -          | descend_hole fixes t =
   1.514 -            if is_hole t then SOME (fixes, I) else NONE
   1.515 +    fun unify_with_rhs context to env thm =
   1.516 +      let
   1.517 +        val (_, rhs) = thm |> Thm.concl_of |> Logic.dest_equals
   1.518 +        val env' = Pattern.unify context (Logic.mk_term to, Logic.mk_term rhs) env
   1.519 +          handle Pattern.Unif => raise NO_TO_MATCH
   1.520 +      in env' end
   1.521 +    
   1.522 +    fun inst_thm_to _ (NONE, _) thm = thm
   1.523 +      | inst_thm_to (ctxt : Proof.context) (SOME to, env) thm =
   1.524 +          instantiate_normalize_env ctxt (unify_with_rhs (Context.Proof ctxt) to env thm) thm
   1.525      
   1.526 -        fun f (t, fixes) = Term (t, (descend_hole (rev fixes) #> the_default ([], I) #> snd) t)
   1.527 +    fun inst_thm ctxt idents (to, tyenv) thm =
   1.528 +      let
   1.529 +        (* Replace any identifiers with their corresponding bound variables. *)
   1.530 +        val maxidx = Term.maxidx_typs (map (snd o snd) (Vartab.dest tyenv)) 0
   1.531 +        val env = Envir.Envir {maxidx = maxidx, tenv = Vartab.empty, tyenv = tyenv}
   1.532 +        val maxidx = Envir.maxidx_of env |> fold Term.maxidx_term (the_list to)
   1.533 +        val thm' = Thm.incr_indexes (maxidx + 1) thm
   1.534 +      in SOME (inst_thm_to ctxt (Option.map (replace_idents idents) to, env) thm') end
   1.535 +      handle NO_TO_MATCH => NONE
   1.536      
   1.537 -      in map (map_term_pattern f) end
   1.538 +  in CConv.rewrs_cconv (map_filter (inst_thm ctxt env_ts (to, tyenv)) thms) end
   1.539  
   1.540 -    val pattern' = interpret_term_patterns ctxt pattern
   1.541 -    val matches = find_matches ctxt pattern' ((Vartab.empty, ctxt), Thm.term_of ct, I)
   1.542 +fun rewrite_conv ctxt (pattern, to) thms ct =
   1.543 +  let
   1.544 +    fun apply_pat At = judgment_pconv
   1.545 +      | apply_pat In = in_pconv
   1.546 +      | apply_pat Asm = params_pconv o asms_pconv
   1.547 +      | apply_pat Concl = params_pconv o concl_pconv
   1.548 +      | apply_pat (For idents) = (fn cv => for_pconv cv (map (apfst SOME) idents))
   1.549 +      | apply_pat (Term x) = (fn cv => match_pconv cv (apsnd (map (apfst SOME)) x))
   1.550  
   1.551 -    val thms' = maps (prep_meta_eq ctxt) thms
   1.552 -
   1.553 -    fun rewrite_conv insty ctxt bounds =
   1.554 -      CConv.rewrs_cconv (map_filter (inst_thm ctxt bounds insty) thms')
   1.555 +    val cv = fold_rev apply_pat pattern
   1.556  
   1.557      fun distinct_prems th =
   1.558        case Seq.pull (distinct_subgoals_tac th) of
   1.559          NONE => th
   1.560        | SOME (th', _) => th'
   1.561  
   1.562 -    fun conv (((tyenv, _), _, position) : focusterm) =
   1.563 -      distinct_prems o position (rewrite_conv (to, tyenv)) ctxt []
   1.564 -
   1.565 -  in Seq.map (fn ft => conv ft) matches end
   1.566 -
   1.567 -in
   1.568 -
   1.569 -fun rewrite ctxt pat thms ct =
   1.570 -  rewrite_raw ctxt pat thms ct |> Seq.map_filter (fn cv => try cv ct)
   1.571 +    val rewrite = rewrs_pconv to (maps (prep_meta_eq ctxt) thms)
   1.572 +  in cv rewrite ctxt (Vartab.empty, []) ct |> distinct_prems end
   1.573  
   1.574  fun rewrite_export_tac ctxt (pat, pat_ctxt) thms =
   1.575    let
   1.576      val export = case pat_ctxt of
   1.577          NONE => I
   1.578        | SOME inner => singleton (Proof_Context.export inner ctxt)
   1.579 -    val tac = CSUBGOAL (fn (ct, i) =>
   1.580 -      rewrite_raw ctxt pat thms ct
   1.581 -      |> Seq.map (fn cv => CCONVERSION (export o cv) i)
   1.582 -      |> SEQ_CONCAT)
   1.583 -  in tac end
   1.584 -
   1.585 -fun rewrite_tac ctxt pat = rewrite_export_tac ctxt (pat, NONE)
   1.586 -
   1.587 -end
   1.588 +  in CCONVERSION (export o rewrite_conv ctxt pat thms) end
   1.589  
   1.590  val _ =
   1.591    Theory.setup
     2.1 --- a/src/HOL/ex/Rewrite_Examples.thy	Fri Apr 17 12:12:14 2015 +0200
     2.2 +++ b/src/HOL/ex/Rewrite_Examples.thy	Fri Apr 17 16:59:43 2015 +0200
     2.3 @@ -9,7 +9,6 @@
     2.4  
     2.5     See also https://www21.in.tum.de/~noschinl/Pattern-2014/
     2.6  *)
     2.7 -
     2.8  lemma
     2.9    fixes a::int and b::int and c::int
    2.10    assumes "P (b + a)"
    2.11 @@ -88,6 +87,11 @@
    2.12    shows "PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    2.13      by (rewrite at asm assms)
    2.14  
    2.15 +lemma
    2.16 +  assumes "PROP P \<equiv> PROP Q"
    2.17 +  shows "PROP R \<Longrightarrow> PROP R \<Longrightarrow> PROP P \<Longrightarrow> PROP Q"
    2.18 +    by (rewrite at asm assms)
    2.19 +
    2.20  (* Rewriting "at asm" selects each full assumption, not any parts *)
    2.21  lemma
    2.22    assumes "(PROP P \<Longrightarrow> PROP Q) \<equiv> (PROP S \<Longrightarrow> PROP R)"
    2.23 @@ -222,7 +226,7 @@
    2.24          Rewrite.In,
    2.25          Rewrite.Term (@{const plus(nat)} $ Free (x, @{typ nat}) $ @{term "1 :: nat"}, [])]
    2.26        val to = NONE
    2.27 -    in Rewrite.rewrite_tac ctxt (pat, to) @{thms add.commute} 1 end
    2.28 +    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
    2.29    \<close>)
    2.30    apply (fact assms)
    2.31    done
    2.32 @@ -242,7 +246,7 @@
    2.33          Rewrite.Term (@{const plus(int)} $ Free (x, @{typ int}) $ Var (("c", 0), @{typ int}), [])
    2.34          ]
    2.35        val to = NONE
    2.36 -    in Rewrite.rewrite_tac ctxt (pat, to) @{thms add.commute} 1 end
    2.37 +    in CCONVERSION (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) 1 end
    2.38    \<close>)
    2.39    apply (fact assms)
    2.40    done
    2.41 @@ -260,8 +264,7 @@
    2.42      Rewrite.Term (@{const plus(int)} $ Free (x, @{typ int}) $ Var (("c", 0), @{typ int}), [])
    2.43      ]
    2.44    val to = NONE
    2.45 -  val ct_ths = Rewrite.rewrite ctxt (pat, to) @{thms add.commute} ct
    2.46 -    |> Seq.list_of
    2.47 +  val th = Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute} ct
    2.48  \<close>
    2.49  
    2.50  section \<open>Regression tests\<close>
    2.51 @@ -274,12 +277,24 @@
    2.52      Rewrite.Term (@{const plus(int)} $ Var (("c", 0), @{typ int}) $ Var (("c", 0), @{typ int}), [])
    2.53      ]
    2.54    val to = NONE
    2.55 -  val ct_ths = Rewrite.rewrite ctxt (pat, to) @{thms add.commute} ct
    2.56 -  val _ = case Seq.pull ct_ths of      NONE => ()
    2.57 +  val _ =
    2.58 +    case try (Rewrite.rewrite_conv ctxt (pat, to) @{thms add.commute}) ct of
    2.59 +      NONE => ()
    2.60      | _ => error "should not have matched anything"
    2.61  \<close>
    2.62  
    2.63 +ML \<open>
    2.64 +  Rewrite.params_pconv (Conv.all_conv |> K |> K) @{context} (Vartab.empty, []) @{cterm "\<And>x. PROP A"}
    2.65 +\<close>
    2.66  
    2.67 +lemma
    2.68 +  assumes eq: "PROP A \<Longrightarrow> PROP B \<equiv> PROP C"
    2.69 +  assumes f1: "PROP D \<Longrightarrow> PROP A"
    2.70 +  assumes f2: "PROP D \<Longrightarrow> PROP C"
    2.71 +  shows "\<And>x. PROP D \<Longrightarrow> PROP B"
    2.72 +  apply (rewrite eq)
    2.73 +  apply (fact f1)
    2.74 +  apply (fact f2)
    2.75 +  done
    2.76  
    2.77  end
    2.78 -