src/Provers/typedsimp.ML
author wenzelm
Thu, 02 Oct 2008 19:59:00 +0200
changeset 28464 dcc030b52583
parent 15574 b1d1b5bfc464
child 30190 479806475f3c
permissions -rw-r--r--
tuned SYNCHRONIZED: outermost Exn.release; tuned tracing;
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
0
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     1
(*  Title: 	typedsimp
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     2
    ID:         $Id$
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     3
    Author: 	Lawrence C Paulson, Cambridge University Computer Laboratory
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     4
    Copyright   1993  University of Cambridge
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     5
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     6
Functor for constructing simplifiers.  Suitable for Constructive Type
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     7
Theory with its typed reflexivity axiom a:A ==> a=a:A.  For most logics try
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     8
simp.ML.
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
     9
*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    10
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    11
signature TSIMP_DATA =
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    12
  sig
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    13
  val refl: thm		(*Reflexive law*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    14
  val sym: thm		(*Symmetric law*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    15
  val trans: thm	(*Transitive law*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    16
  val refl_red: thm	(* reduce(a,a) *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    17
  val trans_red: thm	(* [|a=b; reduce(b,c) |] ==> a=c *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    18
  val red_if_equal: thm (* a=b ==> reduce(a,b) *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    19
  (*Built-in rewrite rules*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    20
  val default_rls: thm list
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    21
  (*Type checking or similar -- solution of routine conditions*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    22
  val routine_tac: thm list -> int -> tactic
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    23
  end;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    24
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    25
signature TSIMP =
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    26
  sig
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    27
  val asm_res_tac: thm list -> int -> tactic   
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    28
  val cond_norm_tac: ((int->tactic) * thm list * thm list) -> tactic
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    29
  val cond_step_tac: ((int->tactic) * thm list * thm list) -> int -> tactic
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    30
  val norm_tac: (thm list * thm list) -> tactic
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    31
  val process_rules: thm list -> thm list * thm list
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    32
  val rewrite_res_tac: int -> tactic   
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    33
  val split_eqn: thm
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    34
  val step_tac: (thm list * thm list) -> int -> tactic
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    35
  val subconv_res_tac: thm list -> int -> tactic   
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    36
  end;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    37
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    38
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    39
functor TSimpFun (TSimp_data: TSIMP_DATA) : TSIMP = 
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    40
struct
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    41
local open TSimp_data
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    42
in
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    43
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    44
(*For simplifying both sides of an equation:
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    45
      [| a=c; b=c |] ==> b=a
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    46
  Can use resolve_tac [split_eqn] to prepare an equation for simplification. *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    47
val split_eqn = standard (sym RSN (2,trans) RS sym);
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    48
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    49
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    50
(*    [| a=b; b=c |] ==> reduce(a,c)  *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    51
val red_trans = standard (trans RS red_if_equal);
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    52
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    53
(*For REWRITE rule: Make a reduction rule for simplification, e.g.
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    54
  [| a: C(0); ... ; a=c: C(0) |] ==> rec(0,a,b) = c: C(0) *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    55
fun simp_rule rl = rl RS trans;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    56
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    57
(*For REWRITE rule: Make rule for resimplifying if possible, e.g.
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    58
  [| a: C(0); ...; a=c: C(0) |] ==> reduce(rec(0,a,b), c)  *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    59
fun resimp_rule rl = rl RS red_trans;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    60
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    61
(*For CONGRUENCE rule, like a=b ==> succ(a) = succ(b)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    62
  Make rule for simplifying subterms, e.g.
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    63
  [| a=b: N; reduce(succ(b), c) |] ==> succ(a)=c: N   *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    64
fun subconv_rule rl = rl RS trans_red;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    65
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    66
(*If the rule proves an equality then add both forms to simp_rls
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    67
  else add the rule to other_rls*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    68
fun add_rule (rl, (simp_rls, other_rls)) =
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    69
    (simp_rule rl :: resimp_rule rl :: simp_rls, other_rls)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    70
    handle THM _ => (simp_rls, rl :: other_rls);
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    71
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    72
(*Given the list rls, return the pair (simp_rls, other_rls).*)
15574
b1d1b5bfc464 Removed practically all references to Library.foldr.
skalberg
parents: 15570
diff changeset
    73
fun process_rules rls = foldr add_rule ([],[]) rls;
0
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    74
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    75
(*Given list of rewrite rules, return list of both forms, reject others*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    76
fun process_rewrites rls = 
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    77
  case process_rules rls of
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    78
      (simp_rls,[])  =>  simp_rls
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    79
    | (_,others) => raise THM 
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    80
	("process_rewrites: Ill-formed rewrite", 0, others);
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    81
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    82
(*Process the default rewrite rules*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    83
val simp_rls = process_rewrites default_rls;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    84
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    85
(*If subgoal is too flexible (e.g. ?a=?b or just ?P) then filt_resolve_tac
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    86
  will fail!  The filter will pass all the rules, and the bound permits
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    87
  no ambiguity.*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    88
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    89
(*Resolution with rewrite/sub rules.  Builds the tree for filt_resolve_tac.*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    90
val rewrite_res_tac = filt_resolve_tac simp_rls 2;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    91
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    92
(*The congruence rules for simplifying subterms.  If subgoal is too flexible
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    93
    then only refl,refl_red will be used (if even them!). *)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    94
fun subconv_res_tac congr_rls =
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    95
  filt_resolve_tac (map subconv_rule congr_rls) 2
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    96
  ORELSE'  filt_resolve_tac [refl,refl_red] 1;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    97
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    98
(*Resolve with asms, whether rewrites or not*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
    99
fun asm_res_tac asms =
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   100
    let val (xsimp_rls,xother_rls) = process_rules asms
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   101
    in 	routine_tac xother_rls  ORELSE'  
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   102
	filt_resolve_tac xsimp_rls 2
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   103
    end;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   104
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   105
(*Single step for simple rewriting*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   106
fun step_tac (congr_rls,asms) =
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   107
    asm_res_tac asms   ORELSE'  rewrite_res_tac  ORELSE'  
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   108
    subconv_res_tac congr_rls;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   109
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   110
(*Single step for conditional rewriting: prove_cond_tac handles new subgoals.*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   111
fun cond_step_tac (prove_cond_tac, congr_rls, asms) =
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   112
    asm_res_tac asms   ORELSE'  rewrite_res_tac  ORELSE'  
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   113
    (resolve_tac [trans, red_trans]  THEN'  prove_cond_tac)  ORELSE'  
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   114
    subconv_res_tac congr_rls;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   115
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   116
(*Unconditional normalization tactic*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   117
fun norm_tac arg = REPEAT_FIRST (step_tac arg)  THEN
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   118
    TRYALL (resolve_tac [red_if_equal]);
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   119
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   120
(*Conditional normalization tactic*)
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   121
fun cond_norm_tac arg = REPEAT_FIRST (cond_step_tac arg)  THEN
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   122
    TRYALL (resolve_tac [red_if_equal]);
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   123
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   124
end;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   125
end;
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   126
a5a9c433f639 Initial revision
clasohm
parents:
diff changeset
   127