tests/rtest_rules.mac

   1 kill (all);
   2 done;
   3
   4 /* Atoms, including false, are OK as rule productions.
   5  * No matchdeclare predicates => match literal expressions only.
   6  */
   7
   8 (tellsimp (foo1 (x), true),
   9  tellsimp (foo2 (x), false),
  10  tellsimp (foo3 (x), %pi),
  11  tellsimp (foo4 (x), 1729),
  12
  13  tellsimpafter (bar1 (x), true),
  14  tellsimpafter (bar2 (x), false),
  15  tellsimpafter (bar3 (x), %pi),
  16  tellsimpafter (bar4 (x), 1729),
  17
  18  defrule (r1, baz1 (x), true),
  19  defrule (r2, baz2 (x), false),
  20  defrule (r3, baz3 (x), %pi),
  21  defrule (r4, baz4 (x), 1729),
  22
  23  0);
  24 0;
  25
  26 [foo1 (x), foo2 (x), foo3 (x), foo4 (x), bar1 (x), bar2 (x), bar3 (x), bar4 (x)];
  27 [true, false, %pi, 1729, true, false, %pi, 1729];
  28
  29 [r1 (baz1 (x)), r2 (baz2 (x)), r3 (baz3 (x)), r4 (baz4 (x))];
  30 [true, false, %pi, 1729];
  31
  32 /* For defrule and defmatch, atoms (both literal and variable) are OK as rule templates.
  33  * (Not OK for tellsimp and tellsimpafter, however.)
  34  */
  35
  36 (defrule (rx, xx, foo_xx),
  37  defrule (r1, 1, foo_1),
  38  defrule (rs, "string", foo_string),
  39  defrule (r17, 17.0, foo_17),
  40  defrule (rtrue, true, foo_true),
  41  defrule (rfalse, false, foo_false),
  42
  43  defmatch (px, xx),
  44  defmatch (p1, 1),
  45  defmatch (ps, "string"),
  46  defmatch (pfloat, 17.0),
  47  defmatch (ptrue, true),
  48  defmatch (pfalse, false),
  49
  50  0);
  51 0;
  52
  53 [rx (xx), r1 (1), rs ("string"), r17 (17.0), rtrue (true), rfalse (false)];
  54 [foo_xx, foo_1, foo_string, foo_17, foo_true, foo_false];
  55
  56 [rx (yy), r1 (2), rs ("string2"), r17 (29.0), rtrue (truly), rfalse (falsely)];
  57 [false, false, false, false, false, false];
  58
  59 [px (xx), p1 (1), ps ("string"), pfloat (17.0), ptrue (true), pfalse (false)];
  60 [true, true, true, true, true, true];
  61
  62 [px (yy), p1 (2), ps ("string2"), pfloat (29.0), ptrue (truly), pfalse (falsely)];
  63 [false, false, false, false, false, false];
  64
  65 (matchdeclare (aa, atom, ii, integerp, ss, stringp, ff, floatnump, bb, booleanp),
  66  booleanp (e) := atom (e) and (e = true or e = false),
  67
  68  defrule (ra, aa, [aa]),
  69  defrule (ri, ii, ii / 10.0),
  70  defrule (rs, ss, concat (ss, "1729")),
  71  defrule (rf, ff, floor (ff)),
  72  defrule (rb, bb, if bb then 1 else 0),
  73
  74  defmatch (pa, aa),
  75  defmatch (pi, ii),
  76  defmatch (ps, ss),
  77  defmatch (pf, ff),
  78  defmatch (pb, bb),
  79
  80  0);
  81 0;
  82
  83 [ra (foobar), ri (17290), rs ("foobar"), rf (17.29), rb (false)];
  84 [[foobar], 1729.0, "foobar1729", 17, 0];
  85
  86 [ra (foo + bar), ri (17290.0), rs (foobar), rf (1729), rb (foo (bar))];
  87 [false, false, false, false, false];
  88
  89 [pa (foobar), pi (17290), ps ("foobar"), pf (1729.0), pb (false)];
  90 [[aa = foobar], [ii = 17290], [ss = "foobar"], [ff = 1729.0], [bb = false]];
  91
  92 [pa (foo + bar), pi (17290.0), ps (foobar), pf (1729), pb (foo (bar))];
  93 [false, false, false, false, false];
  94
  95 /* Match variables are OK as main operator names in defrule and defmatch,
  96  * but not in tellsimp and tellsimpafter. Operators other than the main
  97  * operator can be match variables in tellsimp and tellsimpafter.
  98  * DROP A NOTE TO THIS EFFECT IN RULES.TEXI !!
  99  */
 100
 101 (matchdeclare
 102   ([a, b], atom,
 103     f, lambda ([e], featurep (e, increasing)),
 104    [x, y], all), 0);
 105 0;
 106
 107 (defrule (r1, a(b), b(a)),
 108  defrule (r2, f(x) < f(y), x < y),
 109  defmatch (p1, a(b)),
 110  defmatch (p2, f(x) < f(y)),
 111  0);
 112 0;
 113
 114 [r1 (foo (bar)), r2 (log (u + v) < log (u - v))];
 115 [bar (foo), u + v < u - v];
 116
 117 [p1 (foo (bar)), p2 (log (u + v) < log (u - v))];
 118 [[b = bar, a = foo], [y = u - v, x = u + v, f = log]];
 119
 120 for e in values do apply (remvalue, [e]);
 121 done;
 122
 123 [r1 (foo (bar + baz)), r2 (cosh (x) < cosh (y))];
 124 [false, false];
 125
 126 [p1 (foo (bar + baz)), p2 (cosh (x) < cosh (y))];
 127 [false, false];
 128
 129 (tellsimp (f(x) < f(y), x < y),
 130  tellsimpafter (f(x) > f(y), x > y),
 131  0);
 132 0;
 133
 134 [log (u + v) < log (u - v), cosh (u + v) < cosh (u - v)];
 135 [u + v < u - v, cosh (u + v) < cosh (u - v)];
 136
 137 [sinh (u + v) > sinh (u * v), sin (u + v) > sin (u * v)];
 138 [u + v > u * v, sin (u + v) > sin (u * v)];
 139
 140 /* Various forms of matchdeclare predicates.
 141  * These should different ways to say the same thing.
 142  */
 143
 144 matchdeclare (aa1, true, aa2, all);
 145 done;
 146
 147 matchdeclare
 148   (bb1, integerp,
 149   bb2, integerp(),
 150   bb3, myintegerp_mmacro,
 151   bb4, myintegerp_mmacro(),
 152   bb3, myintegerp_mfunction,
 153   bb4, myintegerp_mfunction(),
 154   bb5, lambda ([x], integerp (x)),
 155   bb6, lambda ([x], integerp (x)) (),
 156   bb7, myintegerp_array_fcn [1234] ());
 157 done;
 158
 159 (myintegerp_mmacro (x) ::= buildq ([x], integerp (x)), myintegerp_mfunction (x) := integerp (x), myintegerp_array_fcn [1234] (x) := integerp (x), 0);
 160 0;
 161
 162 matchdeclare
 163   (cc1, freeof (%e, %i),
 164   cc2, myfreeof_mmacro (%e, %i),
 165   cc3, myfreeof_mfunction (%e, %i),
 166   cc4, lambda ([x, y, z], freeof (x, y, z)) (%e, %i),
 167   cc5, lambda ([[L]], apply (freeof, L)) (%e, %i),
 168   cc6, myfreeof_array_fcn [1234] (%e, %i));
 169 done;
 170
 171 (myfreeof_mmacro ([L]) ::= buildq ([L], freeof (splice (L))), myfreeof_mfunction ([L]) := apply (freeof, L), myfreeof_array_fcn [1234] ([L]) := apply (freeof, L), 0);
 172 0;
 173
 174 /* Rules using equivalent predicate defns should have the same effect.
 175  */
 176
 177 (tellsimpafter (fa1 (aa1), ga (aa1)),
 178 tellsimpafter (fa2 (aa2), ga (aa2)),
 179
 180 tellsimpafter (fb1 (bb1), gb (bb1)),
 181 tellsimpafter (fb2 (bb2), gb (bb2)),
 182 tellsimpafter (fb3 (bb3), gb (bb3)),
 183 tellsimpafter (fb4 (bb4), gb (bb4)),
 184 tellsimpafter (fb5 (bb5), gb (bb5)),
 185 tellsimpafter (fb6 (bb6), gb (bb6)),
 186 tellsimpafter (fb7 (bb7), gb (bb7)),
 187
 188 tellsimpafter (fc1 (cc1), gc (cc1)),
 189 tellsimpafter (fc2 (cc2), gc (cc2)),
 190 tellsimpafter (fc3 (cc3), gc (cc3)),
 191 tellsimpafter (fc4 (cc4), gc (cc4)),
 192 tellsimpafter (fc5 (cc5), gc (cc5)),
 193 tellsimpafter (fc6 (cc6), gc (cc6)),
 194 0);
 195 0;
 196
 197 [fa1 (%pi + %i), fa2 (%pi + %i)];
 198 [ga (%pi + %i), ga (%pi + %i)];
 199
 200 [fb1 (100), fb2 (100), fb3 (100), fb4 (100), fb5 (100), fb6 (100), fb7 (100)];
 201 [gb (100), gb (100), gb (100), gb (100), gb (100), gb (100), gb (100)];
 202
 203 (L : [fb1 (x), fb2 (x), fb3 (x), fb4 (x), fb5 (x), fb6 (x), fb7 (x)], 0);
 204 0;
 205
 206 simp : false;
 207 false;
 208
 209 L;
 210 [fb1 (x), fb2 (x), fb3 (x), fb4 (x), fb5 (x), fb6 (x), fb7 (x)];
 211
 212 simp : true;
 213 true;
 214
 215 [fc1 (x + y), fc2 (x + y), fc3 (x + y), fc4 (x + y), fc5 (x + y), fc6 (x + y)];
 216 [gc (x + y), gc (x + y), gc (x + y), gc (x + y), gc (x + y), gc (x + y)];
 217
 218 (L : [fc1 (%i + y), fc2 (%i + y), fc3 (%i + y), fc4 (%i + y), fc5 (%i + y), fc6 (%i + y)], 0);
 219 0;
 220
 221 simp : false;
 222 false;
 223
 224 L;
 225 [fc1 (%i + y), fc2 (%i + y), fc3 (%i + y), fc4 (%i + y), fc5 (%i + y), fc6 (%i + y)];
 226
 227 simp : true;
 228 true;
 229
 230 /* Repeat tellsimpafter examples using tellsimp.
 231  */
 232
 233 (tellsimp (f2a1 (aa1), ga (aa1)),
 234 tellsimp (f2a2 (aa2), ga (aa2)),
 235
 236 tellsimp (f2b1 (bb1), gb (bb1)),
 237 tellsimp (f2b2 (bb2), gb (bb2)),
 238 tellsimp (f2b3 (bb3), gb (bb3)),
 239 tellsimp (f2b4 (bb4), gb (bb4)),
 240 tellsimp (f2b5 (bb5), gb (bb5)),
 241 tellsimp (f2b6 (bb6), gb (bb6)),
 242 tellsimp (f2b7 (bb7), gb (bb7)),
 243
 244 tellsimp (f2c1 (cc1), gc (cc1)),
 245 tellsimp (f2c2 (cc2), gc (cc2)),
 246 tellsimp (f2c3 (cc3), gc (cc3)),
 247 tellsimp (f2c4 (cc4), gc (cc4)),
 248 tellsimp (f2c5 (cc5), gc (cc5)),
 249 tellsimp (f2c6 (cc6), gc (cc6)),
 250 0);
 251 0;
 252
 253 [f2a1 (%pi + %i), f2a2 (%pi + %i)];
 254 [ga (%pi + %i), ga (%pi + %i)];
 255
 256 [f2b1 (100), f2b2 (100), f2b3 (100), f2b4 (100), f2b5 (100), f2b6 (100), f2b7 (100)];
 257 [gb (100), gb (100), gb (100), gb (100), gb (100), gb (100), gb (100)];
 258
 259 (L : [f2b1 (x), f2b2 (x), f2b3 (x), f2b4 (x), f2b5 (x), f2b6 (x), f2b7 (x)], 0);
 260 0;
 261
 262 simp : false;
 263 false;
 264
 265 L;
 266 [f2b1 (x), f2b2 (x), f2b3 (x), f2b4 (x), f2b5 (x), f2b6 (x), f2b7 (x)];
 267
 268 simp : true;
 269 true;
 270
 271 [f2c1 (x + y), f2c2 (x + y), f2c3 (x + y), f2c4 (x + y), f2c5 (x + y), f2c6 (x + y)];
 272 [gc (x + y), gc (x + y), gc (x + y), gc (x + y), gc (x + y), gc (x + y)];
 273
 274 (L : [f2c1 (%i + y), f2c2 (%i + y), f2c3 (%i + y), f2c4 (%i + y), f2c5 (%i + y), f2c6 (%i + y)], 0);
 275 0;
 276
 277 simp : false;
 278 false;
 279
 280 L;
 281 [f2c1 (%i + y), f2c2 (%i + y), f2c3 (%i + y), f2c4 (%i + y), f2c5 (%i + y), f2c6 (%i + y)];
 282
 283 simp : true;
 284 true;
 285
 286 /* Repeat tellsimpafter examples using defrule.
 287  */
 288
 289 (defrule (rule_a1, f3a1 (aa1), ga (aa1)),
 290 defrule (rule_a2, f3a2 (aa2), ga (aa2)),
 291
 292 defrule (rule_b1, f3b1 (bb1), gb (bb1)),
 293 defrule (rule_b2, f3b2 (bb2), gb (bb2)),
 294 defrule (rule_b3, f3b3 (bb3), gb (bb3)),
 295 defrule (rule_b4, f3b4 (bb4), gb (bb4)),
 296 defrule (rule_b5, f3b5 (bb5), gb (bb5)),
 297 defrule (rule_b6, f3b6 (bb6), gb (bb6)),
 298 defrule (rule_b7, f3b7 (bb7), gb (bb7)),
 299
 300 defrule (rule_c1, f3c1 (cc1), gc (cc1)),
 301 defrule (rule_c2, f3c2 (cc2), gc (cc2)),
 302 defrule (rule_c3, f3c3 (cc3), gc (cc3)),
 303 defrule (rule_c4, f3c4 (cc4), gc (cc4)),
 304 defrule (rule_c5, f3c5 (cc5), gc (cc5)),
 305 defrule (rule_c6, f3c6 (cc6), gc (cc6)),
 306 0);
 307 0;
 308
 309 map (lambda ([e, r], apply (apply1, [e, r])), [f3a1 (%pi + %i), f3a2 (%pi + %i)], [rule_a1, rule_a2]);
 310 [ga (%pi + %i), ga (%pi + %i)];
 311
 312 map (lambda ([e, r], apply (apply1, [e, r])), [f3b1 (100), f3b2 (100), f3b3 (100), f3b4 (100), f3b5 (100), f3b6 (100), f3b7 (100)], [rule_b1, rule_b2, rule_b3, rule_b4, rule_b5, rule_b6, rule_b7]);
 313 [gb (100), gb (100), gb (100), gb (100), gb (100), gb (100), gb (100)];
 314
 315 map (lambda ([e, r], apply (apply1, [e, r])), [f3b1 (x), f3b2 (x), f3b3 (x), f3b4 (x), f3b5 (x), f3b6 (x), f3b7 (x)], [rule_b1, rule_b2, rule_b3, rule_b4, rule_b5, rule_b6, rule_b7]);
 316 [f3b1 (x), f3b2 (x), f3b3 (x), f3b4 (x), f3b5 (x), f3b6 (x), f3b7 (x)];
 317
 318 map (lambda ([e, r], apply (apply1, [e, r])), [f3c1 (x + y), f3c2 (x + y), f3c3 (x + y), f3c4 (x + y), f3c5 (x + y), f3c6 (x + y)], [rule_c1, rule_c2, rule_c3, rule_c4, rule_c5, rule_c6]);
 319 [gc (x + y), gc (x + y), gc (x + y), gc (x + y), gc (x + y), gc (x + y)];
 320
 321 map (lambda ([e, r], apply (apply1, [e, r])), [f3c1 (%i + y), f3c2 (%i + y), f3c3 (%i + y), f3c4 (%i + y), f3c5 (%i + y), f3c6 (%i + y)], [rule_c1, rule_c2, rule_c3, rule_c4, rule_c5, rule_c6]);
 322 [f3c1 (%i + y), f3c2 (%i + y), f3c3 (%i + y), f3c4 (%i + y), f3c5 (%i + y), f3c6 (%i + y)];
 323
 324 /* Repeat tellsimpafter examples using defmatch.
 325  */
 326
 327 (defmatch (prog_a1, f4a1 (aa1)),
 328 defmatch (prog_a2, f4a2 (aa2)),
 329
 330 defmatch (prog_b1, f4b1 (bb1)),
 331 defmatch (prog_b2, f4b2 (bb2)),
 332 defmatch (prog_b3, f4b3 (bb3)),
 333 defmatch (prog_b4, f4b4 (bb4)),
 334 defmatch (prog_b5, f4b5 (bb5)),
 335 defmatch (prog_b6, f4b6 (bb6)),
 336 defmatch (prog_b7, f4b7 (bb7)),
 337
 338 defmatch (prog_c1, f4c1 (cc1)),
 339 defmatch (prog_c2, f4c2 (cc2)),
 340 defmatch (prog_c3, f4c3 (cc3)),
 341 defmatch (prog_c4, f4c4 (cc4)),
 342 defmatch (prog_c5, f4c5 (cc5)),
 343 defmatch (prog_c6, f4c6 (cc6)),
 344 0);
 345 0;
 346
 347 map (lambda ([e, r], r(e)), [f4a1 (%pi + %i), f4a2 (%pi + %i)], [prog_a1, prog_a2]);
 348 ['[aa1 = %pi + %i], '[aa2 = %pi + %i]];
 349
 350 map (lambda ([e, r], r(e)), [f4b1 (100), f4b2 (100), f4b3 (100), f4b4 (100), f4b5 (100), f4b6 (100), f4b7 (100)], [prog_b1, prog_b2, prog_b3, prog_b4, prog_b5, prog_b6, prog_b7]);
 351 ['[bb1 = 100], '[bb2 = 100], '[bb3 = 100], '[bb4 = 100], '[bb5 = 100], '[bb6 = 100], '[bb7 = 100]];
 352
 353 map (lambda ([e, r], r(e)), [f4b1 (x), f4b2 (x), f4b3 (x), f4b4 (x), f4b5 (x), f4b6 (x), f4b7 (x)], [prog_b1, prog_b2, prog_b3, prog_b4, prog_b5, prog_b6, prog_b7]);
 354 [false, false, false, false, false, false, false];
 355
 356 map (lambda ([e, r], r(e)), [f4c1 (x + y), f4c2 (x + y), f4c3 (x + y), f4c4 (x + y), f4c5 (x + y), f4c6 (x + y)], [prog_c1, prog_c2, prog_c3, prog_c4, prog_c5, prog_c6]);
 357 ['[cc1 = y + x], '[cc2 = y + x], '[cc3 = y + x], '[cc4 = y + x], '[cc5 = y + x], '[cc6 = y + x]];
 358
 359 map (lambda ([e, r], r(e)), [f4c1 (%i + y), f4c2 (%i + y), f4c3 (%i + y), f4c4 (%i + y), f4c5 (%i + y), f4c6 (%i + y)], [prog_c1, prog_c2, prog_c3, prog_c4, prog_c5, prog_c6]);
 360 [false, false, false, false, false, false];
 361
 362 /* Re-do above examples using DEFMSPEC functions in matchdeclare predicates.
 363  * Commenting out this part because :lisp is not recognized in test scripts.
 364 :lisp (defmspec $myintegerp_mspec (l) ($integerp (meval (cadr l))))
 365 :lisp (defmspec $myfreeof_mspec (l) (apply '$freeof (mapcar #'meval (cdr l))))
 366
 367 (matchdeclare
 368    (dd1, myintegerp_mspec,
 369     dd2, myintegerp_mspec (),
 370     ee1, myfreeof_mspec (%e, %i)),
 371  0);
 372 0;
 373
 374 (tellsimpafter (fd1 (dd1), gd (dd1)),
 375  tellsimpafter (fd2 (dd2), gd (dd2)),
 376  tellsimpafter (fe1 (ee1), ge (ee1)),
 377
 378  tellsimp (f2d1 (dd1), gd (dd1)),
 379  tellsimp (f2d2 (dd2), gd (dd2)),
 380  tellsimp (f2e1 (ee1), ge (ee1)),
 381
 382  defrule (rule_d1, f3d1 (dd1), gd (dd1)),
 383  defrule (rule_d2, f3d2 (dd2), gd (dd2)),
 384  defrule (rule_e1, f3e1 (ee1), ge (ee1)),
 385
 386  defmatch (prog_d1, f4d1 (dd1)),
 387  defmatch (prog_d2, f4d2 (dd2)),
 388  defmatch (prog_e1, f4e1 (ee1)),
 389  0);
 390 0;
 391
 392 [fd1 (100), fd2 (100), fe1 (x + y),
 393  f2d1 (100), f2d2 (100), f2e1 (x + y),
 394  apply1 (f3d1 (100), rule_d1), apply1 (f3d2 (100), rule_d2), apply1 (f3e1 (x + y), rule_e1),
 395  prog_d1 (f4d1 (100)), prog_d2 (f4d2 (100)), prog_e1 (f4e1 (x + y))];
 396 [gd (100), gd (100), ge (x + y),
 397  gd (100), gd (100), ge (x + y),
 398  gd (100), gd (100), ge (x + y),
 399  '[dd1 = 100], '[dd2 = 100], '[ee1 = x + y]];
 400
 401 (L : [fd1 (x), fd2 (x), f2d1 (x), f2d2 (x)], 0);
 402 0;
 403
 404 simp : false;
 405 false;
 406
 407 L;
 408 [fd1 (x), fd2 (x), f2d1 (x), f2d2 (x)];
 409
 410 simp : true;
 411 true;
 412  */
 413
 414 /* Examples of built-in and user-defined binary operators.
 415  */
 416
 417 (infix ("@@"),
 418  "@@" (a, b) := integerp(a) and integerp(b) and remainder(b, a) = 0,
 419  matchdeclare (aa, "<"(100), bb, ">"(100), cc, "="(100), dd, "#"(100), ee, "@@"(100)),
 420  tellsimpafter (FOO1 (aa, bb, cc, dd, ee), BAR1 (aa - 100, 100 - bb, cc - 100, dd - 100, ee / 100)),
 421  0);
 422 0;
 423
 424 FOO1 (17, 29, 1729, 29, 17);
 425 FOO1 (17, 29, 1729, 29, 17);
 426
 427 FOO1 (1729, 17, 100, 29, 172900);
 428 BAR1 (1729 - 100, 100 - 17, 0, 29 - 100, 1729);
 429
 430 /* Undecided expressions should be treated as failed matches
 431  * (i.e. without causing a predicate evaluation error,
 432  * and without treating some non-false value as true)
 433  */
 434 (matchdeclare (aa, "<"(foo0), bb, ">"(foo0), cc, "="(foo0), dd, "#"(foo0)),
 435  tellsimpafter (BAZ1 (aa, bb, cc, dd), BLURF1 (aa - foo0, foo0 - bb, 0, dd - foo0)),
 436  0);
 437 0;
 438
 439 (BAZ1 (1729, 17, 100, 29), [op (%%), args (%%)]);
 440 [BAZ1, [1729, 17, 100, 29]];
 441
 442 foo0 : 100;
 443 100;
 444
 445 BAZ1 (1729, 17, 100, 29);
 446 BLURF1 (1729 - 100, 100 - 17, 0, 29 - 100);
 447
 448 /* Arguments appearing in matched expressions should be evaluated just once
 449  * (just as they would be if there were no matching).
 450  */
 451
 452 /* NEED EXAMPLES HERE !! */
 453
 454 /* Additional miscellaneous examples.
 455  */
 456 (nzc (e) := constantp (e) and e # 0,
 457  matchdeclare ([aa, bb], constantp, [xx, yy, zz], nzc),
 458  declare (C1, constant),
 459  r1: first (tellsimp (quux (aa, bb), foo (bb, aa))),
 460  r2: first (tellsimp (foo (aa, bb), bar (aa*bb))),
 461  r3: first (tellsimp (baz (aa, bb), foo (bb, aa))),
 462  0);
 463 0;
 464
 465 /* Verify that tellsimp-defined rules are applied one after another.
 466  */
 467
 468 baz (%pi, %i);
 469 bar (%i*%pi);
 470
 471 q1: quux (73, C1);
 472 bar (C1*73);
 473
 474 /* I'd like to kill just r1, but remrule has at least one bug (SF bug # 1204711)
 475  */
 476 remrule (quux, all);
 477 quux;
 478
 479 quux (73, C1);
 480 '(quux (73, C1));
 481
 482 (r4: first (tellsimpafter (quux (xx, yy), glurf (xx^yy))), 0);
 483 0;
 484
 485 quux (73, C1);
 486 glurf (73^C1);
 487
 488 /* For bug [ 1120546 ] defrule (a, b, c) (all atoms) confuses kill (rules)
 489  */
 490
 491 kill (all);
 492 done;
 493
 494 (defrule (a, b, c), 0);
 495 0;
 496
 497 kill (rules);
 498 done;
 499
 500 /* Unreported bug: patterns for + or * match any operator (not just + or *)
 501  * when + or * is not the top-level operator and pattern variables
 502  * partition the arguments of + or *.
 503  */
 504
 505 (matchdeclare (xx, integerp, yy, lambda ([ee], not integerp (ee))),
 506  defrule (r1, FOO (xx + yy), FOOPLUS (xx, yy)),
 507  defrule (r2, FOO (xx * yy), FOOTIMES (xx, yy)),
 508  0);
 509 0;
 510
 511 apply1 (FOO (a + b + c + 123), r1);
 512 FOOPLUS (123, a + b + c);
 513
 514 apply1 (FOO (x * y * z * 234), r2);
 515 FOOTIMES (234, x * y * z);
 516
 517 apply1 (FOO (BAR (a, b, c, 123)), r1, r2);
 518 FOOPLUS (0, BAR (a, b, c, 123));
 519
 520 apply1 (FOO (BAR (a, b, c, 123)), r2, r1);
 521 FOOTIMES (1, BAR (a, b, c, 123));
 522
 523 apply1 (FOO (x + y + z + 345), r2);
 524 FOOTIMES (1, x + y + z + 345);
 525
 526 apply1 (FOO (s * t * u * v * 456), r1);
 527 FOOPLUS (0, s * t * u * v * 456);
 528
 529 (matchdeclare (xx, lambda ([e], integerp(e) and e # 0), yy, lambda ([ee], not integerp (ee))),
 530  defrule (r1, FOO (xx + yy), FOOPLUS (xx, yy)),
 531  matchdeclare (xx, lambda ([e], integerp(e) and e # 1)),
 532  defrule (r2, FOO (xx * yy), FOOTIMES (xx, yy)),
 533  0);
 534 0;
 535
 536 apply1 (FOO (a + b + c + 123), r1);
 537 FOOPLUS (123, a + b + c);
 538
 539 apply1 (FOO (x * y * z * 234), r2);
 540 FOOTIMES (234, x * y * z);
 541
 542 apply1 (FOO (BAR (a, b, c, 123)), r1, r2);
 543 FOO (BAR (a, b, c, 123));
 544
 545 apply1 (FOO (BAR (a, b, c, 123)), r2, r1);
 546 FOO (BAR (a, b, c, 123));
 547
 548 apply1 (FOO (x + y + z + 345), r2);
 549 FOO (x + y + z + 345);
 550
 551 apply1 (FOO (s * t * u * v * 456), r1);
 552 FOO (s * t * u * v * 456);
 553
 554 /* Seems to work OK when pattern variables do not partition the arguments.
 555  * Verify that continues to work after bug fix.
 556  */
 557 (matchdeclare (xx, bfloatp, yy, symbolp),
 558  defrule (r3, BAR (xx + yy), BARPLUS (xx, yy)),
 559  defrule (r4, BAR (xx * yy), BARTIMES (xx, yy)),
 560  0);
 561 0;
 562
 563 apply1 (BAR (1b0 + x + y), r3);
 564 BARPLUS (1b0, x + y);
 565
 566 apply1 (BAR (2b0 * u * v), r4);
 567 BARTIMES (2b0, u * v);
 568
 569 apply1 (BAR (FOO (3b0, g, h)), r3, r4);
 570 BAR (FOO (3b0, g, h));
 571
 572 apply1 (BAR (4b0 * m * n), r3);
 573 BAR (4b0 * m * n);
 574
 575 apply1 (BAR (5b0 + p + q), r4);
 576 BAR (5b0 + p + q);
 577
 578 /* Examples derived from mailing list 2008-03-23
 579  */
 580
 581 (kill (aa, bb, foo, bar),
 582  matchdeclare
 583    (aa, integerp,
 584     bb, floatnump,
 585     foo, lambda ([ee], member (ee, '[sin, cos]))),
 586  defmatch (bar, bb * foo (aa)),
 587  0);
 588 0;
 589
 590 (bar (12.345 * sin (54321)),
 591  if %% = false then false else sort (%%));
 592 [aa = 54321, bb = 12.345, foo = sin];
 593
 594 (matchdeclare
 595    (aa, floatnump,
 596     bb, integerp),
 597  defmatch (baztimes, aa * foo (bb)),
 598  defmatch (bazplus, aa + foo (bb)),
 599  0);
 600 0;
 601
 602 (baztimes (12.345 * sin (54321)),
 603  if %% = false then false else sort (%%));
 604 [aa = 12.345, bb = 54321, foo = sin];
 605
 606 (bazplus (12.345 + sin (54321)),
 607  if %% = false then false else sort (%%));
 608 [aa = 12.345, bb = 54321, foo = sin];
 609
 610 /* "rule issue" mailing list 2014-06-29 */
 611
 612 (matchdeclare (u, atom, fn, symbolp),
 613  defrule (ddint21, 'integrate(delta(u)*fn(u), u, minf, inf), fn(0)),
 614  ddint21('integrate(delta(u)*fn(u), u, minf, inf)));
 615 fn(0);
 616
 617 (kill (f), apply1 (1/(1 + 'integrate (f(x)*delta(x), x, minf, inf)), ddint21));
 618 1/(1 + f(0));
 619
 620 (kill (blurf),
 621  defrule (r1, 'integrate (blurf(u) + fn(u), u, minf, inf), fn(1)),
 622  r1 ('integrate (blurf(a) + g(a), a, minf, inf)));
 623 g(1);
 624
 625 /* rule for f interferes with function definition after kill
 626  * discussion on mailing list circa 2015-08-17: "trouble with GCL build"
 627  */
 628 (kill (all),
 629  matchdeclare (xx, integerp),
 630  tellsimp (f(xx), subst ('xx = xx, lambda ([a], a - xx))),
 631  kill (rules),
 632  f(n) := n + 1,
 633  translate(f),
 634  kill(f),
 635  f(y):=y+3,
 636  [fundef (f), f (10)]);
 637 [f(y) := y + 3, 13];
 638
 639 /* Verify that tellsimpafter rules are all applied.
 640  * This is a test for commit 801a0bb which creates one *AFTERFLAG per rule.
 641  * For good measure, verify that tellsimp and defrule work the same way.
 642  */
 643
 644 (simp:false,
 645  kill (f, g, h, i, j, rj1, rj2, rj3),
 646  tellsimpafter (f(1), f(0)),
 647  tellsimpafter (f(2), f(1)),
 648  tellsimpafter (f(3), f(2)),
 649  tellsimpafter (g(3), g(2)),
 650  tellsimpafter (g(2), g(1)),
 651  tellsimpafter (g(1), g(0)),
 652  tellsimp (h(1), h(0)),
 653  tellsimp (h(2), h(1)),
 654  tellsimp (h(3), h(2)),
 655  tellsimp (i(3), i(2)),
 656  tellsimp (i(2), i(1)),
 657  tellsimp (i(1), i(0)),
 658  defrule (rj1, j(1), j(0)),
 659  defrule (rj2, j(2), j(1)),
 660  defrule (rj3, j(3), j(2)),
 661  simp:true);
 662 true;
 663
 664 [f(1), f(2), f(3)];
 665 [f(0), f(0), f(0)];
 666
 667 [g(1), g(2), g(3)];
 668 [g(0), g(0), g(0)];
 669
 670 [h(1), h(2), h(3)];
 671 [h(0), h(0), h(0)];
 672
 673 [i(1), i(2), i(3)];
 674 [i(0), i(0), i(0)];
 675
 676 /* apply1 applies rj1 until it fails, then rj2, then rj3.
 677  * Since apply1 doesn't go back and try rj1 after rj2, or rj2 after rj3,
 678  * it's expected that the result of apply1 isn't maximally simplified.
 679  */
 680 apply1 ([j(1), j(2), j(3)], rj1, rj2, rj3);
 681 [j(0), j(1), j(2)];
 682
 683 /* apply1 with rules in reverse order does produce j(0) in each case here.
 684  */
 685 apply1 ([j(1), j(2), j(3)], rj3, rj2, rj1);
 686 [j(0), j(0), j(0)];
 687
 688 /* apply2 reapplies earlier rules if a later one succeeds.
 689  * So it's expected that the results will be maximally simplified,
 690  * with rules in either order.
 691  */
 692 apply2 ([j(1), j(2), j(3)], rj1, rj2, rj3);
 693 [j(0), j(0), j(0)];
 694
 695 apply2 ([j(1), j(2), j(3)], rj3, rj2, rj1);
 696 [j(0), j(0), j(0)];
 697
 698 /* applyb1, like apply1, doesn't reapply rules,
 699  * so it's expected results depend on the order of the rules.
 700  */
 701 applyb1 ([j(1), j(2), j(3)], rj1, rj2, rj3);
 702 [j(0), j(1), j(2)];
 703
 704 applyb1 ([j(1), j(2), j(3)], rj3, rj2, rj1);
 705 [j(0), j(0), j(0)];
 706
 707 /* Another test for commit 801a0bb. This time it's expected that *AFTERFLAG
 708  * prevents repeated application of the same tellsimpafter rule,
 709  * but a tellsimp rule is applied repeatedly (because it has no *AFTERFLAG).
 710  */
 711
 712 (kill(nn, k, l),
 713  matchdeclare (nn, lambda ([e], integerp(e) and e > 0)),
 714  tellsimpafter (k(nn), nn + k(nn - 1)),
 715  tellsimp (l(nn), nn + l(nn - 1)),
 716  0);
 717 0;
 718
 719 /* It's difficult to test the result of k(4) because k(3) + 4 is not maximally simplified
 720  * and the test mechanism applies simplification to both the actual and expected results.
 721  * See SIMPLE-EQUAL-P and APPROX-ALIKE in src/mload.lisp.
 722  */
 723 string (k(4));
 724 "k(3)+4";
 725
 726 /* On the other hand, l(0) is maximally simplified, so there's no difficulty here.
 727  */
 728 l(4);
 729 10 + l(0);
 730
 731 /* Another test for commit 801a0bb.
 732  * Tellsimpafter rules change operator from f, to g, to h, to i.
 733  */
 734
 735 (kill(f, g, h, i),
 736  simp:false,
 737  tellsimpafter(f(1), g(1)),
 738  tellsimpafter(g(1), h(1)),
 739  tellsimpafter(h(1), i(1)),
 740  simp:true);
 741 true;
 742
 743 f(1);
 744 i(1);
 745
 746 /* examples to exercise COMPILEPLUS
 747  * These were devised while investigating
 748  * SF bug #3683: "rule function tries to divide out -1, leading to trouble"
 749  * but don't actually have any effect on that bug,
 750  * since these are all about "+" expressions instead of "*".
 751  * Anyway, it doesn't hurt to have more finger exercises.
 752  */
 753
 754 (kill (all),
 755  matchdeclare (aa, all),
 756  matchdeclare (ii, integerp, jj, lambda ([x], integerp(x) and x#0)),
 757  matchdeclare (uu, mapatom, vv, subvarp),
 758  matchdeclare ([xx, yy], symbolp));
 759 done;
 760
 761 (defrule(r1, aa + ii, foo(aa, ii)), 0);
 762 0;
 763
 764 r1(123 + x/y - 2*a);
 765 foo(x/y - 2*a, 123);
 766
 767 r1(x/y - 2*a);
 768 foo(x/y - 2*a, 0);
 769
 770 r1(x + y*%pi - 22/7);
 771 foo(x + y*%pi - 22/7, 0);
 772
 773 /* trips "COMPILEPLUS: MEVAL #2" */
 774 (defrule(r2, aa + ii + 123, foo(aa, ii)), 0);
 775 0;
 776
 777 r2(x/y - 2*a);
 778 foo(x/y - 2*a, -123);
 779
 780 r2(x + y*%pi - 22/7);
 781 foo(x + y*%pi - 883/7, 0);
 782
 783 /* trips "COMPILEPLUS: MEVAL #2" */
 784 (defrule(r3, aa*4 + ii + 123, foo(aa, ii)), 0);
 785 0;
 786
 787 r3(4*u + x[2] + 1230);
 788 false;
 789
 790 r3(4*u + x[2] + 123);
 791 false;
 792
 793 r3(4*u + 123);
 794 foo(u, 0);
 795
 796 r3(u + 123);
 797 foo(u/4, 0);
 798
 799 r3(4*(u - v));
 800 foo(u - v, -123);
 801
 802 /* trips "COMPILEPLUS: MEVAL #5" */
 803 (defrule(r4, g(ii) + xx(uu) + aa, baz(ii,xx,uu,aa)), 0);
 804 0;
 805
 806 r4(f(b[2]) + g(123) + sqrt(3)/z);
 807 baz(123, f, b[2], sqrt(3)/z);
 808
 809 (defrule(r1a, yy(xx) + ii + aa, foo(aa, ii, xx, yy)), 0);
 810 0;
 811
 812 r1a(h(v) + 100 + %pi/2);
 813 foo(%pi/2, 100, v, h);
 814
 815 /* to be expected: yy(xx) matches only one of the terms g(u), h(v) */
 816 r1a(g(u) + h(v) + 100 + %pi/2);
 817 foo(h(v) + %pi/2, 100, u, g);
 818
 819 (defrule(r2b, ii + xx + aa, foo(aa, ii, xx)), 0);
 820 0;
 821
 822 r2b (u + v + w);
 823 foo(0, 0, w + v + u);
 824
 825 /* to be expected: aa matches -v because -v is not a symbol, so xx doesn't match */
 826 r2b (u - v + w);
 827 foo(- v, 0, u + w);
 828
 829 /* to be expected: ii matches -1234 because -1234 is an integer */
 830 r2b(sin(x)*cos(y) + w + v + u - 1234);
 831 foo(sin(x)*cos(y), - 1234, w + v + u);
 832
 833 /* trips "COMPILEPLUS: MEVAL #2" */
 834 (defrule(r2a, ii + xx + aa + u, foo(aa, ii, xx)), 0);
 835 0;
 836
 837 r2a (-200 + u + v + w + x + a^2 + b^2 + c^2);
 838 foo(a^2 + b^2 + c^2, -200, v + w + x);
 839
 840 /* trips "COMPILEPLUS: MEVAL #2" twice */
 841 (defrule(r2aa, ii + xx + aa + 2 + u, foo(aa, ii, xx)), 0);
 842 0;
 843
 844 r2aa (-200 + u + v + w + x + a^2 + b^2 + c^2);
 845 foo(a^2 + b^2 + c^2, -202, v + w + x);
 846
 847 /* trips "COMPILEPLUS: MEVAL #2" */
 848 (defrule (r3aa, fgh(ii,ii + xx), foo(ii, xx)), 0);
 849 0;
 850
 851 r3aa(fgh(111, 111 + u));
 852 foo(111, u);
 853
 854 /* At present, this next example fails to match,
 855  * because PART+ is not pasted into the rule,
 856  * so it matches only a single symbol.
 857  *
 858  * Not matching is the expected output on the theory (not 100% convinced)
 859  * that PART+ is invoked when there are two or more still-to-be-matched variables.
 860  * In r3aa, there's only one, namely xx, since ii is matched already.
 861  */
 862 r3aa(fgh(111, 111 + u + v + w));
 863 false;
 864
 865 /* Same here as with preceding example. */
 866 r3aa(fgh(0, u + v + w));
 867 false;
 868
 869 /* trips "COMPILEPLUS: MEVAL #2" */
 870 (defrule(r3aaa, fgh(ii, ii + xx + uu), foo(ii, xx, uu)), 0);
 871 0;
 872
 873 r3aaa(fgh(0, u + v + w));
 874 foo(0, u + v + w, 0);
 875
 876 r3aaa(fgh(0, u + v + w + a[i] + b[j] + c[k]));
 877 foo(0, u + v + w, a[i] + b[j] + c[k]);
 878
 879 /* trips "COMPILEPLUS: MEVAL #2" */
 880 (defrule (r3aa1, fghi(xx, ii + xx), baz(ii, xx)), 0);
 881 0;
 882
 883 r3aa1(fghi(u, 111 + u));
 884 baz(111, u);
 885
 886 r3aa1(fghi(z, z));
 887 baz(0, z);
 888
 889 /* trips "COMPILEPLUS: MEVAL #2" twice */
 890 (defrule (r3a, fgh(ii,ii + xx + 1234), foo(ii, xx)), 0);
 891 0;
 892
 893 r3a(fgh(111,1345 + u));
 894 foo(111, u);
 895
 896 /* trips "COMPILEPLUS: MEVAL #2" twice */
 897 (defrule (r3b, fgh(ii,ii + xx + abc), foo(ii, xx)), 0);
 898 0;
 899
 900 r3b(fgh(111,111 + u + abc));
 901 foo(111, u);
 902
 903 /* trips "COMPILEPLUS: MEVAL #2" twice */
 904 (defrule (r3c, fgh(ii,ghi(ii + xx + abc)), foo(ii, xx)), 0);
 905 0;
 906
 907 r3c (fgh (222, ghi (222 + v + abc)));
 908 foo(222, v);
 909
 910 /* trips "COMPILEPLUS: MEVAL #2" four times */
 911 (defrule (r3c1, fgh(ii,ghi(ii + xx + abc + bcd + cde)), foo(ii, xx)), 0);
 912 0;
 913
 914 r3c1 (fgh (222, ghi (222 + v + abc + bcd + cde)));
 915 foo(222, v);
 916
 917 /* trips "COMPILEPLUS: MEVAL #2" twice */
 918 (defrule (r3d, fgh(ii,ghi(hij(ii) + xx + abc)), foo(ii, xx)), 0);
 919 0;
 920
 921 r3d(fgh(111,ghi(hij(111) + u + abc)));
 922 foo(111, u);
 923
 924 /* trips "COMPILEPLUS: MEVAL #2" and then "COMPILEPLUS: MEVAL #5" twice */
 925 (defrule (r4,  ii + ghi(hij(ii) + xx + abc), foo(ii, xx)), 0);
 926 0;
 927
 928 r4 (345 + ghi(hij(345) + y + abc));
 929 foo(345, y);
 930
 931 /* trips "COMPILEPLUS: MEVAL #5" three times */
 932 (defrule (r4a, ii + ghi(hij(ii) + xx + abc(yy)), foo(ii, xx, yy)), 0);
 933 0;
 934
 935 r4a (345 + ghi(hij(345) + y + abc(z)));
 936 foo(345, y, z);
 937
 938 /* trips "COMPILEPLUS: MEVAL #5" three times and then "COMPILEPLUS: MEVAL #1" once */
 939 (defrule (r4b, ii + ghi(hij(ii, jj) + xx + abc(yy)) + yy, foo(ii, jj, xx, yy)), 0);
 940 0;
 941
 942 r4b (345 + ghi(hij(345, 999) + uvw + abc(z123)) + z123);
 943 foo(345, 999, uvw, z123);
 944
 945 /* trips "COMPILEPLUS: MEVAL #5", then "COMPILEPLUS: MEVAL #2", then "COMPILEPLUS: MEVAL #5" again, then "COMPILEPLUS: MEVAL #1" */
 946 (defrule (r4c, ii + ghi(hij(ii, jj, yy) + xx + abc(yy)) + yy, foo(ii, jj, xx, yy)), 0);
 947 0;
 948
 949 r4c (345 + ghi(hij(345, 999, z123) + uvw + abc(z123)) + z123);
 950 foo(345, 999, uvw, z123);
 951
 952 /* trips "COMPILEPLUS: MEVAL #5" three times and then "COMPILEPLUS: MEVAL #1" once */
 953 (defrule (r4d, ii + ghi(hij(ii) + xx + abc(yy)) + yy, foo(ii, xx, yy)), 0);
 954 0;
 955
 956 r4d (345 + ghi(hij(345) + uvw + abc(z123)) + z123);
 957 foo(345, uvw, z123);
 958
 959 (defrule (r4e, ii + ghi(ii + xx + abc(yy)) + yy, foo(ii, xx, yy)), 0);
 960 0;
 961
 962 /* trips "COMPILEPLUS: MEVAL #5" twice and then "COMPILEPLUS: MEVAL #1" once */
 963 r4e (345 + ghi(345 + uvw + abc(z123)) + z123);
 964 foo(345, uvw, z123);
 965
 966 /* trips "COMPILEPLUS: MEVAL #5" once and then "COMPILEPLUS: MEVAL #1" once */
 967 (defrule (r4f, ii + ghi(ii + xx + vv) + vv, baz(ii, xx, vv)), 0);
 968 0;
 969
 970 r4f (ghi(345 + uvw + z[3]) + 345 + z[3]);
 971 baz(345, uvw, z[3]);
 972
 973 r4f(ghi(u + v + z[3] + w[2] + 123) + z[3] + w[2] + 123);
 974 baz(123, u + v, z[3] + w[2]);
 975
 976 /* trips "COMPILEPLUS: MEVAL #5" once and then "COMPILEPLUS: MEVAL #1" once */
 977 (defrule (r4fb, jj + ghi(jj + vv + yy) + yy, foo(jj, vv, yy)), 0);
 978 0;
 979
 980 r4fb (345 + ghi(345 + z[123] + uvw) + uvw);
 981 foo(345, z[123], uvw);
 982
 983 r4fb (345 + ghi(345 + z[123] + u + v + w) + u + v + w);
 984 foo(345, z[123], u + v + w);
 985
 986 (defrule (r4f1, zyx(ii, ghi(ii, xx, yy), yy), foo(ii, xx, yy)), 0);
 987 0;
 988
 989 r4f1 (zyx (345, ghi(345, uvw, z123), z123));
 990 foo(345, uvw, z123);
 991
 992 /* trips "COMPILEPLUS: MEVAL #5" once and then "COMPILEPLUS: MEVAL #1" once */
 993 (defrule (r4f2, jj  + ghi(jj + yy) + yy, foo(jj, yy)), 0);
 994 0;
 995
 996 r4f2 (345 + ghi(345 + z123) + z123);
 997 foo(345, z123);
 998
 999 /* trips "COMPILEPLUS: MEVAL #5" once and then "COMPILEPLUS: MEVAL #1" once */
1000 (defrule (r4g, ii + ghi(ii + yy) + yy, foo(ii, yy)), 0);
1001 0;
1002
1003 r4g(u + ghi(u + 123) + 123);
1004 foo(123, u);
1005
1006 (defrule (r5a, jj*xx*vv + yy, baz(jj, vv, xx, yy)), 0);
1007 0;
1008
1009 r5a (17*a*y[4] + mumble);
1010 baz (17, y[4], a, mumble);
1011
1012 r5a (17*a*u*z[4]*y[4] + mumble);
1013 baz (17, z[4]*y[4], a*u, mumble);
1014
1015 (defrule (r5b, 17*vv + yy, baz(vv, yy)), 0);
1016 0;
1017
1018 r5b (17*y[4] + mumble);
1019 baz (y[4], mumble);
1020
1021 /* trips "COMPILEPLUS: MEVAL #3" */
1022 (defrule (r5c, mysymbol*vv + yy, baz(vv, yy)), 0);
1023 0;
1024
1025 r5c (mysymbol*y[4] + mumble);
1026 baz (y[4], mumble);
1027
1028 /* trips "COMPILEPLUS: MEVAL #5" */
1029 (defrule (r6a, jj^xx + yy + vv, quux(jj, vv, xx, yy)), 0);
1030 0;
1031
1032 r6a (29^blurf + b + w[3]);
1033 quux (29, w[3], blurf, b);
1034
1035 r6a (29^blurf + b + c + d + w[3] + m[7]);
1036 quux (29, w[3] + m[7], blurf, b + c + d);
1037
1038 /* trips "COMPILEPLUS: MEVAL #4" */
1039 (defrule (r6b, 29^xx + vv, quux(vv, xx)), 0);
1040 0;
1041
1042 r6b (29^blurf + w[3]);
1043 quux (w[3], blurf);
1044