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 1980 Massachusetts Institute of Technology ;;; 9;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 10 11(in-package :maxima) 12 13(macsyma-module schatc) 14 15;;;; I think this is described in Chapter 3 of J. Moses' thesis, 16;;;; "Symbolic Integration", MIT-LCS-TR-047. A scanned version of the 17;;;; thesis is available at 18;;;; http://www.lcs.mit.edu/publications/pubs/pdf/MIT-LCS-TR-047.pdf. 19;;;; 20;;;; Unfortunately, some important pages in the scan are all black. 21;;;; 22;;;; A version with the missing pages is available (2008-12-14) from 23;;;; http://www.softwarepreservation.org/projects/LISP/MIT 24;;;; 25;;;; Schatchen is Yiddish for "matchmaker" and Schatchen here is a 26;;;; pattern matching routine. 27 28(declare-top (special ans)) 29 30(defvar *schatfactor* nil) ;DETERMINES WHETHER FACTORING SHOULD BE USED. 31 32(defmacro push-context () 33 '(push nil ans)) 34 35(defmacro push-loop-context () 36 '(rplacd ans (cons '*loop (cdr ans)))) 37 38(defmacro preserve (z) 39 `(rplacd ans (cons (cons ,z (cdr ,z)) (cdr ans)))) 40 41(defmacro add-to (var val) 42 `(rplacd ans (cons (cons ,var ,val) (cdr ans)))) 43 44(defmacro var-pat (x) 45 `(atom (car ,x))) 46 47;;VARIOUS SIMPLE PATTERNS 48 49(defun free1 (a) 50 (declare (special var)) 51 (and (null (pzerop a)) (free a var))) 52 53(defun not-zero-free (a var) 54 (declare (special var)) 55 (free1 a)) 56 57(defun linear* (e var) 58 (declare(special var)) 59 (prog (a n) 60 (setq n ($ratcoef e var)) 61 (when (null (free n var)) 62 (return nil)) 63 (setq a (simplus (list '(mplus) e (list '(mtimes) -1 n var)) 1 nil)) 64 (return (cond ((free a var) (cons a n)))))) 65 66(defun dvcoe (e pat args) 67 (m1 ($ratsimp (list '(mtimes) e args)) pat)) 68 69;;; SCHATCHEN pattern matcher. 70;;; 71;;; Match the (maxima) expression in E with the pattern given by P. 72;;; 73;;; The pattern language is partially described in Moses thesis. We 74;;; summarize here some of the main ideas. (This is mostly taken from 75;;; his thesis.) 76;;; 77;;; A variable in the pattern is written in the form (VAR name pred 78;;; arg1 arg2 ... argn) 79;;; 80;;; where 81;;; 82;;; name = name of variable 83;;; pred = predicate associated with the variable 84;;; argi = arguments 2 through n+1 for pred 85;;; 86;;; The first arg of pred is assumed to the expression that the match 87;;; assigns to the variable. 88;;; 89;;; If the variable has a mode, it is written in prefix form. Thus 90;;; A*x, where A is a number and is a coefficient of plus or times 91;;; becomes (coeffpt (var a number) x). 92;;; 93;;; Some modes: 94;;; 95;;; coefft - coefficient of TIMES (matches A in A*x) coeffp - 96;;; coefficient of PLUS (matches B in x + B) coeffpt - coefficient of 97;;; PLUS and TIMES (like coefft and coeffp and matches things like 98;;; 2*x^2+sqrt(2)*x^2 so that the coefficient of x^2 is 2+sqrt(2). 99;;; 100;;; A brief description of the algorithm: 101;;; 102;;; If E equals P, the match succeeds. 103;;; 104;;; If P is of the form (VAR name pred arg1 ... argn), then (pred e 105;;; arg1 arg2 ... argn) is evaluated. If the value of the pred is 106;;; true, the match succeeds and ((name . e) is appended to the 107;;; answer. Otherwise the match fails. 108;;; 109;;; If P is of the form (op p1 ... pn) and op is not PLUS, TIMES, or 110;;; EXPT, then E must be of the form (op1 e1 ... en) and each pi must 111;;; match i1 and op must match op1. Otherwise the match fails. 112;;; 113;;; If the pattern is of the form (EXPT p1 p2) then 114;;; 1) e is (EXPT e1 e2) and p1 matches e1 and p2 matches e2 or 115;;; 2) e is 0 and p1 matches 0 or 116;;; 3) e is 1 and 117;;; a) p2 matches 0 or 118;;; b) p1 matches 1 119;;; 4) p2 matches 1 and p1 matches e 120;;; 121;;; Otherwise the match fails 122;;; 123;;; If the pattern is of the form (op p1 p2 ... pn) and op = PLUS or 124;;; TIMES, then if E is not of the form (op e1 ... em), E is 125;;; transformed to (op E). In this case an attempt is made to match 126;;; each pi with some ej. The scan starts with p1 matched with e1. 127;;; If that fails p1 is matched with e2. If pi matches some ej, ej is 128;;; deleted (destructively) from E and the scan continues with pi=1 129;;; matched with he first subexpression remaining in E. If for some 130;;; pi no ej can be found to match it, then pi is matched with 0 if op 131;;; = PLUS or 1 if op = TIMES. If that also fails, the match fails. 132;;; If all the pi have been matched, but some ej have not, the match 133;;; fails. 134;;; 135;;; Exceptions to the above are due to modes. If op = PLUS, and pi is 136;;; of the form (coeffpt (var name pred arg1 ... argn) p1 ... pk), 137;;; then the remaining expression is traversed with the pattern 138;;; (coefft (var name pred arg1 ... argn) p1 ... pk). Each 139;;; subexpression that is thus matched is deleted from the expression. 140;;; The simplified sum of the result of the scan becomes the value of 141;;; the variable. If no subexpression could thuse be matched, then 142;;; (pred 0 arg1 ... argn) is attempted. If this too fails, the match 143;;; fails. 144;;; 145;;; If op = PLUS and pn is of the form (coeffp (var name pred arg1 146;;; ... argn), then if e is currently of the form (PLUS ei ... en), 147;;; then (pred e arg1 ... argn) is evaluated. If the value of pred is 148;;; true, ((name . e)) is appended. If no subexpressions remain in e, 149;;; then pred 0 arg1 ... argn) is attempted. If it succeeds, ((name 150;;; . )) is appended. Otherwise, the match fails. 151;;; 152;;; If op = PLUS and pi is of the form (coefft (var name pred arg1 153;;; ... argn) p1 ... pk) then (times p1 .... pk) is matched with e. 154;;; If the match succeeds and e remains of the form (times e1 ... en), 155;;; then (pred e arg1 ... argn) is attempted. If it fails, the match 156;;; fails. If no subexpressions remain in e, then (pred 1 arg1 157;;; ... argn) is attempted. If this succeeds, ((name . 1) is 158;;; appended. 159 160(defun schatchen (e p) 161 (m2 e p)) 162 163;;THE RESTORE FUNCTIONS RESTORE THE SPEC-VAR ANS 164;;AND RETURN TRUE OR FALSE AS FOLLOWS 165;;RESTORE - FLASE 166;;RESTORE1 - TRUE AND CLEARS UP ANS 167;;RESTORE2 - TRUE AND CLEARS OFF *LOOP INDICATORS 168;; DOES NOT FIX UP THE EXPRESSION AND 169;; IS THUS TO BE USED ONLY INTERNALLY 170;; 171;;TO INSURE THAT THERE IS NO CONFLICT IN SPECIAL VARIABLES, 172;;ESPECIALLY WITH THE VAR* (SET) MODE ALL SCHATCHEN VARIABLES 173;;ARE TO BE PRECEDED BY A "%" 174 175(defvar *splist*) 176 177(defun m2 (e p) 178 (let ((ans (list nil)) 179 (*splist* nil)) 180 (declare (special *splist*)) 181 (cond ((null (m1 (copy-tree e) p)) nil) 182 ((null (cdr ans))) 183 ((cdr ans))))) 184 185(defun sav&del (x) 186 (preserve x) 187 (rplacd x (cddr x))) 188 189(defun m1 (e p) 190 (cond ((equal e p) t) 191 ((atom p) nil) 192 ((var-pat p) 193 (push-context) 194 (cond ((testa p e nil) 195 (restore1)) 196 ((restore)))) 197 ((atom (caar p)) 198 (cond ((member 'simp (cdar p) :test #'eq) (alike1 e p)) 199 ((member (caar p) '(mplus mtimes) :test #'eq) 200 (loopp e p)) 201 ((member (caar p) '(mexpt zepow) :test #'eq) (zepow e p t)) 202 ((and (not (atom e)) (eq (caar e) (caar p))) (eachp e p)) 203 ((eq (caar p) 'coefft) (coefft e p t)) 204 ((eq (caar p) 'coeffpt) (coeffpt e p t)) 205 ((eq (caar p) 'coeffp) (coeffp e p t)) 206 ((eq (caar p) 'coefftt) 207 (coefftt e (cadr p) t 'mtimes)) 208 ((eq (caar p) 'coeffpp) 209 (coefftt e (cadr p) t 'mplus)))) 210 ((var-pat (caar p)) ;HAIRY OPERATOR MATCHING SCHEME 211 (cond ((atom e) nil) ;NO OPERATOR TO MATCH 212 ((prog2 (push-context) ;BIND THE CONTEXT 213 (testa (caar p) (car e) nil)) ;TRY IT 214 (cond ((member (caar e) '(mplus mtimes) :test #'eq) ;CHECK FOR COMMUTIVITY 215 (cond ((loopp e (cons (car e) (cdr p))) 216 (restore1)) 217 ((restore)))) 218 ((eachp e p) 219 (restore1)) 220 ((restore)))) 221 ((restore)))))) 222 223(defun loopp (e p) 224 (prog (x z) 225 (setq e (cond ((atom e) (list (car p) e)) 226 ((null (eq (caar p) (caar e))) 227 (cond ((and *schatfactor* 228 (eq (caar e) 'mplus) 229 (mtimesp (setq x ($factor e)))) 230 x) 231 ((list (car p) e)))) 232 (e))) 233 (push-context) 234 (setq z p) 235 loop (setq z (cdr z)) 236 (cond ((null z) 237 (return (cond ((null (cdr e)) (restore1)) 238 ((restore)))))) 239 (setq x e) 240 l5 (cond ((null (cdr x)) 241 (let ((ident (opident (caar p)))) 242 (cond ((and ident (m1 ident (car z))) 243 (go loop)) 244 ((return (restore)))))) 245 ((or (atom (car z)) (var-pat (car z))) 246 (when (m1 (cadr x) (car z)) 247 (sav&del x) 248 (go loop))) 249 ((eq (caaar z) 'coefft) 250 (cond ((coefft e (car z) nil) 251 (go loop)) 252 ((return (restore))))) 253 ((eq (caaar z) 'coeffp) 254 (cond ((coeffp e (car z) nil) 255 (go loop)) 256 ((return (restore))))) 257 ((eq (caaar z) 'coeffpt) 258 (cond ((coeffpt e (car z) nil) (go loop)) 259 ((return (restore))))) 260 ((eq (caaar z) 'coefftt) 261 (cond ((coefftt e (cadar z) nil 'mtimes) (go loop)) 262 ((return (restore))))) 263 ((eq (caaar z) 'coeffpp) 264 (cond ((coefftt e (cadar z) nil 'mplus) (go loop)) 265 ((return (restore))))) 266 ((member (caaar z) '(mexpt zepow) :test #'eq) 267 (when (zepow (cadr x) (car z) t) 268 (sav&del x) 269 (go loop))) 270 ((eq (caaar z) 'loop) 271 (cond ((sch-loop e (cdar z)) (go loop)) 272 ((return (restore))))) 273 ((m1 (cadr x) (car z)) 274 (sav&del x) 275 (go loop))) 276 (setq x (cdr x)) 277 (go l5))) 278 279;;; IND = T MEANS AN INTERNAL CALL (USUALLY FROM LOOPP) 280 281(defun coeffp (e p ind) 282 (push-context) 283 (cond ((or (and (null (mplusp e)) ;;;WITH IND SET, OR E = (PLUS <EXPR>) 284 (setq e (list '(mplus) e))) 285 ind (null (cddr e))) 286 (coeffport e p 0 ind)) ;;; USE COEFFPORT 287 ((and (null (cddr p)) ;;; P = ((COEFFP) (<VAR> <PRED> . . .)) 288 (var-pat (cadr p))) ;;; SO CALL TESTA 289 (cond ((testa (cadr p) e nil) 290 (cond ((mplusp e) 291 (preserve e) 292 (rplacd e nil) 293 t) 294 ((merror "COEFFP: incorrect arguments; E=~M, P=~M, IND=~M" e p ind)))))) 295 ((do ((x e (cdr x))) 296 ((null (cdr x)) 297 (cond ((m1 0 p) (restore2)) 298 ((restore)))) 299 (cond ((coeffp (cadr x) p t) 300 (sav&del x) 301 (return (restore2)))))))) 302 303(defun coefft (e p ind) 304 (push-context) 305 (cond ((and (null ind) (null (atom e)) (member (caar e) '(mplus mtimes) :test #'eq)) 306 (do ((x e (cdr x))) 307 ((null (cdr x)) 308 (cond ((m1 1 p) (restore2)) 309 ((restore)))) 310 (cond ((coefft (cadr x) p t) 311 (sav&del x) 312 (return (restore2)))))) 313 ((and (mplusp e) (cddr e)) 314 (cond ((and *schatfactor* (mtimesp (setq e ($factor e)))) 315 (coeffport e p 1 ind)) 316 ((restore)))) 317 (t (coeffport (if (mtimesp e) e (list '(mtimes) e)) p 1 ind)))) 318 319(defun coeffport (e p ident ind) 320 (do ((z (cddr p) (cdr z)) 321 (x e e)) 322 ((null z) 323 (coeffret e (cadr p) ident ind)) 324 l ;;; EACH TIME HERE WE HAVE CDR'D DOWN THE EXP. 325 (cond ((null (cdr x)) 326 (and (null (m1 ident (car z))) 327 (return (restore)))) 328 ((or (atom (car z)) 329 (var-pat (car z)))) 330 ((eq (caaar z) 'coefftt) 331 (and (null (coefftt e (cadar z) nil 'mtimes)) 332 (return (coeffret e p ident ind)))) 333 ((eq (caaar z) 'coeffpp) 334 (and (null (coefftt e (cadar z) nil 'mplus)) 335 (return (coeffret e p ident ind))))) 336 (cond ((null (cdr x))) 337 ((m1 (cadr x) (car z)) 338 (sav&del x)) 339 (t (setq x (cdr x)) 340 (go l))))) 341 342(defun coeffret (e p ident ind) 343 (cond ((null (cdr e)) 344 (cond ((testa p ident nil) 345 (cond (ind (restore1)) 346 ((restore2)))) 347 ((restore)))) 348 ((testa p (cond ((cddr e) (copy-list e )) 349 ((cadr e))) 350 nil) 351 (cond (ind (restore1)) 352 (t (preserve e) 353 (rplacd e nil) 354 (restore2)))) 355 ((restore)))) 356 357(defun coeffpt (e p ind) ;THE PATTERN LIST (P) MUST BE OF VAR-PATTERNS 358 (push-context) 359 (do ((z (cond ((mplusp e) e) ((list '(mplus) e)))) 360 (zz (cons '(coefft) (cdr p)))) ;THIS ROUTINE IS THE ONE WHICH PUTS 361 ;MOST OF THE THE GARBAGE ON ANS IT 362 ((null (cdr z)) ;IT CANNOT USE THE *SPLIST* HACK 363 (setq z (findit (cond ((eq (caadr p) 'var*) ;BECAUSE IT COULD BE USING 364 (car (cddadr p))) ;MANY DIFFERENT VARIABLES ALTHOUGH 365 ((caadr p))))) ;THOUGHT THE FIRST IS THE ONLY ONE 366 (let ((q (cond ((null z) 0) 367 ((null (cdr z)) (car z)) 368 ((simplus (cons '(mplus) z) 1 nil)))) 369 (fl (if (and z (cdr z)) 'coeffpt))) ;WHICH BECOMES A SUM AND MIGHT BE RESET 370 (cond ((null (testa (cadr p) q fl)) 371 (restore)) 372 (ind (restore1)) 373 (t (restore2) q)))) 374 (cond ((null (m1 (cadr z) zz)) ;THIS IS THE DO BODY 375 (setq z (cdr z))) 376 ((sav&del z))))) 377 378(defun zepow (e p fl) ;FL=NIL INDICATES A RECURSIVE CALL 379 (and fl (push-context)) ;SO ANS SHOULD NOT BE MARKED 380 (cond ((atom e) 381 (cond ((equal e 1) 382 (cond ((not (or (m1 0 (caddr p)) (m1 1 (cadr p)))) 383 (restore)) 384 ((restore1)))) 385 ((equal e 0) 386 (cond ((null (m1 0 (cadr p))) (restore)) 387 ((restore1)))) 388 ((and (m1 e (cadr p)) (m1 1 (caddr p))) 389 (restore1)) 390 ((restore)))) 391 ((and *schatfactor* 392 (mplusp e) 393 (setq e ($factor e)) 394 nil)) 395 ((and (eq (caar e) 'mtimes) 396 (mexptp (cadr e))) 397 (do ((e (cddr e) (cdr e)) 398 (b (cadadr e)) 399 (x (caddr (cadr e))) 400 (z)) 401 ((null e) ;OK NOW LETS TRY AGAIN 402 (zepow (list '(mexpt) (simplifya b t) 403 (simplifya x t)) p nil)) 404 (cond ((mexptp (car e)) 405 (cond ((alike1 (cadar e) b) 406 (setq x (simplus (list '(mplus) x (caddar e)) 1 nil))) 407 ((alike1 (caddar e) x) 408 (setq b (simptimes (list '(mtimes) b (cadar e)) 1 nil))) 409 ((signp e (caddr (setq z ($divide x (caddar e))))) 410 (setq b (simptimes (list '(mtimes) b 411 (list '(mexpt) (cadar e) 412 (list '(mtimes) (caddar e) (cadr z)))) 1 nil))) 413 ((return (restore))))) 414 ((alike1 b (car e)) 415 (setq x (simplus (list '(mplus) 1 x) 1 t))) 416 ((return (restore)))))) 417 ((or (and (eq (caar e) 'mexpt) 418 (m1 (cadr e) (cadr p)) 419 (m1 (caddr e) (caddr p))) 420 (and (m1 e (cadr p)) 421 (m1 1 (caddr p)))) 422 (restore1)) 423 ((restore)))) 424 425(defun eachp (e p) 426 (cond ((= (length e) (length p)) 427 (push-context) 428 (do ((e (cdr e) (cdr e))) 429 ((null e) (restore1)) 430 (unless (m1 (car e) (cadr p)) (return (restore))) 431 (setq p (cdr p)))))) 432 433(defun sch-loop (e lp) 434 (push-context) (push-loop-context) 435 (do ((x lp) (z e) (y)) ;Y A PSEUDO SAVE 436 (nil) 437 (cond ((null (m1 (cadr z) (car x))) ;DIDN'T MATCH 438 (setq z (cdr z)) ;NEXT ARG FOR LOOP 439 (cond ((cdr z)) 440 ((eq x lp) (return (restore))) 441 (t 442 (setq x (caar y) 443 z (cdar y)) 444 (setq y (cdr y) 445 ans (cdr ans)) 446 (pop-loop-context)))) 447 (t 448 (push (cons x z) y) 449 (sav&del z) 450 (setq x (cdr x)) 451 (cond ((null x) (return (restore2))) 452 (t (push-loop-context) 453 (setq z e))))))) 454 455(defun coefftt (exp pat ind opind) ;OPIND IS MPLUS OR MTIMES 456 (push-context) 457 (when (or (atom exp) (and ind (not (eq (caar exp) opind)))) 458 (setq exp (list (list opind) exp))) 459 (push (car pat) *splist*) ;SAVE VAR NAME HERE 460 (do ((z exp) (res)) 461 ((null (cdr z)) 462 (setq *splist* (cdr *splist*)) ;KILL NAME SAVED 463 (cond (res (setq res (cond ((cdr res) (cons (list opind) res)) 464 ((car res)))) 465 (cond ((and (eq (car pat) 'var*) 466 (member 'set (cadr pat) :test #'eq)) 467 (add-to (caddr pat) (setf (symbol-value (caddr pat)) (simplifya res nil)))) 468 ((add-to (car pat) (simplifya res nil)))) 469 (cond (ind (restore1)) 470 ((restore2)))) 471 ((null (testa pat (opident opind) nil)) 472 (restore)) 473 (ind (restore1)) 474 ((restore2)))) 475 (cond ((testa pat (cadr z) nil) 476 (push (cadr z) res) 477 (sav&del z)) 478 (t (setq z (cdr z)))))) 479 480(defun restore nil 481 (do ((y (cdr ans) (cdr y))) 482 ((null y) nil) 483 (cond ((eq (car y) '*loop) 484 (rplaca y (cadr y)) 485 (rplacd y (cddr y))) 486 ((null (car y)) 487 (setq ans y) 488 (return nil)) 489 ((null (atom (caar y))) 490 (rplacd (caar y) (cdar y)))))) 491 492(defun restore1 nil 493 (do ((y ans) (l)) ;L IS A LIST OF VAR'S NOTED 494 ((null (cdr y)) t) 495 (cond ((null (cadr y)) ;END OF CONTEXT 496 (rplacd y (cddr y)) ;SPLICE OUT THE CONTEXT MARKER 497 (return t)) 498 ((not (atom (caadr y))) ;FIXUP NECESSARY 499 (rplacd (caadr y) (cdadr y)) 500 (rplacd y (cddr y))) 501 ((member (car y) l :test #'eq) ;THIS VAR HAS ALREADY BEEN SEEN 502 (rplacd y (cddr y))) ;SO SPLICE IT OUT TO KEEP ANS CLEAN 503 ((setq y (cdr y) 504 l (cons (caar y) l)))))) 505 506(defun restore2 nil 507 (do ((y (cdr ans) (cdr y))) 508 ((null (cdr y)) t) 509 (cond ((eq (cadr y) '*loop) 510 (rplacd y (cddr y))) 511 ((null (cadr y)) 512 (rplacd y (cddr y)) 513 (return t))))) 514 515(defun pop-loop-context nil 516 (do ((y ans)) 517 ((eq (cadr y) '*loop) nil) 518 (or (atom (caadr y)) 519 (rplacd (caadr y) (cdadr y))) 520 (rplacd y (cddr y)))) 521 522;;WHEN THE CAR OF ALA IS VAR* THE CADR IS A LIST OF 523;;THE VARIOUS SWITCHES WHICH MAY BE SET. 524;;UVAR- INDICATES THIS SHOULD MATCH SOMETHING WHICH IS ALREADY ON ANS. 525;;SET - ACTUALLY SET THIS VARIABLE TO ITS VALUE IF IT MATCHES. 526;;COEFFPT - SPECIAL ARGUMENT IF IN COEFFPT. 527 528(defun testa (ala exp b) 529 (cond ((eq (car ala) 'mvar*) 530 (testa* ala exp t)) 531 ((eq (car ala) 'var*) 532 (do ((z (cadr ala) (cdr z)) 533 (ala (cddr ala)) 534 (y) (set) (uvar)) 535 ((null z) 536 (setq y (cond (uvar (m1 exp y)) 537 ((testa* ala exp nil)))) 538 (cond ((null y) nil) 539 (set (setf (symbol-value (car ala)) exp)) 540 (y))) 541 (cond ((eq (car z) 'set) (setq set t)) 542 ((eq (car z) 'uvar) 543 (cond ((setq y (cdr (assoc (car ala) ans :test #'equal))) 544 (setq uvar t)))) 545 ((eq (car z) 'coeffpt) 546 (and (eq b 'coeffpt) 547 (setq ala (cadr z))) 548 (setq z (cdr z))) 549 ((merror "TESTA: invalid switch ~M in pattern." (car z)))))) 550 ((testa* ala exp nil)))) 551 552;; ALA IS THE PREDICATE LIST (VAR PREDFN ARG2 ARG3 ARG4 . . .) 553 554(defun testa* (ala exp loc) 555 (declare (special var)) 556 (cond ((cond ((eq (cadr ala) 'freevar) 557 (cond ((eq var '*novar) (equal exp 1)) 558 ((free exp var)))) 559 ((eq (cadr ala) 'numberp) (mnump exp)) 560 ((eq (cadr ala) 'true) t) 561 ((eq (cadr ala) 'linear*) 562 (setq exp (linear* exp (caddr ala)))) 563 ((null loc) 564 (cond ((atom (cadr ala)) 565 (cond ((fboundp (cadr ala)) 566 (apply (cadr ala) 567 (findthem exp (cddr ala)))) 568 ((mget (cadr ala) 'mexpr) 569 (mapply (cadr ala) 570 (findthem exp (cddr ala)) 571 (cadr ala))))) 572 ((member (caadr ala) '(lambda function *function quote) :test #'eq) 573 ;;;THE LAMBDA IS HERE ONLY BECAUSE OF SIN!!! 574 (apply (cadr ala) (findthem exp (cddr ala)))) 575 ((eval-pred (cadr ala) (car ala) exp))))) 576 (cond ((member (car ala) *splist* :test #'eq)) 577 ((add-to (car ala) exp)))) 578 ((cond ((and loc (atom (cadr ala)) 579 (fboundp (cadr ala))) 580 (mapc #'(lambda (q v) (and (null (member q *splist* :test #'eq)) 581 (add-to q v))) 582 (car ala) 583 (apply (cadr ala) (findthem exp (cddr ala))))))))) 584 585(defun eval-pred (exp %var value) 586 (progv (list %var) (list value) 587 (eval exp))) 588 589(defun findthem (exp args) 590 (cons exp 591 (mapcar #'(lambda (q) 592 (cond ((atom q) 593 (or (cdr (assoc q ans :test #'eq)) 594 ;; Evaluate a symbol which has a value. 595 (and (symbolp q) (boundp q) (symbol-value q)) 596 ;; Otherwise return the symbol. 597 q)) 598 (q))) 599 args))) 600 601(defun findit (a) 602 (do ((y ans) (z)) 603 ((or (null (cdr y)) (null (cadr y))) z) 604 (cond ((eq (caadr y) a) 605 (setq z (nconc z (list (cdadr y)))) 606 (rplacd y (cddr y))) 607 ((setq y (cdr y)))))) 608 609(defun sch-replace (dict exp1) 610 (declare (special dict)) 611 (replac exp1)) 612 613(defun replac (exp1) 614 (declare (special dict)) 615 (let ((w1 nil)) 616 (cond ((null exp1) nil) 617 ((not (atom exp1)) 618 (cond ((eq (car exp1) 'eval) 619 (simplifya (eval (replac (cadr exp1))) nil)) 620 ((eq (car exp1) 'quote) (cadr exp1)) 621 (t (setq w1 (mapcar #'replac (cdr exp1))) 622 (cond ((equal w1 (cdr exp1)) 623 exp1) 624 ((simplifya (cons (list (caar exp1)) w1) t)))))) 625 ((numberp exp1) exp1) 626 ((setq w1 (assoc exp1 dict :test #'eq)) 627 (cdr w1)) 628 (exp1)))) 629 630;; Execute BODY with the variables in VARS bound using ALIST. If any variable is 631;; missing, it is set to NIL. 632;; 633;; Example usage: 634;; (alist-bind (a b c) some-alist (+ a b c)) 635(defmacro alist-bind (vars alist &body body) 636 (let ((alist-sym (gensym))) 637 `(let* ((,alist-sym ,alist) 638 ,@(loop 639 for var in vars 640 collecting `(,var (cdr (assoc ',var ,alist-sym :test #'eq))))) 641 (declare (ignorable ,alist-sym)) 642 ,@body))) 643 644;; Factor out the common logic to write a COND statement that uses the Schatchen 645;; pattern matcher. 646;; 647;; Each clause in CLAUSES should match (TEST VARIABLES &body BODY). This will be 648;; transformed into a COND clause that first runs TEST and binds the result to 649;; W. TEST is assumed to boil down to a call to M2, which returns an alist of 650;; results for the matched variables. VARIABLES should be a list of symbols and 651;; the clause only matches if each of these symbols is bound in the alist. 652;; 653;; As a special rule, if the CAR of TEST is of the form (AND F1 F2 .. FN) then 654;; the result of evaluating F1 is bound to W and then the clause only matches if 655;; F2 .. FN all evaluate to true as well as the test described above. 656;; 657;; If the clause matches then the result of the cond is that of evaluating BODY 658;; (in an implicit PROGN) with each variable bound to the corresponding element 659;; of the alist. 660;; 661;; To add an unconditional form at the bottom, use a clause of the form 662;; 663;; (T NIL F1 .. FN). 664;; 665;; This will always match and doesn't try to bind any extra variables. 666 667(defmacro schatchen-cond (w &body clauses) 668 `(let ((,w)) 669 (cond 670 ,@(loop 671 for clause in clauses 672 collecting 673 (let ((test (car clause)) 674 (variables (cadr clause)) 675 (body (cddr clause))) 676 ;; A clause matches in the cond if TEST returns non-nil and 677 ;; binds all the expected variables in the alist. As a special 678 ;; syntax, if the car of TEST is 'AND, then we bind W to the 679 ;; result of the first argument and then check the following 680 ;; arguments in an environment where W is bound (but the 681 ;; variables aren't). 682 (let ((cond-test 683 (if (and (not (atom test)) (eq 'and (car test))) 684 `(progn 685 (setf ,w ,(cadr test)) 686 (and ,w ,@(loop for var in variables 687 collecting `(cdras ',var ,w)) 688 ,@(cddr test))) 689 `(progn 690 (setf ,w ,test) 691 (and ,w ,@(loop for var in variables 692 collecting `(cdras ',var ,w)))))) 693 ;; If the clause matched, we explicitly bind all of those 694 ;; variables in a let form and then evaluate the 695 ;; associated body. 696 (cond-body `(alist-bind ,variables ,w ,@body))) 697 `(,cond-test ,cond-body))))))) 698 699(declare-top (unspecial var ans)) 700