src/HOL/Statespace/state_fun.ML
author wenzelm
Sun Mar 08 17:26:14 2009 +0100 (2009-03-08)
changeset 30364 577edc39b501
parent 30289 b28caca9157f
child 30528 7173bf123335
permissions -rw-r--r--
moved basic algebra of long names from structure NameSpace to Long_Name;
haftmann@28308
     1
(*  Title:      HOL/Statespace/state_fun.ML
schirmer@25171
     2
    Author:     Norbert Schirmer, TU Muenchen
schirmer@25171
     3
*)
schirmer@25171
     4
schirmer@25408
     5
signature STATE_FUN =
schirmer@25408
     6
sig
schirmer@25408
     7
  val lookupN : string
schirmer@25408
     8
  val updateN : string
schirmer@25171
     9
wenzelm@29302
    10
  val mk_constr : theory -> typ -> term
wenzelm@29302
    11
  val mk_destr : theory -> typ -> term
schirmer@25408
    12
wenzelm@29302
    13
  val lookup_simproc : simproc
wenzelm@29302
    14
  val update_simproc : simproc
wenzelm@29302
    15
  val ex_lookup_eq_simproc : simproc
wenzelm@29302
    16
  val ex_lookup_ss : simpset
wenzelm@29302
    17
  val lazy_conj_simproc : simproc
wenzelm@29302
    18
  val string_eq_simp_tac : int -> tactic
schirmer@25408
    19
wenzelm@29302
    20
  val setup : theory -> theory
schirmer@25408
    21
end;
schirmer@25408
    22
schirmer@25408
    23
structure StateFun: STATE_FUN = 
schirmer@25171
    24
struct
schirmer@25171
    25
schirmer@25171
    26
val lookupN = "StateFun.lookup";
schirmer@25171
    27
val updateN = "StateFun.update";
schirmer@25171
    28
schirmer@25408
    29
val sel_name = HOLogic.dest_string;
schirmer@25171
    30
schirmer@25171
    31
fun mk_name i t =
schirmer@25171
    32
  (case try sel_name t of
schirmer@25171
    33
     SOME name => name
schirmer@25171
    34
   | NONE => (case t of 
schirmer@25171
    35
               Free (x,_) => x
schirmer@25171
    36
              |Const (x,_) => x
schirmer@25171
    37
              |_ => "x"^string_of_int i))
schirmer@25171
    38
               
schirmer@25171
    39
local
schirmer@25171
    40
val conj1_False = thm "conj1_False";
schirmer@25171
    41
val conj2_False = thm "conj2_False";
schirmer@25171
    42
val conj_True = thm "conj_True";
schirmer@25171
    43
val conj_cong = thm "conj_cong";
schirmer@25171
    44
fun isFalse (Const ("False",_)) = true
schirmer@25171
    45
  | isFalse _ = false;
schirmer@25171
    46
fun isTrue (Const ("True",_)) = true
schirmer@25171
    47
  | isTrue _ = false;
schirmer@25171
    48
schirmer@25171
    49
in
schirmer@25171
    50
val lazy_conj_simproc =
wenzelm@29064
    51
  Simplifier.simproc @{theory HOL} "lazy_conj_simp" ["P & Q"]
schirmer@25171
    52
    (fn thy => fn ss => fn t =>
schirmer@25171
    53
      (case t of (Const ("op &",_)$P$Q) => 
schirmer@25171
    54
         let
schirmer@25171
    55
            val P_P' = Simplifier.rewrite ss (cterm_of thy P);
schirmer@25171
    56
            val P' = P_P' |> prop_of |> Logic.dest_equals |> #2 
schirmer@25171
    57
         in if isFalse P'
schirmer@25171
    58
            then SOME (conj1_False OF [P_P'])
schirmer@25171
    59
            else 
schirmer@25171
    60
              let
schirmer@25171
    61
                val Q_Q' = Simplifier.rewrite ss (cterm_of thy Q);
schirmer@25171
    62
                val Q' = Q_Q' |> prop_of |> Logic.dest_equals |> #2 
schirmer@25171
    63
              in if isFalse Q'
schirmer@25171
    64
                 then SOME (conj2_False OF [Q_Q'])
schirmer@25171
    65
                 else if isTrue P' andalso isTrue Q'
schirmer@25171
    66
                      then SOME (conj_True OF [P_P', Q_Q'])
schirmer@25171
    67
                      else if P aconv P' andalso Q aconv Q' then NONE
schirmer@25171
    68
                           else SOME (conj_cong OF [P_P', Q_Q'])
schirmer@25171
    69
              end 
schirmer@25171
    70
         end
schirmer@25171
    71
        
schirmer@25171
    72
      | _ => NONE));
schirmer@25171
    73
schirmer@25171
    74
val string_eq_simp_tac =
schirmer@25171
    75
     simp_tac (HOL_basic_ss 
schirmer@25171
    76
                 addsimps (thms "list.inject"@thms "char.inject"@simp_thms)
wenzelm@27099
    77
                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc]
schirmer@25171
    78
                 addcongs [thm "block_conj_cong"])
schirmer@25171
    79
end;
schirmer@25171
    80
schirmer@25171
    81
schirmer@25171
    82
schirmer@25171
    83
local
schirmer@25171
    84
val rules = 
schirmer@25171
    85
 [thm "StateFun.lookup_update_id_same",
schirmer@25171
    86
  thm "StateFun.id_id_cancel",
schirmer@25171
    87
  thm "StateFun.lookup_update_same",thm "StateFun.lookup_update_other"
schirmer@25171
    88
  ]
schirmer@25171
    89
in
schirmer@25171
    90
val lookup_ss = (HOL_basic_ss 
schirmer@25171
    91
                 addsimps (thms "list.inject"@thms "char.inject"@simp_thms@rules)
wenzelm@27099
    92
                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc]
schirmer@25171
    93
                 addcongs [thm "block_conj_cong"]
schirmer@25171
    94
                 addSolver StateSpace.distinctNameSolver) 
schirmer@25171
    95
end;
schirmer@25171
    96
schirmer@25171
    97
val ex_lookup_ss = HOL_ss addsimps [thm "StateFun.ex_id"];
schirmer@25171
    98
schirmer@25171
    99
structure StateFunArgs =
schirmer@25171
   100
struct
schirmer@25171
   101
  type T = (simpset * simpset * bool); 
schirmer@25171
   102
           (* lookup simpset, ex_lookup simpset, are simprocs installed *)
schirmer@25171
   103
  val empty = (empty_ss, empty_ss, false);
schirmer@25171
   104
  val extend = I;
schirmer@25171
   105
  fun merge pp ((ss1,ex_ss1,b1),(ss2,ex_ss2,b2)) = 
schirmer@25171
   106
               (merge_ss (ss1,ss2)
schirmer@25171
   107
               ,merge_ss (ex_ss1,ex_ss2)
schirmer@25171
   108
               ,b1 orelse b2);
schirmer@25171
   109
end;
schirmer@25171
   110
schirmer@25171
   111
schirmer@25171
   112
structure StateFunData = GenericDataFun(StateFunArgs);
schirmer@25171
   113
schirmer@25171
   114
val init_state_fun_data =
schirmer@25171
   115
  Context.theory_map (StateFunData.put (lookup_ss,ex_lookup_ss,false));
schirmer@25171
   116
schirmer@25171
   117
val lookup_simproc =
schirmer@25171
   118
  Simplifier.simproc (the_context ()) "lookup_simp" ["lookup d n (update d' c m v s)"]
schirmer@25171
   119
    (fn thy => fn ss => fn t =>
schirmer@25171
   120
      (case t of (Const ("StateFun.lookup",lT)$destr$n$
schirmer@25171
   121
                   (s as Const ("StateFun.update",uT)$_$_$_$_$_)) =>
schirmer@25171
   122
        (let
schirmer@25171
   123
          val (_::_::_::_::sT::_) = binder_types uT;
schirmer@25171
   124
          val mi = maxidx_of_term t;
schirmer@25171
   125
          fun mk_upds (Const ("StateFun.update",uT)$d'$c$m$v$s) =
schirmer@25171
   126
               let
schirmer@25171
   127
                 val (_::_::_::fT::_::_) = binder_types uT;
schirmer@25171
   128
                 val vT = domain_type fT;
schirmer@25171
   129
                 val (s',cnt) = mk_upds s;
schirmer@25171
   130
                 val (v',cnt') = 
schirmer@25171
   131
                      (case v of
schirmer@25171
   132
                        Const ("StateFun.K_statefun",KT)$v''
schirmer@25171
   133
                         => (case v'' of 
schirmer@25171
   134
                             (Const ("StateFun.lookup",_)$(d as (Const ("Fun.id",_)))$n'$_)
schirmer@25171
   135
                              => if d aconv c andalso n aconv m andalso m aconv n' 
schirmer@25171
   136
                                 then (v,cnt) (* Keep value so that 
schirmer@25171
   137
                                                 lookup_update_id_same can fire *)
schirmer@25171
   138
                                 else (Const ("StateFun.K_statefun",KT)$Var (("v",cnt),vT),
schirmer@25171
   139
                                       cnt+1)
schirmer@25171
   140
                              | _ => (Const ("StateFun.K_statefun",KT)$Var (("v",cnt),vT),
schirmer@25171
   141
                                       cnt+1))
schirmer@25171
   142
                       | _ => (v,cnt));
schirmer@25171
   143
               in (Const ("StateFun.update",uT)$d'$c$m$v'$s',cnt')
schirmer@25171
   144
               end
schirmer@25171
   145
            | mk_upds s = (Var (("s",mi+1),sT),mi+2);
schirmer@25171
   146
          
schirmer@25171
   147
          val ct = cterm_of thy 
schirmer@25171
   148
                    (Const ("StateFun.lookup",lT)$destr$n$(fst (mk_upds s)));
wenzelm@30289
   149
          val ctxt = Simplifier.the_context ss;
schirmer@25171
   150
          val basic_ss = #1 (StateFunData.get (Context.Proof ctxt));
schirmer@25171
   151
          val ss' = Simplifier.context 
schirmer@25171
   152
                     (Config.map MetaSimplifier.simp_depth_limit (K 100) ctxt) basic_ss;
schirmer@25171
   153
          val thm = Simplifier.rewrite ss' ct;
schirmer@25171
   154
        in if (op aconv) (Logic.dest_equals (prop_of thm))
schirmer@25171
   155
           then NONE
schirmer@25171
   156
           else SOME thm
schirmer@25171
   157
        end
schirmer@25171
   158
        handle Option => NONE)
schirmer@25171
   159
         
schirmer@25171
   160
      | _ => NONE ));
schirmer@25171
   161
schirmer@25171
   162
schirmer@25171
   163
fun foldl1 f (x::xs) = foldl f x xs;
schirmer@25171
   164
schirmer@25171
   165
local
schirmer@25171
   166
val update_apply = thm "StateFun.update_apply";
schirmer@25171
   167
val meta_ext = thm "StateFun.meta_ext";
schirmer@25171
   168
val o_apply = thm "Fun.o_apply";
schirmer@25171
   169
val ss' = (HOL_ss addsimps (update_apply::o_apply::thms "list.inject"@thms "char.inject")
wenzelm@27099
   170
                 addsimprocs [DatatypePackage.distinct_simproc,lazy_conj_simproc,StateSpace.distinct_simproc]
schirmer@25171
   171
                 addcongs [thm "block_conj_cong"]);
schirmer@25171
   172
in
schirmer@25171
   173
val update_simproc =
schirmer@25171
   174
  Simplifier.simproc (the_context ()) "update_simp" ["update d c n v s"]
schirmer@25171
   175
    (fn thy => fn ss => fn t =>
schirmer@25171
   176
      (case t of ((upd as Const ("StateFun.update", uT)) $ d $ c $ n $ v $ s) =>
schirmer@25171
   177
         let 
schirmer@25171
   178
            
schirmer@25171
   179
             val (_::_::_::_::sT::_) = binder_types uT;
schirmer@25171
   180
                (*"('v => 'a1) => ('a2 => 'v) => 'n => ('a1 => 'a2) => ('n => 'v) => ('n => 'v)"*)
schirmer@25171
   181
             fun init_seed s = (Bound 0,Bound 0, [("s",sT)],[], false);
schirmer@25171
   182
schirmer@25171
   183
             fun mk_comp f fT g gT =
schirmer@25171
   184
               let val T = (domain_type fT --> range_type gT) 
schirmer@25171
   185
               in (Const ("Fun.comp",gT --> fT --> T)$g$f,T) end
schirmer@25171
   186
schirmer@25171
   187
             fun mk_comps fs = 
schirmer@25171
   188
                   foldl1 (fn ((f,fT),(g,gT)) => mk_comp f fT g gT) fs;
schirmer@25171
   189
schirmer@25171
   190
             fun append n c cT f fT d dT comps =
schirmer@25171
   191
               (case AList.lookup (op aconv) comps n of
schirmer@25171
   192
                  SOME gTs => AList.update (op aconv) 
schirmer@25171
   193
                                    (n,[(c,cT),(f,fT),(d,dT)]@gTs) comps
schirmer@25171
   194
                | NONE => AList.update (op aconv) (n,[(c,cT),(f,fT),(d,dT)]) comps)
schirmer@25171
   195
schirmer@25171
   196
             fun split_list (x::xs) = let val (xs',y) = split_last xs in (x,xs',y) end
schirmer@25171
   197
               | split_list _ = error "StateFun.split_list";
schirmer@25171
   198
schirmer@25171
   199
             fun merge_upds n comps =
schirmer@25171
   200
               let val ((c,cT),fs,(d,dT)) = split_list (the (AList.lookup (op aconv) comps n))
schirmer@25171
   201
               in ((c,cT),fst (mk_comps fs),(d,dT)) end;
schirmer@25171
   202
schirmer@25171
   203
             (* mk_updterm returns 
schirmer@25171
   204
              *  - (orig-term-skeleton,simplified-term-skeleton, vars, b)
schirmer@25171
   205
              *     where boolean b tells if a simplification has occured.
schirmer@25171
   206
                    "orig-term-skeleton = simplified-term-skeleton" is
schirmer@25171
   207
              *     the desired simplification rule.
schirmer@25171
   208
              * The algorithm first walks down the updates to the seed-state while
schirmer@25171
   209
              * memorising the updates in the already-table. While walking up the
schirmer@25171
   210
              * updates again, the optimised term is constructed.
schirmer@25171
   211
              *)
schirmer@25171
   212
             fun mk_updterm already
schirmer@25171
   213
                 (t as ((upd as Const ("StateFun.update", uT)) $ d $ c $ n $ v $ s)) =
schirmer@25171
   214
                      let
schirmer@25171
   215
                         fun rest already = mk_updterm already;
schirmer@25171
   216
                         val (dT::cT::nT::vT::sT::_) = binder_types uT;
schirmer@25171
   217
                          (*"('v => 'a1) => ('a2 => 'v) => 'n => ('a1 => 'a2) => 
schirmer@25171
   218
                                ('n => 'v) => ('n => 'v)"*)
schirmer@25171
   219
                      in if member (op aconv) already n
schirmer@25171
   220
                         then (case rest already s of
schirmer@25171
   221
                                 (trm,trm',vars,comps,_) =>
schirmer@25171
   222
                                   let
schirmer@25171
   223
                                     val i = length vars;
schirmer@25171
   224
                                     val kv = (mk_name i n,vT);
schirmer@25171
   225
                                     val kb = Bound i;
schirmer@25171
   226
                                     val comps' = append n c cT kb vT d dT comps;
schirmer@25171
   227
                                   in (upd$d$c$n$kb$trm, trm', kv::vars,comps',true) end)
schirmer@25171
   228
                         else
schirmer@25171
   229
                          (case rest (n::already) s of
schirmer@25171
   230
                             (trm,trm',vars,comps,b) =>
schirmer@25171
   231
                                let
schirmer@25171
   232
                                   val i = length vars;
schirmer@25171
   233
                                   val kv = (mk_name i n,vT);
schirmer@25171
   234
                                   val kb = Bound i;
schirmer@25171
   235
                                   val comps' = append n c cT kb vT d dT comps;
schirmer@25171
   236
                                   val ((c',c'T),f',(d',d'T)) = merge_upds n comps';
schirmer@25171
   237
                                   val vT' = range_type d'T --> domain_type c'T;
schirmer@25171
   238
                                   val upd' = Const ("StateFun.update",d'T --> c'T --> nT --> vT' --> sT --> sT);
schirmer@25171
   239
                                in (upd$d$c$n$kb$trm, upd'$d'$c'$n$f'$trm', kv::vars,comps',b) 
schirmer@25171
   240
                                end)
schirmer@25171
   241
                      end
schirmer@25171
   242
               | mk_updterm _ t = init_seed t;
schirmer@25171
   243
wenzelm@30289
   244
	     val ctxt = Simplifier.the_context ss |>
schirmer@25171
   245
                        Config.map MetaSimplifier.simp_depth_limit (K 100);
schirmer@25171
   246
             val ss1 = Simplifier.context ctxt ss';
schirmer@25171
   247
             val ss2 = Simplifier.context ctxt 
schirmer@25171
   248
                         (#1 (StateFunData.get (Context.Proof ctxt)));
schirmer@25171
   249
         in (case mk_updterm [] t of
schirmer@25171
   250
               (trm,trm',vars,_,true)
schirmer@25171
   251
                => let
schirmer@25171
   252
                     val eq1 = Goal.prove ctxt [] [] 
wenzelm@27330
   253
                                      (list_all (vars, Logic.mk_equals (trm, trm')))
schirmer@25171
   254
                                      (fn _ => rtac meta_ext 1 THEN 
schirmer@25171
   255
                                               simp_tac ss1 1);
schirmer@25171
   256
                     val eq2 = Simplifier.asm_full_rewrite ss2 (Thm.dest_equals_rhs (cprop_of eq1));
schirmer@25171
   257
                   in SOME (transitive eq1 eq2) end
schirmer@25171
   258
             | _ => NONE)
schirmer@25171
   259
         end
schirmer@25171
   260
       | _ => NONE));
schirmer@25171
   261
end
schirmer@25171
   262
schirmer@25171
   263
schirmer@25171
   264
schirmer@25171
   265
schirmer@25171
   266
local
schirmer@25171
   267
val swap_ex_eq = thm "StateFun.swap_ex_eq";
schirmer@25171
   268
fun is_selector thy T sel =
schirmer@25171
   269
     let 
schirmer@25171
   270
       val (flds,more) = RecordPackage.get_recT_fields thy T 
schirmer@25171
   271
     in member (fn (s,(n,_)) => n=s) (more::flds) sel
schirmer@25171
   272
     end;
schirmer@25171
   273
in
schirmer@25171
   274
val ex_lookup_eq_simproc =
wenzelm@29064
   275
  Simplifier.simproc @{theory HOL} "ex_lookup_eq_simproc" ["Ex t"]
schirmer@25171
   276
    (fn thy => fn ss => fn t =>
schirmer@25171
   277
       let
schirmer@25171
   278
         val ctxt = Simplifier.the_context ss |>
schirmer@25171
   279
                    Config.map MetaSimplifier.simp_depth_limit (K 100)
schirmer@25171
   280
         val ex_lookup_ss = #2 (StateFunData.get (Context.Proof ctxt));
schirmer@25171
   281
         val ss' = (Simplifier.context ctxt ex_lookup_ss);
schirmer@25171
   282
         fun prove prop =
schirmer@25171
   283
           Goal.prove_global thy [] [] prop 
schirmer@25171
   284
             (fn _ => record_split_simp_tac [] (K ~1) 1 THEN
schirmer@25171
   285
                      simp_tac ss' 1);
schirmer@25171
   286
schirmer@25171
   287
         fun mkeq (swap,Teq,lT,lo,d,n,x,s) i =
schirmer@25171
   288
               let val (_::nT::_) = binder_types lT;
schirmer@25171
   289
                         (*  ('v => 'a) => 'n => ('n => 'v) => 'a *)
schirmer@25171
   290
                   val x' = if not (loose_bvar1 (x,0))
schirmer@25171
   291
			    then Bound 1
schirmer@25171
   292
                            else raise TERM ("",[x]);
schirmer@25171
   293
                   val n' = if not (loose_bvar1 (n,0))
schirmer@25171
   294
			    then Bound 2
schirmer@25171
   295
                            else raise TERM ("",[n]);
schirmer@25171
   296
                   val sel' = lo $ d $ n' $ s;
schirmer@25171
   297
                  in (Const ("op =",Teq)$sel'$x',hd (binder_types Teq),nT,swap) end;
schirmer@25171
   298
schirmer@25171
   299
         fun dest_state (s as Bound 0) = s
schirmer@25171
   300
           | dest_state (s as (Const (sel,sT)$Bound 0)) =
schirmer@25171
   301
               if is_selector thy (domain_type sT) sel
schirmer@25171
   302
               then s
schirmer@25171
   303
               else raise TERM ("StateFun.ex_lookup_eq_simproc: not a record slector",[s])
schirmer@25171
   304
           | dest_state s = 
schirmer@25171
   305
                    raise TERM ("StateFun.ex_lookup_eq_simproc: not a record slector",[s]);
schirmer@25171
   306
  
schirmer@25171
   307
         fun dest_sel_eq (Const ("op =",Teq)$
schirmer@25171
   308
                           ((lo as (Const ("StateFun.lookup",lT)))$d$n$s)$X) =
schirmer@25171
   309
                           (false,Teq,lT,lo,d,n,X,dest_state s)
schirmer@25171
   310
           | dest_sel_eq (Const ("op =",Teq)$X$
schirmer@25171
   311
                            ((lo as (Const ("StateFun.lookup",lT)))$d$n$s)) =
schirmer@25171
   312
                           (true,Teq,lT,lo,d,n,X,dest_state s)
schirmer@25171
   313
           | dest_sel_eq _ = raise TERM ("",[]);
schirmer@25171
   314
schirmer@25171
   315
       in
schirmer@25171
   316
         (case t of
schirmer@25171
   317
           (Const ("Ex",Tex)$Abs(s,T,t)) =>
schirmer@25171
   318
             (let val (eq,eT,nT,swap) = mkeq (dest_sel_eq t) 0;
schirmer@25171
   319
                  val prop = list_all ([("n",nT),("x",eT)],
schirmer@25171
   320
                              Logic.mk_equals (Const ("Ex",Tex)$Abs(s,T,eq),
schirmer@25171
   321
                                               HOLogic.true_const));
schirmer@25171
   322
                  val thm = standard (prove prop);
schirmer@25171
   323
                  val thm' = if swap then swap_ex_eq OF [thm] else thm
schirmer@25171
   324
             in SOME thm' end
schirmer@25171
   325
             handle TERM _ => NONE)
schirmer@25171
   326
          | _ => NONE)
schirmer@25171
   327
        end handle Option => NONE) 
schirmer@25171
   328
end;
schirmer@25171
   329
schirmer@25171
   330
val val_sfx = "V";
schirmer@25171
   331
val val_prfx = "StateFun."
schirmer@25171
   332
fun deco base_prfx s = val_prfx ^ (base_prfx ^ suffix val_sfx s);
schirmer@25171
   333
schirmer@25171
   334
fun mkUpper str = 
schirmer@25171
   335
  (case String.explode str of
schirmer@25171
   336
    [] => ""
schirmer@25171
   337
   | c::cs => String.implode (Char.toUpper c::cs ))
schirmer@25171
   338
wenzelm@30364
   339
fun mkName (Type (T,args)) = concat (map mkName args) ^ mkUpper (Long_Name.base_name T)
wenzelm@30364
   340
  | mkName (TFree (x,_)) = mkUpper (Long_Name.base_name x)
wenzelm@30364
   341
  | mkName (TVar ((x,_),_)) = mkUpper (Long_Name.base_name x);
schirmer@25171
   342
schirmer@25171
   343
fun is_datatype thy n = is_some (Symtab.lookup (DatatypePackage.get_datatypes thy) n);
schirmer@25171
   344
wenzelm@30280
   345
fun mk_map "List.list" = Syntax.const "List.map"
wenzelm@30364
   346
  | mk_map n = Syntax.const ("StateFun.map_" ^ Long_Name.base_name n);
schirmer@25171
   347
schirmer@25171
   348
fun gen_constr_destr comp prfx thy (Type (T,[])) = 
wenzelm@30364
   349
      Syntax.const (deco prfx (mkUpper (Long_Name.base_name T)))
schirmer@25171
   350
  | gen_constr_destr comp prfx thy (T as Type ("fun",_)) =
schirmer@25171
   351
     let val (argTs,rangeT) = strip_type T;
schirmer@25171
   352
     in comp 
schirmer@25171
   353
          (Syntax.const (deco prfx (concat (map mkName argTs) ^ "Fun")))
schirmer@25171
   354
          (fold (fn x => fn y => x$y)
schirmer@25171
   355
               (replicate (length argTs) (Syntax.const "StateFun.map_fun"))
schirmer@25171
   356
               (gen_constr_destr comp prfx thy rangeT))
schirmer@25171
   357
     end
schirmer@25171
   358
  | gen_constr_destr comp prfx thy (T' as Type (T,argTs)) = 
schirmer@25171
   359
     if is_datatype thy T
schirmer@25171
   360
     then (* datatype args are recursively embedded into val *)
schirmer@25171
   361
         (case argTs of
schirmer@25171
   362
           [argT] => comp 
wenzelm@30364
   363
                     ((Syntax.const (deco prfx (mkUpper (Long_Name.base_name T)))))
schirmer@25171
   364
                     ((mk_map T $ gen_constr_destr comp prfx thy argT))
schirmer@25171
   365
          | _ => raise (TYPE ("StateFun.gen_constr_destr",[T'],[])))
schirmer@25171
   366
     else (* type args are not recursively embedded into val *)
wenzelm@30364
   367
           Syntax.const (deco prfx (concat (map mkName argTs) ^ mkUpper (Long_Name.base_name T)))
schirmer@25171
   368
  | gen_constr_destr thy _ _ T = raise (TYPE ("StateFun.gen_constr_destr",[T],[]));
schirmer@25171
   369
                   
schirmer@25171
   370
val mk_constr = gen_constr_destr (fn a => fn b => Syntax.const "Fun.comp" $ a $ b) ""
schirmer@25171
   371
val mk_destr =  gen_constr_destr (fn a => fn b => Syntax.const "Fun.comp" $ b $ a) "the_"
schirmer@25171
   372
schirmer@25171
   373
  
schirmer@25171
   374
fun statefun_simp_attr src (ctxt,thm) = 
schirmer@25171
   375
  let
schirmer@25171
   376
     val (lookup_ss,ex_lookup_ss,simprocs_active) = StateFunData.get ctxt;
schirmer@25171
   377
     val (lookup_ss', ex_lookup_ss') = 
schirmer@25171
   378
	   (case (concl_of thm) of
schirmer@25171
   379
            (_$((Const ("Ex",_)$_))) => (lookup_ss, ex_lookup_ss addsimps [thm])
schirmer@25171
   380
            | _ => (lookup_ss addsimps [thm], ex_lookup_ss))
schirmer@25171
   381
     fun activate_simprocs ctxt =
schirmer@25171
   382
          if simprocs_active then ctxt
wenzelm@26496
   383
          else Simplifier.map_ss (fn ss => ss addsimprocs [lookup_simproc,update_simproc]) ctxt
schirmer@25171
   384
               
schirmer@25171
   385
schirmer@25171
   386
     val ctxt' = ctxt 
schirmer@25171
   387
         |> activate_simprocs
schirmer@25171
   388
         |> (StateFunData.put (lookup_ss',ex_lookup_ss',true))
schirmer@25171
   389
  in (ctxt', thm) end;
schirmer@25171
   390
schirmer@25171
   391
val setup = 
schirmer@25171
   392
    init_state_fun_data 
schirmer@25171
   393
    #> Attrib.add_attributes 
schirmer@25171
   394
	  [("statefun_simp",statefun_simp_attr,"simplification in statespaces")]     
schirmer@25171
   395
end