src/HOL/Hoare/Hoare.ML
author nipkow
Fri, 24 Nov 2000 16:49:27 +0100
changeset 10519 ade64af4c57c
parent 9397 358e67410253
child 10642 5be46cd1f94a
permissions -rw-r--r--
hide many names from Datatype_Universe.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
9393
c97111953a66 corrected header
oheimb
parents: 9034
diff changeset
     1
(*  Title:      HOL/Hoare/Hoare.ML
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
     2
    ID:         $Id$
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
     3
    Author:     Leonor Prensa Nieto & Tobias Nipkow
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
     4
    Copyright   1998 TUM
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
     5
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
     6
Derivation of the proof rules and, most importantly, the VCG tactic.
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
     7
*)
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
     8
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
     9
(*** The proof rules ***)
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    10
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    11
Goalw [Valid_def] "p <= q ==> Valid p SKIP q";
6162
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    12
by (Auto_tac);
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    13
qed "SkipRule";
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    14
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    15
Goalw [Valid_def] "p <= {s. (f s):q} ==> Valid p (Basic f) q";
6162
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    16
by (Auto_tac);
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    17
qed "BasicRule";
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    18
8587
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    19
Goalw [Valid_def] "Valid P c1 Q ==> Valid Q c2 R ==> Valid P (c1;c2) R";
6162
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    20
by (Asm_simp_tac 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    21
by (Blast_tac 1);
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    22
qed "SeqRule";
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    23
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    24
Goalw [Valid_def]
8587
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    25
 "p <= {s. (s:b --> s:w) & (s~:b --> s:w')} \
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    26
\ ==> Valid w c1 q ==> Valid w' c2 q \
8573
fc22f59f5ae7 use abstract syntax;
wenzelm
parents: 7127
diff changeset
    27
\ ==> Valid p (Cond b c1 c2) q";
6162
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    28
by (Asm_simp_tac 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    29
by (Blast_tac 1);
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    30
qed "CondRule";
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    31
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    32
Goal "! s s'. Sem c s s' --> s : I Int b --> s' : I ==> \
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    33
\     ! s s'. s : I --> iter n b (Sem c) s s' --> s' : I & s' ~: b";
6162
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    34
by (induct_tac "n" 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    35
 by (Asm_simp_tac 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    36
by (Simp_tac 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    37
by (Blast_tac 1);
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    38
val lemma = result() RS spec RS spec RS mp RS mp;
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    39
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    40
Goalw [Valid_def]
8587
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    41
 "p <= i ==> Valid (i Int b) c i ==> i Int (-b) <= q \
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    42
\ ==> Valid p (While b j c) q";
6162
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    43
by (Asm_simp_tac 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    44
by (Clarify_tac 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    45
by (dtac lemma 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    46
by (assume_tac 2);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    47
by (Blast_tac 1);
484adda70b65 expandshort
paulson
parents: 5646
diff changeset
    48
by (Blast_tac 1);
8587
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    49
qed "WhileRule'";
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    50
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    51
Goal
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    52
 "p <= i ==> Valid (i Int b) c i ==> i Int (-b) <= q \
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    53
\ ==> Valid p (While b i c) q";
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    54
by (rtac WhileRule' 1);
49069dfedb1e added WhileRule';
wenzelm
parents: 8576
diff changeset
    55
by (ALLGOALS assume_tac);
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    56
qed "WhileRule";
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    57
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    58
(*** The tactics ***)
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    59
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    60
(*****************************************************************************)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    61
(** The function Mset makes the theorem                                     **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    62
(** "?Mset <= {(x1,...,xn). ?P (x1,...,xn)} ==> ?Mset <= {s. ?P s}",        **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    63
(** where (x1,...,xn) are the variables of the particular program we are    **)
9397
358e67410253 Updating of some comments
prensani
parents: 9393
diff changeset
    64
(** working on at the moment of the call                                    **)
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    65
(*****************************************************************************)
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    66
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    67
local open HOLogic in
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    68
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    69
(** maps (%x1 ... xn. t) to [x1,...,xn] **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    70
fun abs2list (Const ("split",_) $ (Abs(x,T,t))) = Free (x, T)::abs2list t
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    71
  | abs2list (Abs(x,T,t)) = [Free (x, T)]
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    72
  | abs2list _ = [];
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    73
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    74
(** maps {(x1,...,xn). t} to [x1,...,xn] **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    75
fun mk_vars (Const ("Collect",_) $ T) = abs2list T
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    76
  | mk_vars _ = [];
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    77
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    78
(** abstraction of body over a tuple formed from a list of free variables. 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    79
Types are also built **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    80
fun mk_abstupleC []     body = absfree ("x", unitT, body)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    81
  | mk_abstupleC (v::w) body = let val (n,T) = dest_Free v
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    82
                               in if w=[] then absfree (n, T, body)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    83
        else let val z  = mk_abstupleC w body;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    84
                 val T2 = case z of Abs(_,T,_) => T
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    85
                        | Const (_, Type (_,[_, Type (_,[T,_])])) $ _ => T;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    86
       in Const ("split", (T --> T2 --> boolT) --> mk_prodT (T,T2) --> boolT) 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    87
          $ absfree (n, T, z) end end;
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    88
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    89
(** maps [x1,...,xn] to (x1,...,xn) and types**)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    90
fun mk_bodyC []      = Const ("()", unitT) 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    91
  | mk_bodyC (x::xs) = if xs=[] then x 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    92
               else let val (n, T) = dest_Free x ;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    93
                        val z = mk_bodyC xs;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    94
                        val T2 = case z of Free(_, T) => T
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    95
                                         | Const ("Pair", Type ("fun", [_, Type
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    96
                                            ("fun", [_, T])])) $ _ $ _ => T;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    97
                 in Const ("Pair", [T, T2] ---> mk_prodT (T, T2)) $ x $ z end;
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
    98
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
    99
fun dest_Goal (Const ("Goal", _) $ P) = P;
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   100
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   101
(** maps a goal of the form:
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   102
        1. [| P |] ==> |- VARS x1 ... xn. {._.} _ {._.} or to [x1,...,xn]**) 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   103
fun get_vars thm = let  val c = dest_Goal (concl_of (thm));
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   104
                        val d = Logic.strip_assums_concl c;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   105
                        val Const _ $ pre $ _ $ _ = dest_Trueprop d;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   106
      in mk_vars pre end;
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   107
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   108
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   109
(** Makes Collect with type **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   110
fun mk_CollectC trm = let val T as Type ("fun",[t,_]) = fastype_of trm 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   111
                      in Collect_const t $ trm end;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   112
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   113
fun inclt ty = Const ("op <=", [ty,ty] ---> boolT);
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   114
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   115
(** Makes "Mset <= t" **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   116
fun Mset_incl t = let val MsetT = fastype_of t 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   117
                 in mk_Trueprop ((inclt MsetT) $ Free ("Mset", MsetT) $ t) end;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   118
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   119
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   120
fun Mset thm = let val vars = get_vars(thm);
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   121
                   val varsT = fastype_of (mk_bodyC vars);
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   122
                   val big_Collect = mk_CollectC (mk_abstupleC vars 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   123
                         (Free ("P",varsT --> boolT) $ mk_bodyC vars));
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   124
                   val small_Collect = mk_CollectC (Abs("x",varsT,
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   125
                           Free ("P",varsT --> boolT) $ Bound 0));
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   126
                   val impl = implies $ (Mset_incl big_Collect) $ 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   127
                                          (Mset_incl small_Collect);
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   128
                   val cimpl = cterm_of (#sign (rep_thm thm)) impl
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   129
   in  prove_goalw_cterm [] cimpl (fn prems => 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   130
                              [cut_facts_tac prems 1,Blast_tac 1]) end;
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   131
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   132
end;
3537
79ac9b475621 Removal of the tactical STATE
paulson
parents: 2901
diff changeset
   133
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   134
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   135
(*****************************************************************************)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   136
(** Simplifying:                                                            **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   137
(** Some useful lemmata, lists and simplification tactics to control which  **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   138
(** theorems are used to simplify at each moment, so that the original      **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   139
(** input does not suffer any unexpected transformation                     **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   140
(*****************************************************************************)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   141
8573
fc22f59f5ae7 use abstract syntax;
wenzelm
parents: 7127
diff changeset
   142
val Compl_Collect = prove_goal (the_context ()) "-(Collect b) = {x. ~(b x)}"
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   143
    (fn _ => [Fast_tac 1]);
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   144
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   145
(**Simp_tacs**)
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   146
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   147
val before_set2pred_simp_tac =
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   148
  (simp_tac (HOL_basic_ss addsimps [Collect_conj_eq RS sym,Compl_Collect]));
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   149
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   150
val split_simp_tac = (simp_tac (HOL_basic_ss addsimps [split]));
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   151
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   152
(*****************************************************************************)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   153
(** set2pred transforms sets inclusion into predicates implication,         **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   154
(** maintaining the original variable names.                                **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   155
(** Ex. "{x. x=0} <= {x. x <= 1}" -set2pred-> "x=0 --> x <= 1"              **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   156
(** Subgoals containing intersections (A Int B) or complement sets (-A)     **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   157
(** are first simplified by "before_set2pred_simp_tac", that returns only   **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   158
(** subgoals of the form "{x. P x} <= {x. Q x}", which are easily           **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   159
(** transformed.                                                            **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   160
(** This transformation may solve very easy subgoals due to a ligth         **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   161
(** simplification done by (split_all_tac)                                  **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   162
(*****************************************************************************)
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   163
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   164
fun set2pred i thm = let fun mk_string [] = ""
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   165
                           | mk_string (x::xs) = x^" "^mk_string xs;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   166
                         val vars=get_vars(thm);
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   167
                         val var_string = mk_string (map (fst o dest_Free) vars);
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   168
      in ((before_set2pred_simp_tac i) THEN_MAYBE
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   169
          (EVERY [rtac subsetI i, 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   170
                  rtac CollectI i,
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   171
                  dtac CollectD i,
8576
142065da303d addsimprocs [record_simproc];
wenzelm
parents: 8573
diff changeset
   172
                  (TRY(split_all_tac i)) THEN_MAYBE
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   173
                  ((rename_tac var_string i) THEN
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   174
                   (full_simp_tac (HOL_basic_ss addsimps [split]) i)) ])) thm
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   175
      end;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   176
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   177
(*****************************************************************************)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   178
(** BasicSimpTac is called to simplify all verification conditions. It does **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   179
(** a light simplification by applying "mem_Collect_eq", then it calls      **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   180
(** MaxSimpTac, which solves subgoals of the form "A <= A",                 **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   181
(** and transforms any other into predicates, applying then                 **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   182
(** the tactic chosen by the user, which may solve the subgoal completely.  **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   183
(*****************************************************************************)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   184
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   185
fun MaxSimpTac tac = FIRST'[rtac subset_refl, set2pred THEN_MAYBE' tac];
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   186
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   187
fun BasicSimpTac tac =
8576
142065da303d addsimprocs [record_simproc];
wenzelm
parents: 8573
diff changeset
   188
  simp_tac
142065da303d addsimprocs [record_simproc];
wenzelm
parents: 8573
diff changeset
   189
    (HOL_basic_ss addsimps [mem_Collect_eq,split] addsimprocs [record_simproc])
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   190
  THEN_MAYBE' MaxSimpTac tac;
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   191
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   192
(** HoareRuleTac **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   193
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   194
fun WlpTac Mlem tac i = rtac SeqRule i THEN  HoareRuleTac Mlem tac false (i+1)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   195
and HoareRuleTac Mlem tac pre_cond i st = st |>
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   196
        (*abstraction over st prevents looping*)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   197
    ( (WlpTac Mlem tac i THEN HoareRuleTac Mlem tac pre_cond i)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   198
      ORELSE
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   199
      (FIRST[rtac SkipRule i,
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   200
             EVERY[rtac BasicRule i,
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   201
                   rtac Mlem i,
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   202
                   split_simp_tac i],
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   203
             EVERY[rtac CondRule i,
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   204
                   HoareRuleTac Mlem tac false (i+2),
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   205
                   HoareRuleTac Mlem tac false (i+1)],
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   206
             EVERY[rtac WhileRule i,
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   207
                   BasicSimpTac tac (i+2),
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   208
                   HoareRuleTac Mlem tac true (i+1)] ] 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   209
       THEN (if pre_cond then (BasicSimpTac tac i) else (rtac subset_refl i)) ));
1335
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   210
5e1c0540f285 New directory.
nipkow
parents:
diff changeset
   211
5646
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   212
(** tac:(int -> tactic) is the tactic the user chooses to solve or simplify **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   213
(** the final verification conditions                                       **)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   214
 
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   215
fun hoare_tac tac i thm =
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   216
  let val Mlem = Mset(thm)
7c2ddbaf8b8c New many-sorted version.
nipkow
parents: 5183
diff changeset
   217
  in SELECT_GOAL(EVERY[HoareRuleTac Mlem tac true 1]) i thm end;