src/Provers/eqsubst.ML
changeset 19871 88e8f6173bab
parent 19861 620d90091788
child 19975 ecd684d62808
equal deleted inserted replaced
19870:ef037d1b32d1 19871:88e8f6173bab
     5 A proof method to perform a substiution using an equation.
     5 A proof method to perform a substiution using an equation.
     6 *)
     6 *)
     7 
     7 
     8 signature EQSUBST =
     8 signature EQSUBST =
     9 sig
     9 sig
    10   val setup : theory -> theory
    10   (* a type abriviation for match information *)
       
    11   type match =
       
    12        ((indexname * (sort * typ)) list (* type instantiations *)
       
    13         * (indexname * (typ * term)) list) (* term instantiations *)
       
    14        * (string * typ) list (* fake named type abs env *)
       
    15        * (string * typ) list (* type abs env *)
       
    16        * term (* outer term *)
       
    17 
       
    18   type searchinfo =
       
    19        theory
       
    20        * int (* maxidx *)
       
    21        * Zipper.T (* focusterm to search under *)
       
    22 
       
    23     exception eqsubst_occL_exp of
       
    24        string * int list * Thm.thm list * int * Thm.thm
       
    25     
       
    26     (* low level substitution functions *)
       
    27     val apply_subst_in_asm :
       
    28        int ->
       
    29        Thm.thm ->
       
    30        Thm.thm ->
       
    31        (Thm.cterm list * int * 'a * Thm.thm) * match -> Thm.thm Seq.seq
       
    32     val apply_subst_in_concl :
       
    33        int ->
       
    34        Thm.thm ->
       
    35        Thm.cterm list * Thm.thm ->
       
    36        Thm.thm -> match -> Thm.thm Seq.seq
       
    37 
       
    38     (* matching/unification within zippers *)
       
    39     val clean_match_z :
       
    40        Context.theory -> Term.term -> Zipper.T -> match option
       
    41     val clean_unify_z :
       
    42        Context.theory -> int -> Term.term -> Zipper.T -> match Seq.seq
       
    43 
       
    44     (* skipping things in seq seq's *)
       
    45 
       
    46    (* skipping non-empty sub-sequences but when we reach the end
       
    47       of the seq, remembering how much we have left to skip. *)
       
    48     datatype 'a skipseq = SkipMore of int
       
    49       | SkipSeq of 'a Seq.seq Seq.seq;
       
    50 
       
    51     val skip_first_asm_occs_search :
       
    52        ('a -> 'b -> 'c Seq.seq Seq.seq) ->
       
    53        'a -> int -> 'b -> 'c skipseq
       
    54     val skip_first_occs_search :
       
    55        int -> ('a -> 'b -> 'c Seq.seq Seq.seq) -> 'a -> 'b -> 'c Seq.seq
       
    56     val skipto_skipseq : int -> 'a Seq.seq Seq.seq -> 'a skipseq
       
    57 
       
    58     (* tactics *)
       
    59     val eqsubst_asm_tac :
       
    60        Proof.context ->
       
    61        int list -> Thm.thm list -> int -> Thm.thm -> Thm.thm Seq.seq
       
    62     val eqsubst_asm_tac' :
       
    63        Proof.context ->
       
    64        (searchinfo -> int -> Term.term -> match skipseq) ->
       
    65        int -> Thm.thm -> int -> Thm.thm -> Thm.thm Seq.seq
       
    66     val eqsubst_tac :
       
    67        Proof.context ->
       
    68        int list -> Thm.thm list -> int -> Thm.thm -> Thm.thm Seq.seq
       
    69     val eqsubst_tac' :
       
    70        Proof.context ->
       
    71        (searchinfo -> Term.term -> match Seq.seq) 
       
    72        -> Thm.thm -> int -> Thm.thm -> Thm.thm Seq.seq
       
    73 
       
    74 
       
    75     val fakefree_badbounds :
       
    76        (string * Term.typ) list ->
       
    77        Term.term ->
       
    78        (string * Term.typ) list * (string * Term.typ) list * Term.term
       
    79 
       
    80     val mk_foo_match :
       
    81        (Term.term -> Term.term) ->
       
    82        ('a * Term.typ) list -> Term.term -> Term.term
       
    83 
       
    84     (* preparing substitution *)
       
    85     val prep_meta_eq : Proof.context -> Thm.thm -> Thm.thm list
       
    86     val prep_concl_subst :
       
    87        int -> Thm.thm -> (Thm.cterm list * Thm.thm) * searchinfo
       
    88     val prep_subst_in_asm :
       
    89        int -> Thm.thm -> int ->
       
    90        (Thm.cterm list * int * int * Thm.thm) * searchinfo
       
    91     val prep_subst_in_asms :
       
    92        int -> Thm.thm ->
       
    93        ((Thm.cterm list * int * int * Thm.thm) * searchinfo) list
       
    94     val prep_zipper_match :
       
    95        Zipper.T -> Term.term * ((string * Term.typ) list * (string * Term.typ) list * Term.term)
       
    96 
       
    97     (* search for substitutions *)
       
    98     val valid_match_start : Zipper.T -> bool
       
    99     val search_lr_all : Zipper.T -> Zipper.T Seq.seq
       
   100     val search_lr_valid : (Zipper.T -> bool) -> Zipper.T -> Zipper.T Seq.seq
       
   101     val searchf_lr_unify_all :
       
   102        searchinfo -> Term.term -> match Seq.seq Seq.seq
       
   103     val searchf_lr_unify_valid :
       
   104        searchinfo -> Term.term -> match Seq.seq Seq.seq
       
   105 
       
   106 
       
   107     (* syntax tools *)
       
   108     val ith_syntax : Args.T list -> int list * Args.T list
       
   109     val options_syntax : Args.T list -> bool * Args.T list
       
   110 
       
   111     (* Isar level hooks *)
       
   112     val eqsubst_asm_meth : Proof.context -> int list -> Thm.thm list -> Method.method
       
   113     val eqsubst_meth : Proof.context -> int list -> Thm.thm list -> Method.method
       
   114     val subst_meth : Method.src -> ProofContext.context -> Method.method
       
   115     val setup : theory -> theory
       
   116 
    11 end;
   117 end;
    12 
   118 
    13 structure EqSubst
   119 structure EqSubst
    14 (* : EQSUBST *)
   120 : EQSUBST
    15 = struct
   121 = struct
    16 
   122 
    17 structure Z = Zipper;
   123 structure Z = Zipper;
    18 
   124 
    19 (* changes object "=" to meta "==" which prepares a given rewrite rule *)
   125 (* changes object "=" to meta "==" which prepares a given rewrite rule *)
   185      | Free _ => true
   291      | Free _ => true
   186      | Abs _ => true (* allowed to look inside abs... search decides if we actually consider the abstraction itself *)
   292      | Abs _ => true (* allowed to look inside abs... search decides if we actually consider the abstraction itself *)
   187      | _ => false); (* avoid vars - always suceeds uninterestingly. *)
   293      | _ => false); (* avoid vars - always suceeds uninterestingly. *)
   188                       
   294                       
   189 (* search from top, left to right, then down *)
   295 (* search from top, left to right, then down *)
   190 val search_tlr_all = ZipperSearch.all_td_lr;
   296 val search_lr_all = ZipperSearch.all_bl_ur;
   191 
   297 
   192 (* search from top, left to right, then down *)
   298 (* search from top, left to right, then down *)
   193 fun search_tlr_valid validf =
   299 fun search_lr_valid validf =
   194     let 
   300     let 
   195       fun sf_valid_td_lr z = 
   301       fun sf_valid_td_lr z = 
   196           let val here = if validf z then [Z.Here z] else [] in
   302           let val here = if validf z then [Z.Here z] else [] in
   197             case Z.trm z 
   303             case Z.trm z 
   198              of _ $ _ => here @ [Z.LookIn (Z.move_down_left z),
   304              of _ $ _ => [Z.LookIn (Z.move_down_left z)] 
   199                                  Z.LookIn (Z.move_down_right z)]
   305                          @ here 
       
   306                          @ [Z.LookIn (Z.move_down_right z)]
   200               | Abs _ => here @ [Z.LookIn (Z.move_down_abs z)]
   307               | Abs _ => here @ [Z.LookIn (Z.move_down_abs z)]
   201               | _ => here
   308               | _ => here
   202           end;
   309           end;
   203     in Z.lzy_search sf_valid_td_lr end;
   310     in Z.lzy_search sf_valid_td_lr end;
   204 
   311 
   205 (* search all unifications *)
   312 (* search all unifications *)
   206 fun searchf_tlr_unify_all (sgn, maxidx, z) lhs =
   313 fun searchf_lr_unify_all (sgn, maxidx, z) lhs =
   207     Seq.map (clean_unify_z sgn maxidx lhs) 
   314     Seq.map (clean_unify_z sgn maxidx lhs) 
   208             (Z.limit_apply search_tlr_all z);
   315             (Z.limit_apply search_lr_all z);
   209 
   316 
   210 (* search only for 'valid' unifiers (non abs subterms and non vars) *)
   317 (* search only for 'valid' unifiers (non abs subterms and non vars) *)
   211 fun searchf_tlr_unify_valid (sgn, maxidx, z) lhs  =
   318 fun searchf_lr_unify_valid (sgn, maxidx, z) lhs  =
   212     Seq.map (clean_unify_z sgn maxidx lhs) 
   319     Seq.map (clean_unify_z sgn maxidx lhs) 
   213             (Z.limit_apply (search_tlr_valid valid_match_start) z);
   320             (Z.limit_apply (search_lr_valid valid_match_start) z);
   214 
   321 
   215 
   322 
   216 (* apply a substitution in the conclusion of the theorem th *)
   323 (* apply a substitution in the conclusion of the theorem th *)
   217 (* cfvs are certified free var placeholders for goal params *)
   324 (* cfvs are certified free var placeholders for goal params *)
   218 (* conclthm is a theorem of for just the conclusion *)
   325 (* conclthm is a theorem of for just the conclusion *)
   283         fun apply_occ occ th =
   390         fun apply_occ occ th =
   284             thmseq |> Seq.maps
   391             thmseq |> Seq.maps
   285                     (fn r => eqsubst_tac' 
   392                     (fn r => eqsubst_tac' 
   286                                ctxt 
   393                                ctxt 
   287                                (skip_first_occs_search
   394                                (skip_first_occs_search
   288                                   occ searchf_tlr_unify_valid) r
   395                                   occ searchf_lr_unify_valid) r
   289                                  (i + ((Thm.nprems_of th) - nprems))
   396                                  (i + ((Thm.nprems_of th) - nprems))
   290                                  th);
   397                                  th);
   291         val sortedoccL =
   398         val sortedoccL =
   292             Library.sort (Library.rev_order o Library.int_ord) occL;
   399             Library.sort (Library.rev_order o Library.int_ord) occL;
   293       in
   400       in
   399       let val thmseq = (Seq.of_list thms)
   506       let val thmseq = (Seq.of_list thms)
   400         fun apply_occ occK th =
   507         fun apply_occ occK th =
   401             thmseq |> Seq.maps
   508             thmseq |> Seq.maps
   402                     (fn r =>
   509                     (fn r =>
   403                         eqsubst_asm_tac' ctxt (skip_first_asm_occs_search
   510                         eqsubst_asm_tac' ctxt (skip_first_asm_occs_search
   404                                             searchf_tlr_unify_valid) occK r
   511                                             searchf_lr_unify_valid) occK r
   405                                          (i + ((Thm.nprems_of th) - nprems))
   512                                          (i + ((Thm.nprems_of th) - nprems))
   406                                          th);
   513                                          th);
   407         val sortedoccs =
   514         val sortedoccs =
   408             Library.sort (Library.rev_order o Library.int_ord) occL
   515             Library.sort (Library.rev_order o Library.int_ord) occL
   409       in
   516       in