src/HOL/simpdata.ML
changeset 21551 d276e7d25017
parent 21313 26fc3a45547c
child 21674 8a6bf9d7c751
equal deleted inserted replaced
21550:7cc49399929a 21551:d276e7d25017
    18   fun dest_imp ((c as Const("op -->",_)) $ s $ t) = SOME (c, s, t)
    18   fun dest_imp ((c as Const("op -->",_)) $ s $ t) = SOME (c, s, t)
    19     | dest_imp _ = NONE;
    19     | dest_imp _ = NONE;
    20   val conj = HOLogic.conj
    20   val conj = HOLogic.conj
    21   val imp  = HOLogic.imp
    21   val imp  = HOLogic.imp
    22   (*rules*)
    22   (*rules*)
    23   val iff_reflection = HOL.eq_reflection
    23   val iff_reflection = thm "eq_reflection"
    24   val iffI = HOL.iffI
    24   val iffI = thm "iffI"
    25   val iff_trans = HOL.trans
    25   val iff_trans = thm "trans"
    26   val conjI= HOL.conjI
    26   val conjI= thm "conjI"
    27   val conjE= HOL.conjE
    27   val conjE= thm "conjE"
    28   val impI = HOL.impI
    28   val impI = thm "impI"
    29   val mp   = HOL.mp
    29   val mp   = thm "mp"
    30   val uncurry = thm "uncurry"
    30   val uncurry = thm "uncurry"
    31   val exI  = HOL.exI
    31   val exI  = thm "exI"
    32   val exE  = HOL.exE
    32   val exE  = thm "exE"
    33   val iff_allI = thm "iff_allI"
    33   val iff_allI = thm "iff_allI"
    34   val iff_exI = thm "iff_exI"
    34   val iff_exI = thm "iff_exI"
    35   val all_comm = thm "all_comm"
    35   val all_comm = thm "all_comm"
    36   val ex_comm = thm "ex_comm"
    36   val ex_comm = thm "ex_comm"
    37 end);
    37 end);
    38 
    38 
    39 structure HOL =
    39 structure Simpdata =
    40 struct
    40 struct
    41 
    41 
    42 open HOL;
    42 local
    43 
    43   val eq_reflection = thm "eq_reflection"
    44 val Eq_FalseI = thm "Eq_FalseI";
    44 in fun mk_meta_eq r = r RS eq_reflection end;
    45 val Eq_TrueI = thm "Eq_TrueI";
       
    46 val simp_implies_def = thm "simp_implies_def";
       
    47 val simp_impliesI = thm "simp_impliesI";
       
    48 
       
    49 fun mk_meta_eq r = r RS eq_reflection;
       
    50 fun safe_mk_meta_eq r = mk_meta_eq r handle Thm.THM _ => r;
    45 fun safe_mk_meta_eq r = mk_meta_eq r handle Thm.THM _ => r;
    51 
    46 
    52 fun mk_eq thm = case concl_of thm
    47 local
       
    48   val Eq_FalseI = thm "Eq_FalseI"
       
    49   val Eq_TrueI = thm "Eq_TrueI"
       
    50 in fun mk_eq th = case concl_of th
    53   (*expects Trueprop if not == *)
    51   (*expects Trueprop if not == *)
    54   of Const ("==",_) $ _ $ _ => thm
    52   of Const ("==",_) $ _ $ _ => th
    55    | _ $ (Const ("op =", _) $ _ $ _) => mk_meta_eq thm
    53    | _ $ (Const ("op =", _) $ _ $ _) => mk_meta_eq th
    56    | _ $ (Const ("Not", _) $ _) => thm RS Eq_FalseI
    54    | _ $ (Const ("Not", _) $ _) => th RS Eq_FalseI
    57    | _ => thm RS Eq_TrueI;
    55    | _ => th RS Eq_TrueI
    58 
    56 end;
    59 fun mk_eq_True r =
    57 
       
    58 local
       
    59   val meta_eq_to_obj_eq = thm "meta_eq_to_obj_eq"
       
    60   val Eq_TrueI = thm "Eq_TrueI"
       
    61 in fun mk_eq_True r =
    60   SOME (r RS meta_eq_to_obj_eq RS Eq_TrueI) handle Thm.THM _ => NONE;
    62   SOME (r RS meta_eq_to_obj_eq RS Eq_TrueI) handle Thm.THM _ => NONE;
       
    63 end;
    61 
    64 
    62 (* Produce theorems of the form
    65 (* Produce theorems of the form
    63   (P1 =simp=> ... =simp=> Pn => x == y) ==> (P1 =simp=> ... =simp=> Pn => x = y)
    66   (P1 =simp=> ... =simp=> Pn => x == y) ==> (P1 =simp=> ... =simp=> Pn => x = y)
    64 *)
    67 *)
    65 fun lift_meta_eq_to_obj_eq i st =
    68 local
       
    69   val meta_eq_to_obj_eq = thm "meta_eq_to_obj_eq"
       
    70   val simp_implies_def = thm "simp_implies_def"
       
    71 in fun lift_meta_eq_to_obj_eq i st =
    66   let
    72   let
    67     fun count_imp (Const ("HOL.simp_implies", _) $ P $ Q) = 1 + count_imp Q
    73     fun count_imp (Const ("HOL.simp_implies", _) $ P $ Q) = 1 + count_imp Q
    68       | count_imp _ = 0;
    74       | count_imp _ = 0;
    69     val j = count_imp (Logic.strip_assums_concl (List.nth (prems_of st, i - 1)))
    75     val j = count_imp (Logic.strip_assums_concl (List.nth (prems_of st, i - 1)))
    70   in if j = 0 then meta_eq_to_obj_eq
    76   in if j = 0 then meta_eq_to_obj_eq
    82         (fn prems => EVERY
    88         (fn prems => EVERY
    83          [rewrite_goals_tac [simp_implies_def],
    89          [rewrite_goals_tac [simp_implies_def],
    84           REPEAT (ares_tac (meta_eq_to_obj_eq :: map (rewrite_rule [simp_implies_def]) prems) 1)])
    90           REPEAT (ares_tac (meta_eq_to_obj_eq :: map (rewrite_rule [simp_implies_def]) prems) 1)])
    85       end
    91       end
    86   end;
    92   end;
       
    93 end;
    87 
    94 
    88 (*Congruence rules for = (instead of ==)*)
    95 (*Congruence rules for = (instead of ==)*)
    89 fun mk_meta_cong rl = zero_var_indexes
    96 fun mk_meta_cong rl = zero_var_indexes
    90   (let val rl' = Seq.hd (TRYALL (fn i => fn st =>
    97   (let val rl' = Seq.hd (TRYALL (fn i => fn st =>
    91      rtac (lift_meta_eq_to_obj_eq i st) i st) rl)
    98      rtac (lift_meta_eq_to_obj_eq i st) i st) rl)
   114   in atoms end;
   121   in atoms end;
   115 
   122 
   116 fun mksimps pairs =
   123 fun mksimps pairs =
   117   map_filter (try mk_eq) o mk_atomize pairs o gen_all;
   124   map_filter (try mk_eq) o mk_atomize pairs o gen_all;
   118 
   125 
   119 fun unsafe_solver_tac prems =
   126 local
       
   127   val simp_impliesI = thm "simp_impliesI"
       
   128   val TrueI = thm "TrueI"
       
   129   val FalseE = thm "FalseE"
       
   130   val refl = thm "refl"
       
   131 in fun unsafe_solver_tac prems =
   120   (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN'
   132   (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN'
   121   FIRST'[resolve_tac(reflexive_thm :: TrueI :: refl :: prems), atac, etac FalseE];
   133   FIRST'[resolve_tac(reflexive_thm :: TrueI :: refl :: prems), atac, etac FalseE];
       
   134 end;
   122 val unsafe_solver = mk_solver "HOL unsafe" unsafe_solver_tac;
   135 val unsafe_solver = mk_solver "HOL unsafe" unsafe_solver_tac;
   123 
   136 
   124 (*No premature instantiation of variables during simplification*)
   137 (*No premature instantiation of variables during simplification*)
   125 fun safe_solver_tac prems =
   138 local
       
   139   val simp_impliesI = thm "simp_impliesI"
       
   140   val TrueI = thm "TrueI"
       
   141   val FalseE = thm "FalseE"
       
   142   val refl = thm "refl"
       
   143 in fun safe_solver_tac prems =
   126   (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN'
   144   (fn i => REPEAT_DETERM (match_tac [simp_impliesI] i)) THEN'
   127   FIRST'[match_tac(reflexive_thm :: TrueI :: refl :: prems),
   145   FIRST'[match_tac(reflexive_thm :: TrueI :: refl :: prems),
   128          eq_assume_tac, ematch_tac [FalseE]];
   146          eq_assume_tac, ematch_tac [FalseE]];
       
   147 end;
   129 val safe_solver = mk_solver "HOL safe" safe_solver_tac;
   148 val safe_solver = mk_solver "HOL safe" safe_solver_tac;
   130 
       
   131 end;
       
   132 
   149 
   133 structure SplitterData =
   150 structure SplitterData =
   134 struct
   151 struct
   135   structure Simplifier = Simplifier
   152   structure Simplifier = Simplifier
   136   val mk_eq           = HOL.mk_eq
   153   val mk_eq           = mk_eq
   137   val meta_eq_to_iff  = HOL.meta_eq_to_obj_eq
   154   val meta_eq_to_iff  = thm "meta_eq_to_obj_eq"
   138   val iffD            = HOL.iffD2
   155   val iffD            = thm "iffD2"
   139   val disjE           = HOL.disjE
   156   val disjE           = thm "disjE"
   140   val conjE           = HOL.conjE
   157   val conjE           = thm "conjE"
   141   val exE             = HOL.exE
   158   val exE             = thm "exE"
   142   val contrapos       = HOL.contrapos_nn
   159   val contrapos       = thm "contrapos_nn"
   143   val contrapos2      = HOL.contrapos_pp
   160   val contrapos2      = thm "contrapos_pp"
   144   val notnotD         = HOL.notnotD
   161   val notnotD         = thm "notnotD"
   145 end;
   162 end;
   146 
   163 
   147 structure Splitter = SplitterFun(SplitterData);
   164 structure Splitter = SplitterFun(SplitterData);
   148 
       
   149 
   165 
   150 (* integration of simplifier with classical reasoner *)
   166 (* integration of simplifier with classical reasoner *)
   151 
   167 
   152 structure Clasimp = ClasimpFun
   168 structure Clasimp = ClasimpFun
   153  (structure Simplifier = Simplifier and Splitter = Splitter
   169  (structure Simplifier = Simplifier and Splitter = Splitter
   154   and Classical  = Classical and Blast = Blast
   170   and Classical  = Classical and Blast = Blast
   155   val iffD1 = HOL.iffD1 val iffD2 = HOL.iffD2 val notE = HOL.notE);
   171   val iffD1 = thm "iffD1" val iffD2 = thm "iffD2" val notE = thm "notE");
   156 
       
   157 structure HOL =
       
   158 struct
       
   159 
       
   160 open HOL;
       
   161 
   172 
   162 val mksimps_pairs =
   173 val mksimps_pairs =
   163   [("op -->", [mp]), ("op &", [thm "conjunct1", thm "conjunct2"]),
   174   [("op -->", [thm "mp"]), ("op &", [thm "conjunct1", thm "conjunct2"]),
   164    ("All", [spec]), ("True", []), ("False", []),
   175    ("All", [thm "spec"]), ("True", []), ("False", []),
   165    ("HOL.If", [thm "if_bool_eq_conj" RS iffD1])];
   176    ("HOL.If", [thm "if_bool_eq_conj" RS thm "iffD1"])];
   166 
   177 
   167 val simpset_basic =
   178 val simpset_basic =
   168   Simplifier.theory_context (the_context ()) empty_ss
   179   Simplifier.theory_context (the_context ()) empty_ss
   169     setsubgoaler asm_simp_tac
   180     setsubgoaler asm_simp_tac
   170     setSSolver safe_solver
   181     setSSolver safe_solver
   187 
   198 
   188 val use_neq_simproc = ref true;
   199 val use_neq_simproc = ref true;
   189 
   200 
   190 local
   201 local
   191   val thy = the_context ();
   202   val thy = the_context ();
   192   val neq_to_EQ_False = thm "not_sym" RS HOL.Eq_FalseI;
   203   val neq_to_EQ_False = thm "not_sym" RS thm "Eq_FalseI";
   193   fun neq_prover sg ss (eq $ lhs $ rhs) =
   204   fun neq_prover sg ss (eq $ lhs $ rhs) =
   194     let
   205     let
   195       fun test thm = (case #prop (rep_thm thm) of
   206       fun test thm = (case #prop (rep_thm thm) of
   196                     _ $ (Not $ (eq' $ l' $ r')) =>
   207                     _ $ (Not $ (eq' $ l' $ r')) =>
   197                       Not = HOLogic.Not andalso eq' = eq andalso
   208                       Not = HOLogic.Not andalso eq' = eq andalso
   215 
   226 
   216 local
   227 local
   217   val thy = the_context ();
   228   val thy = the_context ();
   218   val Let_folded = thm "Let_folded";
   229   val Let_folded = thm "Let_folded";
   219   val Let_unfold = thm "Let_unfold";
   230   val Let_unfold = thm "Let_unfold";
       
   231   val Let_def = thm "Let_def";
   220   val (f_Let_unfold, x_Let_unfold) =
   232   val (f_Let_unfold, x_Let_unfold) =
   221       let val [(_$(f$x)$_)] = prems_of Let_unfold
   233       let val [(_$(f$x)$_)] = prems_of Let_unfold
   222       in (cterm_of thy f, cterm_of thy x) end
   234       in (cterm_of thy f, cterm_of thy x) end
   223   val (f_Let_folded, x_Let_folded) =
   235   val (f_Let_folded, x_Let_folded) =
   224       let val [(_$(f$x)$_)] = prems_of Let_folded
   236       let val [(_$(f$x)$_)] = prems_of Let_folded
   234          val ([t'], ctxt') = Variable.import_terms false [t] ctxt;
   246          val ([t'], ctxt') = Variable.import_terms false [t] ctxt;
   235      in Option.map (hd o Variable.export ctxt' ctxt o single)
   247      in Option.map (hd o Variable.export ctxt' ctxt o single)
   236       (case t' of (Const ("Let",_)$x$f) => (* x and f are already in normal form *)
   248       (case t' of (Const ("Let",_)$x$f) => (* x and f are already in normal form *)
   237          if not (!use_let_simproc) then NONE
   249          if not (!use_let_simproc) then NONE
   238          else if is_Free x orelse is_Bound x orelse is_Const x
   250          else if is_Free x orelse is_Bound x orelse is_Const x
   239          then SOME (thm "Let_def")
   251          then SOME Let_def
   240          else
   252          else
   241           let
   253           let
   242              val n = case f of (Abs (x,_,_)) => x | _ => "x";
   254              val n = case f of (Abs (x,_,_)) => x | _ => "x";
   243              val cx = cterm_of sg x;
   255              val cx = cterm_of sg x;
   244              val {T=xT,...} = rep_cterm cx;
   256              val {T=xT,...} = rep_cterm cx;
   287    [| A1; ...; An |] ==> False
   299    [| A1; ...; An |] ==> False
   288    where the Ai are atomic, i.e. no top-level &, | or EX
   300    where the Ai are atomic, i.e. no top-level &, | or EX
   289 *)
   301 *)
   290 
   302 
   291 local
   303 local
       
   304   val conjE = thm "conjE"
       
   305   val exE = thm "exE"
       
   306   val disjE = thm "disjE"
       
   307   val notE = thm "notE"
       
   308   val rev_mp = thm "rev_mp"
       
   309   val ccontr = thm "ccontr"
   292   val nnf_simpset =
   310   val nnf_simpset =
   293     empty_ss setmkeqTrue mk_eq_True
   311     empty_ss setmkeqTrue mk_eq_True
   294     setmksimps (mksimps mksimps_pairs)
   312     setmksimps (mksimps mksimps_pairs)
   295     addsimps [thm "imp_conv_disj", thm "iff_conv_conj_imp", thm "de_Morgan_disj", thm "de_Morgan_conj",
   313     addsimps [thm "imp_conv_disj", thm "iff_conv_conj_imp", thm "de_Morgan_disj", thm "de_Morgan_conj",
   296       thm "not_all", thm "not_ex", thm "not_not"];
   314       thm "not_all", thm "not_ex", thm "not_not"];
   322 
   340 
   323 val simpset_simprocs = simpset_basic
   341 val simpset_simprocs = simpset_basic
   324   addsimprocs [defALL_regroup, defEX_regroup, neq_simproc, let_simproc]
   342   addsimprocs [defALL_regroup, defEX_regroup, neq_simproc, let_simproc]
   325 
   343 
   326 end;
   344 end;
       
   345 
       
   346 structure Splitter = Simpdata.Splitter;
       
   347 structure Clasimp = Simpdata.Clasimp;