src/HOLCF/IOA/meta_theory/ioa_package.ML
author wenzelm
Tue Apr 18 00:49:49 2000 +0200 (2000-04-18)
changeset 8733 3213613a775a
parent 8438 b8389b4fca9c
child 9317 7a72952ca068
permissions -rw-r--r--
renamed 'hide' to 'hide_action';
wenzelm@6508
     1
(*  Title:      HOLCF/IOA/meta_theory/ioa_package.ML
mueller@6467
     2
    ID:         $Id$
wenzelm@6508
     3
    Author:	Tobias Hamberger, TU Muenchen
mueller@6467
     4
*)
mueller@6467
     5
mueller@6467
     6
signature IOA_PACKAGE =
mueller@6467
     7
sig
mueller@6467
     8
  val add_ioa: string -> string ->
mueller@6467
     9
		 (string) list -> (string) list -> (string) list ->
mueller@6467
    10
		(string * string) list -> string ->
mueller@6467
    11
		(string * string * (string * string)list) list
mueller@6467
    12
	-> theory -> theory
mueller@6467
    13
 val add_ioa_i : string -> string ->
mueller@6467
    14
                 (string) list -> (string) list -> (string) list ->
mueller@6467
    15
                (string * string) list -> string ->
mueller@6467
    16
                (string * string * (string * string)list) list
mueller@6467
    17
	-> theory -> theory
mueller@6467
    18
 val add_composition : string -> (string)list -> theory -> theory
mueller@6467
    19
 val add_composition_i : string -> (string)list -> theory -> theory
mueller@6467
    20
 val add_hiding : string -> string -> (string)list -> theory -> theory
mueller@6467
    21
 val add_hiding_i : string -> string -> (string)list -> theory -> theory
mueller@6467
    22
 val add_restriction : string -> string -> (string)list -> theory -> theory
mueller@6467
    23
 val add_restriction_i : string -> string -> (string)list -> theory -> theory
mueller@6467
    24
 val add_rename : string -> string -> string -> theory -> theory
mueller@6467
    25
 val add_rename_i : string -> string -> string -> theory -> theory
mueller@6467
    26
end;
mueller@6467
    27
wenzelm@6508
    28
structure IoaPackage: IOA_PACKAGE =
mueller@6467
    29
struct
mueller@6467
    30
mueller@6467
    31
local
mueller@6467
    32
mueller@6467
    33
exception malformed;
mueller@6467
    34
mueller@6467
    35
(* stripping quotes *)
mueller@6467
    36
fun strip [] = [] |
mueller@6467
    37
strip ("\""::r) = strip r |
mueller@6467
    38
strip (a::r) = a :: (strip r);
mueller@6467
    39
fun strip_quote s = implode(strip(explode(s)));
mueller@6467
    40
mueller@6467
    41
(* used by *_of_varlist *)
mueller@6467
    42
fun extract_first (a,b) = strip_quote a;
mueller@6467
    43
fun extract_second (a,b) = strip_quote b;
mueller@6467
    44
(* following functions producing sth from a varlist *)
mueller@6467
    45
fun comma_list_of_varlist [] = "" |
mueller@6467
    46
comma_list_of_varlist [a] = extract_first a |
mueller@6467
    47
comma_list_of_varlist (a::r) = (extract_first a) ^ "," ^ (comma_list_of_varlist r);
mueller@6467
    48
fun primed_comma_list_of_varlist [] = "" |
mueller@6467
    49
primed_comma_list_of_varlist [a] = (extract_first a) ^ "'" |
mueller@6467
    50
primed_comma_list_of_varlist (a::r) = (extract_first a) ^ "'," ^
mueller@6467
    51
 (primed_comma_list_of_varlist r);
mueller@6467
    52
fun type_product_of_varlist [] = "" |
mueller@6467
    53
type_product_of_varlist [a] = "(" ^ extract_second(a) ^ ")" |
mueller@6467
    54
type_product_of_varlist(a::r) = "(" ^ extract_second(a) ^ ")*" ^ type_product_of_varlist r;
mueller@6467
    55
mueller@6467
    56
(* listing a list *)
mueller@6467
    57
fun list_elements_of [] = "" |
mueller@6467
    58
list_elements_of (a::r) = a ^ " " ^ (list_elements_of r);
mueller@6467
    59
mueller@6467
    60
(* extracting type parameters from a type list *)
mueller@6467
    61
(* fun param_tupel thy [] res = res |
mueller@6467
    62
param_tupel thy ((Type(_,l))::r) res = param_tupel thy (l @ r) res |
mueller@6467
    63
param_tupel thy ((TFree(a,_))::r) res = 
mueller@6467
    64
if (a mem res) then (param_tupel thy r res) else (param_tupel thy r (a::res)) |
mueller@6467
    65
param_tupel thy (a::r) res =
mueller@6467
    66
error ("one component of a statetype is a TVar: " ^ (Sign.string_of_typ (sign_of thy) a));
mueller@6467
    67
*)
mueller@6467
    68
mueller@6467
    69
(* used by constr_list *)
mueller@6467
    70
fun extract_constrs thy [] = [] |
mueller@6467
    71
extract_constrs thy (a::r) =
mueller@6467
    72
let
mueller@6467
    73
fun is_prefix [] s = true
mueller@6467
    74
| is_prefix (p::ps) [] = false
mueller@6467
    75
| is_prefix (p::ps) (x::xs) = (p=x) andalso (is_prefix ps xs);
mueller@6467
    76
fun delete_bold [] = []
mueller@6467
    77
| delete_bold (x::xs) = if (is_prefix ("\^["::"["::"1"::"m"::[]) (x::xs))
mueller@6467
    78
        then (let val (_::_::_::s) = xs in delete_bold s end)
mueller@6467
    79
        else (if (is_prefix ("\^["::"["::"0"::"m"::[]) (x::xs))
mueller@6467
    80
                then  (let val (_::_::_::s) = xs in delete_bold s end)
mueller@6467
    81
                else (x::delete_bold xs));
mueller@6467
    82
fun delete_bold_string s = implode(delete_bold(explode s));
mueller@6467
    83
(* from a constructor term in *.induct (with quantifiers,
mueller@6467
    84
"Trueprop" and ?P stripped away) delivers the head *)
mueller@6467
    85
fun extract_hd (_ $ Abs(_,_,r)) = extract_hd r |
mueller@6467
    86
extract_hd (Const("Trueprop",_) $ r) = extract_hd r |
mueller@6467
    87
extract_hd (Var(_,_) $ r) = extract_hd r |
mueller@6467
    88
extract_hd (a $ b) = extract_hd a |
mueller@6467
    89
extract_hd (Const(s,_)) = s |
mueller@6467
    90
extract_hd _ = raise malformed;
mueller@6467
    91
(* delivers constructor term string from a prem of *.induct *)
mueller@6467
    92
fun extract_constr thy (_ $ Abs(a,T,r)) = extract_constr thy (snd(variant_abs(a,T,r)))|
mueller@6467
    93
extract_constr thy (Const("Trueprop",_) $ r) = extract_constr thy r |
mueller@6467
    94
extract_constr thy (Var(_,_) $ r) =  delete_bold_string(Sign.string_of_term (sign_of thy) r) |
mueller@6467
    95
extract_constr _ _ = raise malformed;
mueller@6467
    96
in
mueller@6467
    97
(extract_hd a,extract_constr thy a) :: (extract_constrs thy r)
mueller@6467
    98
end;
mueller@6467
    99
mueller@6467
   100
(* delivering list of constructor terms of a datatype *)
mueller@6467
   101
fun constr_list thy atyp =
mueller@6467
   102
let
mueller@6467
   103
fun act_name thy (Type(s,_)) = s |
mueller@6467
   104
act_name _ s = 
mueller@6467
   105
error("malformed action type: " ^ (Sign.string_of_typ (sign_of thy) s));
mueller@6467
   106
fun afpl ("." :: a) = [] |
mueller@6467
   107
afpl [] = [] |
mueller@6467
   108
afpl (a::r) = a :: (afpl r);
mueller@6467
   109
fun unqualify s = implode(rev(afpl(rev(explode s))));
mueller@6467
   110
val q_atypstr = act_name thy atyp;
mueller@6467
   111
val uq_atypstr = unqualify q_atypstr;
mueller@6467
   112
val prem = prems_of (get_thm thy (uq_atypstr ^ ".induct"));
mueller@6467
   113
in
mueller@6467
   114
extract_constrs thy prem
mueller@6467
   115
handle malformed =>
mueller@6467
   116
error("malformed theorem : " ^ uq_atypstr ^ ".induct")
mueller@6467
   117
end;
mueller@6467
   118
mueller@6467
   119
fun check_for_constr thy atyp (a $ b) =
mueller@6467
   120
let
mueller@6467
   121
fun all_free (Free(_,_)) = true |
mueller@6467
   122
all_free (a $ b) = if (all_free a) then (all_free b) else false |
mueller@6467
   123
all_free _ = false; 
mueller@6467
   124
in 
mueller@6467
   125
if (all_free b) then (check_for_constr thy atyp a) else false
mueller@6467
   126
end |
mueller@6467
   127
check_for_constr thy atyp (Const(a,_)) =
mueller@6467
   128
let
mueller@6467
   129
val cl = constr_list thy atyp;
mueller@6467
   130
fun fstmem a [] = false |
mueller@6467
   131
fstmem a ((f,s)::r) = if (a=f) then true else (fstmem a r)
mueller@6467
   132
in
mueller@6467
   133
if (fstmem a cl) then true else false
mueller@6467
   134
end |
mueller@6467
   135
check_for_constr _ _ _ = false;
mueller@6467
   136
mueller@6467
   137
(* delivering the free variables of a constructor term *)
mueller@6467
   138
fun free_vars_of (t1 $ t2) = (free_vars_of t1) @ (free_vars_of t2) |
mueller@6467
   139
free_vars_of (Const(_,_)) = [] |
mueller@6467
   140
free_vars_of (Free(a,_)) = [a] |
mueller@6467
   141
free_vars_of _ = raise malformed;
mueller@6467
   142
mueller@6467
   143
(* making a constructor set from a constructor term (of signature) *)
mueller@6467
   144
fun constr_set_string thy atyp ctstr =
mueller@6467
   145
let
mueller@6467
   146
val trm = #t(rep_cterm(read_cterm (sign_of thy) (ctstr,atyp)));
mueller@6467
   147
val l = free_vars_of trm
mueller@6467
   148
in
mueller@6467
   149
if (check_for_constr thy atyp trm) then
mueller@6467
   150
(if (l=[]) then ("{" ^ ctstr ^ "}")
mueller@6467
   151
else "(UN " ^ (list_elements_of l) ^ ". {" ^ ctstr ^ "})")
mueller@6467
   152
else (raise malformed) 
mueller@6467
   153
handle malformed => 
mueller@6467
   154
error("malformed action term: " ^ (Sign.string_of_term (sign_of thy) trm))
mueller@6467
   155
end;
mueller@6467
   156
mueller@6467
   157
(* extracting constructor heads *)
mueller@6467
   158
fun constructor_head thy atypstr s =
mueller@6467
   159
let
mueller@6467
   160
fun hd_of (Const(a,_)) = a |
mueller@6467
   161
hd_of (t $ _) = hd_of t |
mueller@6467
   162
hd_of _ = raise malformed;
mueller@6467
   163
val trm = #t(rep_cterm(read_cterm (sign_of thy) (s,#T(rep_ctyp(read_ctyp (sign_of thy) atypstr))) ))
mueller@6467
   164
in
mueller@6467
   165
hd_of trm handle malformed =>
mueller@6467
   166
error("malformed constructor of datatype " ^ atypstr ^ ": " ^ s)
mueller@6467
   167
end;
mueller@6467
   168
fun constructor_head_list _ _ [] = [] |
mueller@6467
   169
constructor_head_list thy atypstr (a::r) =
mueller@6467
   170
 (constructor_head thy atypstr a)::(constructor_head_list thy atypstr r);
mueller@6467
   171
mueller@6467
   172
(* producing an action set *)
mueller@6467
   173
fun action_set_string thy atyp [] = "{}" |
mueller@6467
   174
action_set_string thy atyp [a] = constr_set_string thy atyp (strip_quote a) |
mueller@6467
   175
action_set_string thy atyp (a::r) = (constr_set_string thy atyp (strip_quote a)) ^
mueller@6467
   176
         " Un " ^ (action_set_string thy atyp r);
mueller@6467
   177
mueller@6467
   178
(* used by extend *)
mueller@6467
   179
fun pstr s [] = "(" ^ s ^ "' = " ^ s ^ ")" |
mueller@6467
   180
pstr s ((a,b)::r) =
mueller@6467
   181
if (s=a) then ("(" ^ s ^ "' = (" ^ b ^ "))") else (pstr s r);
mueller@6467
   182
fun poststring [] l = "" |
mueller@6467
   183
poststring [(a,b)] l = pstr a l |
mueller@6467
   184
poststring ((a,b)::r) l = (pstr a l) ^ " & " ^ (poststring r l);
mueller@6467
   185
mueller@6467
   186
(* extends a (action string,condition,assignlist) tupel by a
mueller@6467
   187
(action term,action string,condition,pseudo_condition,bool) tupel, used by extended_list 
mueller@6467
   188
(where bool indicates whether there is a precondition *)
mueller@6467
   189
fun extend thy atyp statetupel (actstr,r,[]) =
mueller@6467
   190
let
mueller@6467
   191
val trm = #t(rep_cterm(read_cterm (sign_of thy) (actstr,atyp)));
mueller@6467
   192
val rtrm = #t(rep_cterm(read_cterm (sign_of thy) (r,Type("bool",[]))));
mueller@6467
   193
val flag = if (rtrm=Const("True",Type("bool",[]))) then false else true
mueller@6467
   194
in
mueller@6467
   195
if (check_for_constr thy atyp trm)
mueller@6467
   196
then (trm,actstr, "(" ^ r ^ ") & " ^ (poststring statetupel []),r,flag)
mueller@6467
   197
else
mueller@6467
   198
error("transition " ^ actstr ^ " is not a pure constructor term")
mueller@6467
   199
end |
mueller@6467
   200
extend thy atyp statetupel (actstr,r,(a,b)::c) =
mueller@6467
   201
let
mueller@6467
   202
fun pseudo_poststring [] = "" |
mueller@6467
   203
pseudo_poststring ((a,b)::[]) = "(" ^ a ^ " = (" ^ b ^ "))" |
mueller@6467
   204
pseudo_poststring ((a,b)::r) = "(" ^ a ^ " = (" ^ b ^ ")) & " ^ (pseudo_poststring r); 
mueller@6467
   205
val trm = #t(rep_cterm(read_cterm (sign_of thy) (actstr,atyp)));
mueller@6467
   206
val rtrm = #t(rep_cterm(read_cterm (sign_of thy) (r,Type("bool",[]))));
mueller@6467
   207
val flag = if (rtrm=Const("True",Type("bool",[]))) then false else true
mueller@6467
   208
in
mueller@6467
   209
if (check_for_constr thy atyp trm) then
mueller@6467
   210
(if ((a="") andalso (b="") andalso (c=[])) then (trm,actstr,r,"True",false)
mueller@6467
   211
(* the case with transrel *)
mueller@6467
   212
 else 
mueller@6467
   213
 (trm,actstr,"(" ^ r ^ ") & " ^ (poststring statetupel ((a,b)::c)),
mueller@6467
   214
	"(" ^ r ^ ") & " ^ (pseudo_poststring ((a,b)::c)),flag))
mueller@6467
   215
else
mueller@6467
   216
error("transition " ^ actstr ^ " is not a pure constructor term")
mueller@6467
   217
end;
mueller@6467
   218
(* used by make_alt_string *) 
mueller@6467
   219
fun extended_list _ _ _ [] = [] |
mueller@6467
   220
extended_list thy atyp statetupel (a::r) =
mueller@6467
   221
	 (extend thy atyp statetupel a) :: (extended_list thy atyp statetupel r);
mueller@6467
   222
mueller@6467
   223
(* used by write_alts *)
mueller@6467
   224
fun write_alt thy (chead,tr) inp out int [] =
mueller@6467
   225
if (chead mem inp) then
mueller@6467
   226
(
mueller@6467
   227
error("Input action " ^ tr ^ " was not specified")
mueller@6467
   228
) else (
mueller@6467
   229
if (chead mem (out@int)) then
mueller@6467
   230
(writeln("Action " ^ tr ^ " was completedly disabled due to missing specification")) else print("");
mueller@6467
   231
(tr ^ " => False",tr ^ " => False")) |
mueller@6467
   232
write_alt thy (chead,ctrm) inp out int ((a,b,c,d,e)::r) =
mueller@6467
   233
let
mueller@6467
   234
fun hd_of (Const(a,_)) = a |
mueller@6467
   235
hd_of (t $ _) = hd_of t |
mueller@6467
   236
hd_of _ = raise malformed;
mueller@6467
   237
fun occurs_again c [] = false |
mueller@6467
   238
occurs_again c ((a,_,_,_,_)::r) = if (c=(hd_of a)) then true else (occurs_again c r);
mueller@6467
   239
in
mueller@6467
   240
if (chead=(hd_of a)) then 
mueller@6467
   241
(if ((chead mem inp) andalso e) then (
mueller@6467
   242
error("Input action " ^ b ^ " has a precondition")
mueller@6467
   243
) else (if (chead mem (inp@out@int)) then 
mueller@6467
   244
		(if (occurs_again chead r) then (
mueller@6467
   245
error("Two specifications for action: " ^ b)
mueller@6467
   246
		) else (b ^ " => " ^ c,b ^ " => " ^ d))
mueller@6467
   247
	else (
mueller@6467
   248
error("Action " ^ b ^ " is not in automaton signature")
mueller@6467
   249
))) else (write_alt thy (chead,ctrm) inp out int r)
mueller@6467
   250
handle malformed =>
mueller@6467
   251
error ("malformed action term: " ^ (Sign.string_of_term (sign_of thy) a))
mueller@6467
   252
end;
mueller@6467
   253
mueller@6467
   254
(* used by make_alt_string *)
mueller@6467
   255
fun write_alts thy (a,b) inp out int [] ttr = (a,b) |
mueller@6467
   256
write_alts thy (a,b) inp out int [c] ttr =
mueller@6467
   257
let
mueller@6467
   258
val wa = write_alt thy c inp out int ttr
mueller@6467
   259
in
mueller@6467
   260
 (a ^ (fst wa),b ^ (snd wa))
mueller@6467
   261
end |
mueller@6467
   262
write_alts thy (a,b) inp out int (c::r) ttr =
mueller@6467
   263
let
mueller@6467
   264
val wa = write_alt thy c inp out int ttr
mueller@6467
   265
in
mueller@6467
   266
 write_alts thy (a ^ (fst wa) ^ " | ", b ^ (snd wa) ^ " | ") inp out int r ttr
mueller@6467
   267
end;
mueller@6467
   268
mueller@6467
   269
fun make_alt_string thy inp out int atyp statetupel trans =
mueller@6467
   270
let
mueller@6467
   271
val cl = constr_list thy atyp;
mueller@6467
   272
val ttr = extended_list thy atyp statetupel trans;
mueller@6467
   273
in
mueller@6467
   274
write_alts thy ("","") inp out int cl ttr
mueller@6467
   275
end;
mueller@6467
   276
mueller@6467
   277
(* used in gen_add_ioa *)
mueller@6467
   278
fun check_free_primed (Free(a,_)) = 
mueller@6467
   279
let
mueller@6467
   280
val (f::r) = rev(explode a)
mueller@6467
   281
in
mueller@6467
   282
if (f="'") then [a] else []
mueller@6467
   283
end | 
mueller@6467
   284
check_free_primed (a $ b) = ((check_free_primed a) @ (check_free_primed b)) |
mueller@6467
   285
check_free_primed (Abs(_,_,t)) = check_free_primed t |
mueller@6467
   286
check_free_primed _ = [];
mueller@6467
   287
mueller@6467
   288
fun overlap [] _ = true |
mueller@6467
   289
overlap (a::r) l = if (a mem l) then (
mueller@6467
   290
error("Two occurences of action " ^ a ^ " in automaton signature")
mueller@6467
   291
) else (overlap r l);
mueller@6467
   292
mueller@6467
   293
(* delivering some types of an automaton *)
mueller@6467
   294
fun aut_type_of thy aut_name =
mueller@6467
   295
let
mueller@6467
   296
fun left_of (( _ $ left) $ _) = left |
mueller@6467
   297
left_of _ = raise malformed;
mueller@6467
   298
val aut_def = concl_of(get_thm thy (aut_name ^ "_def"));
mueller@6467
   299
in
mueller@6467
   300
(#T(rep_cterm(cterm_of (sign_of thy) (left_of aut_def))))
mueller@6467
   301
handle malformed => error ("malformed_theorem : " ^ aut_name ^ "_def")
mueller@6467
   302
end;
mueller@6467
   303
mueller@6467
   304
fun act_type_of thy (Type(pair1,(Type(pair_asig,(Type(actionset,[acttyp])::_))::_))) = acttyp |
mueller@6467
   305
act_type_of thy t = error ("could not extract action type of following automaton type:\n" ^
mueller@6467
   306
(Sign.string_of_typ (sign_of thy) t));
mueller@6467
   307
fun st_type_of thy (Type(pair1,_::(Type(pair2,Type(initial_set,[statetyp])::_))::_)) = statetyp |
mueller@6467
   308
st_type_of thy t = error ("could not extract state type of following automaton type:\n" ^
mueller@6467
   309
(Sign.string_of_typ (sign_of thy) t));
mueller@6467
   310
mueller@6467
   311
fun comp_st_type_of thy [a] = st_type_of thy (aut_type_of thy a) |
mueller@6467
   312
comp_st_type_of thy (a::r) = Type("*",[st_type_of thy (aut_type_of thy a), comp_st_type_of thy r]) |
mueller@6467
   313
comp_st_type_of _ _ = error "empty automaton list";
mueller@6467
   314
mueller@6467
   315
(* checking consistency of action types (for composition) *)
mueller@6467
   316
fun check_ac thy (a::r) =
mueller@6467
   317
let
mueller@6467
   318
fun ch_f_a thy acttyp [] = acttyp |
mueller@6467
   319
ch_f_a thy acttyp (a::r) =
mueller@6467
   320
let
mueller@6467
   321
val auttyp = aut_type_of thy a;
mueller@6467
   322
val ac = (act_type_of thy auttyp);
mueller@6467
   323
in
mueller@6467
   324
if (ac=acttyp) then (ch_f_a thy acttyp r) else (error "A")
mueller@6467
   325
end;
mueller@6467
   326
val auttyp = aut_type_of thy a;
mueller@6467
   327
val acttyp = (act_type_of thy auttyp);
mueller@6467
   328
in
mueller@6467
   329
ch_f_a thy acttyp r
mueller@6467
   330
end |
mueller@6467
   331
check_ac _ [] = error "empty automaton list";
mueller@6467
   332
mueller@6467
   333
fun clist [] = "" |
mueller@6467
   334
clist [a] = a |
mueller@6467
   335
clist (a::r) = a ^ " || " ^ (clist r);
mueller@6467
   336
mueller@6467
   337
(* gen_add_ioa *)
mueller@6467
   338
mueller@6467
   339
fun gen_add_ioa prep_term automaton_name action_type inp out int statetupel ini trans thy =
wenzelm@6508
   340
(writeln("Constructing automaton " ^ automaton_name ^ " ...");
mueller@6467
   341
let
mueller@6467
   342
val state_type_string = type_product_of_varlist(statetupel);
mueller@6467
   343
val styp = #T(rep_ctyp (read_ctyp (sign_of thy) state_type_string)) ;
mueller@6467
   344
val state_vars_tupel = "(" ^ (comma_list_of_varlist statetupel) ^ ")";
mueller@6467
   345
val state_vars_primed = "(" ^ (primed_comma_list_of_varlist statetupel) ^ ")";
mueller@6467
   346
val atyp = #T(rep_ctyp (read_ctyp (sign_of thy) action_type));
mueller@6467
   347
val inp_set_string = action_set_string thy atyp inp;
mueller@6467
   348
val out_set_string = action_set_string thy atyp out;
mueller@6467
   349
val int_set_string = action_set_string thy atyp int;
mueller@6467
   350
val inp_head_list = constructor_head_list thy action_type inp;
mueller@6467
   351
val out_head_list = constructor_head_list thy action_type out;
mueller@6467
   352
val int_head_list = constructor_head_list thy action_type int;
mueller@6467
   353
val overlap_flag = ((overlap inp out) andalso (overlap inp int) andalso (overlap out int)); 
mueller@6467
   354
val alt_string = make_alt_string thy inp_head_list out_head_list int_head_list 
mueller@6467
   355
							atyp statetupel trans;
mueller@6467
   356
val thy2 = (thy
mueller@6467
   357
|> ContConsts.add_consts
mueller@6467
   358
[(automaton_name ^ "_initial", "(" ^ state_type_string ^ ")set" ,NoSyn),
mueller@6467
   359
(automaton_name ^ "_asig", "(" ^ action_type ^ ")signature" ,NoSyn),
mueller@6467
   360
(automaton_name ^ "_trans",
mueller@6467
   361
 "(" ^ action_type ^ "," ^ state_type_string ^ ")transition set" ,NoSyn),
mueller@6467
   362
(automaton_name, "(" ^ action_type ^ "," ^ state_type_string ^ ")ioa" ,NoSyn)]
wenzelm@8438
   363
|> (#1 oo (PureThy.add_defs o map Thm.no_attributes))
mueller@6467
   364
[(automaton_name ^ "_initial_def",
mueller@6467
   365
automaton_name ^ "_initial == {" ^ state_vars_tupel ^ "." ^ ini ^ "}"),
mueller@6467
   366
(automaton_name ^ "_asig_def",
mueller@6467
   367
automaton_name ^ "_asig == (" ^
mueller@6467
   368
 inp_set_string ^ "," ^ out_set_string ^ "," ^ int_set_string ^ ")"),
mueller@6467
   369
(automaton_name ^ "_trans_def",
mueller@6467
   370
automaton_name ^ "_trans == {(" ^
mueller@6467
   371
 state_vars_tupel ^ ", act_of_" ^ automaton_name ^ ", " ^ state_vars_primed ^
mueller@6467
   372
"). case act_of_" ^ automaton_name ^ " of " ^ fst(alt_string) ^ "}"),
mueller@6467
   373
(automaton_name ^ "_def",
mueller@6467
   374
automaton_name ^ " == (" ^ automaton_name ^ "_asig, " ^ automaton_name ^
mueller@6467
   375
"_initial, " ^ automaton_name ^ "_trans,{},{})")
mueller@6467
   376
])
mueller@6467
   377
val chk_prime_list = (check_free_primed (#t(rep_cterm(read_cterm (sign_of thy2)
mueller@6467
   378
( "case act_of_" ^ automaton_name ^ " of " ^ snd(alt_string),Type("bool",[]))))));
mueller@6467
   379
in
mueller@6467
   380
(
mueller@6467
   381
if (chk_prime_list = []) then thy2
mueller@6467
   382
else (
mueller@6467
   383
error("Precondition or assignment terms in postconditions contain following primed variables:\n"
mueller@6467
   384
 ^ (list_elements_of chk_prime_list)))
mueller@6467
   385
)
mueller@6467
   386
end)
mueller@6467
   387
mueller@6467
   388
fun gen_add_composition prep_term automaton_name aut_list thy =
wenzelm@6508
   389
(writeln("Constructing automaton " ^ automaton_name ^ " ...");
mueller@6467
   390
let
mueller@6467
   391
val acttyp = check_ac thy aut_list; 
mueller@6467
   392
val st_typ = comp_st_type_of thy aut_list; 
mueller@6467
   393
val comp_list = clist aut_list;
mueller@6467
   394
in
mueller@6467
   395
thy
mueller@6467
   396
|> ContConsts.add_consts_i
mueller@6467
   397
[(automaton_name,
mueller@6467
   398
Type("*",
mueller@6467
   399
[Type("*",[Type("set",[acttyp]),Type("*",[Type("set",[acttyp]),Type("set",[acttyp])])]),
mueller@6467
   400
 Type("*",[Type("set",[st_typ]),
mueller@6467
   401
  Type("*",[Type("set",[Type("*",[st_typ,Type("*",[acttyp,st_typ])])]),
mueller@6467
   402
   Type("*",[Type("set",[Type("set",[acttyp])]),Type("set",[Type("set",[acttyp])])])])])])
mueller@6467
   403
,NoSyn)]
wenzelm@8438
   404
|> (#1 oo (PureThy.add_defs o map Thm.no_attributes))
mueller@6467
   405
[(automaton_name ^ "_def",
mueller@6467
   406
automaton_name ^ " == " ^ comp_list)]
mueller@6467
   407
end)
mueller@6467
   408
mueller@6467
   409
fun gen_add_restriction prep_term automaton_name aut_source actlist thy =
wenzelm@6508
   410
(writeln("Constructing automaton " ^ automaton_name ^ " ...");
mueller@6467
   411
let
mueller@6467
   412
val auttyp = aut_type_of thy aut_source;
mueller@6467
   413
val acttyp = act_type_of thy auttyp; 
mueller@6467
   414
val rest_set = action_set_string thy acttyp actlist
mueller@6467
   415
in
mueller@6467
   416
thy
mueller@6467
   417
|> ContConsts.add_consts_i
mueller@6467
   418
[(automaton_name, auttyp,NoSyn)]
wenzelm@8438
   419
|> (#1 oo (PureThy.add_defs o map Thm.no_attributes))
mueller@6467
   420
[(automaton_name ^ "_def",
mueller@6467
   421
automaton_name ^ " == restrict " ^ aut_source ^ " " ^ rest_set)] 
mueller@6467
   422
end)
mueller@6467
   423
fun gen_add_hiding prep_term automaton_name aut_source actlist thy =
wenzelm@6508
   424
(writeln("Constructing automaton " ^ automaton_name ^ " ...");
mueller@6467
   425
let
mueller@6467
   426
val auttyp = aut_type_of thy aut_source;
mueller@6467
   427
val acttyp = act_type_of thy auttyp; 
mueller@6467
   428
val hid_set = action_set_string thy acttyp actlist
mueller@6467
   429
in
mueller@6467
   430
thy
mueller@6467
   431
|> ContConsts.add_consts_i
mueller@6467
   432
[(automaton_name, auttyp,NoSyn)]
wenzelm@8438
   433
|> (#1 oo (PureThy.add_defs o map Thm.no_attributes))
mueller@6467
   434
[(automaton_name ^ "_def",
mueller@6467
   435
automaton_name ^ " == hide " ^ aut_source ^ " " ^ hid_set)] 
mueller@6467
   436
end)
mueller@6467
   437
mueller@6467
   438
fun ren_act_type_of thy funct =
mueller@6467
   439
let
mueller@6467
   440
(* going into a pseudo-proof-state to enable the use of function read *)
mueller@6467
   441
val _ = goal thy (funct ^ " = t");
mueller@6467
   442
fun arg_typ_of (Type("fun",[a,b])) = a |
mueller@6467
   443
arg_typ_of _ = raise malformed;
mueller@6467
   444
in
mueller@6467
   445
arg_typ_of(#T(rep_cterm(cterm_of (sign_of thy) (read(funct)))))
mueller@6467
   446
handle malformed => error ("could not extract argument type of renaming function term")
mueller@6467
   447
end;
mueller@6467
   448
 
mueller@6467
   449
fun gen_add_rename prep_term automaton_name aut_source fun_name thy =
wenzelm@6508
   450
(writeln("Constructing automaton " ^ automaton_name ^ " ...");
mueller@6467
   451
let
mueller@6467
   452
val auttyp = aut_type_of thy aut_source;
mueller@6467
   453
val st_typ = st_type_of thy auttyp;
mueller@6467
   454
val acttyp = ren_act_type_of thy fun_name
mueller@6467
   455
in
mueller@6467
   456
thy
mueller@6467
   457
|> ContConsts.add_consts_i
mueller@6467
   458
[(automaton_name,
mueller@6467
   459
Type("*",
mueller@6467
   460
[Type("*",[Type("set",[acttyp]),Type("*",[Type("set",[acttyp]),Type("set",[acttyp])])]),
mueller@6467
   461
 Type("*",[Type("set",[st_typ]),
mueller@6467
   462
  Type("*",[Type("set",[Type("*",[st_typ,Type("*",[acttyp,st_typ])])]),
mueller@6467
   463
   Type("*",[Type("set",[Type("set",[acttyp])]),Type("set",[Type("set",[acttyp])])])])])])
mueller@6467
   464
,NoSyn)]
wenzelm@8438
   465
|> (#1 oo (PureThy.add_defs o map Thm.no_attributes))
mueller@6467
   466
[(automaton_name ^ "_def",
mueller@6467
   467
automaton_name ^ " == rename " ^ aut_source ^ " (" ^ fun_name ^ ")")]
mueller@6467
   468
end)
mueller@6467
   469
mueller@6467
   470
(* external interfaces *)
mueller@6467
   471
mueller@6467
   472
fun read_term sg str =
wenzelm@8100
   473
  read_cterm sg (str, HOLogic.termT);
mueller@6467
   474
mueller@6467
   475
fun cert_term sg tm =
mueller@6467
   476
  cterm_of sg tm handle TERM (msg, _) => error msg;
mueller@6467
   477
mueller@6467
   478
in
mueller@6467
   479
mueller@6467
   480
val add_ioa = gen_add_ioa read_term;
mueller@6467
   481
val add_ioa_i = gen_add_ioa cert_term;
mueller@6467
   482
val add_composition = gen_add_composition read_term;
mueller@6467
   483
val add_composition_i = gen_add_composition cert_term;
mueller@6467
   484
val add_hiding = gen_add_hiding read_term;
mueller@6467
   485
val add_hiding_i = gen_add_hiding cert_term;
mueller@6467
   486
val add_restriction = gen_add_restriction read_term;
mueller@6467
   487
val add_restriction_i = gen_add_restriction cert_term;
mueller@6467
   488
val add_rename = gen_add_rename read_term;
mueller@6467
   489
val add_rename_i = gen_add_rename cert_term;
mueller@6467
   490
mueller@6467
   491
end
mueller@6467
   492
wenzelm@6508
   493
wenzelm@6508
   494
wenzelm@6508
   495
(** outer syntax **)
wenzelm@6508
   496
wenzelm@6508
   497
(* prepare results *)
wenzelm@6508
   498
wenzelm@6508
   499
(*encoding transition specifications with a element of ParseTrans*)
wenzelm@6508
   500
datatype ParseTrans = Rel of string | PP of string*(string*string)list;
wenzelm@6508
   501
fun mk_trans_of_rel s = Rel(s);
wenzelm@6508
   502
fun mk_trans_of_prepost (s,l) = PP(s,l); 
wenzelm@6508
   503
wenzelm@6508
   504
fun trans_of (a, Rel b) = (a, b, [("", "")])
wenzelm@6508
   505
  | trans_of (a, PP (b, l)) = (a, b, l);
wenzelm@6508
   506
wenzelm@6508
   507
wenzelm@6508
   508
fun mk_ioa_decl (aut, ((((((action_type, inp), out), int), states), initial), trans)) =
wenzelm@6508
   509
  add_ioa aut action_type inp out int states initial (map trans_of trans);
wenzelm@6508
   510
wenzelm@6508
   511
fun mk_composition_decl (aut, autlist) =
wenzelm@6508
   512
  add_composition aut autlist;
wenzelm@6508
   513
wenzelm@6508
   514
fun mk_hiding_decl (aut, (actlist, source_aut)) =
wenzelm@6508
   515
  add_hiding aut source_aut actlist;
wenzelm@6508
   516
wenzelm@6508
   517
fun mk_restriction_decl (aut, (source_aut, actlist)) =
wenzelm@6508
   518
  add_restriction aut source_aut actlist;
wenzelm@6508
   519
wenzelm@6508
   520
fun mk_rename_decl (aut, (source_aut, rename_f)) =
wenzelm@6508
   521
  add_rename aut source_aut rename_f;
wenzelm@6508
   522
wenzelm@6508
   523
wenzelm@6508
   524
(* parsers *)
wenzelm@6508
   525
wenzelm@6723
   526
local structure P = OuterParse and K = OuterSyntax.Keyword in
wenzelm@6508
   527
wenzelm@6723
   528
val actionlist = P.list1 P.term;
wenzelm@6723
   529
val inputslist = P.$$$ "inputs" |-- actionlist;
wenzelm@6723
   530
val outputslist = P.$$$ "outputs" |-- actionlist;
wenzelm@6723
   531
val internalslist = P.$$$ "internals" |-- actionlist;
wenzelm@6723
   532
val stateslist = P.$$$ "states" |-- Scan.repeat1 (P.name --| P.$$$ "::" -- P.typ);
wenzelm@6723
   533
val initial = P.$$$ "initially" |-- P.term;
wenzelm@6723
   534
val assign_list = P.list1 (P.name --| P.$$$ ":=" -- P.term);
wenzelm@6723
   535
val pre = P.$$$ "pre" |-- P.term;
wenzelm@6723
   536
val post = P.$$$ "post" |-- assign_list;
wenzelm@6508
   537
val pre1 = (pre -- (Scan.optional post [])) >> mk_trans_of_prepost;
wenzelm@6508
   538
val post1 = ((Scan.optional pre "True") -- post) >> mk_trans_of_prepost;
wenzelm@6723
   539
val transrel =  (P.$$$ "transrel" |-- P.term) >> mk_trans_of_rel;
wenzelm@6723
   540
val transition = P.term -- (transrel || pre1 || post1);
wenzelm@6723
   541
val translist = P.$$$ "transitions" |-- Scan.repeat1 transition;
wenzelm@6508
   542
wenzelm@6508
   543
val ioa_decl =
wenzelm@6723
   544
  (P.name -- (P.$$$ "=" |--
wenzelm@6723
   545
    (P.$$$ "signature" |--
wenzelm@6723
   546
      (P.$$$ "actions" |--
wenzelm@6723
   547
        (P.typ --
wenzelm@6508
   548
          (Scan.optional inputslist []) --
wenzelm@6508
   549
          (Scan.optional outputslist []) --
wenzelm@6508
   550
          (Scan.optional internalslist []) --
wenzelm@6508
   551
          stateslist --
wenzelm@6508
   552
          (Scan.optional initial "True") --
wenzelm@6508
   553
        translist))))) >> mk_ioa_decl ||
wenzelm@6723
   554
  (P.name -- (P.$$$ "=" |-- (P.$$$ "compose" |-- P.list1 P.name))) >> mk_composition_decl ||
wenzelm@8733
   555
  (P.name -- (P.$$$ "=" |-- (P.$$$ "hide_action" |-- P.list1 P.term -- (P.$$$ "in" |-- P.name))))
wenzelm@6723
   556
    >> mk_hiding_decl ||
wenzelm@6723
   557
  (P.name -- (P.$$$ "=" |-- (P.$$$ "restrict" |-- P.name -- (P.$$$ "to" |-- P.list1 P.term))))
wenzelm@6508
   558
    >> mk_restriction_decl ||
wenzelm@7040
   559
  (P.name -- (P.$$$ "=" |-- (P.$$$ "rename" |-- P.name -- (P.$$$ "using" |-- P.term))))
wenzelm@6723
   560
    >> mk_rename_decl;
wenzelm@6508
   561
wenzelm@6723
   562
val automatonP =
wenzelm@6723
   563
  OuterSyntax.command "automaton" "define Lynch/Vaandrager-style I/O automaton" K.thy_decl
wenzelm@6723
   564
    (ioa_decl >> Toplevel.theory);
wenzelm@6508
   565
mueller@6467
   566
end;
wenzelm@6508
   567
wenzelm@6508
   568
wenzelm@6508
   569
(* setup outer syntax *)
wenzelm@6508
   570
wenzelm@6508
   571
val _ = OuterSyntax.add_keywords ["signature", "actions", "inputs",
wenzelm@6508
   572
  "outputs", "internals", "states", "initially", "transitions", "pre",
wenzelm@8733
   573
  "post", "transrel", ":=", "compose", "hide_action", "in", "restrict", "to",
wenzelm@7040
   574
  "rename", "using"];
wenzelm@6508
   575
wenzelm@6508
   576
val _ = OuterSyntax.add_parsers [automatonP];
wenzelm@6508
   577
wenzelm@6508
   578
wenzelm@6508
   579
end;