src/HOL/Modelcheck/mucke_oracle.ML
author wenzelm
Tue Sep 06 16:24:53 2005 +0200 (2005-09-06)
changeset 17272 c63e5220ed77
parent 16587 b34c8aa657a5
child 17374 63e0ab9f2ea9
permissions -rw-r--r--
converted to Isar theory format;
wenzelm@16152
     1
wenzelm@16152
     2
(* $Id$ *)
wenzelm@16152
     3
mueller@6473
     4
val trace_mc = ref false; 
mueller@6473
     5
mueller@6473
     6
mueller@6473
     7
(* transform_case post-processes output strings of the syntax "Mucke" *)
mueller@6473
     8
(* with respect to the syntax of the case construct                   *)
mueller@6473
     9
local
mueller@6473
    10
  fun extract_argument [] = []
mueller@6473
    11
  | extract_argument ("*"::_) = []
mueller@6473
    12
  | extract_argument (x::xs) = x::(extract_argument xs);
mueller@6473
    13
mueller@6473
    14
  fun cut_argument [] = []
mueller@6473
    15
  | cut_argument ("*"::r) = r
mueller@6473
    16
  | cut_argument (_::xs) = cut_argument xs;
mueller@6473
    17
mueller@6473
    18
  fun insert_case_argument [] s = []
mueller@6473
    19
  | insert_case_argument ("*"::"="::xl) (x::xs) =
mueller@6473
    20
         (explode(x)@(" "::"="::(insert_case_argument xl (x::xs))))
mueller@6473
    21
  | insert_case_argument ("c"::"a"::"s"::"e"::"*"::xl) s =
mueller@6473
    22
        (let
mueller@6473
    23
        val arg=implode(extract_argument xl);
mueller@6473
    24
        val xr=cut_argument xl
mueller@6473
    25
        in
mueller@6473
    26
         "c"::"a"::"s"::"e"::" "::(insert_case_argument xr (arg::s))
mueller@6473
    27
        end)
mueller@6473
    28
  | insert_case_argument ("e"::"s"::"a"::"c"::"*"::xl) (x::xs) =
mueller@6473
    29
        "e"::"s"::"a"::"c"::(insert_case_argument xl xs)
mueller@6473
    30
  | insert_case_argument (x::xl) s = x::(insert_case_argument xl s);
mueller@6473
    31
in
mueller@6473
    32
mueller@6473
    33
fun transform_case s = implode(insert_case_argument (explode s) []);
mueller@6473
    34
mueller@6473
    35
end;
mueller@6473
    36
mueller@6473
    37
mueller@6473
    38
(* if_full_simp_tac is a tactic for rewriting non-boolean ifs *)
mueller@6473
    39
local
mueller@6473
    40
  (* searching an if-term as below as possible *)
mueller@6473
    41
  fun contains_if (Abs(a,T,t)) = [] |
paulson@16587
    42
  contains_if (Const("HOL.If",T) $ b $ a1 $ a2) =
mueller@6473
    43
  let
mueller@6473
    44
  fun tn (Type(s,_)) = s |
mueller@6473
    45
  tn _ = error "cannot master type variables in if term";
mueller@6473
    46
  val s = tn(body_type T);
mueller@6473
    47
  in
mueller@6473
    48
  if (s="bool") then [] else [b,a1,a2]
mueller@6473
    49
  end |
mueller@6473
    50
  contains_if (a $ b) = if ((contains_if b)=[]) then (contains_if a)
mueller@6473
    51
		        else (contains_if b) |
mueller@6473
    52
  contains_if _ = [];
mueller@6473
    53
mueller@6473
    54
  fun find_replace_term (Abs(a,T,t)) = find_replace_term (snd(variant_abs(a,T,t))) |
mueller@6473
    55
  find_replace_term (a $ b) = if ((contains_if (a $ b))=[]) then
mueller@6473
    56
  (if (snd(find_replace_term b)=[]) then (find_replace_term a) else (find_replace_term b))
mueller@6473
    57
  else (a $ b,contains_if(a $ b))|
mueller@6473
    58
  find_replace_term t = (t,[]);
mueller@6473
    59
mueller@6473
    60
  fun if_substi (Abs(a,T,t)) trm = Abs(a,T,t) |
paulson@16587
    61
  if_substi (Const("HOL.If",T) $ b $ a1 $ a2) t = t |
mueller@6473
    62
  if_substi (a $ b) t = if ((contains_if b)=[]) then ((if_substi a t)$b)
mueller@6473
    63
		        else (a$(if_substi b t)) |
mueller@6473
    64
  if_substi t v = t;
mueller@6473
    65
mueller@6473
    66
  fun deliver_term (t,[]) = [] |
mueller@6473
    67
  deliver_term (t,[b,a1,a2]) =
mueller@6473
    68
  [
mueller@6473
    69
  Const("Trueprop",Type("fun",[Type("bool",[]),Type("prop",[])])) $
mueller@6473
    70
  (
mueller@6473
    71
Const("op =",Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])]))
mueller@6473
    72
  $ t $
mueller@6473
    73
  (
mueller@6473
    74
Const("op &",Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])]))
mueller@6473
    75
  $
mueller@6473
    76
  (
mueller@6473
    77
Const("op -->",Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])]))
mueller@6473
    78
  $ b $ (if_substi t a1))
mueller@6473
    79
  $
mueller@6473
    80
  (
mueller@6473
    81
Const("op -->",Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])]))
mueller@6473
    82
  $ (Const("Not",Type("fun",[Type("bool",[]),Type("bool",[])])) $ b) $ (if_substi t a2))
mueller@6473
    83
  ))] |
mueller@6473
    84
  deliver_term _ =
mueller@6473
    85
  error "tactic failed due to occurence of malformed if-term" (* shouldnt occur *);
mueller@6473
    86
mueller@6473
    87
  fun search_if (*((Const("==",_)) $ _ $*) (a) = deliver_term(find_replace_term a);
mueller@6473
    88
mueller@6473
    89
  fun search_ifs [] = [] |
mueller@6473
    90
  search_ifs (a::r) =
mueller@6473
    91
  let
mueller@6473
    92
  val i = search_if a
mueller@6473
    93
  in
mueller@6473
    94
  if (i=[]) then (search_ifs r) else i
mueller@6473
    95
  end;
mueller@6473
    96
in
mueller@6473
    97
mueller@6473
    98
fun if_full_simp_tac sset i state =
mueller@6473
    99
let val sign = #sign (rep_thm state);
skalberg@15570
   100
        val (subgoal::_) = Library.drop(i-1,prems_of state);
mueller@6473
   101
        val prems = Logic.strip_imp_prems subgoal;
mueller@6473
   102
	val concl = Logic.strip_imp_concl subgoal;
mueller@6473
   103
	val prems = prems @ [concl];
mueller@6473
   104
        val itrm = search_ifs prems;
mueller@6473
   105
in
wenzelm@16152
   106
if (itrm = []) then no_tac state else
mueller@6473
   107
(
mueller@6473
   108
let
mueller@6473
   109
val trm = hd(itrm)
mueller@6473
   110
in
mueller@6473
   111
(
mueller@6473
   112
push_proof();
mueller@6473
   113
goalw_cterm [] (cterm_of sign trm);
mueller@6473
   114
by (simp_tac (simpset()) 1);
mueller@6473
   115
        let
mueller@6473
   116
        val if_tmp_result = result()
mueller@6473
   117
        in
mueller@6473
   118
        (
mueller@6473
   119
        pop_proof();
mueller@6473
   120
        CHANGED(full_simp_tac (sset addsimps [if_tmp_result]) i) state)
mueller@6473
   121
        end
mueller@6473
   122
)
mueller@6473
   123
end)
mueller@6473
   124
end;
mueller@6473
   125
mueller@6473
   126
end;
mueller@6473
   127
mueller@6473
   128
(********************************************************)
mueller@6473
   129
(* All following stuff serves for defining mk_mc_oracle *)
mueller@6473
   130
(********************************************************)
mueller@6473
   131
mueller@6473
   132
(***************************************)
mueller@6473
   133
(* SECTION 0: some auxiliary functions *)
mueller@6473
   134
mueller@6473
   135
fun list_contains_key [] _ = false |
mueller@6473
   136
list_contains_key ((a,l)::r) t = if (a=t) then true else (list_contains_key r t);
mueller@6473
   137
mueller@6473
   138
fun search_in_keylist [] _ = [] |
mueller@6473
   139
search_in_keylist ((a,l)::r) t = if (a=t) then l else (search_in_keylist r t);
mueller@6473
   140
mueller@6473
   141
(* delivers the part of a qualified type/const-name after the last dot *)
mueller@6473
   142
fun post_last_dot str =
mueller@6473
   143
let
mueller@6473
   144
fun fl [] = [] |
mueller@6473
   145
fl (a::r) = if (a=".") then [] else (a::(fl r));
mueller@6473
   146
in
mueller@6473
   147
implode(rev(fl(rev(explode str))))
mueller@6473
   148
end;
mueller@6473
   149
mueller@6473
   150
(* OUTPUT - relevant *)
mueller@6473
   151
(* converts type to string by a mucke-suitable convention *)
mueller@6473
   152
fun type_to_string_OUTPUT (Type(a,[])) = post_last_dot a |
mueller@6473
   153
type_to_string_OUTPUT (Type("*",[a,b])) =
mueller@6473
   154
         "P_" ^ (type_to_string_OUTPUT a) ^ "_AI_" ^ (type_to_string_OUTPUT b) ^ "_R" |
mueller@6473
   155
type_to_string_OUTPUT (Type(a,l)) =
mueller@6473
   156
let
mueller@6473
   157
fun ts_to_string [] = "" |
mueller@6473
   158
ts_to_string (a::[]) = type_to_string_OUTPUT a |
mueller@6473
   159
ts_to_string (a::l) = (type_to_string_OUTPUT a) ^ "_I_" ^ (ts_to_string l);
mueller@6473
   160
in
mueller@6473
   161
(post_last_dot a) ^ "_A_" ^ (ts_to_string l) ^ "_C"
mueller@6473
   162
end |
mueller@6473
   163
type_to_string_OUTPUT _ =
mueller@6473
   164
error "unexpected type variable in type_to_string";
mueller@6473
   165
mueller@6473
   166
(* delivers type of a term *)
mueller@6473
   167
fun type_of_term (Const(_,t)) = t |
mueller@6473
   168
type_of_term (Free(_,t)) = t |
mueller@6473
   169
type_of_term (Var(_,t)) = t |
mueller@6473
   170
type_of_term (Abs(x,t,trm)) = Type("fun",[t,type_of_term(snd(variant_abs(x,t,trm)))]) |
mueller@6473
   171
type_of_term (a $ b) =
mueller@6473
   172
let
mueller@6473
   173
 fun accept_fun_type (Type("fun",[x,y])) = (x,y) |
mueller@6473
   174
 accept_fun_type _ =
mueller@6473
   175
 error "no function type returned, where it was expected (in type_of_term)";
mueller@6473
   176
 val (x,y) = accept_fun_type(type_of_term a)
mueller@6473
   177
in
mueller@6473
   178
y
mueller@6473
   179
end |
mueller@6473
   180
type_of_term _ = 
mueller@6473
   181
error "unexpected bound variable when calculating type of a term (in type_of_term)";
mueller@6473
   182
mueller@6473
   183
(* makes list [a1..an] and ty to type an -> .. -> a1 -> ty *)
mueller@6473
   184
fun fun_type_of [] ty = ty |
mueller@6473
   185
fun_type_of (a::r) ty = fun_type_of r (Type("fun",[a,ty]));
mueller@6473
   186
mueller@6473
   187
(* creates a constructor term from constructor and its argument terms *)
mueller@6473
   188
fun con_term_of t [] = t |
mueller@6473
   189
con_term_of t (a::r) = con_term_of (t $ a) r;
mueller@6473
   190
mueller@6473
   191
(* creates list of constructor terms *)
mueller@6473
   192
fun con_term_list_of trm [] = [] |
mueller@6473
   193
con_term_list_of trm (a::r) = (con_term_of trm a)::(con_term_list_of trm r);
mueller@6473
   194
mueller@6473
   195
(* list multiplication *)
mueller@6473
   196
fun multiply_element a [] = [] |
mueller@6473
   197
multiply_element a (l::r) = (a::l)::(multiply_element a r);
mueller@6473
   198
fun multiply_list [] l = [] |
mueller@6473
   199
multiply_list (a::r) l = (multiply_element a l)@(multiply_list r l);
mueller@6473
   200
mueller@6473
   201
(* To a list of types, delivers all lists of proper argument terms; tl has to *)
mueller@6473
   202
(* be a preprocessed type list with element type: (type,[(string,[type])])    *)
mueller@6473
   203
fun arglist_of sg tl [] = [[]] |
mueller@6473
   204
arglist_of sg tl (a::r) =
mueller@6473
   205
let
mueller@6473
   206
fun ispair (Type("*",x::y::[])) = (true,(x,y)) |
mueller@6473
   207
ispair x = (false,(x,x));
mueller@6473
   208
val erg =
mueller@6473
   209
(if (fst(ispair a))
mueller@6473
   210
 then (let
mueller@6473
   211
        val (x,y) = snd(ispair a)
mueller@6473
   212
       in
mueller@6473
   213
        con_term_list_of (Const("pair",Type("fun",[x,Type("fun",[y,a])])))
mueller@6473
   214
			 (arglist_of sg tl [x,y])
mueller@6473
   215
       end)
mueller@6473
   216
 else
mueller@6473
   217
 (let
mueller@6473
   218
  fun deliver_erg sg tl _ [] = [] |
mueller@6473
   219
  deliver_erg sg tl typ ((c,tyl)::r) = let
mueller@6473
   220
                        val ft = fun_type_of (rev tyl) typ;
mueller@6473
   221
                        val trm = #t(rep_cterm(read_cterm sg (c,ft)));
mueller@6473
   222
                        in
mueller@6473
   223
                        (con_term_list_of trm (arglist_of sg tl tyl))
mueller@6473
   224
			@(deliver_erg sg tl typ r)
mueller@6473
   225
                        end;
mueller@6473
   226
  val cl = search_in_keylist tl a;
mueller@6473
   227
  in
mueller@6473
   228
  deliver_erg sg tl a cl
mueller@6473
   229
  end))
mueller@6473
   230
in
mueller@6473
   231
multiply_list erg (arglist_of sg tl r)
mueller@6473
   232
end;
mueller@6473
   233
mueller@6473
   234
(*******************************************************************)
mueller@6473
   235
(* SECTION 1: Robert Sandner's source was improved and extended by *)
mueller@6473
   236
(* generation of function declarations                             *)
mueller@6473
   237
mueller@6473
   238
fun dest_Abs (Abs s_T_t) = s_T_t
mueller@6473
   239
  | dest_Abs t = raise TERM("dest_Abs", [t]);
mueller@6473
   240
mueller@6473
   241
(*
mueller@6473
   242
fun force_Abs (Abs s_T_t) = Abs s_T_t
mueller@6473
   243
  | force_Abs t = Abs("x", hd(fst(strip_type (type_of t))),
mueller@6473
   244
		      (incr_boundvars 1 t) $ (Bound 0));
mueller@6473
   245
mueller@6473
   246
fun etaexp_dest_Abs t = dest_Abs (force_Abs t);
mueller@6473
   247
*)
mueller@6473
   248
mueller@6473
   249
(* replace Vars bei Frees, freeze_thaw shares code of tactic/freeze_thaw
mueller@6473
   250
   and thm.instantiate *)
mueller@6473
   251
fun freeze_thaw t =
mueller@6473
   252
  let val used = add_term_names (t, [])
mueller@6473
   253
          and vars = term_vars t;
mueller@6473
   254
      fun newName (Var(ix,_), (pairs,used)) = 
mueller@6473
   255
          let val v = variant used (string_of_indexname ix)
mueller@6473
   256
          in  ((ix,v)::pairs, v::used)  end;
skalberg@15574
   257
      val (alist, _) = foldr newName ([], used) vars;
mueller@6473
   258
      fun mk_inst (Var(v,T)) = 
mueller@6473
   259
          (Var(v,T),
skalberg@15570
   260
           Free(valOf (assoc(alist,v)), T));
mueller@6473
   261
      val insts = map mk_inst vars;
mueller@6473
   262
  in subst_atomic insts t end;
mueller@6473
   263
mueller@6473
   264
fun make_fun_type (a::b::l) = Type("fun",a::(make_fun_type (b::l))::[]) 
mueller@6473
   265
  | make_fun_type (a::l) = a;
mueller@6473
   266
mueller@6473
   267
fun make_decl muckeType id isaType =
mueller@6473
   268
  let val constMuckeType = Const(muckeType,isaType);
mueller@6473
   269
      val constId = Const(id,isaType);
mueller@6473
   270
      val constDecl = Const("_decl", make_fun_type [isaType,isaType,isaType]); 
mueller@6473
   271
  in (constDecl $ constMuckeType) $ constId end;
mueller@6473
   272
mueller@6473
   273
fun make_MuTerm muDeclTerm ParamDeclTerm muTerm isaType =
mueller@6473
   274
  let val constMu = Const("_mu",
mueller@6473
   275
			  make_fun_type [isaType,isaType,isaType,isaType]);
mueller@6473
   276
      val t1 = constMu $ muDeclTerm;
mueller@6473
   277
      val t2 = t1 $ ParamDeclTerm;
mueller@6473
   278
      val t3 = t2 $  muTerm
mueller@6473
   279
  in t3 end;
mueller@6473
   280
mueller@6473
   281
fun make_MuDecl muDeclTerm ParamDeclTerm isaType =
mueller@6473
   282
  let val constMu = Const("_mudec",
mueller@6473
   283
                          make_fun_type [isaType,isaType,isaType]);
mueller@6473
   284
      val t1 = constMu $ muDeclTerm;
mueller@6473
   285
      val t2 = t1 $ ParamDeclTerm
mueller@6473
   286
  in t2 end;
mueller@6473
   287
mueller@6473
   288
fun make_NuTerm muDeclTerm ParamDeclTerm muTerm isaType =
mueller@6473
   289
  let val constMu = Const("_nu",
mueller@6473
   290
                          make_fun_type [isaType,isaType,isaType,isaType]);
mueller@6473
   291
      val t1 = constMu $ muDeclTerm;
mueller@6473
   292
      val t2 = t1 $ ParamDeclTerm;
mueller@6473
   293
      val t3 = t2 $  muTerm
mueller@6473
   294
  in t3 end;
mueller@6473
   295
mueller@6473
   296
fun make_NuDecl muDeclTerm ParamDeclTerm isaType =
mueller@6473
   297
  let val constMu = Const("_nudec",
mueller@6473
   298
                          make_fun_type [isaType,isaType,isaType]);
mueller@6473
   299
      val t1 = constMu $ muDeclTerm;
mueller@6473
   300
      val t2 = t1 $ ParamDeclTerm
mueller@6473
   301
  in t2 end;
mueller@6473
   302
mueller@6473
   303
fun is_mudef (( Const("==",_) $ t1) $ ((Const("MuCalculus.mu",_)) $ t2)) = true
mueller@6473
   304
  | is_mudef _ = false;
mueller@6473
   305
mueller@6473
   306
fun is_nudef (( Const("==",_) $ t1) $ ((Const("MuCalculus.nu",_)) $ t2)) = true
mueller@6473
   307
  | is_nudef _ = false;
mueller@6473
   308
mueller@6473
   309
fun make_decls sign Dtype (Const(str,tp)::n::Clist) = 
mueller@6473
   310
    let val const_decls = Const("_decls",make_fun_type [Dtype,Dtype,Dtype]);
mueller@6473
   311
        val decl = make_decl (type_to_string_OUTPUT tp) str Dtype;
mueller@6473
   312
    in
mueller@6473
   313
    ((const_decls $ decl) $ (make_decls sign Dtype (n::Clist)))
mueller@6473
   314
    end
mueller@6473
   315
  | make_decls sign Dtype [Const(str,tp)] = 
mueller@6473
   316
      make_decl (type_to_string_OUTPUT tp) str Dtype;
mueller@6473
   317
mueller@6473
   318
mueller@6473
   319
(* make_mu_def transforms an Isabelle Mu-Definition into Mucke format
mueller@6473
   320
   Takes equation of the form f = Mu Q. % x. t *)
mueller@6473
   321
mueller@6473
   322
fun dest_atom (Const t) = dest_Const (Const t)
mueller@6473
   323
  | dest_atom (Free t)  = dest_Free (Free t);
mueller@6473
   324
mueller@6473
   325
fun get_decls sign Clist (Abs(s,tp,trm)) = 
mueller@6473
   326
    let val VarAbs = variant_abs(s,tp,trm);
mueller@6473
   327
    in get_decls sign (Const(fst VarAbs,tp)::Clist) (snd VarAbs)
mueller@6473
   328
    end
mueller@6473
   329
  | get_decls sign Clist ((Const("split",_)) $ trm) = get_decls sign Clist trm
mueller@6473
   330
  | get_decls sign Clist trm = (Clist,trm);
mueller@6473
   331
mueller@6473
   332
fun make_mu_def sign ((tt $ LHS) $ (ttt $ RHS)) =
mueller@6473
   333
  let 	val LHSStr = fst (dest_atom LHS);
mueller@6473
   334
	val MuType = Type("bool",[]); (* always ResType of mu, also serves
mueller@6473
   335
					 as dummy type *)
mueller@6473
   336
	val (_,_,PAbs) = dest_Abs (RHS); (* RHS is %Q. ... *)
mueller@6473
   337
  	val (PCon_LHS,MMuTerm) = get_decls sign [] (subst_bound (LHS,PAbs));
mueller@6473
   338
	val PConsts = rev PCon_LHS;
mueller@6473
   339
	val muDeclTerm = make_decl "bool" LHSStr MuType;
mueller@6473
   340
	val PDeclsTerm = make_decls sign MuType PConsts;
mueller@6473
   341
	val MuDefTerm = make_MuTerm muDeclTerm PDeclsTerm MMuTerm MuType;		
mueller@6473
   342
  in MuDefTerm end;
mueller@6473
   343
mueller@6473
   344
fun make_mu_decl sign ((tt $ LHS) $ (ttt $ RHS)) =
mueller@6473
   345
  let   val LHSStr = fst (dest_atom LHS);
mueller@6473
   346
        val MuType = Type("bool",[]); (* always ResType of mu, also serves
mueller@6473
   347
                                         as dummy type *)
mueller@6473
   348
        val (_,_,PAbs) = dest_Abs (RHS); (* RHS is %Q. ... *)
mueller@6473
   349
        val (PCon_LHS,MMuTerm) = get_decls sign [] (subst_bound (LHS,PAbs));
mueller@6473
   350
        val PConsts = rev PCon_LHS;
mueller@6473
   351
        val muDeclTerm = make_decl "bool" LHSStr MuType;
mueller@6473
   352
        val PDeclsTerm = make_decls sign MuType PConsts;
mueller@6473
   353
        val MuDeclTerm = make_MuDecl muDeclTerm PDeclsTerm MuType;
mueller@6473
   354
  in MuDeclTerm end;
mueller@6473
   355
mueller@6473
   356
fun make_nu_def sign ((tt $ LHS) $ (ttt $ RHS)) =
mueller@6473
   357
  let   val LHSStr = fst (dest_atom LHS);
mueller@6473
   358
        val MuType = Type("bool",[]); (* always ResType of mu, also serves
mueller@6473
   359
                                         as dummy type *)
mueller@6473
   360
        val (_,_,PAbs) = dest_Abs (RHS); (* RHS is %Q. ... *)
mueller@6473
   361
        val (PCon_LHS,MMuTerm) = get_decls sign [] (subst_bound (LHS,PAbs));
mueller@6473
   362
        val PConsts = rev PCon_LHS;
mueller@6473
   363
        val muDeclTerm = make_decl "bool" LHSStr MuType;
mueller@6473
   364
        val PDeclsTerm = make_decls sign MuType PConsts;
mueller@6473
   365
        val NuDefTerm = make_NuTerm muDeclTerm PDeclsTerm MMuTerm MuType;
mueller@6473
   366
  in NuDefTerm end;
mueller@6473
   367
mueller@6473
   368
fun make_nu_decl sign ((tt $ LHS) $ (ttt $ RHS)) =
mueller@6473
   369
  let   val LHSStr = fst (dest_atom LHS);
mueller@6473
   370
        val MuType = Type("bool",[]); (* always ResType of mu, also serves
mueller@6473
   371
                                         as dummy type *)
mueller@6473
   372
        val (_,_,PAbs) = dest_Abs (RHS); (* RHS is %Q. ... *)
mueller@6473
   373
        val (PCon_LHS,MMuTerm) = get_decls sign [] (subst_bound (LHS,PAbs));
mueller@6473
   374
        val PConsts = rev PCon_LHS; 
mueller@6473
   375
        val muDeclTerm = make_decl "bool" LHSStr MuType;
mueller@6473
   376
        val PDeclsTerm = make_decls sign MuType PConsts; 
mueller@6473
   377
        val NuDeclTerm = make_NuDecl muDeclTerm PDeclsTerm MuType;
mueller@6473
   378
  in NuDeclTerm end;
mueller@6473
   379
mueller@6473
   380
fun make_FunMuckeTerm FunDeclTerm ParamDeclTerm Term isaType =
mueller@6473
   381
  let 	val constFun = Const("_fun",
mueller@6473
   382
			    make_fun_type [isaType,isaType,isaType,isaType]);
mueller@6473
   383
      	val t1 = constFun $ FunDeclTerm;
mueller@6473
   384
      	val t2 = t1 $ ParamDeclTerm;
mueller@6473
   385
      	val t3 = t2 $  Term
mueller@6473
   386
  in t3 end;
mueller@6473
   387
mueller@6473
   388
fun make_FunMuckeDecl FunDeclTerm ParamDeclTerm isaType =
mueller@6473
   389
  let   val constFun = Const("_dec",
mueller@6473
   390
                            make_fun_type [isaType,isaType,isaType]);
mueller@6473
   391
      val t1 = constFun $ FunDeclTerm;
mueller@6473
   392
      val t2 = t1 $ ParamDeclTerm
mueller@6473
   393
  in t2 end;
mueller@6473
   394
mueller@6473
   395
fun is_fundef (( Const("==",_) $ _) $ ((Const("split",_)) $ _)) = true |
mueller@6473
   396
is_fundef (( Const("==",_) $ _) $ Abs(x_T_t)) = true 
mueller@6473
   397
| is_fundef _ = false; 
mueller@6473
   398
mueller@6473
   399
fun make_mucke_fun_def sign ((_ $ LHS) $ RHS) =
mueller@6473
   400
  let 	(* fun dest_atom (Const t) = dest_Const (Const t)
mueller@6473
   401
          | dest_atom (Free t)  = dest_Free (Free t); *)
mueller@6473
   402
	val LHSStr = fst (dest_atom LHS);
mueller@6473
   403
	val LHSResType = body_type(snd(dest_atom LHS));
mueller@6473
   404
	val LHSResTypeStr = type_to_string_OUTPUT LHSResType;
mueller@6473
   405
(*	val (_,AbsType,RawTerm) = dest_Abs(RHS);
mueller@6473
   406
*)	val (Consts_LHS_rev,Free_RHS) = get_decls sign [] RHS;
mueller@6473
   407
	val Consts_LHS = rev Consts_LHS_rev;
mueller@6473
   408
	val PDeclsTerm = make_decls sign LHSResType Consts_LHS; 
mueller@6473
   409
		(* Boolean functions only, list necessary in general *)
mueller@6473
   410
	val DeclTerm = make_decl LHSResTypeStr LHSStr LHSResType;
mueller@6473
   411
	val MuckeDefTerm = make_FunMuckeTerm DeclTerm PDeclsTerm Free_RHS
mueller@6473
   412
					 LHSResType;	
mueller@6473
   413
  in MuckeDefTerm end;
mueller@6473
   414
mueller@6473
   415
fun make_mucke_fun_decl sign ((_ $ LHS) $ RHS) =
mueller@6473
   416
  let   (* fun dest_atom (Const t) = dest_Const (Const t)
mueller@6473
   417
          | dest_atom (Free t)  = dest_Free (Free t); *)
mueller@6473
   418
        val LHSStr = fst (dest_atom LHS);
mueller@6473
   419
	val LHSResType = body_type(snd(dest_atom LHS));
mueller@6473
   420
        val LHSResTypeStr = type_to_string_OUTPUT LHSResType;
mueller@6473
   421
(*      val (_,AbsType,RawTerm) = dest_Abs(RHS);
mueller@6473
   422
*)      val (Consts_LHS_rev,Free_RHS) = get_decls sign [] RHS;
mueller@6473
   423
        val Consts_LHS = rev Consts_LHS_rev;
mueller@6473
   424
        val PDeclsTerm = make_decls sign LHSResType Consts_LHS;
mueller@6473
   425
                (* Boolean functions only, list necessary in general *)
mueller@6473
   426
        val DeclTerm = make_decl LHSResTypeStr LHSStr LHSResType;
mueller@6473
   427
	val MuckeDeclTerm = make_FunMuckeDecl DeclTerm PDeclsTerm LHSResType;
mueller@6473
   428
in MuckeDeclTerm end;
mueller@6473
   429
mueller@6473
   430
fun elim_quantifications sign ((Const("Ex",_)) $ Abs (str,tp,t)) =
mueller@6473
   431
    (let val ExConst = Const("_Ex",make_fun_type [tp,tp,tp,tp]);
mueller@6473
   432
     	 val TypeConst = Const (type_to_string_OUTPUT tp,tp);
mueller@6473
   433
	 val VarAbs = variant_abs(str,tp,t);
mueller@6473
   434
	 val BoundConst = Const(fst VarAbs,tp);
mueller@6473
   435
	 val t1 = ExConst $ TypeConst;
mueller@6473
   436
	 val t2 = t1 $ BoundConst;
mueller@6473
   437
 	 val t3 = elim_quantifications sign (snd VarAbs)
mueller@6473
   438
     in t2 $ t3 end)
mueller@6473
   439
  |  elim_quantifications sign ((Const("All",_)) $ Abs (str,tp,t)) =
mueller@6473
   440
    (let val AllConst = Const("_All",make_fun_type [tp,tp,tp,tp]);
mueller@6473
   441
    	 val TypeConst = Const (type_to_string_OUTPUT tp,tp);
mueller@6473
   442
	 val VarAbs = variant_abs(str,tp,t);
mueller@6473
   443
	 val BoundConst = Const(fst VarAbs,tp);
mueller@6473
   444
	 val t1 = AllConst $ TypeConst;
mueller@6473
   445
	 val t2 = t1 $ BoundConst;
mueller@6473
   446
	 val t3 = elim_quantifications sign (snd VarAbs)
mueller@6473
   447
     in t2 $ t3 end)
mueller@6473
   448
  | elim_quantifications sign (t1 $ t2) = 
mueller@6473
   449
   	(elim_quantifications sign t1) $ (elim_quantifications sign t2)
mueller@6473
   450
  | elim_quantifications sign (Abs(_,_,t)) = elim_quantifications sign t
mueller@6473
   451
  | elim_quantifications sign t = t;
mueller@6473
   452
fun elim_quant_in_list sign [] = []
mueller@6473
   453
  | elim_quant_in_list sign (trm::list) = 
mueller@6473
   454
			(elim_quantifications sign trm)::(elim_quant_in_list sign list);
mueller@6473
   455
mueller@6473
   456
fun dummy true = writeln "True\n" |
mueller@6473
   457
    dummy false = writeln "Fals\n";
mueller@6473
   458
mueller@6473
   459
fun transform_definitions sign [] = []
mueller@6473
   460
  | transform_definitions sign (trm::list) = 
mueller@6473
   461
      if is_mudef trm 
mueller@6473
   462
      then (make_mu_def sign trm)::(transform_definitions sign list)
mueller@6473
   463
      else 
mueller@6473
   464
	if is_nudef trm
mueller@6473
   465
	 then (make_nu_def sign trm)::(transform_definitions sign list)
mueller@6473
   466
     	 else 
mueller@6473
   467
	   if is_fundef trm
mueller@6473
   468
 	   then (make_mucke_fun_def sign trm)::(transform_definitions sign list)
mueller@6473
   469
		     else trm::(transform_definitions sign list);
mueller@6473
   470
mueller@6473
   471
fun terms_to_decls sign [] = []
mueller@6473
   472
 | terms_to_decls sign (trm::list) =
mueller@6473
   473
      if is_mudef trm
mueller@6473
   474
      then (make_mu_decl sign trm)::(terms_to_decls sign list)
mueller@6473
   475
      else
mueller@6473
   476
        if is_nudef trm
mueller@6473
   477
         then (make_nu_decl sign trm)::(terms_to_decls sign list)
mueller@6473
   478
         else
mueller@6473
   479
           if is_fundef trm
mueller@6473
   480
           then (make_mucke_fun_decl sign trm)::(terms_to_decls sign list)
mueller@6473
   481
                     else (transform_definitions sign list);
mueller@6473
   482
mueller@6473
   483
fun transform_terms sign list = 
mueller@6473
   484
let val DefsOk = transform_definitions sign list;
mueller@6473
   485
in elim_quant_in_list sign DefsOk
mueller@6473
   486
end;
mueller@6473
   487
mueller@6473
   488
fun string_of_terms sign terms =
mueller@6473
   489
let fun make_string sign [] = "" |
wenzelm@14818
   490
 	make_string sign (trm::list) =
wenzelm@14980
   491
           Sign.string_of_term sign trm ^ "\n" ^ make_string sign list
mueller@6473
   492
in
mueller@6473
   493
(setmp print_mode ["Mucke"] (make_string sign) terms)
mueller@6473
   494
end;
mueller@6473
   495
wenzelm@6491
   496
fun callmc s =
wenzelm@6491
   497
  let
wenzelm@7295
   498
    val mucke_home = getenv "MUCKE_HOME";
wenzelm@7295
   499
    val mucke =
wenzelm@7295
   500
      if mucke_home = "" then error "Environment variable MUCKE_HOME not set"
wenzelm@7295
   501
      else mucke_home ^ "/mucke";
wenzelm@7295
   502
    val mucke_input_file = File.tmp_path (Path.basic "tmp.mu");
wenzelm@7295
   503
    val _ = File.write mucke_input_file s;
wenzelm@16258
   504
    val result = execute (mucke ^ " -nb -res " ^ File.shell_path mucke_input_file);
wenzelm@7295
   505
  in
wenzelm@7295
   506
    if not (!trace_mc) then (File.rm mucke_input_file) else (); 
wenzelm@7295
   507
    result
wenzelm@7295
   508
  end;
mueller@6473
   509
mueller@6473
   510
(* extract_result looks for true value before *) 
mueller@6473
   511
(* finishing line "===..." of mucke output    *)
wenzelm@7295
   512
(* ------------------------------------------ *)
wenzelm@7295
   513
(* Be Careful:                                *)
wenzelm@7295
   514
(* If the mucke version changes, some changes *)
wenzelm@7295
   515
(* have also to be made here:                 *)
wenzelm@7295
   516
(* In extract_result, the value               *)
wenzelm@7295
   517
(* answer_with_info_lines checks the output   *)
wenzelm@7295
   518
(* of the muche version, where the output     *)
wenzelm@7295
   519
(* finishes with information about memory and *)
wenzelm@7295
   520
(* time (segregated from the "true" value by  *)
wenzelm@7295
   521
(* a line of equality signs).                 *)
wenzelm@7295
   522
(* For older versions, where this line does   *)
wenzelm@7295
   523
(* exist, value general_answer checks whether *)
wenzelm@7295
   524
(* "true" stand at the end of the output.     *)
mueller@6473
   525
local
mueller@6473
   526
wenzelm@7295
   527
infix is_prefix_of contains at_post string_contains string_at_post;
mueller@6473
   528
mueller@6473
   529
  val is_blank : string -> bool =
mueller@6473
   530
      fn " " => true | "\t" => true | "\n" => true | "\^L" => true 
mueller@6473
   531
       | "\160" => true | _ => false;
mueller@6473
   532
mueller@6473
   533
  fun delete_blanks [] = []
mueller@6473
   534
    | delete_blanks (":"::xs) = delete_blanks xs
mueller@6473
   535
    | delete_blanks (x::xs) = 
mueller@6473
   536
        if (is_blank x) then (delete_blanks xs)
mueller@6473
   537
	       	        else x::(delete_blanks xs);
mueller@6473
   538
  
mueller@6473
   539
  fun delete_blanks_string s = implode(delete_blanks (explode s));
mueller@6473
   540
mueller@6473
   541
  fun [] is_prefix_of s = true
mueller@6473
   542
    | (p::ps) is_prefix_of  [] = false
mueller@6473
   543
    | (p::ps) is_prefix_of (x::xs) = (p = x) andalso (ps is_prefix_of xs);
mueller@6473
   544
mueller@6473
   545
  fun [] contains [] = true
mueller@6473
   546
    | [] contains s = false
mueller@6473
   547
    | (x::xs) contains s = (s is_prefix_of (x::xs)) orelse (xs contains s);
mueller@6473
   548
wenzelm@7295
   549
  fun [] at_post [] = true
wenzelm@7295
   550
    | [] at_post s = false
wenzelm@7295
   551
    | (x::xs) at_post s = (s = (x::xs)) orelse (xs at_post s);
wenzelm@7295
   552
 
mueller@6473
   553
  fun s string_contains s1 = 
mueller@6473
   554
      (explode s) contains (explode s1);
wenzelm@7295
   555
  fun s string_at_post s1 =
wenzelm@7295
   556
      (explode s) at_post (explode s1);
mueller@6473
   557
mueller@6473
   558
in 
mueller@6473
   559
mueller@6473
   560
fun extract_result goal answer =
mueller@6473
   561
  let 
mueller@6473
   562
    val search_text_true = "istrue===";
mueller@6473
   563
    val short_answer = delete_blanks_string answer;
wenzelm@7295
   564
    val answer_with_info_lines = short_answer string_contains search_text_true;
wenzelm@7305
   565
    (* val general_answer = short_answer string_at_post "true" *) 
mueller@6473
   566
  in
wenzelm@7305
   567
    (answer_with_info_lines) (* orelse (general_answer) *)
mueller@6473
   568
  end;
mueller@6473
   569
mueller@6473
   570
end; 
mueller@6473
   571
mueller@6473
   572
(**************************************************************)
mueller@6473
   573
(* SECTION 2: rewrites case-constructs over complex datatypes *)
mueller@6473
   574
local
mueller@6473
   575
mueller@6473
   576
(* check_case checks, whether a term is of the form a $ "(case x of ...)", *)
mueller@6473
   577
(* where x is of complex datatype; the second argument of the result is    *)
mueller@6473
   578
(* the number of constructors of the type of x                             *) 
mueller@6473
   579
fun check_case sg tl (a $ b) =
mueller@6473
   580
let
mueller@6473
   581
 (* tl_contains_complex returns true in the 1st argument when argument type is *)
mueller@6473
   582
 (* complex; the 2nd argument is the number of constructors                    *)
mueller@6473
   583
 fun tl_contains_complex [] _ = (false,0) |
mueller@6473
   584
 tl_contains_complex ((a,l)::r) t =
mueller@6473
   585
 let
mueller@6473
   586
  fun check_complex [] p = p |
mueller@6473
   587
  check_complex ((a,[])::r) (t,i) = check_complex r (t,i+1) |
mueller@6473
   588
  check_complex ((a,_)::r) (t,i) = check_complex r (true,i+1);
mueller@6473
   589
 in
mueller@6473
   590
	if (a=t) then (check_complex l (false,0)) else (tl_contains_complex r t)
mueller@6473
   591
 end;
mueller@6473
   592
 fun check_head_for_case sg (Const(s,_)) st 0 = 
mueller@6473
   593
	if (post_last_dot(s) = (st ^ "_case")) then true else false |
mueller@6473
   594
 check_head_for_case sg (a $ (Const(s,_))) st 0 = 
mueller@6473
   595
	if (post_last_dot(s) = (st ^ "_case")) then true else false |
mueller@6473
   596
 check_head_for_case _ _ _ 0 = false |
mueller@6473
   597
 check_head_for_case sg (a $ b) st n = check_head_for_case sg a st (n-1) |
mueller@6473
   598
 check_head_for_case _ _ _ _ = false;
mueller@6473
   599
 fun qtn (Type(a,_)) = a | 
mueller@6473
   600
 qtn _ = error "unexpected type variable in check_case";
mueller@6473
   601
 val t = type_of_term b;
mueller@6473
   602
 val (bv,n) = tl_contains_complex tl t
mueller@6473
   603
 val st = post_last_dot(qtn t); 
mueller@6473
   604
in
mueller@6473
   605
 if (bv) then ((check_head_for_case sg a st n),n) else (false,n) 
mueller@6473
   606
end |
mueller@6473
   607
check_case sg tl trm = (false,0);
mueller@6473
   608
mueller@6473
   609
(* enrich_case_with_terms enriches a case term with additional *)
mueller@6473
   610
(* conditions according to the context of the case replacement *)
mueller@6473
   611
fun enrich_case_with_terms sg [] t = t |
mueller@6473
   612
enrich_case_with_terms sg [trm] (Abs(x,T,t)) =
mueller@6473
   613
let
mueller@6473
   614
 val v = variant_abs(x,T,t);
mueller@6473
   615
 val f = fst v;
mueller@6473
   616
 val s = snd v
mueller@6473
   617
in
mueller@6473
   618
(Const("Ex",Type("fun",[Type("fun",[T,Type("bool",[])]),Type("bool",[])])) $
mueller@6473
   619
(Abs(x,T,
mueller@6473
   620
abstract_over(Free(f,T),
mueller@6473
   621
Const("op &",Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])]))
mueller@6473
   622
$
mueller@6473
   623
(Const("op =",Type("fun",[T,Type("fun",[T,Type("bool",[])])])) $ (Free(f,T)) $ trm)
mueller@6473
   624
$ s))))
mueller@6473
   625
end |
mueller@6473
   626
enrich_case_with_terms sg (a::r) (Abs(x,T,t)) =
mueller@6473
   627
        enrich_case_with_terms sg [a] (Abs(x,T,(enrich_case_with_terms sg r t))) |
mueller@6473
   628
enrich_case_with_terms sg (t::r) trm =
mueller@6473
   629
let val ty = type_of_term t
mueller@6473
   630
in
mueller@6473
   631
(Const("Ex",Type("fun",[Type("fun",[ ty ,Type("bool",[])]),Type("bool",[])])) $
mueller@6473
   632
Abs("a", ty,
mueller@6473
   633
Const("op &",Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])]))
mueller@6473
   634
$
mueller@6473
   635
(Const("op =",Type("fun",[ ty ,Type("fun",[ ty ,Type("bool",[])])])) $ Bound(0) $ t)
mueller@6473
   636
$
mueller@6473
   637
enrich_case_with_terms sg r (trm $ (Bound(length(r))))))
mueller@6473
   638
end;
mueller@6473
   639
mueller@6473
   640
fun replace_termlist_with_constrs sg tl (a::l1) (c::l2) t = 
mueller@6473
   641
let
mueller@6473
   642
 fun heart_of_trm (Abs(x,T,t)) = heart_of_trm(snd(variant_abs(x,T,t))) |
mueller@6473
   643
 heart_of_trm t = t;
mueller@6473
   644
 fun replace_termlist_with_args _ _ trm _ [] _ ([],[]) = trm (* should never occur *) |
mueller@6473
   645
 replace_termlist_with_args sg _ trm _ [a] _ ([],[]) =
mueller@6473
   646
	if ((heart_of_trm trm)= Const("False",Type("bool",[]))) then trm else 
mueller@6473
   647
	(enrich_case_with_terms sg a trm) |
mueller@6473
   648
 replace_termlist_with_args sg tl trm con [] t (l1,l2) =
mueller@6473
   649
	(replace_termlist_with_constrs sg tl l1 l2 t) | 
mueller@6473
   650
 replace_termlist_with_args sg tl trm con (a::r) t (l1,l2) =
mueller@6473
   651
 let
mueller@6473
   652
  val tty = type_of_term t;
mueller@6473
   653
  val con_term = con_term_of con a;
mueller@6473
   654
 in
paulson@16587
   655
	(Const("HOL.If",Type("fun",[Type("bool",[]),
mueller@6473
   656
        Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])])])) $
mueller@6473
   657
	(Const("op =",Type("fun",[tty,Type("fun",[tty,Type("bool",[])])])) $
mueller@6473
   658
        t $ con_term) $
mueller@6473
   659
	(if ((heart_of_trm trm)= Const("False",Type("bool",[]))) then trm else 
mueller@6473
   660
	(enrich_case_with_terms sg a trm)) $
mueller@6473
   661
	(replace_termlist_with_args sg tl trm con r t (l1,l2)))
mueller@6473
   662
 end;
mueller@6473
   663
 val arglist = arglist_of sg tl (snd c);
mueller@6473
   664
 val tty = type_of_term t;
mueller@6473
   665
 val con_typ = fun_type_of (rev (snd c)) tty;
mueller@6473
   666
 val con = #t(rep_cterm(read_cterm sg (fst c,con_typ)));
mueller@6473
   667
in
mueller@6473
   668
 replace_termlist_with_args sg tl a con arglist t (l1,l2)
mueller@6473
   669
end |
mueller@6473
   670
replace_termlist_with_constrs _ _ _ _ _ = 
mueller@6473
   671
error "malformed arguments in replace_termlist_with_constrs" (* shouldnt occur *);
mueller@6473
   672
mueller@6473
   673
(* rc_in_termlist constructs a cascading if with the case terms in trm_list, *)
mueller@6473
   674
(* which were found in rc_in_term (see replace_case)                         *)
mueller@6473
   675
fun rc_in_termlist sg tl trm_list trm =  
mueller@6473
   676
let
mueller@6473
   677
 val ty = type_of_term trm;
mueller@6473
   678
 val constr_list = search_in_keylist tl ty;
mueller@6473
   679
in
mueller@6473
   680
	replace_termlist_with_constrs sg tl trm_list constr_list trm
mueller@6473
   681
end;  
mueller@6473
   682
mueller@6473
   683
in
mueller@6473
   684
mueller@6473
   685
(* replace_case replaces each case statement over a complex datatype by a cascading if; *)
mueller@6473
   686
(* it is normally called with a 0 in the 4th argument, it is positive, if in the course *)
mueller@6473
   687
(* of calculation, a "case" is discovered and then indicates the distance to that case  *)
mueller@6473
   688
fun replace_case sg tl (a $ b) 0 =
mueller@6473
   689
let
mueller@6473
   690
 (* rc_in_term changes the case statement over term x to a cascading if; the last *)
mueller@6473
   691
 (* indicates the distance to the "case"-constant                                 *)
mueller@6473
   692
 fun rc_in_term sg tl (a $ b) l x 0 =
mueller@6473
   693
	 (replace_case sg tl a 0) $ (rc_in_termlist sg tl l x) |  
mueller@6473
   694
 rc_in_term sg tl  _ l x 0 = rc_in_termlist sg tl l x |
mueller@6473
   695
 rc_in_term sg tl (a $ b) l x n = rc_in_term sg tl a (b::l) x (n-1) |
mueller@6473
   696
 rc_in_term sg _ trm _ _ n =
mueller@6473
   697
 error("malformed term for case-replacement: " ^ (Sign.string_of_term sg trm));
mueller@6473
   698
 val (bv,n) = check_case sg tl (a $ b);
mueller@6473
   699
in
mueller@6473
   700
 if (bv) then 
mueller@6473
   701
	(let
mueller@6473
   702
	val t = (replace_case sg tl a n) 
mueller@6473
   703
	in 
mueller@6473
   704
	rc_in_term sg tl t [] b n	
mueller@6473
   705
	end)
mueller@6473
   706
 else ((replace_case sg tl a 0) $ (replace_case sg tl b 0))
mueller@6473
   707
end |
mueller@6473
   708
replace_case sg tl (a $ b) 1 = a $ (replace_case sg tl b 0) |
mueller@6473
   709
replace_case sg tl (a $ b) n = (replace_case sg tl a (n-1)) $ (replace_case sg tl b 0) |
mueller@6473
   710
replace_case sg tl (Abs(x,T,t)) _ = 
mueller@6473
   711
let 
mueller@6473
   712
 val v = variant_abs(x,T,t);
mueller@6473
   713
 val f = fst v;
mueller@6473
   714
 val s = snd v
mueller@6473
   715
in
mueller@6473
   716
 Abs(x,T,abstract_over(Free(f,T),replace_case sg tl s 0))
mueller@6473
   717
end |
mueller@6473
   718
replace_case _ _ t _ = t;
mueller@6473
   719
mueller@6473
   720
end;
mueller@6473
   721
mueller@6473
   722
(*******************************************************************)
mueller@6473
   723
(* SECTION 3: replacing variables being part of a constructor term *)
mueller@6473
   724
mueller@6473
   725
(* transforming terms so that nowhere a variable is subterm of *)
mueller@6473
   726
(* a constructor term; the transformation uses cascading ifs   *)
mueller@6473
   727
fun remove_vars sg tl (Abs(x,ty,trm)) =
mueller@6473
   728
let
mueller@6473
   729
(* checks freeness of variable x in term *)
mueller@6473
   730
fun xFree x (a $ b) = if (xFree x a) then true else (xFree x b) |
mueller@6473
   731
xFree x (Abs(a,T,trm)) = xFree x trm |
mueller@6473
   732
xFree x (Free(y,_)) = if (x=y) then true else false |
mueller@6473
   733
xFree _ _ = false;
mueller@6473
   734
(* really substitues variable x by term c *)
mueller@6473
   735
fun real_subst sg tl x c (a$b) = (real_subst sg tl x c a) $ (real_subst sg tl x c b) |
mueller@6473
   736
real_subst sg tl x c (Abs(y,T,trm)) = Abs(y,T,real_subst sg tl x c trm) |
mueller@6473
   737
real_subst sg tl x c (Free(y,t)) = if (x=y) then c else Free(y,t) |
mueller@6473
   738
real_subst sg tl x c t = t;
mueller@6473
   739
(* substituting variable x by term c *)
mueller@6473
   740
fun x_subst sg tl x c (a $ b) =
mueller@6473
   741
let
mueller@6473
   742
 val t = (type_of_term (a $ b))
mueller@6473
   743
in
mueller@6473
   744
 if ((list_contains_key tl t) andalso (xFree x (a$b)))
mueller@6473
   745
 then (real_subst sg tl x c (a$b)) else ((x_subst sg tl x c a) $ (x_subst sg tl x c b))
mueller@6473
   746
end |
mueller@6473
   747
x_subst sg tl x c (Abs(y,T,trm)) = Abs(y,T,x_subst sg tl x c trm) |
mueller@6473
   748
x_subst sg tl x c t = t;
mueller@6473
   749
(* genearting a cascading if *)
mueller@6473
   750
fun casc_if sg tl x ty (c::l) trm =
mueller@6473
   751
let
mueller@6473
   752
 val arglist = arglist_of sg tl (snd c);
mueller@6473
   753
 val con_typ = fun_type_of (rev (snd c)) ty;
mueller@6473
   754
 val con = #t(rep_cterm(read_cterm sg (fst c,con_typ)));
mueller@6473
   755
 fun casc_if2 sg tl x con [] ty trm [] = trm | (* should never occur *)
mueller@6473
   756
 casc_if2 sg tl x con [arg] ty trm [] = x_subst sg tl x (con_term_of con arg) trm |
mueller@6473
   757
 casc_if2 sg tl x con (a::r) ty trm cl =
paulson@16587
   758
        Const("HOL.If",Type("fun",[Type("bool",[]),
mueller@6473
   759
        Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])])
mueller@6473
   760
        ])) $
mueller@6473
   761
     (Const("op =",Type("fun",[ty,Type("fun",[ty,Type("bool",[])])])) $
mueller@6473
   762
        Free(x,ty) $ (real_subst sg tl x (con_term_of con a) (Free(x,ty)))) $
mueller@6473
   763
   (x_subst sg tl x (con_term_of con a) trm) $
mueller@6473
   764
   (casc_if2 sg tl x con r ty trm cl) |
mueller@6473
   765
 casc_if2 sg tl x con [] ty trm cl = casc_if sg tl x ty cl trm;
mueller@6473
   766
in
mueller@6473
   767
 casc_if2 sg tl x con arglist ty trm l
mueller@6473
   768
end |
mueller@6473
   769
casc_if _ _ _ _ [] trm = trm (* should never occur *); 
mueller@6473
   770
fun if_term sg tl x ty trm =
mueller@6473
   771
let
mueller@6473
   772
 val tyC_list = search_in_keylist tl ty;
mueller@6473
   773
in
mueller@6473
   774
 casc_if sg tl x ty tyC_list trm
mueller@6473
   775
end;
mueller@6473
   776
(* checking whether a variable occurs in a constructor term *)
mueller@6473
   777
fun constr_term_contains_var sg tl (a $ b) x =
mueller@6473
   778
let
mueller@6473
   779
 val t = type_of_term (a $ b)
mueller@6473
   780
in
mueller@6473
   781
 if ((list_contains_key tl t) andalso (xFree x (a$b))) then true
mueller@6473
   782
 else
mueller@6473
   783
 (if (constr_term_contains_var sg tl a x) then true 
mueller@6473
   784
  else (constr_term_contains_var sg tl b x))
mueller@6473
   785
end |
mueller@6473
   786
constr_term_contains_var sg tl (Abs(y,ty,trm)) x =
mueller@6473
   787
         constr_term_contains_var sg tl (snd(variant_abs(y,ty,trm))) x |
mueller@6473
   788
constr_term_contains_var _ _ _ _ = false;
mueller@6473
   789
val vt = variant_abs(x,ty,trm);
mueller@6473
   790
val tt = remove_vars sg tl (snd(vt))
mueller@6473
   791
in
mueller@6473
   792
if (constr_term_contains_var sg tl tt (fst vt))
mueller@6473
   793
(* fst vt muss frei vorkommen, als ECHTER TeilKonstruktorterm *)
mueller@6473
   794
then (Abs(x,ty,
mueller@6473
   795
        abstract_over(Free(fst vt,ty),
mueller@6473
   796
	if_term sg ((Type("bool",[]),[("True",[]),("False",[])])::tl) (fst vt) ty tt)))
mueller@6473
   797
else Abs(x,ty,abstract_over(Free(fst vt,ty),tt))
mueller@6473
   798
end |
mueller@6473
   799
remove_vars sg tl (a $ b) = (remove_vars sg tl a) $ (remove_vars sg tl b) |
mueller@6473
   800
remove_vars sg tl t = t;
mueller@6473
   801
mueller@6473
   802
(* dissolves equalities "=" of boolean terms, where one of them is a complex term *)
mueller@6473
   803
fun remove_equal sg tl (Abs(x,ty,trm)) = Abs(x,ty,remove_equal sg tl trm) |
mueller@6473
   804
remove_equal sg tl (Const("op =",Type("fun",[Type("bool",[]),
mueller@6473
   805
	Type("fun",[Type("bool",[]),Type("bool",[])])])) $ lhs $ rhs) =
mueller@6473
   806
let
mueller@6473
   807
fun complex_trm (Abs(_,_,_)) = true |
mueller@6473
   808
complex_trm (_ $ _) = true |
mueller@6473
   809
complex_trm _ = false;
mueller@6473
   810
in
mueller@6473
   811
(if ((complex_trm lhs) orelse (complex_trm rhs)) then
mueller@6473
   812
(let
mueller@6473
   813
val lhs = remove_equal sg tl lhs;
mueller@6473
   814
val rhs = remove_equal sg tl rhs
mueller@6473
   815
in
mueller@6473
   816
(
mueller@6473
   817
Const("op &",
mueller@6473
   818
Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])])) $
mueller@6473
   819
(Const("op -->",
mueller@6473
   820
 Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])])) $
mueller@6473
   821
	lhs $ rhs) $
mueller@6473
   822
(Const("op -->",
mueller@6473
   823
 Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])])) $
mueller@6473
   824
	rhs $ lhs)
mueller@6473
   825
)
mueller@6473
   826
end)
mueller@6473
   827
else
mueller@6473
   828
(Const("op =",
mueller@6473
   829
 Type("fun",[Type("bool",[]),Type("fun",[Type("bool",[]),Type("bool",[])])])) $
mueller@6473
   830
	lhs $ rhs))
mueller@6473
   831
end |
mueller@6473
   832
remove_equal sg tl (a $ b) = (remove_equal sg tl a) $ (remove_equal sg tl b) |
mueller@6473
   833
remove_equal sg tl trm = trm;
mueller@6473
   834
mueller@6473
   835
(* rewrites constructor terms (without vars) for mucke *)
mueller@6473
   836
fun rewrite_dt_term sg tl (Abs(x,ty,t)) = Abs(x,ty,(rewrite_dt_term sg tl t)) |
mueller@6473
   837
rewrite_dt_term sg tl (a $ b) =
mueller@6473
   838
let
mueller@6473
   839
mueller@6473
   840
(* OUTPUT - relevant *)
mueller@6473
   841
(* transforms constructor term to a mucke-suitable output *)
mueller@6473
   842
fun term_OUTPUT sg (Const("Pair",_) $ a $ b) =
mueller@6473
   843
		(term_OUTPUT sg a) ^ "_I_" ^ (term_OUTPUT sg b) |
mueller@6473
   844
term_OUTPUT sg (a $ b) = (term_OUTPUT sg a) ^ "_I_" ^ (term_OUTPUT sg b) |
mueller@6473
   845
term_OUTPUT sg (Const(s,t)) = post_last_dot s |
mueller@6473
   846
term_OUTPUT _ _ = 
mueller@6473
   847
error "term contains an unprintable constructor term (in term_OUTPUT)";
mueller@6473
   848
mueller@6473
   849
fun contains_bound i (Bound(j)) = if (j>=i) then true else false |
mueller@6473
   850
contains_bound i (a $ b) = if (contains_bound i a) then true else (contains_bound i b) |
mueller@6473
   851
contains_bound i (Abs(_,_,t)) = contains_bound (i+1) t |
mueller@6473
   852
contains_bound _ _ = false;
mueller@6473
   853
mueller@6473
   854
in
mueller@6473
   855
        if (contains_bound 0 (a $ b)) 
mueller@6473
   856
	then ((rewrite_dt_term sg tl a) $ (rewrite_dt_term sg tl b))
mueller@6473
   857
        else
mueller@6473
   858
        (
mueller@6473
   859
        let
mueller@6473
   860
        val t = type_of_term (a $ b);
mueller@6473
   861
        in
mueller@6473
   862
        if (list_contains_key tl t) then (Const((term_OUTPUT sg (a $ b)),t)) else
mueller@6473
   863
        ((rewrite_dt_term sg tl a) $ (rewrite_dt_term sg tl b))
mueller@6473
   864
        end)
mueller@6473
   865
end |
mueller@6473
   866
rewrite_dt_term sg tl t = t;
mueller@6473
   867
mueller@6473
   868
fun rewrite_dt_terms sg tl [] = [] |
mueller@6473
   869
rewrite_dt_terms sg tl (a::r) =
mueller@6473
   870
let
mueller@6473
   871
 val c = (replace_case sg ((Type("bool",[]),[("True",[]),("False",[])])::tl) a 0);
mueller@6473
   872
 val rv = (remove_vars sg tl c);  
mueller@6473
   873
 val rv = (remove_equal sg tl rv);
mueller@6473
   874
in
mueller@6473
   875
 ((rewrite_dt_term sg tl rv) 
mueller@6473
   876
 :: (rewrite_dt_terms sg tl r))
mueller@6473
   877
end;
mueller@6473
   878
mueller@6473
   879
(**********************************************************************)
mueller@6473
   880
(* SECTION 4: generating type declaration and preprocessing type list *)
mueller@6473
   881
mueller@6473
   882
fun make_type_decls [] tl = "" |
mueller@6473
   883
make_type_decls ((a,l)::r) tl = 
mueller@6473
   884
let
mueller@6473
   885
fun comma_list_of [] = "" |
mueller@6473
   886
comma_list_of (a::[]) = a |
mueller@6473
   887
comma_list_of (a::r) = a ^ "," ^ (comma_list_of r);
mueller@6473
   888
mueller@6473
   889
(* OUTPUT - relevant *)
mueller@6473
   890
(* produces for each type of the 2nd argument its constant names (see *)
mueller@6473
   891
(* concat_constr) and appends them to prestring (see concat_types)    *)
mueller@6473
   892
fun generate_constnames_OUTPUT prestring [] _ = [prestring] |
mueller@6473
   893
generate_constnames_OUTPUT prestring ((Type("*",[a,b]))::r) tl =
mueller@6473
   894
 generate_constnames_OUTPUT prestring (a::b::r) tl |
mueller@6473
   895
generate_constnames_OUTPUT prestring (a::r) tl =
mueller@6473
   896
let
mueller@6473
   897
 fun concat_constrs [] _ = [] |
mueller@6473
   898
 concat_constrs ((c,[])::r) tl = c::(concat_constrs r tl)  |
mueller@6473
   899
 concat_constrs ((c,l)::r) tl =
mueller@6473
   900
         (generate_constnames_OUTPUT (c ^ "_I_") l tl) @ (concat_constrs r tl);
mueller@6473
   901
 fun concat_types _ [] _ _ = [] |
mueller@6473
   902
 concat_types prestring (a::q) [] tl = [prestring ^ a] 
mueller@6473
   903
				       @ (concat_types prestring q [] tl) |
mueller@6473
   904
 concat_types prestring (a::q) r tl = 
mueller@6473
   905
		(generate_constnames_OUTPUT (prestring ^ a ^ "_I_") r tl) 
mueller@6473
   906
		@ (concat_types prestring q r tl);
mueller@6473
   907
 val g = concat_constrs (search_in_keylist tl a) tl;
mueller@6473
   908
in
mueller@6473
   909
 concat_types prestring g r tl
mueller@6473
   910
end;
mueller@6473
   911
mueller@6473
   912
fun make_type_decl a tl =
mueller@6473
   913
let
mueller@6473
   914
        val astr = type_to_string_OUTPUT a;
mueller@6473
   915
        val dl = generate_constnames_OUTPUT "" [a] tl;
mueller@6473
   916
        val cl = comma_list_of dl;
mueller@6473
   917
in
mueller@6473
   918
        ("enum " ^ astr ^ " {" ^ cl ^ "};\n")
mueller@6473
   919
end;
mueller@6473
   920
in
mueller@6473
   921
 (make_type_decl a tl) ^ (make_type_decls r tl)
mueller@6473
   922
end;
mueller@6473
   923
mueller@6473
   924
fun check_finity gl [] [] true = true |
mueller@6473
   925
check_finity gl bl [] true = (check_finity gl [] bl false) |
mueller@6473
   926
check_finity _ _ [] false =
mueller@6473
   927
error "used datatypes are not finite" |
mueller@6473
   928
check_finity gl bl ((t,cl)::r) b =
mueller@6473
   929
let
mueller@6473
   930
fun listmem [] _ = true |
mueller@6473
   931
listmem (a::r) l = if (a mem l) then (listmem r l) else false;
mueller@6473
   932
fun snd_listmem [] _ = true |
mueller@6473
   933
snd_listmem ((a,b)::r) l = if (listmem b l) then (snd_listmem r l) else false;
mueller@6473
   934
in
mueller@6473
   935
(if (snd_listmem cl gl) then (check_finity (t::gl) bl r true)
mueller@6473
   936
else (check_finity gl ((t,cl)::bl) r b))
mueller@6473
   937
end;
mueller@6473
   938
wenzelm@7295
   939
fun preprocess_td sg [] done = [] |
wenzelm@7295
   940
preprocess_td sg (a::b) done =
mueller@6473
   941
let
mueller@6473
   942
fun extract_hd sg (_ $ Abs(_,_,r)) = extract_hd sg r |
mueller@6473
   943
extract_hd sg (Const("Trueprop",_) $ r) = extract_hd sg r |
mueller@6473
   944
extract_hd sg (Var(_,_) $ r) = extract_hd sg r |
mueller@6473
   945
extract_hd sg (a $ b) = extract_hd sg a |
mueller@6473
   946
extract_hd sg (Const(s,t)) = post_last_dot s |
mueller@6473
   947
extract_hd _ _ =
mueller@6473
   948
error "malformed constructor term in a induct-theorem";
mueller@6473
   949
fun list_of_param_types sg tl pl (_ $ Abs(_,t,r)) =
mueller@6473
   950
let
mueller@6473
   951
 fun select_type [] [] t = t |
mueller@6473
   952
 select_type (a::r) (b::s) t =
mueller@6473
   953
 if (t=b) then a else (select_type r s t) |
mueller@6473
   954
 select_type _ _ _ =
mueller@6473
   955
 error "wrong number of argument of a constructor in a induct-theorem";
mueller@6473
   956
in
mueller@6473
   957
 (select_type tl pl t) :: (list_of_param_types sg tl pl r)
mueller@6473
   958
end |
mueller@6473
   959
list_of_param_types sg tl pl (Const("Trueprop",_) $ r) = list_of_param_types sg tl pl r |
mueller@6473
   960
list_of_param_types _ _ _ _ = [];
mueller@6473
   961
fun split_constr sg tl pl a = (extract_hd sg a,list_of_param_types sg tl pl a);
mueller@6473
   962
fun split_constrs _ _ _ [] = [] |
mueller@6473
   963
split_constrs sg tl pl (a::r) = (split_constr sg tl pl a) :: (split_constrs sg tl pl r);
mueller@6473
   964
fun new_types [] = [] |
mueller@6473
   965
new_types ((t,l)::r) =
mueller@6473
   966
let
mueller@6473
   967
 fun ex_bool [] = [] |
mueller@6473
   968
 ex_bool ((Type("bool",[]))::r) = ex_bool r |
mueller@6473
   969
 ex_bool ((Type("*",[a,b]))::r) = ex_bool (a::b::r) |
mueller@6473
   970
 ex_bool (s::r) = s:: (ex_bool r);
mueller@6473
   971
 val ll = ex_bool l
mueller@6473
   972
in
mueller@6473
   973
 (ll @ (new_types r))
mueller@6473
   974
end;
mueller@6473
   975
in
mueller@6473
   976
        if (a mem done)
wenzelm@7295
   977
        then (preprocess_td sg b done)
mueller@6473
   978
        else
mueller@6473
   979
        (let
mueller@6473
   980
	 fun qtn (Type(a,tl)) = (a,tl) |
mueller@6473
   981
	 qtn _ = error "unexpected type variable in preprocess_td";
mueller@6473
   982
	 val s =  post_last_dot(fst(qtn a));
mueller@6473
   983
	 fun param_types ((Const("Trueprop",_)) $ (_ $ (Var(_,Type(_,t)))))  = t |
mueller@6473
   984
	 param_types _ = error "malformed induct-theorem in preprocess_td";	
wenzelm@16486
   985
	 val pl = param_types (concl_of (get_thm sg (Name (s ^ ".induct"))));		
wenzelm@16486
   986
         val l = split_constrs sg (snd(qtn a)) pl (prems_of (get_thm sg (Name (s ^ ".induct"))));
mueller@6473
   987
	 val ntl = new_types l;
mueller@6473
   988
        in 
wenzelm@7295
   989
        ((a,l) :: (preprocess_td sg (ntl @ b) (a :: done)))
mueller@6473
   990
        end)
mueller@6473
   991
end;
mueller@6473
   992
mueller@6473
   993
fun extract_type_names_prems sg [] = [] |
mueller@6473
   994
extract_type_names_prems sg (a::b) =
mueller@6473
   995
let
mueller@6473
   996
fun analyze_types sg [] = [] |
mueller@6473
   997
analyze_types sg [Type(a,[])] =
mueller@6473
   998
(let
mueller@6473
   999
 val s = (Sign.string_of_typ sg (Type(a,[])))
mueller@6473
  1000
in
mueller@6473
  1001
 (if (s="bool") then ([]) else ([Type(a,[])]))
mueller@6473
  1002
end) |
mueller@6473
  1003
analyze_types sg [Type("*",l)] = analyze_types sg l |
mueller@6473
  1004
analyze_types sg [Type("fun",l)] = analyze_types sg l |
mueller@6473
  1005
analyze_types sg [Type(t,l)] = ((Type(t,l))::(analyze_types sg l)) |
mueller@6473
  1006
analyze_types sg (a::l) = (analyze_types sg [a]) @ (analyze_types sg l);
mueller@6473
  1007
fun extract_type_names sg (Const("==",_)) = [] |
mueller@6473
  1008
extract_type_names sg (Const("Trueprop",_)) = [] |
mueller@6473
  1009
extract_type_names sg (Const(_,typ)) = analyze_types sg [typ] |
mueller@6473
  1010
extract_type_names sg (a $ b) = (extract_type_names sg a) @ (extract_type_names sg b) |
mueller@6473
  1011
extract_type_names sg (Abs(x,T,t)) = (analyze_types sg [T]) @ (extract_type_names sg t) |
mueller@6473
  1012
extract_type_names _ _ = [];
mueller@6473
  1013
in
mueller@6473
  1014
 (extract_type_names sg a) @ extract_type_names_prems sg b
mueller@6473
  1015
end;
mueller@6473
  1016
mueller@6473
  1017
(**********************************************************)
mueller@6473
  1018
wenzelm@17272
  1019
fun mk_mc_mucke_oracle sign subgoal = 
mueller@6473
  1020
  let 	val Freesubgoal = freeze_thaw subgoal;
mueller@6473
  1021
mueller@6473
  1022
	val prems = Logic.strip_imp_prems Freesubgoal; 
mueller@6473
  1023
	val concl = Logic.strip_imp_concl Freesubgoal; 
mueller@6473
  1024
	
mueller@6473
  1025
	val Muckedecls = terms_to_decls sign prems;
mueller@6473
  1026
	val decls_str = string_of_terms sign Muckedecls;
mueller@6473
  1027
	
mueller@6473
  1028
	val type_list = (extract_type_names_prems sign (prems@[concl]));
wenzelm@7295
  1029
	val ctl =  preprocess_td sign type_list [];
mueller@6473
  1030
	val b = if (ctl=[]) then true else (check_finity [Type("bool",[])] [] ctl false);
mueller@6473
  1031
	val type_str = make_type_decls ctl 
mueller@6473
  1032
				((Type("bool",[]),("True",[])::("False",[])::[])::ctl);
mueller@6473
  1033
	
mueller@6473
  1034
	val mprems = rewrite_dt_terms sign ctl prems;
mueller@6473
  1035
	val mconcl = rewrite_dt_terms sign ctl [concl];
mueller@6473
  1036
mueller@6473
  1037
	val Muckeprems = transform_terms sign mprems;
mueller@6473
  1038
        val prems_str = transform_case(string_of_terms sign Muckeprems);
mueller@6473
  1039
mueller@6473
  1040
        val Muckeconcl = elim_quant_in_list sign mconcl;
mueller@6473
  1041
	val concl_str = transform_case(string_of_terms sign Muckeconcl);
mueller@6473
  1042
mueller@6473
  1043
	val MCstr = (
mueller@6473
  1044
		"/**** type declarations: ****/\n" ^ type_str ^
mueller@6473
  1045
		"/**** declarations: ****/\n" ^ decls_str ^
mueller@6473
  1046
		"/**** definitions: ****/\n" ^ prems_str ^ 
mueller@6473
  1047
		"/**** formula: ****/\n" ^ concl_str ^";");
mueller@6473
  1048
	val result = callmc MCstr;
mueller@6473
  1049
  in
mueller@6473
  1050
(if !trace_mc then 
mueller@6473
  1051
	(writeln ("\nmodelchecker input:\n" ^ MCstr ^ "\n/**** end ****/"))
mueller@6473
  1052
          else ();
mueller@6473
  1053
(case (extract_result concl_str result) of 
mueller@6473
  1054
	true  =>  (Logic.strip_imp_concl subgoal) | 
mueller@6473
  1055
	false => (error ("Mucke couldn't solve subgoal: \n" ^result)))) 
mueller@6473
  1056
  end;