src/HOL/SizeChange/sct.ML
author wenzelm
Mon Mar 16 18:24:30 2009 +0100 (2009-03-16)
changeset 30549 d2d7874648bd
parent 30450 7655e6533209
child 30607 c3d1590debd8
permissions -rw-r--r--
simplified method setup;
haftmann@28308
     1
(*  Title:      HOL/SizeChange/sct.ML
krauss@25314
     2
    ID:         $Id$
krauss@25314
     3
    Author:     Alexander Krauss, TU Muenchen
krauss@25314
     4
krauss@25314
     5
Tactics for size change termination.
krauss@25314
     6
*)
krauss@25314
     7
signature SCT =
krauss@25314
     8
sig
krauss@25314
     9
  val abs_rel_tac : tactic
krauss@26875
    10
  val mk_call_graph : Proof.context -> tactic
krauss@25314
    11
end
krauss@25314
    12
krauss@25314
    13
structure Sct : SCT =
krauss@25314
    14
struct
krauss@25314
    15
krauss@25314
    16
fun matrix [] ys = []
krauss@25314
    17
  | matrix (x::xs) ys = map (pair x) ys :: matrix xs ys
krauss@25314
    18
krauss@25314
    19
fun map_matrix f xss = map (map f) xss
krauss@25314
    20
krauss@25314
    21
val scgT = @{typ "nat scg"}
krauss@25314
    22
val acgT = @{typ "nat acg"}
krauss@25314
    23
krauss@25314
    24
fun edgeT nT eT = HOLogic.mk_prodT (nT, HOLogic.mk_prodT (eT, nT))
krauss@25314
    25
fun graphT nT eT = Type ("Graphs.graph", [nT, eT])
krauss@25314
    26
krauss@25314
    27
fun graph_const nT eT = Const ("Graphs.graph.Graph", HOLogic.mk_setT (edgeT nT eT) --> graphT nT eT)
krauss@25314
    28
krauss@25314
    29
val stepP_const = "Interpretation.stepP"
krauss@25314
    30
val stepP_def = thm "Interpretation.stepP.simps"
krauss@25314
    31
krauss@25314
    32
fun mk_stepP RD1 RD2 M1 M2 Rel =
krauss@25314
    33
    let val RDT = fastype_of RD1
krauss@25314
    34
      val MT = fastype_of M1
krauss@25314
    35
    in
krauss@25314
    36
      Const (stepP_const, RDT --> RDT --> MT --> MT --> (fastype_of Rel) --> HOLogic.boolT)
krauss@25314
    37
            $ RD1 $ RD2 $ M1 $ M2 $ Rel
krauss@25314
    38
    end
krauss@25314
    39
krauss@25314
    40
val no_stepI = thm "Interpretation.no_stepI"
krauss@25314
    41
krauss@25314
    42
val approx_const = "Interpretation.approx"
krauss@25314
    43
val approx_empty = thm "Interpretation.approx_empty"
krauss@25314
    44
val approx_less = thm "Interpretation.approx_less"
krauss@25314
    45
val approx_leq = thm "Interpretation.approx_leq"
krauss@25314
    46
krauss@25314
    47
fun mk_approx G RD1 RD2 Ms1 Ms2 =
krauss@25314
    48
    let val RDT = fastype_of RD1
krauss@25314
    49
      val MsT = fastype_of Ms1
krauss@25314
    50
    in Const (approx_const, scgT --> RDT --> RDT --> MsT --> MsT --> HOLogic.boolT) $ G $ RD1 $ RD2 $ Ms1 $ Ms2 end
krauss@25314
    51
krauss@25314
    52
val sound_int_const = "Interpretation.sound_int"
krauss@25314
    53
val sound_int_def = thm "Interpretation.sound_int_def"
krauss@25314
    54
fun mk_sound_int A RDs M =
krauss@25314
    55
    let val RDsT = fastype_of RDs
krauss@25314
    56
      val MT = fastype_of M
krauss@25314
    57
    in Const (sound_int_const, acgT --> RDsT --> MT --> HOLogic.boolT) $ A $ RDs $ M end
krauss@25314
    58
krauss@25314
    59
krauss@25314
    60
val nth_const = "List.nth"
krauss@25314
    61
fun mk_nth xs =
krauss@25314
    62
    let val lT as Type (_, [T]) = fastype_of xs
krauss@25314
    63
    in Const (nth_const, lT --> HOLogic.natT --> T) $ xs end
krauss@25314
    64
krauss@25314
    65
krauss@25314
    66
val has_edge_simps = [thm "Graphs.has_edge_def", thm "Graphs.dest_graph.simps"]
krauss@25314
    67
krauss@25314
    68
val all_less_zero = thm "Interpretation.all_less_zero"
krauss@25314
    69
val all_less_Suc = thm "Interpretation.all_less_Suc"
krauss@25314
    70
krauss@25314
    71
(* --> Library? *)
krauss@25314
    72
fun del_index n [] = []
krauss@25314
    73
  | del_index n (x :: xs) =
krauss@25314
    74
    if n>0 then x :: del_index (n - 1) xs else xs
krauss@25314
    75
krauss@25314
    76
(* Lists as finite multisets *)
krauss@25314
    77
krauss@25314
    78
fun remove1 eq x [] = []
krauss@25314
    79
  | remove1 eq x (y :: ys) = if eq (x, y) then ys else y :: remove1 eq x ys
krauss@25314
    80
krauss@25314
    81
fun multi_union eq [] ys = ys
krauss@25314
    82
  | multi_union eq (x::xs) ys = x :: multi_union eq xs (remove1 eq x ys)
krauss@25314
    83
krauss@25314
    84
fun dest_ex (Const ("Ex", _) $ Abs (a as (_,T,_))) =
krauss@25314
    85
    let
krauss@25314
    86
      val (n, body) = Term.dest_abs a
krauss@25314
    87
    in
krauss@25314
    88
      (Free (n, T), body)
krauss@25314
    89
    end
krauss@25314
    90
  | dest_ex _ = raise Match
krauss@25314
    91
krauss@25314
    92
fun dest_all_ex (t as (Const ("Ex",_) $ _)) =
krauss@25314
    93
    let
krauss@25314
    94
      val (v,b) = dest_ex t
krauss@25314
    95
      val (vs, b') = dest_all_ex b
krauss@25314
    96
    in
krauss@25314
    97
      (v :: vs, b')
krauss@25314
    98
    end
krauss@25314
    99
  | dest_all_ex t = ([],t)
krauss@25314
   100
krauss@25314
   101
fun dist_vars [] vs = (null vs orelse error "dist_vars"; [])
krauss@25314
   102
  | dist_vars (T::Ts) vs =
krauss@25314
   103
    case find_index (fn v => fastype_of v = T) vs of
krauss@25314
   104
      ~1 => Free ("", T) :: dist_vars Ts vs
krauss@25314
   105
    |  i => (nth vs i) :: dist_vars Ts (del_index i vs)
krauss@25314
   106
krauss@25314
   107
fun dest_case rebind t =
krauss@25314
   108
    let
krauss@25314
   109
      val (_ $ _ $ rhs :: _ $ _ $ match :: guards) = HOLogic.dest_conj t
krauss@25314
   110
      val guard = case guards of [] => HOLogic.true_const | gs => foldr1 HOLogic.mk_conj gs
krauss@25314
   111
    in
krauss@25314
   112
      foldr1 HOLogic.mk_prod [rebind guard, rebind rhs, rebind match]
krauss@25314
   113
    end
krauss@25314
   114
krauss@25314
   115
fun bind_many [] = I
krauss@25314
   116
  | bind_many vs = FundefLib.tupled_lambda (foldr1 HOLogic.mk_prod vs)
krauss@25314
   117
krauss@25314
   118
(* Builds relation descriptions from a relation definition *)
krauss@25314
   119
fun mk_reldescs (Abs a) =
krauss@25314
   120
    let
krauss@25314
   121
      val (_, Abs a') = Term.dest_abs a
krauss@25314
   122
      val (_, b) = Term.dest_abs a'
krauss@25314
   123
      val cases = HOLogic.dest_disj b
krauss@25314
   124
      val (vss, bs) = split_list (map dest_all_ex cases)
krauss@25314
   125
      val unionTs = fold (multi_union (op =)) (map (map fastype_of) vss) []
krauss@25314
   126
      val rebind = map (bind_many o dist_vars unionTs) vss
krauss@25314
   127
krauss@25314
   128
      val RDs = map2 dest_case rebind bs
krauss@25314
   129
    in
krauss@25314
   130
      HOLogic.mk_list (fastype_of (hd RDs)) RDs
krauss@25314
   131
    end
krauss@25314
   132
krauss@25314
   133
fun abs_rel_tac (st : thm) =
krauss@25314
   134
    let
krauss@25314
   135
      val thy = theory_of_thm st
krauss@25314
   136
      val (def, rd) = HOLogic.dest_eq (HOLogic.dest_Trueprop (hd (prems_of st)))
krauss@25314
   137
      val RDs = cterm_of thy (mk_reldescs def)
krauss@25314
   138
      val rdvar = Var (the_single (Term.add_vars rd [])) |> cterm_of thy
krauss@25314
   139
    in
krauss@25314
   140
      Seq.single (cterm_instantiate [(rdvar, RDs)] st)
krauss@25314
   141
    end
krauss@25314
   142
krauss@25314
   143
krauss@25314
   144
krauss@25314
   145
krauss@25314
   146
krauss@25314
   147
krauss@25314
   148
(* very primitive *)
krauss@26875
   149
fun measures_of ctxt RD =
krauss@25314
   150
    let
krauss@25314
   151
      val domT = range_type (fastype_of (fst (HOLogic.dest_prod (snd (HOLogic.dest_prod RD)))))
krauss@26875
   152
      val measures = MeasureFunctions.get_measure_functions ctxt domT
krauss@25314
   153
    in
krauss@25314
   154
      measures
krauss@25314
   155
    end
krauss@25314
   156
krauss@25314
   157
val mk_number = HOLogic.mk_nat
krauss@25314
   158
val dest_number = HOLogic.dest_nat
krauss@25314
   159
krauss@25314
   160
fun nums_to i = map mk_number (0 upto (i - 1))
krauss@25314
   161
krauss@25314
   162
val nth_simps = [thm "List.nth_Cons_0", thm "List.nth_Cons_Suc"]
krauss@25314
   163
val nth_ss = (HOL_basic_ss addsimps nth_simps)
krauss@25314
   164
val simp_nth_tac = simp_tac nth_ss
krauss@25314
   165
krauss@25314
   166
krauss@25314
   167
fun tabulate_tlist thy l =
krauss@25314
   168
    let
krauss@25314
   169
      val n = length (HOLogic.dest_list l)
krauss@25314
   170
      val table = Inttab.make (map (fn i => (i, Simplifier.rewrite nth_ss (cterm_of thy (mk_nth l $ mk_number i)))) (0 upto n - 1))
krauss@25314
   171
    in
krauss@25314
   172
      the o Inttab.lookup table
krauss@25314
   173
    end
krauss@25314
   174
krauss@25314
   175
val get_elem = snd o Logic.dest_equals o prop_of
krauss@25314
   176
krauss@25314
   177
fun inst_nums thy i j (t:thm) =
krauss@25314
   178
  instantiate' [] [NONE, NONE, NONE, SOME (cterm_of thy (mk_number i)), NONE, SOME (cterm_of thy (mk_number j))] t
krauss@25314
   179
krauss@25314
   180
datatype call_fact =
krauss@25314
   181
   NoStep of thm
krauss@25314
   182
 | Graph of (term * thm)
krauss@25314
   183
krauss@25314
   184
fun rand (_ $ t) = t
krauss@25314
   185
krauss@25314
   186
fun setup_probe_goal thy domT Dtab Mtab (i, j) =
krauss@25314
   187
    let
krauss@25314
   188
      val RD1 = get_elem (Dtab i)
krauss@25314
   189
      val RD2 = get_elem (Dtab j)
krauss@25314
   190
      val Ms1 = get_elem (Mtab i)
krauss@25314
   191
      val Ms2 = get_elem (Mtab j)
krauss@25314
   192
krauss@25314
   193
      val Mst1 = HOLogic.dest_list (rand Ms1)
krauss@25314
   194
      val Mst2 = HOLogic.dest_list (rand Ms2)
krauss@25314
   195
krauss@25314
   196
      val mvar1 = Free ("sctmfv1", domT --> HOLogic.natT)
krauss@25314
   197
      val mvar2 = Free ("sctmfv2", domT --> HOLogic.natT)
krauss@25314
   198
      val relvar = Free ("sctmfrel", HOLogic.natT --> HOLogic.natT --> HOLogic.boolT)
krauss@25314
   199
      val N = length Mst1 and M = length Mst2
krauss@25314
   200
      val saved_state = HOLogic.mk_Trueprop (mk_stepP RD1 RD2 mvar1 mvar2 relvar)
krauss@25314
   201
                         |> cterm_of thy
krauss@25314
   202
                         |> Goal.init
krauss@25314
   203
                         |> CLASIMPSET auto_tac |> Seq.hd
krauss@25314
   204
krauss@25314
   205
      val no_step = saved_state
krauss@25314
   206
                      |> forall_intr (cterm_of thy relvar)
krauss@25314
   207
                      |> forall_elim (cterm_of thy (Abs ("", HOLogic.natT, Abs ("", HOLogic.natT, HOLogic.false_const))))
krauss@25314
   208
                      |> CLASIMPSET auto_tac |> Seq.hd
krauss@25314
   209
krauss@25314
   210
    in
krauss@25314
   211
      if Thm.no_prems no_step
krauss@25314
   212
      then NoStep (Goal.finish no_step RS no_stepI)
krauss@25314
   213
      else
krauss@25314
   214
        let
krauss@25314
   215
          fun set_m1 i =
krauss@25314
   216
              let
krauss@25314
   217
                val M1 = nth Mst1 i
krauss@25314
   218
                val with_m1 = saved_state
krauss@25314
   219
                                |> forall_intr (cterm_of thy mvar1)
krauss@25314
   220
                                |> forall_elim (cterm_of thy M1)
krauss@25314
   221
                                |> CLASIMPSET auto_tac |> Seq.hd
krauss@25314
   222
krauss@25314
   223
                fun set_m2 j =
krauss@25314
   224
                    let
krauss@25314
   225
                      val M2 = nth Mst2 j
krauss@25314
   226
                      val with_m2 = with_m1
krauss@25314
   227
                                      |> forall_intr (cterm_of thy mvar2)
krauss@25314
   228
                                      |> forall_elim (cterm_of thy M2)
krauss@25314
   229
                                      |> CLASIMPSET auto_tac |> Seq.hd
krauss@25314
   230
krauss@25314
   231
                      val decr = forall_intr (cterm_of thy relvar)
wenzelm@26187
   232
                                   #> forall_elim (cterm_of thy @{const HOL.less(nat)})
krauss@25314
   233
                                   #> CLASIMPSET auto_tac #> Seq.hd
krauss@25314
   234
krauss@25314
   235
                      val decreq = forall_intr (cterm_of thy relvar)
wenzelm@26187
   236
                                     #> forall_elim (cterm_of thy @{const HOL.less_eq(nat)})
krauss@25314
   237
                                     #> CLASIMPSET auto_tac #> Seq.hd
krauss@25314
   238
krauss@25314
   239
                      val thm1 = decr with_m2
krauss@25314
   240
                    in
krauss@25314
   241
                      if Thm.no_prems thm1
krauss@25314
   242
                      then ((rtac (inst_nums thy i j approx_less) 1) THEN (simp_nth_tac 1) THEN (rtac (Goal.finish thm1) 1))
krauss@25314
   243
                      else let val thm2 = decreq with_m2 in
krauss@25314
   244
                             if Thm.no_prems thm2
krauss@25314
   245
                             then ((rtac (inst_nums thy i j approx_leq) 1) THEN (simp_nth_tac 1) THEN (rtac (Goal.finish thm2) 1))
krauss@25314
   246
                             else all_tac end
krauss@25314
   247
                    end
krauss@25314
   248
              in set_m2 end
krauss@25314
   249
krauss@25314
   250
          val goal = HOLogic.mk_Trueprop (mk_approx (Var (("G", 0), scgT)) RD1 RD2 Ms1 Ms2)
krauss@25314
   251
krauss@25314
   252
          val tac = (EVERY (map (fn n => EVERY (map (set_m1 n) (0 upto M - 1))) (0 upto N - 1)))
krauss@25314
   253
                      THEN (rtac approx_empty 1)
krauss@25314
   254
krauss@25314
   255
          val approx_thm = goal
krauss@25314
   256
                    |> cterm_of thy
krauss@25314
   257
                    |> Goal.init
krauss@25314
   258
                    |> tac |> Seq.hd
krauss@25314
   259
                    |> Goal.finish
krauss@25314
   260
krauss@25314
   261
          val _ $ (_ $ G $ _ $ _ $ _ $ _) = prop_of approx_thm
krauss@25314
   262
        in
krauss@25314
   263
          Graph (G, approx_thm)
krauss@25314
   264
        end
krauss@25314
   265
    end
krauss@25314
   266
krauss@25314
   267
fun mk_edge m G n = HOLogic.mk_prod (m, HOLogic.mk_prod (G, n))
krauss@25314
   268
krauss@25314
   269
val in_graph_tac =
krauss@25314
   270
    simp_tac (HOL_basic_ss addsimps has_edge_simps) 1
krauss@25314
   271
    THEN SIMPSET (fn x => simp_tac x 1) (* FIXME reduce simpset *)
krauss@25314
   272
krauss@25314
   273
fun approx_tac (NoStep thm) = rtac disjI1 1 THEN rtac thm 1
krauss@25314
   274
  | approx_tac (Graph (G, thm)) =
krauss@25314
   275
    rtac disjI2 1
krauss@25314
   276
    THEN rtac exI 1
krauss@25314
   277
    THEN rtac conjI 1
krauss@25314
   278
    THEN rtac thm 2
krauss@25314
   279
    THEN in_graph_tac
krauss@25314
   280
krauss@25314
   281
fun all_less_tac [] = rtac all_less_zero 1
krauss@25314
   282
  | all_less_tac (t :: ts) = rtac all_less_Suc 1
krauss@25314
   283
                                  THEN simp_nth_tac 1
krauss@25314
   284
                                  THEN t
krauss@25314
   285
                                  THEN all_less_tac ts
krauss@25314
   286
krauss@25314
   287
krauss@25314
   288
fun mk_length l = HOLogic.size_const (fastype_of l) $ l;
krauss@25314
   289
val length_simps = thms "Interpretation.length_simps"
krauss@25314
   290
krauss@25314
   291
krauss@25314
   292
krauss@26875
   293
fun mk_call_graph ctxt (st : thm) =
krauss@25314
   294
    let
krauss@25314
   295
      val thy = theory_of_thm st
krauss@25314
   296
      val _ $ _ $ RDlist $ _ = HOLogic.dest_Trueprop (hd (prems_of st))
krauss@25314
   297
krauss@25314
   298
      val RDs = HOLogic.dest_list RDlist
krauss@25314
   299
      val n = length RDs
krauss@25314
   300
krauss@26875
   301
      val Mss = map (measures_of ctxt) RDs
krauss@25314
   302
krauss@25314
   303
      val domT = domain_type (fastype_of (hd (hd Mss)))
krauss@25314
   304
krauss@25314
   305
      val mfuns = map (fn Ms => mk_nth (HOLogic.mk_list (fastype_of (hd Ms)) Ms)) Mss
krauss@25314
   306
                      |> (fn l => HOLogic.mk_list (fastype_of (hd l)) l)
krauss@25314
   307
krauss@25314
   308
      val Dtab = tabulate_tlist thy RDlist
krauss@25314
   309
      val Mtab = tabulate_tlist thy mfuns
krauss@25314
   310
krauss@25314
   311
      val len_simp = Simplifier.rewrite (HOL_basic_ss addsimps length_simps) (cterm_of thy (mk_length RDlist))
krauss@25314
   312
krauss@25314
   313
      val mlens = map length Mss
krauss@25314
   314
krauss@25314
   315
      val indices = (n - 1 downto 0)
krauss@25314
   316
      val pairs = matrix indices indices
krauss@25314
   317
      val parts = map_matrix (fn (n,m) =>
krauss@25314
   318
                                 (timeap_msg (string_of_int n ^ "," ^ string_of_int m)
krauss@25314
   319
                                             (setup_probe_goal thy domT Dtab Mtab) (n,m))) pairs
krauss@25314
   320
krauss@25314
   321
krauss@25314
   322
      val s = fold_index (fn (i, cs) => fold_index (fn (j, Graph (G, _)) => prefix ("(" ^ string_of_int i ^ "," ^ string_of_int j ^ "): " ^
wenzelm@26953
   323
                                                                            Syntax.string_of_term ctxt G ^ ",\n")
krauss@25314
   324
                                                     | _ => I) cs) parts ""
wenzelm@26941
   325
      val _ = warning s
krauss@25314
   326
krauss@25314
   327
krauss@25314
   328
      val ACG = map_filter (fn (Graph (G, _),(m, n)) => SOME (mk_edge (mk_number m) G (mk_number n)) | _ => NONE) (flat parts ~~ flat pairs)
haftmann@30450
   329
                    |> HOLogic.mk_set (edgeT HOLogic.natT scgT)
krauss@25314
   330
                    |> curry op $ (graph_const HOLogic.natT scgT)
krauss@25314
   331
krauss@25314
   332
krauss@25314
   333
      val sound_int_goal = HOLogic.mk_Trueprop (mk_sound_int ACG RDlist mfuns)
krauss@25314
   334
krauss@25314
   335
      val tac =
krauss@25314
   336
          (SIMPSET (unfold_tac [sound_int_def, len_simp]))
krauss@25314
   337
            THEN all_less_tac (map (all_less_tac o map approx_tac) parts)
krauss@25314
   338
    in
krauss@25314
   339
      tac (instantiate' [] [SOME (cterm_of thy ACG), SOME (cterm_of thy mfuns)] st)
krauss@25314
   340
    end
krauss@25314
   341
krauss@25314
   342
krauss@25314
   343
end
krauss@25314
   344
krauss@25314
   345
krauss@25314
   346
krauss@25314
   347
krauss@25314
   348
krauss@25314
   349
krauss@25314
   350