src/HOL/Tools/Nitpick/nitpick_peephole.ML
author blanchet
Fri Dec 18 12:00:29 2009 +0100 (2009-12-18)
changeset 34126 8a2c5d7aff51
parent 34124 c4628a1dcf75
child 34936 c4f04bee79f3
permissions -rw-r--r--
polished Nitpick's binary integer support etc.;
etc. = improve inconsistent scope correction + sort values nicely in output
+ handle "mod" using the characterization "x mod y = x - x div y * y"
(instead of explicit code in Nitpick)
+ introduce KK = Kodkod as abbreviation
blanchet@33982
     1
(*  Title:      HOL/Tools/Nitpick/nitpick_peephole.ML
blanchet@33192
     2
    Author:     Jasmin Blanchette, TU Muenchen
blanchet@33192
     3
    Copyright   2008, 2009
blanchet@33192
     4
blanchet@33192
     5
Peephole optimizer for Nitpick.
blanchet@33192
     6
*)
blanchet@33192
     7
blanchet@33192
     8
signature NITPICK_PEEPHOLE =
blanchet@33192
     9
sig
blanchet@34124
    10
  type n_ary_index = Kodkod.n_ary_index
blanchet@33192
    11
  type formula = Kodkod.formula
blanchet@33192
    12
  type int_expr = Kodkod.int_expr
blanchet@33192
    13
  type rel_expr = Kodkod.rel_expr
blanchet@33192
    14
  type decl = Kodkod.decl
blanchet@33192
    15
  type expr_assign = Kodkod.expr_assign
blanchet@33192
    16
blanchet@33192
    17
  type name_pool = {
blanchet@34124
    18
    rels: n_ary_index list,
blanchet@34124
    19
    vars: n_ary_index list,
blanchet@33192
    20
    formula_reg: int,
blanchet@33192
    21
    rel_reg: int}
blanchet@33192
    22
blanchet@33192
    23
  val initial_pool : name_pool
blanchet@34124
    24
  val not3_rel : n_ary_index
blanchet@34124
    25
  val suc_rel : n_ary_index
blanchet@34124
    26
  val unsigned_bit_word_sel_rel : n_ary_index
blanchet@34124
    27
  val signed_bit_word_sel_rel : n_ary_index
blanchet@34124
    28
  val nat_add_rel : n_ary_index
blanchet@34124
    29
  val int_add_rel : n_ary_index
blanchet@34124
    30
  val nat_subtract_rel : n_ary_index
blanchet@34124
    31
  val int_subtract_rel : n_ary_index
blanchet@34124
    32
  val nat_multiply_rel : n_ary_index
blanchet@34124
    33
  val int_multiply_rel : n_ary_index
blanchet@34124
    34
  val nat_divide_rel : n_ary_index
blanchet@34124
    35
  val int_divide_rel : n_ary_index
blanchet@34124
    36
  val nat_less_rel : n_ary_index
blanchet@34124
    37
  val int_less_rel : n_ary_index
blanchet@34124
    38
  val gcd_rel : n_ary_index
blanchet@34124
    39
  val lcm_rel : n_ary_index
blanchet@34124
    40
  val norm_frac_rel : n_ary_index
blanchet@33192
    41
  val atom_for_bool : int -> bool -> rel_expr
blanchet@33192
    42
  val formula_for_bool : bool -> formula
blanchet@33192
    43
  val atom_for_nat : int * int -> int -> int
blanchet@33192
    44
  val min_int_for_card : int -> int
blanchet@33192
    45
  val max_int_for_card : int -> int
blanchet@33192
    46
  val int_for_atom : int * int -> int -> int
blanchet@33192
    47
  val atom_for_int : int * int -> int -> int
blanchet@34124
    48
  val is_twos_complement_representable : int -> int -> bool
blanchet@33192
    49
  val inline_rel_expr : rel_expr -> bool
blanchet@33192
    50
  val empty_n_ary_rel : int -> rel_expr
blanchet@33192
    51
  val num_seq : int -> int -> int_expr list
blanchet@33192
    52
  val s_and : formula -> formula -> formula
blanchet@33192
    53
blanchet@33192
    54
  type kodkod_constrs = {
blanchet@33192
    55
    kk_all: decl list -> formula -> formula,
blanchet@33192
    56
    kk_exist: decl list -> formula -> formula,
blanchet@33192
    57
    kk_formula_let: expr_assign list -> formula -> formula,
blanchet@33192
    58
    kk_formula_if: formula -> formula -> formula -> formula,
blanchet@33192
    59
    kk_or: formula -> formula -> formula,
blanchet@33192
    60
    kk_not: formula -> formula,
blanchet@33192
    61
    kk_iff: formula -> formula -> formula,
blanchet@33192
    62
    kk_implies: formula -> formula -> formula,
blanchet@33192
    63
    kk_and: formula -> formula -> formula,
blanchet@33192
    64
    kk_subset: rel_expr -> rel_expr -> formula,
blanchet@33192
    65
    kk_rel_eq: rel_expr -> rel_expr -> formula,
blanchet@33192
    66
    kk_no: rel_expr -> formula,
blanchet@33192
    67
    kk_lone: rel_expr -> formula,
blanchet@33192
    68
    kk_one: rel_expr -> formula,
blanchet@33192
    69
    kk_some: rel_expr -> formula,
blanchet@33192
    70
    kk_rel_let: expr_assign list -> rel_expr -> rel_expr,
blanchet@33192
    71
    kk_rel_if: formula -> rel_expr -> rel_expr -> rel_expr,
blanchet@33192
    72
    kk_union: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
    73
    kk_difference: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
    74
    kk_override: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
    75
    kk_intersect: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
    76
    kk_product: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
    77
    kk_join: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
    78
    kk_closure: rel_expr -> rel_expr,
blanchet@33192
    79
    kk_reflexive_closure: rel_expr -> rel_expr,
blanchet@33192
    80
    kk_comprehension: decl list -> formula -> rel_expr,
blanchet@33192
    81
    kk_project: rel_expr -> int_expr list -> rel_expr,
blanchet@33192
    82
    kk_project_seq: rel_expr -> int -> int -> rel_expr,
blanchet@33192
    83
    kk_not3: rel_expr -> rel_expr,
blanchet@33192
    84
    kk_nat_less: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
    85
    kk_int_less: rel_expr -> rel_expr -> rel_expr
blanchet@33192
    86
  }
blanchet@33192
    87
blanchet@33192
    88
  val kodkod_constrs : bool -> int -> int -> int -> kodkod_constrs
blanchet@33192
    89
end;
blanchet@33192
    90
blanchet@33232
    91
structure Nitpick_Peephole : NITPICK_PEEPHOLE =
blanchet@33192
    92
struct
blanchet@33192
    93
blanchet@33192
    94
open Kodkod
blanchet@33232
    95
open Nitpick_Util
blanchet@33192
    96
blanchet@33192
    97
type name_pool = {
blanchet@33192
    98
  rels: n_ary_index list,
blanchet@33192
    99
  vars: n_ary_index list,
blanchet@33192
   100
  formula_reg: int,
blanchet@33192
   101
  rel_reg: int}
blanchet@33192
   102
blanchet@33192
   103
(* If you add new built-in relations, make sure to increment the counters here
blanchet@33192
   104
   as well to avoid name clashes (which fortunately would be detected by
blanchet@33192
   105
   Kodkodi). *)
blanchet@33192
   106
val initial_pool =
blanchet@33192
   107
  {rels = [(2, 10), (3, 20), (4, 10)], vars = [], formula_reg = 10,
blanchet@33192
   108
   rel_reg = 10}
blanchet@33192
   109
blanchet@34124
   110
val not3_rel = (2, 0)
blanchet@34124
   111
val suc_rel = (2, 1)
blanchet@34124
   112
val unsigned_bit_word_sel_rel = (2, 2)
blanchet@34124
   113
val signed_bit_word_sel_rel = (2, 3)
blanchet@34124
   114
val nat_add_rel = (3, 0)
blanchet@34124
   115
val int_add_rel = (3, 1)
blanchet@34124
   116
val nat_subtract_rel = (3, 2)
blanchet@34124
   117
val int_subtract_rel = (3, 3)
blanchet@34124
   118
val nat_multiply_rel = (3, 4)
blanchet@34124
   119
val int_multiply_rel = (3, 5)
blanchet@34124
   120
val nat_divide_rel = (3, 6)
blanchet@34124
   121
val int_divide_rel = (3, 7)
blanchet@34124
   122
val nat_less_rel = (3, 8)
blanchet@34124
   123
val int_less_rel = (3, 9)
blanchet@34124
   124
val gcd_rel = (3, 10)
blanchet@34124
   125
val lcm_rel = (3, 11)
blanchet@34124
   126
val norm_frac_rel = (4, 0)
blanchet@33192
   127
blanchet@33192
   128
(* int -> bool -> rel_expr *)
blanchet@33192
   129
fun atom_for_bool j0 = Atom o Integer.add j0 o int_for_bool
blanchet@33192
   130
(* bool -> formula *)
blanchet@33192
   131
fun formula_for_bool b = if b then True else False
blanchet@33192
   132
blanchet@33192
   133
(* int * int -> int -> int *)
blanchet@33192
   134
fun atom_for_nat (k, j0) n = if n < 0 orelse n >= k then ~1 else n + j0
blanchet@33192
   135
(* int -> int *)
blanchet@33192
   136
fun min_int_for_card k = ~k div 2 + 1
blanchet@33192
   137
fun max_int_for_card k = k div 2
blanchet@33192
   138
(* int * int -> int -> int *)
blanchet@33192
   139
fun int_for_atom (k, j0) j =
blanchet@33192
   140
  let val j = j - j0 in if j <= max_int_for_card k then j else j - k end
blanchet@33192
   141
fun atom_for_int (k, j0) n =
blanchet@33192
   142
  if n < min_int_for_card k orelse n > max_int_for_card k then ~1
blanchet@33192
   143
  else if n < 0 then n + k + j0
blanchet@33192
   144
  else n + j0
blanchet@34124
   145
(* int -> int -> bool *)
blanchet@34124
   146
fun is_twos_complement_representable bits n =
blanchet@34124
   147
  let val max = reasonable_power 2 bits in n >= ~ max andalso n < max end
blanchet@33192
   148
blanchet@33192
   149
(* rel_expr -> bool *)
blanchet@33192
   150
fun is_none_product (Product (r1, r2)) =
blanchet@33192
   151
    is_none_product r1 orelse is_none_product r2
blanchet@33192
   152
  | is_none_product None = true
blanchet@33192
   153
  | is_none_product _ = false
blanchet@33192
   154
blanchet@33192
   155
(* rel_expr -> bool *)
blanchet@33192
   156
fun is_one_rel_expr (Atom _) = true
blanchet@33192
   157
  | is_one_rel_expr (AtomSeq (1, _)) = true
blanchet@33192
   158
  | is_one_rel_expr (Var _) = true
blanchet@33192
   159
  | is_one_rel_expr _ = false
blanchet@33192
   160
blanchet@33192
   161
(* rel_expr -> bool *)
blanchet@33192
   162
fun inline_rel_expr (Product (r1, r2)) =
blanchet@33192
   163
    inline_rel_expr r1 andalso inline_rel_expr r2
blanchet@33192
   164
  | inline_rel_expr Iden = true
blanchet@33192
   165
  | inline_rel_expr Ints = true
blanchet@33192
   166
  | inline_rel_expr None = true
blanchet@33192
   167
  | inline_rel_expr Univ = true
blanchet@33192
   168
  | inline_rel_expr (Atom _) = true
blanchet@33192
   169
  | inline_rel_expr (AtomSeq _) = true
blanchet@33192
   170
  | inline_rel_expr (Rel _) = true
blanchet@33192
   171
  | inline_rel_expr (Var _) = true
blanchet@33192
   172
  | inline_rel_expr (RelReg _) = true
blanchet@33192
   173
  | inline_rel_expr _ = false
blanchet@33192
   174
blanchet@33192
   175
(* rel_expr -> rel_expr -> bool option *)
blanchet@33192
   176
fun rel_expr_equal None (Atom _) = SOME false
blanchet@33192
   177
  | rel_expr_equal None (AtomSeq (k, _)) = SOME (k = 0)
blanchet@33192
   178
  | rel_expr_equal (Atom _) None = SOME false
blanchet@33192
   179
  | rel_expr_equal (AtomSeq (k, _)) None = SOME (k = 0)
blanchet@33192
   180
  | rel_expr_equal (Atom j1) (Atom j2) = SOME (j1 = j2)
blanchet@33192
   181
  | rel_expr_equal (Atom j) (AtomSeq (k, j0)) = SOME (j = j0 andalso k = 1)
blanchet@33192
   182
  | rel_expr_equal (AtomSeq (k, j0)) (Atom j) = SOME (j = j0 andalso k = 1)
blanchet@33192
   183
  | rel_expr_equal (AtomSeq x1) (AtomSeq x2) = SOME (x1 = x2)
blanchet@33192
   184
  | rel_expr_equal r1 r2 = if r1 = r2 then SOME true else NONE
blanchet@33192
   185
blanchet@33192
   186
(* rel_expr -> rel_expr -> bool option *)
blanchet@33192
   187
fun rel_expr_intersects (Atom j1) (Atom j2) = SOME (j1 = j2)
blanchet@33192
   188
  | rel_expr_intersects (Atom j) (AtomSeq (k, j0)) = SOME (j < j0 + k)
blanchet@33192
   189
  | rel_expr_intersects (AtomSeq (k, j0)) (Atom j) = SOME (j < j0 + k)
blanchet@33192
   190
  | rel_expr_intersects (AtomSeq (k1, j01)) (AtomSeq (k2, j02)) =
blanchet@33192
   191
    SOME (k1 > 0 andalso k2 > 0 andalso j01 + k1 > j02 andalso j02 + k2 > j01)
blanchet@33192
   192
  | rel_expr_intersects r1 r2 =
blanchet@33192
   193
    if is_none_product r1 orelse is_none_product r2 then SOME false else NONE
blanchet@33192
   194
blanchet@33192
   195
(* int -> rel_expr *)
blanchet@33232
   196
fun empty_n_ary_rel 0 = raise ARG ("Nitpick_Peephole.empty_n_ary_rel", "0")
blanchet@33192
   197
  | empty_n_ary_rel n = funpow (n - 1) (curry Product None) None
blanchet@33192
   198
blanchet@33192
   199
(* decl -> rel_expr *)
blanchet@33192
   200
fun decl_one_set (DeclOne (_, r)) = r
blanchet@33192
   201
  | decl_one_set _ =
blanchet@33232
   202
    raise ARG ("Nitpick_Peephole.decl_one_set", "not \"DeclOne\"")
blanchet@33192
   203
blanchet@33192
   204
(* int_expr -> bool *)
blanchet@33192
   205
fun is_Num (Num _) = true
blanchet@33192
   206
  | is_Num _ = false
blanchet@33192
   207
(* int_expr -> int *)
blanchet@33192
   208
fun dest_Num (Num k) = k
blanchet@33232
   209
  | dest_Num _ = raise ARG ("Nitpick_Peephole.dest_Num", "not \"Num\"")
blanchet@33192
   210
(* int -> int -> int_expr list *)
blanchet@33192
   211
fun num_seq j0 n = map Num (index_seq j0 n)
blanchet@33192
   212
blanchet@33192
   213
(* rel_expr -> rel_expr -> bool *)
blanchet@33192
   214
fun occurs_in_union r (Union (r1, r2)) =
blanchet@33192
   215
    occurs_in_union r r1 orelse occurs_in_union r r2
blanchet@33192
   216
  | occurs_in_union r r' = (r = r')
blanchet@33192
   217
blanchet@33192
   218
(* rel_expr -> rel_expr -> rel_expr *)
blanchet@33192
   219
fun s_and True f2 = f2
blanchet@33192
   220
  | s_and False _ = False
blanchet@33192
   221
  | s_and f1 True = f1
blanchet@33192
   222
  | s_and _ False = False
blanchet@33192
   223
  | s_and f1 f2 = And (f1, f2)
blanchet@33192
   224
blanchet@33192
   225
type kodkod_constrs = {
blanchet@33192
   226
  kk_all: decl list -> formula -> formula,
blanchet@33192
   227
  kk_exist: decl list -> formula -> formula,
blanchet@33192
   228
  kk_formula_let: expr_assign list -> formula -> formula,
blanchet@33192
   229
  kk_formula_if: formula -> formula -> formula -> formula,
blanchet@33192
   230
  kk_or: formula -> formula -> formula,
blanchet@33192
   231
  kk_not: formula -> formula,
blanchet@33192
   232
  kk_iff: formula -> formula -> formula,
blanchet@33192
   233
  kk_implies: formula -> formula -> formula,
blanchet@33192
   234
  kk_and: formula -> formula -> formula,
blanchet@33192
   235
  kk_subset: rel_expr -> rel_expr -> formula,
blanchet@33192
   236
  kk_rel_eq: rel_expr -> rel_expr -> formula,
blanchet@33192
   237
  kk_no: rel_expr -> formula,
blanchet@33192
   238
  kk_lone: rel_expr -> formula,
blanchet@33192
   239
  kk_one: rel_expr -> formula,
blanchet@33192
   240
  kk_some: rel_expr -> formula,
blanchet@33192
   241
  kk_rel_let: expr_assign list -> rel_expr -> rel_expr,
blanchet@33192
   242
  kk_rel_if: formula -> rel_expr -> rel_expr -> rel_expr,
blanchet@33192
   243
  kk_union: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
   244
  kk_difference: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
   245
  kk_override: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
   246
  kk_intersect: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
   247
  kk_product: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
   248
  kk_join: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
   249
  kk_closure: rel_expr -> rel_expr,
blanchet@33192
   250
  kk_reflexive_closure: rel_expr -> rel_expr,
blanchet@33192
   251
  kk_comprehension: decl list -> formula -> rel_expr,
blanchet@33192
   252
  kk_project: rel_expr -> int_expr list -> rel_expr,
blanchet@33192
   253
  kk_project_seq: rel_expr -> int -> int -> rel_expr,
blanchet@33192
   254
  kk_not3: rel_expr -> rel_expr,
blanchet@33192
   255
  kk_nat_less: rel_expr -> rel_expr -> rel_expr,
blanchet@33192
   256
  kk_int_less: rel_expr -> rel_expr -> rel_expr
blanchet@33192
   257
}
blanchet@33192
   258
blanchet@33192
   259
(* We assume throughout that Kodkod variables have a "one" constraint. This is
blanchet@33192
   260
   always the case if Kodkod's skolemization is disabled. *)
blanchet@33192
   261
(* bool -> int -> int -> int -> kodkod_constrs *)
blanchet@33192
   262
fun kodkod_constrs optim nat_card int_card main_j0 =
blanchet@33192
   263
  let
blanchet@33192
   264
    val false_atom = Atom main_j0
blanchet@33192
   265
    val true_atom = Atom (main_j0 + 1)
blanchet@33192
   266
blanchet@33192
   267
    (* bool -> int *)
blanchet@33192
   268
    val from_bool = atom_for_bool main_j0
blanchet@34126
   269
    (* int -> rel_expr *)
blanchet@33192
   270
    fun from_nat n = Atom (n + main_j0)
blanchet@33192
   271
    val from_int = Atom o atom_for_int (int_card, main_j0)
blanchet@33192
   272
    (* int -> int *)
blanchet@33192
   273
    fun to_nat j = j - main_j0
blanchet@33192
   274
    val to_int = int_for_atom (int_card, main_j0)
blanchet@33192
   275
blanchet@33192
   276
    (* decl list -> formula -> formula *)
blanchet@33192
   277
    fun s_all _ True = True
blanchet@33192
   278
      | s_all _ False = False
blanchet@33192
   279
      | s_all [] f = f
blanchet@33192
   280
      | s_all ds (All (ds', f)) = All (ds @ ds', f)
blanchet@33192
   281
      | s_all ds f = All (ds, f)
blanchet@33192
   282
    fun s_exist _ True = True
blanchet@33192
   283
      | s_exist _ False = False
blanchet@33192
   284
      | s_exist [] f = f
blanchet@33192
   285
      | s_exist ds (Exist (ds', f)) = Exist (ds @ ds', f)
blanchet@33192
   286
      | s_exist ds f = Exist (ds, f)
blanchet@33192
   287
blanchet@33192
   288
    (* expr_assign list -> formula -> formula *)
blanchet@33192
   289
    fun s_formula_let _ True = True
blanchet@33192
   290
      | s_formula_let _ False = False
blanchet@33192
   291
      | s_formula_let assigns f = FormulaLet (assigns, f)
blanchet@33192
   292
blanchet@33192
   293
    (* formula -> formula *)
blanchet@33192
   294
    fun s_not True = False
blanchet@33192
   295
      | s_not False = True
blanchet@33192
   296
      | s_not (All (ds, f)) = Exist (ds, s_not f)
blanchet@33192
   297
      | s_not (Exist (ds, f)) = All (ds, s_not f)
blanchet@33192
   298
      | s_not (Or (f1, f2)) = And (s_not f1, s_not f2)
blanchet@33192
   299
      | s_not (Implies (f1, f2)) = And (f1, s_not f2)
blanchet@33192
   300
      | s_not (And (f1, f2)) = Or (s_not f1, s_not f2)
blanchet@33192
   301
      | s_not (Not f) = f
blanchet@33192
   302
      | s_not (No r) = Some r
blanchet@33192
   303
      | s_not (Some r) = No r
blanchet@33192
   304
      | s_not f = Not f
blanchet@33192
   305
blanchet@33192
   306
    (* formula -> formula -> formula *)
blanchet@33192
   307
    fun s_or True _ = True
blanchet@33192
   308
      | s_or False f2 = f2
blanchet@33192
   309
      | s_or _ True = True
blanchet@33192
   310
      | s_or f1 False = f1
blanchet@33192
   311
      | s_or f1 f2 = if f1 = f2 then f1 else Or (f1, f2)
blanchet@33192
   312
    fun s_iff True f2 = f2
blanchet@33192
   313
      | s_iff False f2 = s_not f2
blanchet@33192
   314
      | s_iff f1 True = f1
blanchet@33192
   315
      | s_iff f1 False = s_not f1
blanchet@33192
   316
      | s_iff f1 f2 = if f1 = f2 then True else Iff (f1, f2)
blanchet@33192
   317
    fun s_implies True f2 = f2
blanchet@33192
   318
      | s_implies False _ = True
blanchet@33192
   319
      | s_implies _ True = True
blanchet@33192
   320
      | s_implies f1 False = s_not f1
blanchet@33192
   321
      | s_implies f1 f2 = if f1 = f2 then True else Implies (f1, f2)
blanchet@33192
   322
blanchet@33192
   323
    (* formula -> formula -> formula -> formula *)
blanchet@33192
   324
    fun s_formula_if True f2 _ = f2
blanchet@33192
   325
      | s_formula_if False _ f3 = f3
blanchet@33192
   326
      | s_formula_if f1 True f3 = s_or f1 f3
blanchet@33192
   327
      | s_formula_if f1 False f3 = s_and (s_not f1) f3
blanchet@33192
   328
      | s_formula_if f1 f2 True = s_implies f1 f2
blanchet@33192
   329
      | s_formula_if f1 f2 False = s_and f1 f2
blanchet@33192
   330
      | s_formula_if f f1 f2 = FormulaIf (f, f1, f2)
blanchet@33192
   331
blanchet@33192
   332
    (* rel_expr -> int_expr list -> rel_expr *)
blanchet@33192
   333
    fun s_project r is =
blanchet@33192
   334
      (case r of
blanchet@33192
   335
         Project (r1, is') =>
blanchet@33192
   336
         if forall is_Num is then
blanchet@33192
   337
           s_project r1 (map (nth is' o dest_Num) is)
blanchet@33192
   338
         else
blanchet@33192
   339
           raise SAME ()
blanchet@33192
   340
       | _ => raise SAME ())
blanchet@33192
   341
      handle SAME () =>
blanchet@33192
   342
             let val n = length is in
blanchet@33192
   343
               if arity_of_rel_expr r = n andalso is = num_seq 0 n then r
blanchet@33192
   344
               else Project (r, is)
blanchet@33192
   345
             end
blanchet@33192
   346
blanchet@33192
   347
    (* rel_expr -> formula *)
blanchet@33192
   348
    fun s_no None = True
blanchet@33192
   349
      | s_no (Product (r1, r2)) = s_or (s_no r1) (s_no r2)
blanchet@34126
   350
      | s_no (Intersect (Closure (Rel x), Iden)) = Acyclic x
blanchet@33192
   351
      | s_no r = if is_one_rel_expr r then False else No r
blanchet@33192
   352
    fun s_lone None = True
blanchet@33192
   353
      | s_lone r = if is_one_rel_expr r then True else Lone r
blanchet@33192
   354
    fun s_one None = False
blanchet@33192
   355
      | s_one r =
blanchet@33192
   356
        if is_one_rel_expr r then
blanchet@33192
   357
          True
blanchet@33192
   358
        else if inline_rel_expr r then
blanchet@33192
   359
          case arity_of_rel_expr r of
blanchet@33192
   360
            1 => One r
blanchet@33192
   361
          | arity => foldl1 And (map (One o s_project r o single o Num)
blanchet@33192
   362
                                     (index_seq 0 arity))
blanchet@33192
   363
        else
blanchet@33192
   364
          One r
blanchet@33192
   365
    fun s_some None = False
blanchet@33192
   366
      | s_some (Atom _) = True
blanchet@33192
   367
      | s_some (Product (r1, r2)) = s_and (s_some r1) (s_some r2)
blanchet@33192
   368
      | s_some r = if is_one_rel_expr r then True else Some r
blanchet@33192
   369
blanchet@33192
   370
    (* rel_expr -> rel_expr *)
blanchet@33192
   371
    fun s_not3 (Atom j) = Atom (if j = main_j0 then j + 1 else j - 1)
blanchet@33192
   372
      | s_not3 (r as Join (r1, r2)) =
blanchet@34124
   373
        if r2 = Rel not3_rel then r1 else Join (r, Rel not3_rel)
blanchet@34124
   374
      | s_not3 r = Join (r, Rel not3_rel)
blanchet@33192
   375
blanchet@33192
   376
    (* rel_expr -> rel_expr -> formula *)
blanchet@33192
   377
    fun s_rel_eq r1 r2 =
blanchet@33192
   378
      (case (r1, r2) of
blanchet@34124
   379
         (Join (r11, Rel x), _) =>
blanchet@34124
   380
         if x = not3_rel then s_rel_eq r11 (s_not3 r2) else raise SAME ()
blanchet@34124
   381
       | (_, Join (r21, Rel x)) =>
blanchet@34124
   382
         if x = not3_rel then s_rel_eq r21 (s_not3 r1) else raise SAME ()
blanchet@34124
   383
       | (RelIf (f, r11, r12), _) =>
blanchet@34124
   384
         if inline_rel_expr r2 then
blanchet@34124
   385
           s_formula_if f (s_rel_eq r11 r2) (s_rel_eq r12 r2)
blanchet@34124
   386
         else
blanchet@34124
   387
           raise SAME ()
blanchet@34124
   388
       | (_, RelIf (f, r21, r22)) =>
blanchet@34124
   389
         if inline_rel_expr r1 then
blanchet@34124
   390
           s_formula_if f (s_rel_eq r1 r21) (s_rel_eq r1 r22)
blanchet@34124
   391
         else
blanchet@34124
   392
           raise SAME ()
blanchet@34124
   393
       | (RelLet (bs, r1'), Atom _) => s_formula_let bs (s_rel_eq r1' r2)
blanchet@34124
   394
       | (Atom _, RelLet (bs, r2')) => s_formula_let bs (s_rel_eq r1 r2')
blanchet@33192
   395
       | _ => raise SAME ())
blanchet@33192
   396
      handle SAME () =>
blanchet@33192
   397
             case rel_expr_equal r1 r2 of
blanchet@33192
   398
               SOME true => True
blanchet@33192
   399
             | SOME false => False
blanchet@33192
   400
             | NONE =>
blanchet@33192
   401
               case (r1, r2) of
blanchet@33192
   402
                 (_, RelIf (f, r21, r22)) =>
blanchet@33192
   403
                  if inline_rel_expr r1 then
blanchet@33192
   404
                    s_formula_if f (s_rel_eq r1 r21) (s_rel_eq r1 r22)
blanchet@33192
   405
                  else
blanchet@33192
   406
                    RelEq (r1, r2)
blanchet@33192
   407
               | (RelIf (f, r11, r12), _) =>
blanchet@33192
   408
                  if inline_rel_expr r2 then
blanchet@33192
   409
                    s_formula_if f (s_rel_eq r11 r2) (s_rel_eq r12 r2)
blanchet@33192
   410
                  else
blanchet@33192
   411
                    RelEq (r1, r2)
blanchet@34126
   412
               | (_, None) => s_no r1
blanchet@34126
   413
               | (None, _) => s_no r2
blanchet@33192
   414
               | _ => RelEq (r1, r2)
blanchet@33192
   415
    fun s_subset (Atom j1) (Atom j2) = formula_for_bool (j1 = j2)
blanchet@33192
   416
      | s_subset (Atom j) (AtomSeq (k, j0)) =
blanchet@33192
   417
        formula_for_bool (j >= j0 andalso j < j0 + k)
blanchet@33192
   418
      | s_subset (r1 as Union (r11, r12)) r2 =
blanchet@33192
   419
        s_and (s_subset r11 r2) (s_subset r12 r2)
blanchet@33192
   420
      | s_subset r1 (r2 as Union (r21, r22)) =
blanchet@33192
   421
        if is_one_rel_expr r1 then
blanchet@33192
   422
          s_or (s_subset r1 r21) (s_subset r1 r22)
blanchet@33192
   423
        else
blanchet@33192
   424
          if s_subset r1 r21 = True orelse s_subset r1 r22 = True
blanchet@33192
   425
             orelse r1 = r2 then
blanchet@33192
   426
            True
blanchet@33192
   427
          else
blanchet@33192
   428
            Subset (r1, r2)
blanchet@33192
   429
      | s_subset r1 r2 =
blanchet@33192
   430
        if r1 = r2 orelse is_none_product r1 then True
blanchet@33192
   431
        else if is_none_product r2 then s_no r1
blanchet@33192
   432
        else if forall is_one_rel_expr [r1, r2] then s_rel_eq r1 r2
blanchet@33192
   433
        else Subset (r1, r2)
blanchet@33192
   434
blanchet@33192
   435
    (* expr_assign list -> rel_expr -> rel_expr *)
blanchet@33192
   436
    fun s_rel_let [b as AssignRelReg (x', r')] (r as RelReg x) =
blanchet@33192
   437
        if x = x' then r' else RelLet ([b], r)
blanchet@33192
   438
      | s_rel_let bs r = RelLet (bs, r)
blanchet@33192
   439
blanchet@33192
   440
    (* formula -> rel_expr -> rel_expr -> rel_expr *)
blanchet@33192
   441
    fun s_rel_if f r1 r2 =
blanchet@33192
   442
      (case (f, r1, r2) of
blanchet@33192
   443
         (True, _, _) => r1
blanchet@33192
   444
       | (False, _, _) => r2
blanchet@33192
   445
       | (No r1', None, RelIf (One r2', r3', r4')) =>
blanchet@33192
   446
         if r1' = r2' andalso r2' = r3' then s_rel_if (Lone r1') r1' r4'
blanchet@33192
   447
         else raise SAME ()
blanchet@33192
   448
       | _ => raise SAME ())
blanchet@33192
   449
      handle SAME () => if r1 = r2 then r1 else RelIf (f, r1, r2)
blanchet@33192
   450
blanchet@33192
   451
    (* rel_expr -> rel_expr -> rel_expr *)
blanchet@33192
   452
    fun s_union r1 (Union (r21, r22)) = s_union (s_union r1 r21) r22
blanchet@33192
   453
      | s_union r1 r2 =
blanchet@33192
   454
        if is_none_product r1 then r2
blanchet@33192
   455
        else if is_none_product r2 then r1
blanchet@33192
   456
        else if r1 = r2 then r1
blanchet@33192
   457
        else if occurs_in_union r2 r1 then r1
blanchet@33192
   458
        else Union (r1, r2)
blanchet@33192
   459
    fun s_difference r1 r2 =
blanchet@33192
   460
      if is_none_product r1 orelse is_none_product r2 then r1
blanchet@33192
   461
      else if r1 = r2 then empty_n_ary_rel (arity_of_rel_expr r1)
blanchet@33192
   462
      else Difference (r1, r2)
blanchet@33192
   463
    fun s_override r1 r2 =
blanchet@33192
   464
      if is_none_product r2 then r1
blanchet@33192
   465
      else if is_none_product r1 then r2
blanchet@33192
   466
      else Override (r1, r2)
blanchet@33192
   467
    fun s_intersect r1 r2 =
blanchet@33192
   468
      case rel_expr_intersects r1 r2 of
blanchet@33192
   469
        SOME true => if r1 = r2 then r1 else Intersect (r1, r2)
blanchet@33192
   470
      | SOME false => empty_n_ary_rel (arity_of_rel_expr r1)
blanchet@33192
   471
      | NONE => if is_none_product r1 then r1
blanchet@33192
   472
                else if is_none_product r2 then r2
blanchet@33192
   473
                else Intersect (r1, r2)
blanchet@33192
   474
    fun s_product r1 r2 =
blanchet@33192
   475
      if is_none_product r1 then
blanchet@33192
   476
        Product (r1, empty_n_ary_rel (arity_of_rel_expr r2))
blanchet@33192
   477
      else if is_none_product r2 then
blanchet@33192
   478
        Product (empty_n_ary_rel (arity_of_rel_expr r1), r2)
blanchet@33192
   479
      else
blanchet@33192
   480
        Product (r1, r2)
blanchet@33192
   481
    fun s_join r1 (Product (Product (r211, r212), r22)) =
blanchet@33192
   482
        Product (s_join r1 (Product (r211, r212)), r22)
blanchet@33192
   483
      | s_join (Product (r11, Product (r121, r122))) r2 =
blanchet@33192
   484
        Product (r11, s_join (Product (r121, r122)) r2)
blanchet@33192
   485
      | s_join None r = empty_n_ary_rel (arity_of_rel_expr r - 1)
blanchet@33192
   486
      | s_join r None = empty_n_ary_rel (arity_of_rel_expr r - 1)
blanchet@33192
   487
      | s_join (Product (None, None)) r = empty_n_ary_rel (arity_of_rel_expr r)
blanchet@33192
   488
      | s_join r (Product (None, None)) = empty_n_ary_rel (arity_of_rel_expr r)
blanchet@33192
   489
      | s_join Iden r2 = r2
blanchet@33192
   490
      | s_join r1 Iden = r1
blanchet@33192
   491
      | s_join (Product (r1, r2)) Univ =
blanchet@33192
   492
        if arity_of_rel_expr r2 = 1 then r1
blanchet@33192
   493
        else Product (r1, s_join r2 Univ)
blanchet@33192
   494
      | s_join Univ (Product (r1, r2)) =
blanchet@33192
   495
        if arity_of_rel_expr r1 = 1 then r2
blanchet@33192
   496
        else Product (s_join Univ r1, r2)
blanchet@33192
   497
      | s_join r1 (r2 as Product (r21, r22)) =
blanchet@33192
   498
        if arity_of_rel_expr r1 = 1 then
blanchet@33192
   499
          case rel_expr_intersects r1 r21 of
blanchet@33192
   500
            SOME true => r22
blanchet@33192
   501
          | SOME false => empty_n_ary_rel (arity_of_rel_expr r2 - 1)
blanchet@33192
   502
          | NONE => Join (r1, r2)
blanchet@33192
   503
        else
blanchet@33192
   504
          Join (r1, r2)
blanchet@33192
   505
      | s_join (r1 as Product (r11, r12)) r2 =
blanchet@33192
   506
        if arity_of_rel_expr r2 = 1 then
blanchet@33192
   507
          case rel_expr_intersects r2 r12 of
blanchet@33192
   508
            SOME true => r11
blanchet@33192
   509
          | SOME false => empty_n_ary_rel (arity_of_rel_expr r1 - 1)
blanchet@33192
   510
          | NONE => Join (r1, r2)
blanchet@33192
   511
        else
blanchet@33192
   512
          Join (r1, r2)
blanchet@33192
   513
      | s_join r1 (r2 as RelIf (f, r21, r22)) =
blanchet@33192
   514
        if inline_rel_expr r1 then s_rel_if f (s_join r1 r21) (s_join r1 r22)
blanchet@33192
   515
        else Join (r1, r2)
blanchet@33192
   516
      | s_join (r1 as RelIf (f, r11, r12)) r2 =
blanchet@33192
   517
        if inline_rel_expr r2 then s_rel_if f (s_join r11 r2) (s_join r12 r2)
blanchet@33192
   518
        else Join (r1, r2)
blanchet@34124
   519
      | s_join (r1 as Atom j1) (r2 as Rel (x as (2, j2))) =
blanchet@34124
   520
        if x = suc_rel then
blanchet@33192
   521
          let val n = to_nat j1 + 1 in
blanchet@33192
   522
            if n < nat_card then from_nat n else None
blanchet@33192
   523
          end
blanchet@33192
   524
        else
blanchet@33192
   525
          Join (r1, r2)
blanchet@33192
   526
      | s_join r1 (r2 as Project (r21, Num k :: is)) =
blanchet@33192
   527
        if k = arity_of_rel_expr r21 - 1 andalso arity_of_rel_expr r1 = 1 then
blanchet@33192
   528
          s_project (s_join r21 r1) is
blanchet@33192
   529
        else
blanchet@33192
   530
          Join (r1, r2)
blanchet@34124
   531
      | s_join r1 (Join (r21, r22 as Rel (x as (3, j22)))) =
blanchet@34124
   532
        ((if x = nat_add_rel then
blanchet@33192
   533
            case (r21, r1) of
blanchet@33192
   534
              (Atom j1, Atom j2) =>
blanchet@33192
   535
              let val n = to_nat j1 + to_nat j2 in
blanchet@33192
   536
                if n < nat_card then from_nat n else None
blanchet@33192
   537
              end
blanchet@33192
   538
            | (Atom j, r) =>
blanchet@33192
   539
              (case to_nat j of
blanchet@33192
   540
                 0 => r
blanchet@34124
   541
               | 1 => s_join r (Rel suc_rel)
blanchet@33192
   542
               | _ => raise SAME ())
blanchet@33192
   543
            | (r, Atom j) =>
blanchet@33192
   544
              (case to_nat j of
blanchet@33192
   545
                 0 => r
blanchet@34124
   546
               | 1 => s_join r (Rel suc_rel)
blanchet@33192
   547
               | _ => raise SAME ())
blanchet@33192
   548
            | _ => raise SAME ()
blanchet@34124
   549
          else if x = nat_subtract_rel then
blanchet@33192
   550
            case (r21, r1) of
blanchet@33705
   551
              (Atom j1, Atom j2) => from_nat (nat_minus (to_nat j1) (to_nat j2))
blanchet@33192
   552
            | _ => raise SAME ()
blanchet@34124
   553
          else if x = nat_multiply_rel then
blanchet@33192
   554
            case (r21, r1) of
blanchet@33192
   555
              (Atom j1, Atom j2) =>
blanchet@33192
   556
              let val n = to_nat j1 * to_nat j2 in
blanchet@33192
   557
                if n < nat_card then from_nat n else None
blanchet@33192
   558
              end
blanchet@33192
   559
            | (Atom j, r) =>
blanchet@33192
   560
              (case to_nat j of 0 => Atom j | 1 => r | _ => raise SAME ())
blanchet@33192
   561
            | (r, Atom j) =>
blanchet@33192
   562
              (case to_nat j of 0 => Atom j | 1 => r | _ => raise SAME ())
blanchet@33192
   563
            | _ => raise SAME ()
blanchet@33192
   564
          else
blanchet@33192
   565
            raise SAME ())
blanchet@33192
   566
         handle SAME () => List.foldr Join r22 [r1, r21])
blanchet@33192
   567
      | s_join r1 r2 = Join (r1, r2)
blanchet@33192
   568
blanchet@33192
   569
    (* rel_expr -> rel_expr *)
blanchet@33192
   570
    fun s_closure Iden = Iden
blanchet@33192
   571
      | s_closure r = if is_none_product r then r else Closure r
blanchet@33192
   572
    fun s_reflexive_closure Iden = Iden
blanchet@33192
   573
      | s_reflexive_closure r =
blanchet@33192
   574
        if is_none_product r then Iden else ReflexiveClosure r
blanchet@33192
   575
blanchet@33192
   576
    (* decl list -> formula -> rel_expr *)
blanchet@33192
   577
    fun s_comprehension ds False = empty_n_ary_rel (length ds)
blanchet@33192
   578
      | s_comprehension ds True = fold1 s_product (map decl_one_set ds)
blanchet@33192
   579
      | s_comprehension [d as DeclOne ((1, j1), r)]
blanchet@33192
   580
                        (f as RelEq (Var (1, j2), Atom j)) =
blanchet@33192
   581
        if j1 = j2 andalso rel_expr_intersects (Atom j) r = SOME true then
blanchet@33192
   582
          Atom j
blanchet@33192
   583
        else
blanchet@33192
   584
          Comprehension ([d], f)
blanchet@33192
   585
      | s_comprehension ds f = Comprehension (ds, f)
blanchet@33192
   586
blanchet@33192
   587
    (* rel_expr -> int -> int -> rel_expr *)
blanchet@33192
   588
    fun s_project_seq r =
blanchet@33192
   589
      let
blanchet@33192
   590
        (* int -> rel_expr -> int -> int -> rel_expr *)
blanchet@33192
   591
        fun aux arity r j0 n =
blanchet@33192
   592
          if j0 = 0 andalso arity = n then
blanchet@33192
   593
            r
blanchet@33192
   594
          else case r of
blanchet@33192
   595
            RelIf (f, r1, r2) =>
blanchet@33192
   596
            s_rel_if f (aux arity r1 j0 n) (aux arity r2 j0 n)
blanchet@33192
   597
          | Product (r1, r2) =>
blanchet@33192
   598
            let
blanchet@33192
   599
              val arity2 = arity_of_rel_expr r2
blanchet@33192
   600
              val arity1 = arity - arity2
blanchet@33705
   601
              val n1 = Int.min (nat_minus arity1 j0, n)
blanchet@33192
   602
              val n2 = n - n1
blanchet@33192
   603
              (* unit -> rel_expr *)
blanchet@33192
   604
              fun one () = aux arity1 r1 j0 n1
blanchet@33705
   605
              fun two () = aux arity2 r2 (nat_minus j0 arity1) n2
blanchet@33192
   606
            in
blanchet@33192
   607
              case (n1, n2) of
blanchet@33192
   608
                (0, _) => s_rel_if (s_some r1) (two ()) (empty_n_ary_rel n2)
blanchet@33192
   609
              | (_, 0) => s_rel_if (s_some r2) (one ()) (empty_n_ary_rel n1)
blanchet@33192
   610
              | _ => s_product (one ()) (two ())
blanchet@33192
   611
            end
blanchet@33192
   612
          | _ => s_project r (num_seq j0 n)
blanchet@33192
   613
      in aux (arity_of_rel_expr r) r end
blanchet@33192
   614
blanchet@33192
   615
    (* rel_expr -> rel_expr -> rel_expr *)
blanchet@34124
   616
    fun s_nat_subtract r1 r2 = fold s_join [r1, r2] (Rel nat_subtract_rel)
blanchet@33192
   617
    fun s_nat_less (Atom j1) (Atom j2) = from_bool (j1 < j2)
blanchet@34124
   618
      | s_nat_less r1 r2 = fold s_join [r1, r2] (Rel nat_less_rel)
blanchet@33192
   619
    fun s_int_less (Atom j1) (Atom j2) = from_bool (to_int j1 < to_int j2)
blanchet@34124
   620
      | s_int_less r1 r2 = fold s_join [r1, r2] (Rel int_less_rel)
blanchet@33192
   621
blanchet@33192
   622
    (* rel_expr -> int -> int -> rel_expr *)
blanchet@33192
   623
    fun d_project_seq r j0 n = Project (r, num_seq j0 n)
blanchet@33192
   624
    (* rel_expr -> rel_expr *)
blanchet@34124
   625
    fun d_not3 r = Join (r, Rel not3_rel)
blanchet@33192
   626
    (* rel_expr -> rel_expr -> rel_expr *)
blanchet@34124
   627
    fun d_nat_subtract r1 r2 = List.foldl Join (Rel nat_subtract_rel) [r1, r2]
blanchet@34124
   628
    fun d_nat_less r1 r2 = List.foldl Join (Rel nat_less_rel) [r1, r2]
blanchet@34124
   629
    fun d_int_less r1 r2 = List.foldl Join (Rel int_less_rel) [r1, r2]
blanchet@33192
   630
  in
blanchet@33192
   631
    if optim then
blanchet@33192
   632
      {kk_all = s_all, kk_exist = s_exist, kk_formula_let = s_formula_let,
blanchet@33192
   633
       kk_formula_if = s_formula_if, kk_or = s_or, kk_not = s_not,
blanchet@33192
   634
       kk_iff = s_iff, kk_implies = s_implies, kk_and = s_and,
blanchet@33192
   635
       kk_subset = s_subset, kk_rel_eq = s_rel_eq, kk_no = s_no,
blanchet@33192
   636
       kk_lone = s_lone, kk_one = s_one, kk_some = s_some,
blanchet@33192
   637
       kk_rel_let = s_rel_let, kk_rel_if = s_rel_if, kk_union = s_union,
blanchet@33192
   638
       kk_difference = s_difference, kk_override = s_override,
blanchet@33192
   639
       kk_intersect = s_intersect, kk_product = s_product, kk_join = s_join,
blanchet@33192
   640
       kk_closure = s_closure, kk_reflexive_closure = s_reflexive_closure,
blanchet@33192
   641
       kk_comprehension = s_comprehension, kk_project = s_project,
blanchet@33192
   642
       kk_project_seq = s_project_seq, kk_not3 = s_not3,
blanchet@33192
   643
       kk_nat_less = s_nat_less, kk_int_less = s_int_less}
blanchet@33192
   644
    else
blanchet@33192
   645
      {kk_all = curry All, kk_exist = curry Exist,
blanchet@33192
   646
       kk_formula_let = curry FormulaLet, kk_formula_if = curry3 FormulaIf,
blanchet@33192
   647
       kk_or = curry Or,kk_not = Not, kk_iff = curry Iff, kk_implies = curry
blanchet@33192
   648
       Implies, kk_and = curry And, kk_subset = curry Subset, kk_rel_eq = curry
blanchet@33192
   649
       RelEq, kk_no = No, kk_lone = Lone, kk_one = One, kk_some = Some,
blanchet@33192
   650
       kk_rel_let = curry RelLet, kk_rel_if = curry3 RelIf, kk_union = curry
blanchet@33192
   651
       Union, kk_difference = curry Difference, kk_override = curry Override,
blanchet@33192
   652
       kk_intersect = curry Intersect, kk_product = curry Product,
blanchet@33192
   653
       kk_join = curry Join, kk_closure = Closure,
blanchet@33192
   654
       kk_reflexive_closure = ReflexiveClosure, kk_comprehension = curry
blanchet@33192
   655
       Comprehension, kk_project = curry Project,
blanchet@33192
   656
       kk_project_seq = d_project_seq, kk_not3 = d_not3,
blanchet@33192
   657
       kk_nat_less = d_nat_less, kk_int_less = d_int_less}
blanchet@33192
   658
  end
blanchet@33192
   659
blanchet@33192
   660
end;