src/matcom.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancements.                   ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8 ;;;     (c) Copyright 1982 Massachusetts Institute of Technology         ;;;
   9 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10
  11 (in-package :maxima)
  12
  13 (macsyma-module matcom)
  14
  15 ;; This is the Match Compiler.
  16
  17 (declare-top (special boundlist reflist topreflist program))
  18
  19 (defmvar $announce_rules_firing nil)
  20
  21 (defmspec $matchdeclare (form)
  22   (let ((meta-prop-p nil))
  23     (proc-$matchdeclare (cdr form))))
  24
  25 (defun proc-$matchdeclare (x)
  26   (if (oddp (length x))
  27       (merror (intl:gettext "matchdeclare: must be an even number of arguments.")))
  28   (do ((x x (cddr x))) ((null x))
  29     (cond ((symbolp (car x))
  30            (cond ((and (not (symbolp (cadr x)))
  31                        (or (numberp (cadr x))
  32                            (member (caaadr x) '(mand mor mnot mcond mprog) :test #'eq)))
  33                   (improper-arg-err (cadr x) '$matchdeclare)))
  34            (meta-add2lnc (car x) '$props)
  35            (meta-mputprop (car x) (ncons (cadr x)) 'matchdeclare))
  36           ((not ($listp (car x)))
  37            (improper-arg-err (car x) '$matchdeclare))
  38           (t (do ((l (cdar x) (cdr l))) ((null l))
  39                (proc-$matchdeclare (list (car l) (cadr x)))))))
  40   '$done)
  41
  42 (defun compileatom (e p)
  43   (prog (d)
  44      (setq d (getdec p e))
  45      (return (cond ((null d)
  46                     (emit (list 'cond
  47                                 (list (list 'not
  48                                             (list 'equal
  49                                                   e
  50                                                   (list 'quote p)))
  51                                       '(matcherr)))))
  52                    ((member p boundlist :test #'eq)
  53                     (emit (list 'cond
  54                                 (list (list 'not (list 'equal e p))
  55                                       '(matcherr)))))
  56                    (t (setq boundlist (cons p boundlist)) (emit d))))))
  57
  58 (defun emit (x) (setq program (nconc program (list x))))
  59
  60 (defun memqargs (x)
  61   (cond ((or (numberp x) (member x boundlist :test #'eq)) x)
  62         ((and (symbolp x) (get x 'operators)) `(quote ,x))
  63         ;; ((NULL BOUNDLIST) (LIST 'SIMPLIFYA (LIST 'QUOTE X) NIL))
  64         (t `(meval (quote ,x)))))
  65
  66 (defun makepreds (l gg)
  67   (cond ((null l) nil)
  68         (t (cons (cond ((atom (car l))
  69                         (list 'lambda (list (setq gg (gensym)))
  70                               `(declare (special ,gg))
  71                               (getdec (car l) gg)))
  72                        (t (defmatch1 (car l) (gensym))))
  73                  (makepreds (cdr l) nil)))))
  74
  75 (defun defmatch1 (pt e)
  76   (prog (topreflist program prog-variables)
  77      (setq topreflist (list e))
  78      (cond ((atom (errset (compilematch e pt)))
  79             (merror (intl:gettext "defmatch: failed to compile match for pattern ~M") pt))
  80            (t
  81          ;; NOTE TO TRANSLATORS: MEANING OF FOLLOWING TEXT IS UNKNOWN
  82          (mtell "defmatch: ~M will be matched uniquely since sub-parts would otherwise be ambiguous.~%" pt)
  83               (return (list 'lambda
  84                             (list e)
  85                             `(declare (special ,e))
  86                             (list 'catch ''match
  87                                   (nconc (list 'prog)
  88                                          (list (setq prog-variables (cdr (reverse topreflist))))
  89                      `((declare (special ,@ prog-variables)))
  90                                          program
  91                                          (list (list 'return t))))))))))
  92
  93 (defun compileplus (e p)
  94   (prog (reflist f g h flag leftover)
  95    a    (setq p (cdr p))
  96    a1   (cond ((null p)
  97                (cond ((null leftover)
  98                       (return (emit (list 'cond
  99                                           (list (list 'not (list 'equal e 0.))
 100                                                 '(matcherr))))))
 101                      ((null (cdr leftover)) (return (compilematch e (car leftover))))
 102                      ((setq f (intersection leftover boundlist :test #'equal))
 103                       (emit (list 'setq
 104                                   e
 105                                   (list 'meval
 106                                         (list 'quote
 107                                               (list '(mplus)
 108                                                     e
 109                                                     (list '(mminus) (car f)))))))
 110                       (setq leftover (delete (car f) leftover :test #'equal))
 111                       (go a1))
 112                      (t
 113                       ;; Almost nobody knows what this means. Just suppress the noise.
 114                       ;; (mtell "COMPILEPLUS: ~M partitions '+'
 115                       ;; expression.~%" (cons '(mplus) leftover))
 116                       (setq boundlist (append boundlist (remove-if-not #'atom leftover)))
 117                       (return (emit (list 'cond
 118                                           (list (list 'part+
 119                                                       e
 120                                                       (list 'quote leftover)
 121                                                       (list 'quote
 122                                                             (makepreds leftover nil))))
 123                                           '(t (matcherr))))))))
 124               ((fixedmatchp (car p))
 125                (emit (list 'setq
 126                            e
 127                            (list 'meval
 128                                  (list 'quote
 129                                        (list '(mplus)
 130                                              e
 131                                              (list '(mminus) (car p))))))))
 132               ((atom (car p))
 133                (cond ((cdr p) (setq leftover (cons (car p) leftover)) (setq p (cdr p)) (go a1))
 134                      (leftover (setq leftover (cons (car p) leftover)) (setq p nil) (go a1)))
 135                (setq boundlist (cons (car p) boundlist))
 136                (emit (getdec (car p) e))
 137                (cond ((null (cdr p)) (return nil)) (t (go a))))
 138               ((eq (caaar p) 'mtimes)
 139                (cond ((and (not (or (numberp (cadar p))
 140                                (and (not (atom (cadar p)))
 141                                   (eq (caar (cadar p)) 'rat))))
 142                          (fixedmatchp (cadar p)))
 143                       (setq flag nil)
 144                       (emit `(setq ,(genref)
 145                                    (ratdisrep
 146                                     (ratcoef ,e ,(memqargs (cadar p))))))
 147                       (compiletimes (car reflist) (cons '(mtimes) (cddar p)))
 148                       (emit `(setq ,e (meval
 149                                        (quote
 150                                         (($ratsimp)
 151                                          ((mplus) ,e
 152                                                   ((mtimes) -1 ,(car reflist)
 153                                                             ,(cadar p)))))))))
 154                      ((null flag)
 155                       (setq flag t) (rplacd (car p) (reverse (cdar p))) (go a1))
 156                      (t (setq leftover (cons (car p) leftover)) (go a))))
 157               ((eq (caaar p) 'mexpt)
 158                (cond ((fixedmatchp (cadar p))
 159                       (setq f 'findexpon)
 160                       (setq g (cadar p))
 161                       (setq h (caddar p)))
 162                      ((fixedmatchp (caddar p))
 163                       (setq f 'findbase)
 164                       (setq g (caddar p))
 165                       (setq h (cadar p)))
 166                      (t (go functionmatch)))
 167                (emit (list 'setq
 168                            (genref)
 169                            (list f e (setq g (memqargs g)) ''mplus)))
 170                (emit (list 'setq
 171                            e
 172                            (list 'meval
 173                                  (list 'quote
 174                                        (list '(mplus)
 175                                              e
 176                                              (list '(mminus)
 177                                                    (cond ((eq f 'findexpon)
 178                                                           (list '(mexpt)
 179                                                                 g
 180                                                                 (car reflist)))
 181                                                          (t (list '(mexpt)
 182                                                                   (car reflist)
 183                                                                   g)))))))))
 184                (compilematch (car reflist) h))
 185               ((not (fixedmatchp (caaar p)))
 186                (cond ((cdr p)
 187                       (setq leftover (cons (car p) leftover))
 188                       (setq p (cdr p))
 189                       (go a1))
 190                      (leftover (setq leftover (cons (car p) leftover)) (setq p nil) (go a1)))
 191                (setq boundlist (cons (caaar p) boundlist))
 192                (emit (list 'msetq
 193                            (caaar p)
 194                            (list 'kaar e)))
 195                (go functionmatch))
 196               (t (go functionmatch)))
 197      (go a)
 198    functionmatch
 199      (emit (list 'setq
 200                  (genref)
 201                  (list 'findfun e (memqargs (caaar p)) ''mplus)))
 202      (cond ((eq (caaar p) 'mplus)
 203             (mtell (intl:gettext "COMPILEPLUS: warning: '+' within '+' in: ~M~%") (car p))
 204             (compileplus (car reflist) (car p)))
 205            (t (emit (list 'setq (genref) (list 'kdr (cadr reflist))))
 206               (compileeach (car reflist) (cdar p))))
 207      (emit (list 'setq
 208                  e
 209                  (list 'meval
 210                        (list 'quote
 211                              (list '(mplus) e (list '(mminus) (car p)))))))
 212      (go a)))
 213
 214 (defun compiletimes (e p)
 215   (prog (reflist f g h leftover)
 216    a    (setq p (cdr p))
 217    a1   (cond ((null p)
 218                (cond ((null leftover)
 219                       (return (emit (list 'cond
 220                                           (list (list 'not (list 'equal e 1.))
 221                                                 '(matcherr))))))
 222                      ((null (cdr leftover)) (return (compilematch e (car leftover))))
 223                      ((setq f (intersection leftover boundlist :test #'equal))
 224                       (emit (list 'setq
 225                                   e
 226                                   (list 'meval
 227                                         (list 'quote
 228                                               (list '(mquotient) e (car f))))))
 229                       (setq leftover (delete (car f) leftover :test #'equal))
 230                       (go a1))
 231                      (t
 232                       ;; Almost nobody knows what this means. Just suppress the noise.
 233                       ;; (mtell "COMPILETIMES: ~M partitions '*' expression.~%" (cons '(mtimes) leftover))
 234                       (setq boundlist (append boundlist (remove-if-not #'atom leftover)))
 235                       (return (emit (list 'cond
 236                                           (list (list 'part*
 237                                                       e
 238                                                       (list 'quote leftover)
 239                                                       (list 'quote
 240                                                             (makepreds leftover nil))))
 241                                           '(t (matcherr))))))))
 242               ((fixedmatchp (car p))
 243                (emit (list 'setq
 244                            e
 245                            (list 'meval
 246                                  (list 'quote (list '(mquotient) e (car p)))))))
 247               ((atom (car p))
 248                (cond ((cdr p) (setq leftover (cons (car p) leftover)) (setq p (cdr p)) (go a1))
 249                      (leftover (setq leftover (cons (car p) leftover)) (setq p nil) (go a1)))
 250                (setq boundlist (cons (car p) boundlist))
 251                (emit (getdec (car p) e))
 252                (cond ((null (cdr p)) (return nil)) (t (go a))))
 253               ((eq (caaar p) 'mexpt)
 254                (cond ((fixedmatchp (cadar p))
 255                       (setq f 'findexpon)
 256                       (setq g (cadar p))
 257                       (setq h (caddar p)))
 258                      ((fixedmatchp (caddar p))
 259                       (setq f 'findbase)
 260                       (setq g (caddar p))
 261                       (setq h (cadar p)))
 262                      (t (go functionmatch)))
 263                (emit (list 'setq
 264                            (genref)
 265                            (list f e (setq g (memqargs g)) ''mtimes)))
 266                (cond ((eq f 'findbase)
 267                       (emit (list 'cond
 268                                   (list (list 'equal (car reflist) 0)
 269                                         '(matcherr))))))
 270                (emit (list 'setq
 271                            e
 272                            (list 'meval
 273                                  (list 'quote
 274                                        (list '(mquotient)
 275                                              e
 276                                              (cond ((eq f 'findexpon)
 277                                                     (list '(mexpt) g (car reflist)))
 278                                                    (t (list '(mexpt)
 279                                                             (car reflist)
 280                                                             g))))))))
 281                (compilematch (car reflist) h))
 282               ((not (fixedmatchp (caaar p)))
 283                (cond ((cdr p)
 284                       (setq leftover (cons (car p) leftover))
 285                       (setq p (cdr p))
 286                       (go a1))
 287                      (leftover (setq leftover (cons (car p) leftover)) (setq p nil) (go a1)))
 288                (setq boundlist (cons (caaar p) boundlist))
 289                (emit (list 'msetq
 290                            (caaar p)
 291                            (list 'kaar e)))
 292                (go functionmatch))
 293               (t (go functionmatch)))
 294      (go a)
 295    functionmatch
 296      (emit (list 'setq
 297                  (genref)
 298                  (list 'findfun e (memqargs (caaar p)) ''mtimes)))
 299      (cond ((eq (caaar p) 'mtimes)
 300             (mtell (intl:gettext "COMPILETIMES: warning: '*' within '*' in: ~M~%") (car p))
 301             (compiletimes (car reflist) (car p)))
 302            (t (emit (list 'setq (genref) (list 'kdr (cadr reflist))))
 303               (compileeach (car reflist) (cdar p))))
 304      (emit (list 'setq
 305                  e
 306                  (list 'meval
 307                        (list 'quote (list '(mquotient) e (car p))))))
 308      (go a)))
 309
 310
 311 (defmspec $defmatch (form)
 312   (let ((meta-prop-p nil))
 313     (proc-$defmatch (cdr form))))
 314
 315 (defun proc-$defmatch (l)
 316   (prog (pt pt* args a boundlist reflist topreflist program name tem)
 317      (setq name (car l))
 318      (setq pt (copy-tree (setq pt* (simplify (cadr l)))))
 319      (cond ((atom pt)
 320             (setq pt (copy-tree (setq pt* (meval pt))))
 321             (mtell (intl:gettext "defmatch: evaluation of atomic pattern yields: ~M~%") pt)))
 322      (setq args (cddr l))
 323      (cond ((null (allatoms args)) (mtell (intl:gettext "defmatch: some pattern variables are not atoms."))
 324             (return nil)))
 325      (setq boundlist args)
 326      (setq a (genref))
 327      (cond ((atom (errset (compilematch a pt)))
 328             (merror (intl:gettext "defmatch: failed to compile match for pattern ~M") pt))
 329            (t (meta-fset name
 330                          (list 'lambda
 331                                (cons a args)
 332                                `(declare (special ,a ,@ boundlist))
 333                                (list 'catch ''match
 334                                      (nconc (list 'prog)
 335                                             (list (setq tem  (cdr (reverse topreflist))))
 336                                             `((declare (special ,@ tem)))
 337
 338                                             (when (not (atom pt))
 339                                               ;; Ensure that the expression to be matched is an array expression iff the pattern is.
 340                                               (if (member 'array (car pt))
 341                                                 (list `(when (not (member 'array (kar ,a))) (matcherr)))
 342                                                 (list `(when (member 'array (kar ,a)) (matcherr)))))
 343
 344                                             program
 345                                             (list (list 'return
 346                                                         (cond (boundlist (cons 'retlist
 347                                                                                boundlist))
 348                                                               (t t))))))))
 349               (meta-add2lnc name '$rules)
 350               (meta-mputprop name (list '(mlist) pt* (cons '(mlist) args)) '$rule)
 351               (return name)))))
 352
 353 (defmspec $tellsimp (form)
 354   (let ((meta-prop-p nil))
 355     (proc-$tellsimp (cdr form))))
 356
 357 (defmfun $clear_rules ()
 358   (mapc 'kill1 (cdr $rules))
 359   (loop for v in '(mexpt mplus mtimes)
 360          do (setf (mget v 'rulenum) nil)))
 361
 362 (defun proc-$tellsimp (l)
 363   (prog (pt rhs boundlist reflist topreflist a program name tem
 364          oldstuff pgname oname rulenum)
 365      (setq pt (copy-tree (simplifya (car l) nil)))
 366      (setq name pt)
 367      (setq rhs (copy-tree (simplifya (cadr l) nil)))
 368      (cond ((alike1 pt rhs) (merror (intl:gettext "tellsimp: circular rule attempted.")))
 369            ((atom pt) (merror (intl:gettext "tellsimp: pattern must not be an atom; found: ~A") (fullstrip1 (getop name))))
 370            ((mget (setq name (caar pt)) 'matchdeclare)
 371             (merror (intl:gettext "tellsimp: main operator of pattern must not be match variable; found: ~A") (fullstrip1 (getop name))))
 372            ((member name '(mplus mtimes) :test #'eq)
 373             (mtell (intl:gettext "tellsimp: warning: rule will treat '~M' as noncommutative and nonassociative.~%") name)))
 374      (setq a (genref))
 375      (cond ((atom (errset (compileeach a (cdr pt))))
 376             (merror (intl:gettext "tellsimp: failed to compile match for pattern ~M") (cdr pt))))
 377      (setq oldstuff (get name 'operators))
 378      (setq rulenum (mget name 'rulenum))
 379      (cond ((null rulenum) (setq rulenum 1.)))
 380      (setq oname (getop name))
 381      (setq pgname (implode (append (%to$ (explodec oname))
 382                                    '(|r| |u| |l| |e|)
 383                                    (mexploden rulenum))))
 384      (meta-mputprop pgname name 'ruleof)
 385      (meta-add2lnc pgname '$rules)
 386      (meta-mputprop name (f1+ rulenum) 'rulenum)
 387      (meta-fset pgname
 388                 (list 'lambda '(x a2 a3)
 389                       `(declare (special x a2 a3))
 390                       (list 'prog
 391                             (list 'ans a 'rule-hit)
 392                             `(declare (special ans ,a))
 393                             (list 'setq
 394                                   'x
 395                                   (list 'cons
 396                                         '(car x)
 397                                         (list 'setq
 398                                               a
 399                                               '(cond (a3 (cdr x))
 400                                                 (t (mapcar #'(lambda (h) (simplifya h a3))
 401                                                     (cdr x)))))))
 402                             (list
 403                              'multiple-value-setq
 404                              '(ans rule-hit)
 405                              (list 'catch ''match
 406                                    (nconc (list 'prog)
 407                                           (list (setq tem (nconc boundlist
 408                                                                  (cdr (reverse topreflist)))))
 409                                           `((declare (special ,@ tem)))
 410
 411                                           ;; Ensure that the expression to be matched is an array expression iff the pattern is.
 412                                           (if (member 'array (car pt))
 413                                             (list '(when (not (member 'array (kar x))) (matcherr)))
 414                                             (list '(when (member 'array (kar x)) (matcherr))))
 415
 416                                           program
 417                                           (list (list 'return
 418                                                       (list 'values (memqargs rhs) t))))))
 419                             (cond ((not (member name '(mtimes mplus) :test #'eq))
 420                                    (list 'return
 421                                          (list 'cond
 422                                                '(rule-hit ans) '((and (not dosimp) (member 'simp (cdar x) :test #'eq))x)
 423                                                (list t
 424                                                      (cond (oldstuff (cons oldstuff
 425                                                                            '(x a2 t)))
 426                                                            (t '(eqtest x x)))))))
 427                                   ((eq name 'mtimes)
 428                                    (list 'return
 429                                          (list 'cond
 430                                                (list '(and (equal 1. a2) rule-hit) 'ans)
 431                                                '(rule-hit (meval '((mexpt) ans a2)))
 432                                                (list t
 433                                                      (cond (oldstuff (cons oldstuff
 434                                                                            '(x a2 a3)))
 435                                                            (t '(eqtest x x)))))))
 436                                   ((eq name 'mplus)
 437                                    (list 'return
 438                                          (list 'cond
 439                                                (list '(and (equal 1. a2) rule-hit) 'ans)
 440                                                '(rule-hit (meval '((mtimes) ans a2)))
 441                                                (list t
 442                                                      (cond (oldstuff (cons oldstuff
 443                                                                            '(x a2 a3)))
 444                                                            (t '(eqtest x x)))))))))))
 445      (meta-mputprop pgname (list '(mequal) pt rhs) '$rule)
 446      (cond ((null (mget name 'oldrules))
 447             (meta-mputprop name
 448                            (list (get name 'operators))
 449                            'oldrules)))
 450      (meta-putprop name pgname 'operators)
 451      (return (cons '(mlist)
 452                    (meta-mputprop name
 453                                   (cons pgname (mget name 'oldrules))
 454                                   'oldrules)))))
 455
 456 (defun %to$ (l) (cond ((eq (car l) '%) (rplaca l '$)) (l)))
 457
 458
 459 (defmspec $tellsimpafter (form)
 460   (let ((meta-prop-p nil))
 461     (proc-$tellsimpafter (cdr form))))
 462
 463 (defun proc-$tellsimpafter (l)
 464   (prog (pt rhs boundlist reflist topreflist a program name oldstuff plustimes pgname oname tem
 465          rulenum my*afterflag)
 466      (setq pt (copy-tree (simplifya (car l) nil)))
 467      (setq name pt)
 468      (setq rhs (copy-tree (simplifya (cadr l) nil)))
 469      (cond ((alike1 pt rhs) (merror (intl:gettext "tellsimpafter: circular rule attempted.")))
 470            ((atom pt) (merror (intl:gettext "tellsimpafter: pattern must not be an atom; found: ~A") (fullstrip1 (getop name))))
 471            ((mget (setq name (caar pt)) 'matchdeclare)
 472             (merror (intl:gettext "tellsimpafter: main operator of pattern must not be match variable; found: ~A") (fullstrip1 (getop name)))))
 473      (setq a (genref))
 474      (setq plustimes (member name '(mplus mtimes) :test #'eq))
 475      (if (atom (if plustimes (errset (compilematch a pt))
 476                    (errset (compileeach a (cdr pt)))))
 477          (merror (intl:gettext "tellsimpafter: failed to compile match for pattern ~M") (cdr pt)))
 478      (setq oldstuff (get name 'operators))
 479      (setq rulenum (mget name 'rulenum))
 480      (if (null rulenum) (setq rulenum 1))
 481      (setq oname (getop name))
 482      (setq pgname (implode (append (%to$ (explodec oname))
 483                                    '(|r| |u| |l| |e|) (mexploden rulenum))))
 484      (setq my*afterflag (gensym "*AFTERFLAG-"))
 485      (proclaim `(special ,my*afterflag))
 486      (setf (symbol-value my*afterflag) nil)
 487      (meta-mputprop pgname name 'ruleof)
 488      (meta-add2lnc pgname '$rules)
 489      (meta-mputprop name (f1+ rulenum) 'rulenum)
 490      (meta-fset
 491       pgname
 492       (list
 493        'lambda
 494        '(x ans a3)
 495        (if oldstuff
 496          (list 'setq 'x (list oldstuff 'x 'ans 'a3))
 497          (list 'setq 'x (list 'simpargs1 'x 'ans 'a3)))
 498        (list
 499         'cond
 500
 501         `(,my*afterflag x)
 502         (list 't
 503               (nconc (list 'prog)
 504                      (list (cons a `(,my*afterflag rule-hit)))
 505                      `((declare (special ,a ,my*afterflag)))
 506                      (list `(setq ,my*afterflag t))
 507                      (cond (oldstuff (subst (list 'quote name)
 508                                             'name
 509                                             '((cond ((or (atom x) (not (eq (caar x) name)))
 510                                                      (return x)))))))
 511                      (list (list 'setq
 512                                  a
 513                                  (cond (plustimes 'x) (t '(cdr x)))))
 514                      (list (list 'multiple-value-setq
 515                                  '(ans rule-hit)
 516                                  (list 'catch ''match
 517                                        (nconc (list 'prog)
 518                                               (list (setq tem(nconc boundlist
 519                                                                     (cdr (reverse topreflist)))))
 520                                               `((declare (special ,@ tem)))
 521
 522                                               ;; Ensure that the expression to be matched is an array expression iff the pattern is.
 523                                               (if (member 'array (car pt))
 524                                                 (list '(when (not (member 'array (kar x))) (matcherr)))
 525                                                 (list '(when (member 'array (kar x)) (matcherr))))
 526
 527                                               program
 528                           (cond
 529                             ($announce_rules_firing
 530                               (list (list 'return (list 'values (list 'announce-rule-firing `',pgname 'x (memqargs rhs)) t))))
 531                             (t
 532                               (list (list 'return (list 'values (memqargs rhs) t)))))))))
 533                      (list '(return (if rule-hit ans (eqtest x x)))))))))
 534      (meta-mputprop pgname (list '(mequal) pt rhs) '$rule)
 535      (cond ((null (mget name 'oldrules))
 536             (meta-mputprop name (list (get name 'operators)) 'oldrules)))
 537      (meta-putprop name pgname 'operators)
 538      (return (cons '(mlist)
 539                    (meta-mputprop name
 540                                   (cons pgname (mget name 'oldrules))
 541                                   'oldrules)))))
 542
 543 (defun announce-rule-firing (rulename expr simplified-expr)
 544   (let (($display2d nil) ($stringdisp nil))
 545     ($print "By" rulename "," expr "-->" simplified-expr))
 546   simplified-expr)
 547
 548 (defmspec $defrule (form)
 549   (let ((meta-prop-p nil))
 550     (proc-$defrule (cdr form))))
 551
 552 ;;(defvar *match-specials* nil);;Hell lets declare them all special, its safer--wfs
 553 (defun proc-$defrule (l)
 554   (prog (pt rhs boundlist reflist topreflist name a program lhs* rhs*   tem)
 555      (if (not (= (length l) 3)) (wna-err '$defrule))
 556      (setq name (car l))
 557      (if (or (not (symbolp name)) (mopp name) (member name '($all $%) :test #'eq))
 558          (merror (intl:gettext "defrule: rule name must be a symbol, and not an operator or 'all' or '%'; found: ~M") name))
 559      (setq pt (copy-tree (setq lhs* (simplify (cadr l)))))
 560      (setq rhs (copy-tree (setq rhs* (simplify (caddr l)))))
 561      (setq a (genref))
 562      (cond ((atom (errset (compilematch a pt)))
 563             (merror (intl:gettext "defrule: failed to compile match for pattern ~M") pt))
 564            (t (meta-fset name
 565                          (list 'lambda
 566                                (list a)
 567                                `(declare (special ,a))
 568                                (list 'catch ''match
 569                                      (nconc (list 'prog)
 570                                             (list (setq tem (nconc boundlist
 571                                                                    (cdr (reverse topreflist)))))
 572                                             `((declare (special ,@ tem)))
 573
 574                                             (when (not (atom pt))
 575                                               ;; Ensure that the expression to be matched is an array expression iff the pattern is.
 576                                               (if (member 'array (car pt))
 577                                                 (list `(when (not (member 'array (kar ,a))) (matcherr)))
 578                                                 (list `(when (member 'array (kar ,a)) (matcherr)))))
 579
 580                                             program
 581                                             (list (list 'return
 582                                                         (list 'values (memqargs rhs) t)))))))
 583               (meta-add2lnc name '$rules)
 584               (meta-mputprop name (setq l (list '(mequal) lhs* rhs*)) '$rule)
 585               (meta-mputprop name '$defrule '$ruletype)
 586               (return (list '(msetq) name (cons '(marrow) (cdr l))))))))
 587
 588 ; GETDEC constructs an expression of the form ``if <match> then <assign value> else <match failed>''.
 589
 590 ; matchdeclare (aa, true);
 591 ;  :lisp (symbol-plist '$aa) => (MPROPS (NIL MATCHDECLARE (T)))
 592 ; tellsimpafter (fa(aa), ga(aa));
 593 ;  getdec => (MSETQ $AA TR-GENSYM~1)
 594
 595 ; matchdeclare (bb, integerp);
 596 ;  :lisp (symbol-plist '$bb) => (MPROPS (NIL MATCHDECLARE ($INTEGERP)))
 597 ; tellsimpafter (fb(bb), gb(bb));
 598 ;  getdec => (COND ((IS '(($INTEGERP) TR-GENSYM~3)) (MSETQ $BB TR-GENSYM~3)) ((MATCHERR)))
 599
 600 ; my_p(x) := integerp(x) and x>100;
 601 ; matchdeclare (cc, my_p);
 602 ;  :lisp (symbol-plist '$cc) => (MPROPS (NIL MATCHDECLARE ($MY_P)))
 603 ; tellsimpafter (fc(cc), gc(cc));
 604 ;  getdec => (COND ((IS '(($MY_P) TR-GENSYM~5)) (MSETQ $CC TR-GENSYM~5)) ((MATCHERR)))
 605
 606 ; :lisp (defmfun $my_p2 (y x) (is `((mgeqp) ,x ,y)))
 607 ; matchdeclare (dd, my_p2 (200));
 608 ;  :lisp (symbol-plist '$dd) => (MPROPS (NIL MATCHDECLARE ((($MY_P2) 200))))
 609 ; tellsimpafter (fd(dd), gd(dd));
 610 ;  getdec => (COND ((IS '(($MY_P2) 200 TR-GENSYM~7)) (MSETQ $DD TR-GENSYM~7)) ((MATCHERR)))
 611
 612 ; my_p3 (y, x) := is (x > y);
 613 ; matchdeclare (ee, my_p3 (300));
 614 ;  :lisp (symbol-plist '$ee) => (MPROPS (NIL MATCHDECLARE ((($MY_P3) 300))))
 615 ; tellsimpafter (fe(ee), ge(ee));
 616 ;  getdec => (COND ((IS '(($MY_P3) 300 TR-GENSYM~9)) (MSETQ $EE TR-GENSYM~9)) ((MATCHERR)))
 617
 618 ; matchdeclare (ff, lambda ([x], x > 400));
 619 ;  :lisp (symbol-plist '$ff) => (MPROPS (NIL MATCHDECLARE (((LAMBDA) ((MLIST) $X) ((MGREATERP) $X 400)))))
 620 ; tellsimpafter (fff(ff), ggg(ff));
 621 ;  getdec => (COND ((IS (MAPPLY1 '((LAMBDA) ((MLIST) $X) ((MGREATERP) $X 400)) (LIST TR-GENSYM~11) T NIL)) (MSETQ $FF TR-GENSYM~11)) ((MATCHERR)))
 622
 623 ; matchdeclare (gg, lambda ([y, x], x > y) (500));
 624 ;  :lisp (symbol-plist '$gg) => (MPROPS (NIL MATCHDECLARE (((MQAPPLY) ((LAMBDA) ((MLIST) $Y $X) ((MGREATERP) $X $Y)) 500))))
 625 ; tellsimpafter (fg(gg), gg(gg));
 626 ;  getdec => (COND ((IS (MEVAL '((MQAPPLY) ((LAMBDA) ((MLIST) $Y $X) ((MGREATERP) $X $Y)) 500 TR-GENSYM~13))) (MSETQ $GG TR-GENSYM~13)) ((MATCHERR)))
 627
 628 ; pattern-variable is the pattern variable (as declared by matchdeclare)
 629 ; match-against is the expression to match against
 630
 631 ; Return T if $MAYBE returns T, otherwise NIL.
 632 ; That makes all non-T values (e.g. $UNKNOWN or noun expressions) act like NIL.
 633
 634 (defun definitely-so (e)
 635   (eq (mfuncall '$maybe e) t))
 636
 637 (defun getdec (pattern-variable match-against)
 638   (let (p)
 639     (if (setq p (mget pattern-variable 'matchdeclare))
 640       ; P is (<foo>) where <foo> is the matchdeclare predicate
 641       ; If <foo> is an atom, it is T or the name of a Lisp or Maxima function
 642       ; Otherwise, <foo> is ((<op>) <args>)
 643
 644       ; If <foo> is $TRUE, T, or $ALL, generated code always assigns gensym value to pattern variable
 645       (if (and (atom (car p)) (member (car p) '($true t $all) :test #'eq))
 646         `(msetq ,pattern-variable ,match-against)
 647
 648         ; Otherwise, we have some work to do.
 649
 650         (let ((p-op (car p)) (p-args) (test-expr))
 651           (setq test-expr
 652                 (if (atom p-op)
 653                   ; P-OP is the name of a function. Try to generate a Lisp function call.
 654                   (if (and (fboundp p-op) (not (get p-op 'translated)))   ; WHY THE TEST FOR TRANSLATED PROPERTY ??
 655                     `(eq t (,p-op ,@(ncons match-against)))
 656                     `(definitely-so '((,p-op) ,@(ncons match-against))))
 657
 658                   ; Otherwise P-OP is something like ((<op>) <args>).
 659                   (progn
 660                     (setq p-args (cdr p-op))
 661                     (cond
 662                       ((eq (caar p-op) 'lambda)
 663                        `(definitely-so (mapply1 ',p-op (list ,match-against) t nil)))
 664                       ((eq (caar p-op) 'mqapply)
 665                        `(definitely-so (meval ',(append p-op (ncons match-against)))))
 666                       ; Otherwise P-OP must be a function call with the last arg missing.
 667                       (t
 668                         (if (and (consp (car p-op)) (mget (caar p-op) 'mmacro))
 669                           `(definitely-so (cons ',(car p-op) ,(append '(list) (mapcar 'memqargs p-args) (ncons match-against))))
 670                           `(definitely-so (cons ',(car p-op) ',(append (mapcar 'memqargs p-args) (ncons match-against))))))))))
 671
 672           `(cond
 673              (,test-expr (msetq ,pattern-variable ,match-against))
 674              ((matcherr))))))))
 675
 676 (defun compilematch (e p)
 677   (prog (reflist)
 678      (cond ((fixedmatchp p)
 679             (emit (list 'cond
 680                         (list (list 'not
 681                                     (list 'alike1
 682                                           e
 683                                           (list 'meval (list 'quote
 684                                                              p))))
 685                               '(matcherr)))))
 686            ((atom p) (compileatom e p))
 687            ((eq (caar p) 'mplus) (compileplus e p))
 688            ((eq (caar p) 'mtimes) (compiletimes e p))
 689            (t (compileatom (list 'kaar e)
 690                            (caar p))
 691               (emit (list 'setq
 692                           (genref)
 693                           (list 'kdr e)))
 694               (compileeach (car reflist) (cdr p))))
 695      (return program)))
 696
 697 (defun genref nil
 698   (prog (a)
 699      (setq a (tr-gensym))
 700      (setq topreflist (cons a topreflist))
 701      (return (car (setq reflist (cons a reflist))))))
 702 (defun compileeach (elist plist)
 703     (prog (reflist count)
 704        (setq count 0)
 705        (setq reflist (cons elist reflist))
 706        a    (setq count (f1+ count))
 707        (cond ((null plist)
 708               (return (emit (list 'cond
 709                                   (list (list 'nthkdr elist (f1- count))
 710                                         '(matcherr)))))))
 711        (emit (list 'setq (genref) (list 'kar (cadr reflist))))
 712        (compilematch (car reflist) (car plist))
 713        (setq plist (cdr plist))
 714        (setq reflist (cons (list 'kdr (cadr reflist)) reflist))
 715        (go a)))
 716
 717 (defun fixedmatchp (x)
 718   (cond ((numberp x) t)
 719         ((atom x)
 720          (if (or (member x boundlist :test #'eq) (null (mget x 'matchdeclare))) t))
 721         (t (and (or (member (caar x) boundlist :test #'eq)
 722                     (null (mget (caar x) 'matchdeclare)))
 723                 (fmp1 (cdr x))))))
 724
 725 (defun fmp1 (x)
 726   (if (null x) t (and (fixedmatchp (car x)) (fmp1 (cdr x)))))