src/HOL/Modelcheck/MuckeSyn.thy
author wenzelm
Thu Feb 11 21:33:25 2010 +0100 (2010-02-11)
changeset 35109 0015a0a99ae9
parent 33955 fff6f11b1f09
child 37139 e0bd5934a2fb
permissions -rw-r--r--
modernized syntax/translations;
mueller@6466
     1
(*  Title:      HOL/Modelcheck/MuckeSyn.thy
mueller@6466
     2
    Author:     Tobias Hamberger
mueller@6466
     3
    Copyright   1999  TU Muenchen
mueller@6466
     4
*)
mueller@6466
     5
wenzelm@17272
     6
theory MuckeSyn
wenzelm@17272
     7
imports MuCalculus
wenzelm@17272
     8
uses "mucke_oracle.ML"
wenzelm@17272
     9
begin
mueller@6466
    10
wenzelm@17272
    11
(* extended with some operators and case treatment (which requires postprocessing with
mueller@6466
    12
transform_case (from MuCalculus) (TH) *)
mueller@6466
    13
wenzelm@17272
    14
nonterminals
wenzelm@17272
    15
  mutype
mueller@6466
    16
  decl decls
wenzelm@17272
    17
  cases_syn case_syn
wenzelm@10125
    18
mueller@6466
    19
syntax (Mucke output)
wenzelm@17272
    20
  True          :: bool                                 ("true")
wenzelm@17272
    21
  False         :: bool                                 ("false")
wenzelm@17272
    22
  Not           :: "bool => bool"                       ("! _" [40] 40)
wenzelm@17272
    23
  If            :: "[bool, 'a, 'a] => 'a"       ("('(if'((_)')/ '((_)')/ else/ '((_)'))')" 10)
mueller@6466
    24
wenzelm@17272
    25
  "op &"        :: "[bool, bool] => bool"               (infixr "&" 35)
wenzelm@17272
    26
  "op |"        :: "[bool, bool] => bool"               (infixr "|" 30)
wenzelm@17272
    27
  "op -->"      :: "[bool, bool] => bool"               (infixr "->" 25)
wenzelm@17272
    28
  "op ="        :: "['a, 'a] => bool"                   ("(_ =/ _)" [51, 51] 50)
wenzelm@17272
    29
  "_not_equal"  :: "['a, 'a] => bool"                   ("(_ !=/ _)" [51, 51] 50)
mueller@6466
    30
wenzelm@21524
    31
  All_binder    :: "[idts, bool] => bool"               ("'((3forall _./ _)')" [0, 10] 10)
wenzelm@21524
    32
  Ex_binder     :: "[idts, bool] => bool"               ("'((3exists _./ _)')" [0, 10] 10)
mueller@6466
    33
wenzelm@17272
    34
  "_lambda"     :: "[idts, 'a] => 'b"                   ("(3L _./ _)" 10)
wenzelm@17272
    35
  "_applC"      :: "[('b => 'a), cargs] => aprop"       ("(1_/ '(_'))" [1000,1000] 999)
wenzelm@17272
    36
  "_cargs"      :: "['a, cargs] => cargs"               ("_,/ _" [1000,1000] 1000)
wenzelm@17272
    37
wenzelm@17272
    38
  "_idts"       :: "[idt, idts] => idts"                ("_,/ _" [1, 0] 0)
mueller@6466
    39
wenzelm@9368
    40
  "_tuple"      :: "'a => tuple_args => 'a * 'b"        ("(1_,/ _)")
wenzelm@35109
    41
(* "_pttrn"     :: "[pttrn, pttrns] => pttrn"           ("_,/ _" [1, 0] 0)
wenzelm@17272
    42
  "_pattern"    :: "[pttrn, patterns] => pttrn"         ("_,/ _" [1, 0] 0) *)
mueller@6466
    43
wenzelm@17272
    44
  "_decl"       :: "[mutype,pttrn] => decl"             ("_ _")
wenzelm@17272
    45
  "_decls"      :: "[decl,decls] => decls"              ("_,/ _")
wenzelm@17272
    46
  ""            :: "decl => decls"                      ("_")
wenzelm@17272
    47
  "_mu"         :: "[decl,decls,'a pred] => 'a pred"    ("mu _ '(_') _ ;")
wenzelm@17272
    48
  "_mudec"      :: "[decl,decls] => 'a pred"            ("mu _ '(_') ;")
wenzelm@17272
    49
  "_nu"         :: "[decl,decls,'a pred] => 'a pred"    ("nu _ '(_') _ ;")
wenzelm@17272
    50
  "_nudec"      :: "[decl,decls] => 'a pred"            ("nu _ '(_') ;")
wenzelm@17272
    51
  "_fun"        :: "[decl,decls,'a pred] => 'a pred"    ("_ '(_') _ ;")
wenzelm@17272
    52
  "_dec"        :: "[decl,decls] => 'a pred"            ("_ '(_') ;")
wenzelm@17272
    53
wenzelm@17272
    54
  "_Ex"         :: "[decl,idts,'a pred] => 'a pred"     ("'((3exists _ _./ _)')")
wenzelm@17272
    55
  "_All"        :: "[decl,idts,'a pred] => 'a pred"     ("'((3forall _ _./ _)')")
mueller@6466
    56
wenzelm@17272
    57
  "Mu "         :: "[idts, 'a pred] => 'a pred"         ("(3mu _./ _)" 1000)
wenzelm@17272
    58
  "Nu "         :: "[idts, 'a pred] => 'a pred"         ("(3nu _./ _)" 1000)
wenzelm@17272
    59
wenzelm@17272
    60
  "_case_syntax":: "['a, cases_syn] => 'b"              ("(case*_* / _ / esac*)" 10)
wenzelm@17272
    61
  "_case1"      :: "['a, 'b] => case_syn"               ("(2*= _ :/ _;)" 10)
wenzelm@17272
    62
  ""            :: "case_syn => cases_syn"              ("_")
wenzelm@17272
    63
  "_case2"      :: "[case_syn, cases_syn] => cases_syn" ("_/ _")
mueller@6466
    64
wenzelm@17272
    65
(*Terms containing a case statement must be post-processed with the
wenzelm@17272
    66
  ML function transform_case. There, all asterikses before the "="
wenzelm@17272
    67
  will be replaced by the expression between the two asterisks
wenzelm@17272
    68
  following "case" and the asterisk after esac will be deleted *)
mueller@6466
    69
wenzelm@28290
    70
oracle mc_mucke_oracle = mk_mc_mucke_oracle
mueller@6466
    71
wenzelm@22819
    72
ML {*
wenzelm@22819
    73
(* search_mu t searches for Mu terms in term t. In the case of nested Mu's,
wenzelm@22819
    74
   it yields innermost one. If no Mu term is present, search_mu yields NONE
wenzelm@22819
    75
*)
wenzelm@22819
    76
wenzelm@22819
    77
(* extended for treatment of nu (TH) *)
wenzelm@22819
    78
fun search_mu ((Const("MuCalculus.mu",tp)) $ t2) = 
wenzelm@32960
    79
        (case (search_mu t2) of
wenzelm@32960
    80
              SOME t => SOME t 
wenzelm@32960
    81
            | NONE => SOME ((Const("MuCalculus.mu",tp)) $ t2))
wenzelm@22819
    82
  | search_mu ((Const("MuCalculus.nu",tp)) $ t2) =
wenzelm@22819
    83
        (case (search_mu t2) of
wenzelm@22819
    84
              SOME t => SOME t
wenzelm@22819
    85
            | NONE => SOME ((Const("MuCalculus.nu",tp)) $ t2))
wenzelm@22819
    86
  | search_mu (t1 $ t2) = 
wenzelm@32960
    87
        (case (search_mu t1) of
wenzelm@32960
    88
              SOME t => SOME t 
wenzelm@32960
    89
            | NONE     => search_mu t2)
wenzelm@22819
    90
  | search_mu (Abs(_,_,t)) = search_mu t
wenzelm@22819
    91
  | search_mu _ = NONE;
wenzelm@22819
    92
wenzelm@22819
    93
wenzelm@22819
    94
wenzelm@22819
    95
wenzelm@22819
    96
(* seraching a variable in a term. Used in move_mus to extract the
wenzelm@22819
    97
   term-rep of var b in hthm *)
wenzelm@22819
    98
wenzelm@22819
    99
fun search_var s t =
wenzelm@22819
   100
case t of
wenzelm@22819
   101
     t1 $ t2 => (case (search_var s t1) of
wenzelm@32960
   102
                             SOME tt => SOME tt |
wenzelm@32960
   103
                             NONE => search_var s t2) |
wenzelm@22819
   104
     Abs(_,_,t) => search_var s t |
wenzelm@22819
   105
     Var((s1,_),_) => if s = s1 then SOME t else NONE |
wenzelm@22819
   106
     _ => NONE;
wenzelm@32960
   107
        
wenzelm@22819
   108
wenzelm@22819
   109
(* function move_mus:
wenzelm@22819
   110
   Mucke can't deal with nested Mu terms. move_mus i searches for 
wenzelm@22819
   111
   Mu terms in the subgoal i and replaces Mu terms in the conclusion
wenzelm@22819
   112
   by constants and definitions in the premises recursively.
wenzelm@22819
   113
wenzelm@22819
   114
   move_thm is the theorem the performs the replacement. To create NEW
wenzelm@22819
   115
   names for the Mu terms, the indizes of move_thm are incremented by
wenzelm@22819
   116
   max_idx of the subgoal.
wenzelm@22819
   117
*)
wenzelm@22819
   118
wenzelm@22819
   119
local
wenzelm@22819
   120
wenzelm@32178
   121
  val move_thm = OldGoals.prove_goal @{theory} "[| a = b ==> P a; a = b |] ==> P b"
wenzelm@32960
   122
        (fn prems => [cut_facts_tac prems 1, dtac sym 1, hyp_subst_tac 1,
wenzelm@32960
   123
                     REPEAT (resolve_tac prems 1)]);
wenzelm@22819
   124
wenzelm@22819
   125
  val sig_move_thm = Thm.theory_of_thm move_thm;
wenzelm@33035
   126
  val bCterm = cterm_of sig_move_thm (the (search_var "b" (concl_of move_thm)));
wenzelm@33035
   127
  val aCterm = cterm_of sig_move_thm (the (search_var "a" (hd(prems_of move_thm)))); 
wenzelm@22819
   128
wenzelm@22819
   129
in
wenzelm@22819
   130
wenzelm@22819
   131
fun move_mus i state =
wenzelm@22819
   132
let val sign = Thm.theory_of_thm state;
haftmann@33955
   133
    val subgoal = nth (prems_of state) i;
wenzelm@22819
   134
    val concl = Logic.strip_imp_concl subgoal; (* recursive mu's in prems? *)
wenzelm@22819
   135
    val redex = search_mu concl;
wenzelm@22819
   136
    val idx = let val t = #maxidx (rep_thm state) in 
wenzelm@32960
   137
              if t < 0 then 1 else t+1 end;
wenzelm@22819
   138
in
wenzelm@22819
   139
case redex of
wenzelm@22819
   140
     NONE => all_tac state |
wenzelm@22819
   141
     SOME redexterm => 
wenzelm@32960
   142
        let val Credex = cterm_of sign redexterm;
wenzelm@32960
   143
            val aiCterm = 
wenzelm@32960
   144
                cterm_of sig_move_thm (Logic.incr_indexes ([],idx) (term_of aCterm));
wenzelm@32960
   145
            val inst_move_thm = cterm_instantiate 
wenzelm@32960
   146
                                [(bCterm,Credex),(aCterm,aiCterm)] move_thm;
wenzelm@32960
   147
        in
wenzelm@22819
   148
            ((rtac inst_move_thm i) THEN (dtac eq_reflection i) 
wenzelm@32960
   149
                THEN (move_mus i)) state
wenzelm@32960
   150
        end
wenzelm@22819
   151
end;
wenzelm@22819
   152
end;
mueller@6466
   153
mueller@6466
   154
wenzelm@28290
   155
val call_mucke_tac = CSUBGOAL (fn (cgoal, i) =>
wenzelm@28290
   156
let val OraAss = mc_mucke_oracle cgoal
wenzelm@28290
   157
in cut_facts_tac [OraAss] i end);
wenzelm@22819
   158
wenzelm@22819
   159
wenzelm@22819
   160
(* transforming fun-defs into lambda-defs *)
wenzelm@22819
   161
wenzelm@32178
   162
val [eq] = OldGoals.goal Pure.thy "(!! x. f x == g x) ==> f == g";
wenzelm@32178
   163
 OldGoals.by (rtac (extensional eq) 1);
wenzelm@32178
   164
OldGoals.qed "ext_rl";
wenzelm@22819
   165
wenzelm@22819
   166
infix cc;
wenzelm@22819
   167
wenzelm@22819
   168
fun NONE cc xl = xl
wenzelm@22819
   169
  | (SOME x) cc xl = x::xl;
wenzelm@22819
   170
wenzelm@22819
   171
fun getargs ((x $ y) $ (Var ((z,_),_))) = getargs (x $ y) ^ " " ^z
wenzelm@22819
   172
  | getargs (x $ (Var ((y,_),_))) = y;
wenzelm@22819
   173
wenzelm@22819
   174
fun getfun ((x $ y) $ z) = getfun (x $ y)
wenzelm@22819
   175
  | getfun (x $ _) = x;
wenzelm@22819
   176
wenzelm@22819
   177
local
wenzelm@22819
   178
wenzelm@22819
   179
fun delete_bold [] = []
wenzelm@22819
   180
| delete_bold (x::xs) = if (is_prefix (op =) ("\^["::"["::"0"::"m"::[]) (x::xs))
wenzelm@22819
   181
        then (let val (_::_::_::s) = xs in delete_bold s end)
wenzelm@22819
   182
        else (if (is_prefix (op =) ("\^["::"["::"1"::"m"::[]) (x::xs))
wenzelm@22819
   183
                then  (let val (_::_::_::s) = xs in delete_bold s end)
wenzelm@22819
   184
                else (x::delete_bold xs));
wenzelm@22819
   185
wenzelm@22819
   186
fun delete_bold_string s = implode(delete_bold (explode s));
wenzelm@22819
   187
wenzelm@22819
   188
in
wenzelm@22819
   189
wenzelm@22819
   190
(* extension with removing bold font (TH) *)
wenzelm@22819
   191
fun mk_lam_def (_::_) _ _ = NONE  
wenzelm@22819
   192
  | mk_lam_def [] ((Const("==",_) $ (Const _)) $ RHS) t = SOME t
wenzelm@22819
   193
  | mk_lam_def [] ((Const("==",_) $ LHS) $ RHS) t = 
wenzelm@22819
   194
    let val thy = theory_of_thm t;
wenzelm@32960
   195
        val fnam = Syntax.string_of_term_global thy (getfun LHS);
wenzelm@32960
   196
        val rhs = Syntax.string_of_term_global thy (freeze_thaw RHS)
wenzelm@32960
   197
        val gl = delete_bold_string (fnam ^" == % " ^ (getargs LHS) ^" . " ^ rhs);
wenzelm@22819
   198
    in
wenzelm@32960
   199
        SOME (OldGoals.prove_goal thy gl (fn prems =>
wenzelm@32960
   200
                [(REPEAT (rtac ext_rl 1)), (rtac t 1) ]))
wenzelm@22819
   201
    end
wenzelm@22819
   202
| mk_lam_def [] _ t= NONE; 
wenzelm@22819
   203
wenzelm@22819
   204
fun mk_lam_defs ([]:thm list) = ([]: thm list) 
wenzelm@22819
   205
  | mk_lam_defs (t::l) = 
wenzelm@22819
   206
      (mk_lam_def (prems_of t) (concl_of t) t) cc (mk_lam_defs l);
wenzelm@22819
   207
wenzelm@22819
   208
end;
wenzelm@22819
   209
wenzelm@22819
   210
wenzelm@22819
   211
(* first simplification, then model checking *)
wenzelm@22819
   212
wenzelm@22819
   213
val pair_eta_expand = Thm.symmetric (mk_meta_eq (thm "split_eta"));
wenzelm@22819
   214
wenzelm@22819
   215
val pair_eta_expand_proc =
wenzelm@32010
   216
  Simplifier.simproc @{theory} "pair_eta_expand" ["f::'a*'b=>'c"]
wenzelm@22819
   217
  (fn _ => fn _ => fn t => case t of Abs _ => SOME pair_eta_expand | _ => NONE);
wenzelm@22819
   218
wenzelm@26342
   219
val Mucke_ss = @{simpset} addsimprocs [pair_eta_expand_proc] addsimps [Let_def];
wenzelm@22819
   220
wenzelm@22819
   221
wenzelm@22819
   222
(* the interface *)
wenzelm@22819
   223
wenzelm@22819
   224
fun mc_mucke_tac defs i state =
haftmann@33955
   225
  (case try (nth (Thm.prems_of state)) i of
haftmann@33955
   226
    NONE => no_tac state
haftmann@33955
   227
  | SOME subgoal =>
wenzelm@22819
   228
      EVERY [
wenzelm@22819
   229
        REPEAT (etac thin_rl i),
wenzelm@22819
   230
        cut_facts_tac (mk_lam_defs defs) i,
wenzelm@22819
   231
        full_simp_tac (Mucke_ss delsimps [not_iff,split_part]) i,
wenzelm@22819
   232
        move_mus i, call_mucke_tac i,atac i,
wenzelm@22819
   233
        REPEAT (rtac refl i)] state);
wenzelm@22819
   234
*}
wenzelm@22819
   235
wenzelm@22819
   236
end