src/matcom.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   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 $rules $props 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                                             program
 338                                             (list (list 'return
 339                                                         (cond (boundlist (cons 'retlist
 340                                                                                boundlist))
 341                                                               (t t))))))))
 342               (meta-add2lnc name '$rules)
 343               (meta-mputprop name (list '(mlist) pt* (cons '(mlist) args)) '$rule)
 344               (return name)))))
 345
 346 (defmspec $tellsimp (form)
 347   (let ((meta-prop-p nil))
 348     (proc-$tellsimp (cdr form))))
 349
 350 (defmfun $clear_rules ()
 351   (mapc 'kill1 (cdr $rules))
 352   (loop for v in '(mexpt mplus mtimes)
 353          do (setf (mget v 'rulenum) nil)))
 354
 355 (defun proc-$tellsimp (l)
 356   (prog (pt rhs boundlist reflist topreflist a program name tem
 357          oldstuff pgname oname rulenum)
 358      (setq pt (copy-tree (simplifya (car l) nil)))
 359      (setq name pt)
 360      (setq rhs (copy-tree (simplifya (cadr l) nil)))
 361      (cond ((alike1 pt rhs) (merror (intl:gettext "tellsimp: circular rule attempted.")))
 362            ((atom pt) (merror (intl:gettext "tellsimp: pattern must not be an atom; found: ~A") (fullstrip1 (getop name))))
 363            ((mget (setq name (caar pt)) 'matchdeclare)
 364             (merror (intl:gettext "tellsimp: main operator of pattern must not be match variable; found: ~A") (fullstrip1 (getop name))))
 365            ((member name '(mplus mtimes) :test #'eq)
 366             (mtell (intl:gettext "tellsimp: warning: rule will treat '~M' as noncommutative and nonassociative.~%") name)))
 367      (setq a (genref))
 368      (cond ((atom (errset (compileeach a (cdr pt))))
 369             (merror (intl:gettext "tellsimp: failed to compile match for pattern ~M") (cdr pt))))
 370      (setq oldstuff (get name 'operators))
 371      (setq rulenum (mget name 'rulenum))
 372      (cond ((null rulenum) (setq rulenum 1.)))
 373      (setq oname (getop name))
 374      (setq pgname (implode (append (%to$ (explodec oname))
 375                                    '(|r| |u| |l| |e|)
 376                                    (mexploden rulenum))))
 377      (meta-mputprop pgname name 'ruleof)
 378      (meta-add2lnc pgname '$rules)
 379      (meta-mputprop name (f1+ rulenum) 'rulenum)
 380      (meta-fset pgname
 381                 (list 'lambda '(x a2 a3)
 382                       `(declare (special x a2 a3))
 383                       (list 'prog
 384                             (list 'ans a 'rule-hit)
 385                             `(declare (special ans ,a))
 386                             (list 'setq
 387                                   'x
 388                                   (list 'cons
 389                                         '(car x)
 390                                         (list 'setq
 391                                               a
 392                                               '(cond (a3 (cdr x))
 393                                                 (t (mapcar #'(lambda (h) (simplifya h a3))
 394                                                     (cdr x)))))))
 395                             (list
 396                              'multiple-value-setq
 397                              '(ans rule-hit)
 398                              (list 'catch ''match
 399                                    (nconc (list 'prog)
 400                                           (list (setq tem (nconc boundlist
 401                                                                  (cdr (reverse topreflist)))))
 402                                           `((declare (special ,@ tem)))
 403                                           program
 404                                           (list (list 'return
 405                                                       (list 'values (memqargs rhs) t))))))
 406                             (cond ((not (member name '(mtimes mplus) :test #'eq))
 407                                    (list 'return
 408                                          (list 'cond
 409                                                '(rule-hit ans) '((and (not dosimp) (member 'simp (cdar x) :test #'eq))x)
 410                                                (list t
 411                                                      (cond (oldstuff (cons oldstuff
 412                                                                            '(x a2 t)))
 413                                                            (t '(eqtest x x)))))))
 414                                   ((eq name 'mtimes)
 415                                    (list 'return
 416                                          (list 'cond
 417                                                (list '(and (equal 1. a2) rule-hit) 'ans)
 418                                                '(rule-hit (meval '((mexpt) ans a2)))
 419                                                (list t
 420                                                      (cond (oldstuff (cons oldstuff
 421                                                                            '(x a2 a3)))
 422                                                            (t '(eqtest x x)))))))
 423                                   ((eq name 'mplus)
 424                                    (list 'return
 425                                          (list 'cond
 426                                                (list '(and (equal 1. a2) rule-hit) 'ans)
 427                                                '(rule-hit (meval '((mtimes) ans a2)))
 428                                                (list t
 429                                                      (cond (oldstuff (cons oldstuff
 430                                                                            '(x a2 a3)))
 431                                                            (t '(eqtest x x)))))))))))
 432      (meta-mputprop pgname (list '(mequal) pt rhs) '$rule)
 433      (cond ((null (mget name 'oldrules))
 434             (meta-mputprop name
 435                            (list (get name 'operators))
 436                            'oldrules)))
 437      (meta-putprop name pgname 'operators)
 438      (return (cons '(mlist)
 439                    (meta-mputprop name
 440                                   (cons pgname (mget name 'oldrules))
 441                                   'oldrules)))))
 442
 443 (defun %to$ (l) (cond ((eq (car l) '%) (rplaca l '$)) (l)))
 444
 445
 446 (defmspec $tellsimpafter (form)
 447   (let ((meta-prop-p nil))
 448     (proc-$tellsimpafter (cdr form))))
 449
 450 (defun proc-$tellsimpafter (l)
 451   (prog (pt rhs boundlist reflist topreflist a program name oldstuff plustimes pgname oname tem
 452          rulenum my*afterflag)
 453      (setq pt (copy-tree (simplifya (car l) nil)))
 454      (setq name pt)
 455      (setq rhs (copy-tree (simplifya (cadr l) nil)))
 456      (cond ((alike1 pt rhs) (merror (intl:gettext "tellsimpafter: circular rule attempted.")))
 457            ((atom pt) (merror (intl:gettext "tellsimpafter: pattern must not be an atom; found: ~A") (fullstrip1 (getop name))))
 458            ((mget (setq name (caar pt)) 'matchdeclare)
 459             (merror (intl:gettext "tellsimpafter: main operator of pattern must not be match variable; found: ~A") (fullstrip1 (getop name)))))
 460      (setq a (genref))
 461      (setq plustimes (member name '(mplus mtimes) :test #'eq))
 462      (if (atom (if plustimes (errset (compilematch a pt))
 463                    (errset (compileeach a (cdr pt)))))
 464          (merror (intl:gettext "tellsimpafter: failed to compile match for pattern ~M") (cdr pt)))
 465      (setq oldstuff (get name 'operators))
 466      (setq rulenum (mget name 'rulenum))
 467      (if (null rulenum) (setq rulenum 1))
 468      (setq oname (getop name))
 469      (setq pgname (implode (append (%to$ (explodec oname))
 470                                    '(|r| |u| |l| |e|) (mexploden rulenum))))
 471      (setq my*afterflag (gensym "*AFTERFLAG-"))
 472      (proclaim `(special ,my*afterflag))
 473      (setf (symbol-value my*afterflag) nil)
 474      (meta-mputprop pgname name 'ruleof)
 475      (meta-add2lnc pgname '$rules)
 476      (meta-mputprop name (f1+ rulenum) 'rulenum)
 477      (meta-fset
 478       pgname
 479       (list
 480        'lambda
 481        '(x ans a3)
 482        (if oldstuff
 483          (list 'setq 'x (list oldstuff 'x 'ans 'a3))
 484          (list 'setq 'x (list 'simpargs1 'x 'ans 'a3)))
 485        (list
 486         'cond
 487         `(,my*afterflag x)
 488         (list 't
 489               (nconc (list 'prog)
 490                      (list (cons a `(,my*afterflag rule-hit)))
 491                      `((declare (special ,a ,my*afterflag)))
 492                      (list `(setq ,my*afterflag t))
 493                      (cond (oldstuff (subst (list 'quote name)
 494                                             'name
 495                                             '((cond ((or (atom x) (not (eq (caar x) name)))
 496                                                      (return x)))))))
 497                      (list (list 'setq
 498                                  a
 499                                  (cond (plustimes 'x) (t '(cdr x)))))
 500                      (list (list 'multiple-value-setq
 501                                  '(ans rule-hit)
 502                                  (list 'catch ''match
 503                                        (nconc (list 'prog)
 504                                               (list (setq tem(nconc boundlist
 505                                                                     (cdr (reverse topreflist)))))
 506                                               `((declare (special ,@ tem)))
 507                                               program
 508                           (cond
 509                             ($announce_rules_firing
 510                               (list (list 'return (list 'values (list 'announce-rule-firing `',pgname 'x (memqargs rhs)) t))))
 511                             (t
 512                               (list (list 'return (list 'values (memqargs rhs) t)))))))))
 513                      (list '(return (if rule-hit ans (eqtest x x)))))))))
 514      (meta-mputprop pgname (list '(mequal) pt rhs) '$rule)
 515      (cond ((null (mget name 'oldrules))
 516             (meta-mputprop name (list (get name 'operators)) 'oldrules)))
 517      (meta-putprop name pgname 'operators)
 518      (return (cons '(mlist)
 519                    (meta-mputprop name
 520                                   (cons pgname (mget name 'oldrules))
 521                                   'oldrules)))))
 522
 523 (defun announce-rule-firing (rulename expr simplified-expr)
 524   (let (($display2d nil) ($stringdisp nil))
 525     ($print "By" rulename "," expr "-->" simplified-expr))
 526   simplified-expr)
 527
 528 (defmspec $defrule (form)
 529   (let ((meta-prop-p nil))
 530     (proc-$defrule (cdr form))))
 531
 532 ;;(defvar *match-specials* nil);;Hell lets declare them all special, its safer--wfs
 533 (defun proc-$defrule (l)
 534   (prog (pt rhs boundlist reflist topreflist name a program lhs* rhs*   tem)
 535      (if (not (= (length l) 3)) (wna-err '$defrule))
 536      (setq name (car l))
 537      (if (or (not (symbolp name)) (mopp name) (member name '($all $%) :test #'eq))
 538          (merror (intl:gettext "defrule: rule name must be a symbol, and not an operator or 'all' or '%'; found: ~M") name))
 539      (setq pt (copy-tree (setq lhs* (simplify (cadr l)))))
 540      (setq rhs (copy-tree (setq rhs* (simplify (caddr l)))))
 541      (setq a (genref))
 542      (cond ((atom (errset (compilematch a pt)))
 543             (merror (intl:gettext "defrule: failed to compile match for pattern ~M") pt))
 544            (t (meta-fset name
 545                          (list 'lambda
 546                                (list a)
 547                                `(declare (special ,a))
 548                                (list 'catch ''match
 549                                      (nconc (list 'prog)
 550                                             (list (setq tem (nconc boundlist
 551                                                                    (cdr (reverse topreflist)))))
 552                                             `((declare (special ,@ tem)))
 553                                             program
 554                                             (list (list 'return
 555                                                         (list 'values (memqargs rhs) t)))))))
 556               (meta-add2lnc name '$rules)
 557               (meta-mputprop name (setq l (list '(mequal) lhs* rhs*)) '$rule)
 558               (meta-mputprop name '$defrule '$ruletype)
 559               (return (list '(msetq) name (cons '(marrow) (cdr l))))))))
 560
 561 ; GETDEC constructs an expression of the form ``if <match> then <assign value> else <match failed>''.
 562
 563 ; matchdeclare (aa, true);
 564 ;  :lisp (symbol-plist '$aa) => (MPROPS (NIL MATCHDECLARE (T)))
 565 ; tellsimpafter (fa(aa), ga(aa));
 566 ;  getdec => (MSETQ $AA TR-GENSYM~1)
 567
 568 ; matchdeclare (bb, integerp);
 569 ;  :lisp (symbol-plist '$bb) => (MPROPS (NIL MATCHDECLARE ($INTEGERP)))
 570 ; tellsimpafter (fb(bb), gb(bb));
 571 ;  getdec => (COND ((IS '(($INTEGERP) TR-GENSYM~3)) (MSETQ $BB TR-GENSYM~3)) ((MATCHERR)))
 572
 573 ; my_p(x) := integerp(x) and x>100;
 574 ; matchdeclare (cc, my_p);
 575 ;  :lisp (symbol-plist '$cc) => (MPROPS (NIL MATCHDECLARE ($MY_P)))
 576 ; tellsimpafter (fc(cc), gc(cc));
 577 ;  getdec => (COND ((IS '(($MY_P) TR-GENSYM~5)) (MSETQ $CC TR-GENSYM~5)) ((MATCHERR)))
 578
 579 ; :lisp (defmfun $my_p2 (y x) (is `((mgeqp) ,x ,y)))
 580 ; matchdeclare (dd, my_p2 (200));
 581 ;  :lisp (symbol-plist '$dd) => (MPROPS (NIL MATCHDECLARE ((($MY_P2) 200))))
 582 ; tellsimpafter (fd(dd), gd(dd));
 583 ;  getdec => (COND ((IS '(($MY_P2) 200 TR-GENSYM~7)) (MSETQ $DD TR-GENSYM~7)) ((MATCHERR)))
 584
 585 ; my_p3 (y, x) := is (x > y);
 586 ; matchdeclare (ee, my_p3 (300));
 587 ;  :lisp (symbol-plist '$ee) => (MPROPS (NIL MATCHDECLARE ((($MY_P3) 300))))
 588 ; tellsimpafter (fe(ee), ge(ee));
 589 ;  getdec => (COND ((IS '(($MY_P3) 300 TR-GENSYM~9)) (MSETQ $EE TR-GENSYM~9)) ((MATCHERR)))
 590
 591 ; matchdeclare (ff, lambda ([x], x > 400));
 592 ;  :lisp (symbol-plist '$ff) => (MPROPS (NIL MATCHDECLARE (((LAMBDA) ((MLIST) $X) ((MGREATERP) $X 400)))))
 593 ; tellsimpafter (fff(ff), ggg(ff));
 594 ;  getdec => (COND ((IS (MAPPLY1 '((LAMBDA) ((MLIST) $X) ((MGREATERP) $X 400)) (LIST TR-GENSYM~11) T NIL)) (MSETQ $FF TR-GENSYM~11)) ((MATCHERR)))
 595
 596 ; matchdeclare (gg, lambda ([y, x], x > y) (500));
 597 ;  :lisp (symbol-plist '$gg) => (MPROPS (NIL MATCHDECLARE (((MQAPPLY) ((LAMBDA) ((MLIST) $Y $X) ((MGREATERP) $X $Y)) 500))))
 598 ; tellsimpafter (fg(gg), gg(gg));
 599 ;  getdec => (COND ((IS (MEVAL '((MQAPPLY) ((LAMBDA) ((MLIST) $Y $X) ((MGREATERP) $X $Y)) 500 TR-GENSYM~13))) (MSETQ $GG TR-GENSYM~13)) ((MATCHERR)))
 600
 601 ; pattern-variable is the pattern variable (as declared by matchdeclare)
 602 ; match-against is the expression to match against
 603
 604 ; Return T if $MAYBE returns T, otherwise NIL.
 605 ; That makes all non-T values (e.g. $UNKNOWN or noun expressions) act like NIL.
 606
 607 (defun definitely-so (e)
 608   (eq (mfuncall '$maybe e) t))
 609
 610 (defun getdec (pattern-variable match-against)
 611   (let (p)
 612     (if (setq p (mget pattern-variable 'matchdeclare))
 613       ; P is (<foo>) where <foo> is the matchdeclare predicate
 614       ; If <foo> is an atom, it is T or the name of a Lisp or Maxima function
 615       ; Otherwise, <foo> is ((<op>) <args>)
 616
 617       ; If <foo> is $TRUE, T, or $ALL, generated code always assigns gensym value to pattern variable
 618       (if (and (atom (car p)) (member (car p) '($true t $all) :test #'eq))
 619         `(msetq ,pattern-variable ,match-against)
 620
 621         ; Otherwise, we have some work to do.
 622
 623         (let ((p-op (car p)) (p-args) (test-expr))
 624           (setq test-expr
 625                 (if (atom p-op)
 626                   ; P-OP is the name of a function. Try to generate a Lisp function call.
 627                   (if (and (fboundp p-op) (not (get p-op 'translated)))   ; WHY THE TEST FOR TRANSLATED PROPERTY ??
 628                     `(eq t (,p-op ,@(ncons match-against)))
 629                     `(definitely-so '((,p-op) ,@(ncons match-against))))
 630
 631                   ; Otherwise P-OP is something like ((<op>) <args>).
 632                   (progn
 633                     (setq p-args (cdr p-op))
 634                     (cond
 635                       ((eq (caar p-op) 'lambda)
 636                        `(definitely-so (mapply1 ',p-op (list ,match-against) t nil)))
 637                       ((eq (caar p-op) 'mqapply)
 638                        `(definitely-so (meval ',(append p-op (ncons match-against)))))
 639                       ; Otherwise P-OP must be a function call with the last arg missing.
 640                       (t
 641                         (if (and (consp (car p-op)) (mget (caar p-op) 'mmacro))
 642                           `(definitely-so (cons ',(car p-op) ,(append '(list) (mapcar 'memqargs p-args) (ncons match-against))))
 643                           `(definitely-so (cons ',(car p-op) ',(append (mapcar 'memqargs p-args) (ncons match-against))))))))))
 644
 645           `(cond
 646              (,test-expr (msetq ,pattern-variable ,match-against))
 647              ((matcherr))))))))
 648
 649 (defun compilematch (e p)
 650   (prog (reflist)
 651      (cond ((fixedmatchp p)
 652             (emit (list 'cond
 653                         (list (list 'not
 654                                     (list 'alike1
 655                                           e
 656                                           (list 'meval (list 'quote
 657                                                              p))))
 658                               '(matcherr)))))
 659            ((atom p) (compileatom e p))
 660            ((eq (caar p) 'mplus) (compileplus e p))
 661            ((eq (caar p) 'mtimes) (compiletimes e p))
 662            (t (compileatom (list 'kaar e)
 663                            (caar p))
 664               (emit (list 'setq
 665                           (genref)
 666                           (list 'kdr e)))
 667               (compileeach (car reflist) (cdr p))))
 668      (return program)))
 669
 670 (defun genref nil
 671   (prog (a)
 672      (setq a (tr-gensym))
 673      (setq topreflist (cons a topreflist))
 674      (return (car (setq reflist (cons a reflist))))))
 675 (defun compileeach (elist plist)
 676     (prog (reflist count)
 677        (setq count 0)
 678        (setq reflist (cons elist reflist))
 679        a    (setq count (f1+ count))
 680        (cond ((null plist)
 681               (return (emit (list 'cond
 682                                   (list (list 'nthkdr elist (f1- count))
 683                                         '(matcherr)))))))
 684        (emit (list 'setq (genref) (list 'kar (cadr reflist))))
 685        (compilematch (car reflist) (car plist))
 686        (setq plist (cdr plist))
 687        (setq reflist (cons (list 'kdr (cadr reflist)) reflist))
 688        (go a)))
 689
 690 (defun fixedmatchp (x)
 691   (cond ((numberp x) t)
 692         ((atom x)
 693          (if (or (member x boundlist :test #'eq) (null (mget x 'matchdeclare))) t))
 694         (t (and (or (member (caar x) boundlist :test #'eq)
 695                     (null (mget (caar x) 'matchdeclare)))
 696                 (fmp1 (cdr x))))))
 697
 698 (defun fmp1 (x)
 699   (if (null x) t (and (fixedmatchp (car x)) (fmp1 (cdr x)))))