From 85994ed77031eaf9dd6ad853d5d89404d4e4b736 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Thu, 8 Mar 2018 22:06:53 -0800 Subject: [PATCH] Added files to support building and running Macsyma. Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work. --- Makefile | 4 +- README.md | 3 + bin/lisp/format.extend | Bin 0 -> 3194 bytes bin/lisp/format.float | Bin 0 -> 7395 bytes bin/lisp/format.hair | Bin 0 -> 9634 bytes bin/lisp/format.invoke | Bin 0 -> 1684 bytes bin/lisp/format.iter | Bin 0 -> 4839 bytes bin/lisp/format.macros | Bin 0 -> 2816 bytes bin/lisp/format.num | Bin 0 -> 5478 bytes bin/lisp/format.umacs | Bin 0 -> 4484 bytes build/build.tcl | 184 ++- src/aljabr/*.lisp | 2 + src/aljabr/complr.163 | 206 +++ src/aljabr/loader.262 | 348 +++++ src/aljabr/reset.34 | 16 + src/cffk/cpoly.64 | 901 +++++++++++++ src/das/mstuff.21 | 74 ++ src/ell/hyp.98 | 1234 +++++++++++++++++ src/ell/hypgeo.9 | 2395 +++++++++++++++++++++++++++++++++ src/ellen/option.88 | 1048 +++++++++++++++ src/ellen/primer.213 | 297 +++++ src/emaxim/edbuf.39 | 280 ++++ src/emaxim/edctl.22 | 857 ++++++++++++ src/emaxim/edexp.174 | 656 +++++++++ src/emaxim/edits.99 | Bin 0 -> 9158 bytes src/emaxim/edlm.20 | Bin 0 -> 4233 bytes src/jim/askp.85 | 103 ++ src/jim/limit.273 | 2616 ++++++++++++++++++++++++++++++++++++ src/jim/tlimit.47 | 49 + src/jm/risch.434 | 1039 +++++++++++++++ src/jm/simp.834 | 2130 +++++++++++++++++++++++++++++ src/jm/sin.200 | 1419 ++++++++++++++++++++ src/jm/sinint.140 | 374 ++++++ src/jm/zero.23 | 63 + src/jpg/comm.395 | 917 +++++++++++++ src/jpg/comm2.56 | 771 +++++++++++ src/jpg/dskfn.169 | 492 +++++++ src/jpg/medit.85 | 382 ++++++ src/jpg/mlisp.613 | 1959 +++++++++++++++++++++++++++ src/jpg/ode2.trlisp | 231 ++++ src/jpg/plot.67 | 307 +++++ src/jpg/suprv.619 | 2724 ++++++++++++++++++++++++++++++++++++++ src/lisp/lock.mail | 104 ++ src/macrak/logarc.27 | 55 + src/macrak/rpart.263 | 509 +++++++ src/maxdoc/dcl.autold | 312 +++++ src/maxdoc/dcl.fctns | 887 +++++++++++++ src/maxdoc/dcl.fexpr | 37 + src/maxdoc/dcl.lispm | 296 +++++ src/maxdoc/dcl.load | 303 +++++ src/maxdoc/dcl.multix | 276 ++++ src/maxdoc/dcl.vars | 341 +++++ src/maxdoc/files.72 | 483 +++++++ src/maxdoc/init.norese | 21 + src/maxdoc/init.reset | 175 +++ src/maxdoc/mcldat.34 | 1212 +++++++++++++++++ src/maxdoc/tdcl.10 | 120 ++ src/maxsrc/ar.17 | 165 +++ src/maxsrc/ards.11 | 145 ++ src/maxsrc/char.2 | 33 + src/maxsrc/descri.58 | 226 ++++ src/maxsrc/dover.3 | 62 + src/maxsrc/ermsgm.12 | 61 + src/maxsrc/h19.4 | 47 + src/maxsrc/ininte.54 | 1155 ++++++++++++++++ src/maxsrc/inmis.98 | 90 ++ src/maxsrc/intpol.13 | 107 ++ src/maxsrc/irinte.1 | 1155 ++++++++++++++++ src/maxsrc/irinte.54 | 1155 ++++++++++++++++ src/maxsrc/laplac.202 | 935 +++++++++++++ src/maxsrc/laplac.205 | 918 +++++++++++++ src/maxsrc/ldisp.43 | 100 ++ src/maxsrc/mdot.94 | 379 ++++++ src/maxsrc/merror.47 | 252 ++++ src/maxsrc/mformt.27 | 145 ++ src/maxsrc/mload.121 | 479 +++++++ src/maxsrc/mtrace.41 | 654 +++++++++ src/maxsrc/mtree.1 | 86 ++ src/maxsrc/mutils.11 | 57 + src/maxsrc/ndiffq.5 | 199 +++ src/maxsrc/numer.17 | 276 ++++ src/maxsrc/opers.75 | 142 ++ src/maxsrc/ops.1 | 47 + src/maxsrc/outex.37 | 209 +++ src/maxsrc/outmis.309 | 1025 ++++++++++++++ src/maxsrc/rombrg.43 | 143 ++ src/maxsrc/runtim.19 | 104 ++ src/maxsrc/sets.11 | 439 ++++++ src/maxsrc/sublis.11 | 117 ++ src/maxsrc/sumcon.18 | 147 ++ src/maxsrc/suspen.13 | 99 ++ src/maxsrc/synex.10 | 187 +++ src/maxsrc/utils.26 | 182 +++ src/maxsrc/vt100.5 | 33 + src/maxtul/mcldmp.(init) | 20 +- src/mrg/compar.857 | 1320 ++++++++++++++++++ src/mrg/db.1145 | 701 ++++++++++ src/mrg/displa.769 | 1558 ++++++++++++++++++++++ src/mrg/fortra.64 | 158 +++ src/mrg/gram.5 | 599 +++++++++ src/mrg/grind.150 | 426 ++++++ src/mrg/macros.81 | 317 +++++ src/mrg/macros.82 | 318 +++++ src/mrg/nforma.15 | 111 ++ src/mrg/optim.14 | 142 ++ src/mrg/scs.60 | 53 + src/mrg/trigi.343 | 579 ++++++++ src/mrg/trigo.330 | 383 ++++++ src/munfas/ratlap.unfasl | 17 + src/paulw/algfac.45 | 403 ++++++ src/paulw/csimp.299 | 349 +++++ src/paulw/csimp2.63 | 518 ++++++++ src/paulw/defint.658 | 2599 ++++++++++++++++++++++++++++++++++++ src/paulw/eez.62 | 310 +++++ src/paulw/linnew.27 | 867 ++++++++++++ src/paulw/mat.286 | 452 +++++++ src/paulw/matrix.320 | 645 +++++++++ src/paulw/newfac.73 | 954 +++++++++++++ src/paulw/newinv.89 | 144 ++ src/paulw/residu.105 | 193 +++ src/paulw/sprdet.60 | 283 ++++ src/rat/algsys.1 | 502 +++++++ src/rat/algsys.480 | 948 +++++++++++++ src/rat/ezgcd.262 | 478 +++++++ src/rat/factor.472 | 1387 +++++++++++++++++++ src/rat/factor.473 | 1380 +++++++++++++++++++ src/rat/float.321 | 1027 ++++++++++++++ src/rat/float.329 | 1013 ++++++++++++++ src/rat/hayat.386 | 2150 ++++++++++++++++++++++++++++++ src/rat/hayat.436 | 2619 ++++++++++++++++++++++++++++++++++++ src/rat/homog.39 | 156 +++ src/rat/homog.41 | 163 +++ src/rat/lesfac.147 | 300 +++++ src/rat/lesfac.148 | 301 +++++ src/rat/matcom.98 | 626 +++++++++ src/rat/matrun.80 | 302 +++++ src/rat/matrun.81 | 308 +++++ src/rat/mhayat.61 | 354 +++++ src/rat/mhayat.67 | 367 +++++ src/rat/nalgfa.67 | 450 +++++++ src/rat/nalgfa.68 | 450 +++++++ src/rat/newdet.12 | 165 +++ src/rat/nisimp.81 | 421 ++++++ src/rat/nisimp.85 | 407 ++++++ src/rat/nrat4.265 | 611 +++++++++ src/rat/nrat4.280 | 638 +++++++++ src/rat/pade.42 | 119 ++ src/rat/pois2.74 | 794 +++++++++++ src/rat/pois3.66 | 891 +++++++++++++ src/rat/polyrz.93 | 261 ++++ src/rat/polyrz.99 | 294 ++++ src/rat/psolve.19 | 273 ++++ src/rat/psolve.22 | Bin 0 -> 7218 bytes src/rat/rat3a.258 | 678 ++++++++++ src/rat/rat3a.264 | 693 ++++++++++ src/rat/rat3b.95 | 240 ++++ src/rat/rat3b.97 | 255 ++++ src/rat/rat3c.302 | 552 ++++++++ src/rat/rat3d.264 | 478 +++++++ src/rat/rat3d.271 | 500 +++++++ src/rat/rat3e.546 | 1058 +++++++++++++++ src/rat/rat3e.562 | 1076 +++++++++++++++ src/rat/ratmac.34 | 99 ++ src/rat/ratmac.35 | 99 ++ src/rat/ratout.64 | 742 +++++++++++ src/rat/ratout.65 | 745 +++++++++++ src/rat/ratpoi.7 | 54 + src/rat/ratpoi.8 | 56 + src/rat/result.30 | 266 ++++ src/rat/result.34 | 279 ++++ src/rat/solve.401 | 956 +++++++++++++ src/rat/solve.412 | 957 +++++++++++++ src/rat/spgcd.110 | 581 ++++++++ src/rat/ufact.32 | 161 +++ src/rat/ufact.33 | 162 +++ src/reh/buildq.9 | 195 +++ src/reh/mmacro.50 | 194 +++ src/reh/mmacro.51 | 198 +++ src/rlb/bitmac.17 | 66 + src/rlb/fasdmp.124 | 367 +++++ src/rlb/faslre.116 | 465 +++++++ src/rlb/faslro.71 | 294 ++++ src/rlb/faslro.72 | 294 ++++ src/rz/asum.271 | 632 +++++++++ src/rz/asum.277 | 561 ++++++++ src/rz/combin.152 | 1195 +++++++++++++++++ src/rz/combin.163 | 1270 ++++++++++++++++++ src/rz/numth.47 | 249 ++++ src/rz/numth.57 | 260 ++++ src/rz/schatc.54 | 557 ++++++++ src/rz/series.133 | 583 ++++++++ src/rz/series.137 | 588 ++++++++ src/rz/trgred.88 | 508 +++++++ src/share/aplot2.300 | 1558 ++++++++++++++++++++++ src/share/fileop.23 | 149 +++ src/share/iffun.23 | 139 ++ src/share/plot3d.66 | 808 +++++++++++ src/share/print.33 | 83 ++ src/share/tekplt.171 | 1221 +++++++++++++++++ src/tensor/canten.8 | 451 +++++++ src/tensor/gener.51 | 344 +++++ src/tensor/itensr.119 | 1164 ++++++++++++++++ src/tensor/symtry.102 | 275 ++++ src/transl/acall.71 | 419 ++++++ src/transl/evalw.12 | 42 + src/transl/fcall.40 | 222 ++++ src/transl/ljob.16 | 294 ++++ src/transl/mcompi.145 | 107 ++ src/transl/mtags.18 | 161 +++ src/transl/trans1.108 | 578 ++++++++ src/transl/trans2.39 | 118 ++ src/transl/trans3.49 | 337 +++++ src/transl/trans4.29 | 256 ++++ src/transl/trans5.26 | 337 +++++ src/transl/transf.11 | 73 + src/transl/transl.1157 | 1550 ++++++++++++++++++++++ src/transl/transs.90 | 523 ++++++++ src/transl/transs.91 | 523 ++++++++ src/transl/trdata.68 | 87 ++ src/transl/trdebg.8 | 132 ++ src/transl/trdump.27 | 89 ++ src/transl/trhook.6 | 62 + src/transl/trmode.73 | 268 ++++ src/transl/trmode.74 | 267 ++++ src/transl/troper.15 | 213 +++ src/transl/trpred.6 | 176 +++ src/transl/trprop.1 | 40 + src/transl/trutil.27 | 140 ++ src/wgd/specfn.96 | 426 ++++++ src/wgd/specfn.99 | 429 ++++++ src/zz/apropo.31 | 43 + 231 files changed, 108800 insertions(+), 8 deletions(-) create mode 100755 bin/lisp/format.extend create mode 100755 bin/lisp/format.float create mode 100755 bin/lisp/format.hair create mode 100755 bin/lisp/format.invoke create mode 100755 bin/lisp/format.iter create mode 100755 bin/lisp/format.macros create mode 100755 bin/lisp/format.num create mode 100755 bin/lisp/format.umacs create mode 100644 src/aljabr/*.lisp create mode 100644 src/aljabr/complr.163 create mode 100644 src/aljabr/loader.262 create mode 100644 src/aljabr/reset.34 create mode 100644 src/cffk/cpoly.64 create mode 100644 src/das/mstuff.21 create mode 100644 src/ell/hyp.98 create mode 100644 src/ell/hypgeo.9 create mode 100644 src/ellen/option.88 create mode 100644 src/ellen/primer.213 create mode 100755 src/emaxim/edbuf.39 create mode 100755 src/emaxim/edctl.22 create mode 100755 src/emaxim/edexp.174 create mode 100644 src/emaxim/edits.99 create mode 100755 src/emaxim/edlm.20 create mode 100644 src/jim/askp.85 create mode 100644 src/jim/limit.273 create mode 100644 src/jim/tlimit.47 create mode 100644 src/jm/risch.434 create mode 100644 src/jm/simp.834 create mode 100644 src/jm/sin.200 create mode 100644 src/jm/sinint.140 create mode 100644 src/jm/zero.23 create mode 100644 src/jpg/comm.395 create mode 100644 src/jpg/comm2.56 create mode 100644 src/jpg/dskfn.169 create mode 100644 src/jpg/medit.85 create mode 100644 src/jpg/mlisp.613 create mode 100644 src/jpg/ode2.trlisp create mode 100644 src/jpg/plot.67 create mode 100644 src/jpg/suprv.619 create mode 100755 src/lisp/lock.mail create mode 100644 src/macrak/logarc.27 create mode 100644 src/macrak/rpart.263 create mode 100755 src/maxdoc/dcl.autold create mode 100644 src/maxdoc/dcl.fctns create mode 100755 src/maxdoc/dcl.fexpr create mode 100755 src/maxdoc/dcl.lispm create mode 100755 src/maxdoc/dcl.load create mode 100755 src/maxdoc/dcl.multix create mode 100644 src/maxdoc/dcl.vars create mode 100755 src/maxdoc/files.72 create mode 100644 src/maxdoc/init.norese create mode 100644 src/maxdoc/init.reset create mode 100755 src/maxdoc/mcldat.34 create mode 100755 src/maxdoc/tdcl.10 create mode 100644 src/maxsrc/ar.17 create mode 100644 src/maxsrc/ards.11 create mode 100644 src/maxsrc/char.2 create mode 100644 src/maxsrc/descri.58 create mode 100644 src/maxsrc/dover.3 create mode 100644 src/maxsrc/ermsgm.12 create mode 100644 src/maxsrc/h19.4 create mode 100644 src/maxsrc/ininte.54 create mode 100644 src/maxsrc/inmis.98 create mode 100644 src/maxsrc/intpol.13 create mode 100644 src/maxsrc/irinte.1 create mode 100755 src/maxsrc/irinte.54 create mode 100644 src/maxsrc/laplac.202 create mode 100644 src/maxsrc/laplac.205 create mode 100644 src/maxsrc/ldisp.43 create mode 100644 src/maxsrc/mdot.94 create mode 100644 src/maxsrc/merror.47 create mode 100644 src/maxsrc/mformt.27 create mode 100644 src/maxsrc/mload.121 create mode 100644 src/maxsrc/mtrace.41 create mode 100644 src/maxsrc/mtree.1 create mode 100644 src/maxsrc/mutils.11 create mode 100644 src/maxsrc/ndiffq.5 create mode 100644 src/maxsrc/numer.17 create mode 100644 src/maxsrc/opers.75 create mode 100644 src/maxsrc/ops.1 create mode 100644 src/maxsrc/outex.37 create mode 100644 src/maxsrc/outmis.309 create mode 100644 src/maxsrc/rombrg.43 create mode 100644 src/maxsrc/runtim.19 create mode 100644 src/maxsrc/sets.11 create mode 100644 src/maxsrc/sublis.11 create mode 100644 src/maxsrc/sumcon.18 create mode 100644 src/maxsrc/suspen.13 create mode 100644 src/maxsrc/synex.10 create mode 100644 src/maxsrc/utils.26 create mode 100644 src/maxsrc/vt100.5 create mode 100644 src/mrg/compar.857 create mode 100644 src/mrg/db.1145 create mode 100644 src/mrg/displa.769 create mode 100644 src/mrg/fortra.64 create mode 100644 src/mrg/gram.5 create mode 100644 src/mrg/grind.150 create mode 100644 src/mrg/macros.81 create mode 100644 src/mrg/macros.82 create mode 100644 src/mrg/nforma.15 create mode 100644 src/mrg/optim.14 create mode 100644 src/mrg/scs.60 create mode 100644 src/mrg/trigi.343 create mode 100644 src/mrg/trigo.330 create mode 100755 src/munfas/ratlap.unfasl create mode 100644 src/paulw/algfac.45 create mode 100644 src/paulw/csimp.299 create mode 100644 src/paulw/csimp2.63 create mode 100644 src/paulw/defint.658 create mode 100644 src/paulw/eez.62 create mode 100644 src/paulw/linnew.27 create mode 100644 src/paulw/mat.286 create mode 100644 src/paulw/matrix.320 create mode 100644 src/paulw/newfac.73 create mode 100644 src/paulw/newinv.89 create mode 100644 src/paulw/residu.105 create mode 100644 src/paulw/sprdet.60 create mode 100644 src/rat/algsys.1 create mode 100755 src/rat/algsys.480 create mode 100644 src/rat/ezgcd.262 create mode 100644 src/rat/factor.472 create mode 100755 src/rat/factor.473 create mode 100644 src/rat/float.321 create mode 100644 src/rat/float.329 create mode 100644 src/rat/hayat.386 create mode 100755 src/rat/hayat.436 create mode 100644 src/rat/homog.39 create mode 100755 src/rat/homog.41 create mode 100644 src/rat/lesfac.147 create mode 100644 src/rat/lesfac.148 create mode 100644 src/rat/matcom.98 create mode 100644 src/rat/matrun.80 create mode 100644 src/rat/matrun.81 create mode 100644 src/rat/mhayat.61 create mode 100755 src/rat/mhayat.67 create mode 100644 src/rat/nalgfa.67 create mode 100644 src/rat/nalgfa.68 create mode 100644 src/rat/newdet.12 create mode 100644 src/rat/nisimp.81 create mode 100644 src/rat/nisimp.85 create mode 100644 src/rat/nrat4.265 create mode 100755 src/rat/nrat4.280 create mode 100644 src/rat/pade.42 create mode 100644 src/rat/pois2.74 create mode 100644 src/rat/pois3.66 create mode 100644 src/rat/polyrz.93 create mode 100644 src/rat/polyrz.99 create mode 100644 src/rat/psolve.19 create mode 100755 src/rat/psolve.22 create mode 100644 src/rat/rat3a.258 create mode 100755 src/rat/rat3a.264 create mode 100644 src/rat/rat3b.95 create mode 100755 src/rat/rat3b.97 create mode 100644 src/rat/rat3c.302 create mode 100644 src/rat/rat3d.264 create mode 100755 src/rat/rat3d.271 create mode 100644 src/rat/rat3e.546 create mode 100755 src/rat/rat3e.562 create mode 100755 src/rat/ratmac.34 create mode 100644 src/rat/ratmac.35 create mode 100644 src/rat/ratout.64 create mode 100644 src/rat/ratout.65 create mode 100644 src/rat/ratpoi.7 create mode 100644 src/rat/ratpoi.8 create mode 100644 src/rat/result.30 create mode 100755 src/rat/result.34 create mode 100644 src/rat/solve.401 create mode 100755 src/rat/solve.412 create mode 100644 src/rat/spgcd.110 create mode 100644 src/rat/ufact.32 create mode 100644 src/rat/ufact.33 create mode 100644 src/reh/buildq.9 create mode 100644 src/reh/mmacro.50 create mode 100644 src/reh/mmacro.51 create mode 100644 src/rlb/bitmac.17 create mode 100755 src/rlb/fasdmp.124 create mode 100755 src/rlb/faslre.116 create mode 100755 src/rlb/faslro.71 create mode 100644 src/rlb/faslro.72 create mode 100644 src/rz/asum.271 create mode 100644 src/rz/asum.277 create mode 100644 src/rz/combin.152 create mode 100644 src/rz/combin.163 create mode 100644 src/rz/numth.47 create mode 100644 src/rz/numth.57 create mode 100644 src/rz/schatc.54 create mode 100644 src/rz/series.133 create mode 100644 src/rz/series.137 create mode 100644 src/rz/trgred.88 create mode 100644 src/share/aplot2.300 create mode 100755 src/share/fileop.23 create mode 100644 src/share/iffun.23 create mode 100644 src/share/plot3d.66 create mode 100644 src/share/print.33 create mode 100644 src/share/tekplt.171 create mode 100644 src/tensor/canten.8 create mode 100644 src/tensor/gener.51 create mode 100644 src/tensor/itensr.119 create mode 100644 src/tensor/symtry.102 create mode 100644 src/transl/acall.71 create mode 100755 src/transl/evalw.12 create mode 100644 src/transl/fcall.40 create mode 100644 src/transl/ljob.16 create mode 100755 src/transl/mcompi.145 create mode 100755 src/transl/mtags.18 create mode 100644 src/transl/trans1.108 create mode 100644 src/transl/trans2.39 create mode 100644 src/transl/trans3.49 create mode 100755 src/transl/trans4.29 create mode 100644 src/transl/trans5.26 create mode 100644 src/transl/transf.11 create mode 100644 src/transl/transl.1157 create mode 100644 src/transl/transs.90 create mode 100644 src/transl/transs.91 create mode 100644 src/transl/trdata.68 create mode 100644 src/transl/trdebg.8 create mode 100644 src/transl/trdump.27 create mode 100644 src/transl/trhook.6 create mode 100644 src/transl/trmode.73 create mode 100644 src/transl/trmode.74 create mode 100644 src/transl/troper.15 create mode 100644 src/transl/trpred.6 create mode 100644 src/transl/trprop.1 create mode 100644 src/transl/trutil.27 create mode 100644 src/wgd/specfn.96 create mode 100644 src/wgd/specfn.99 create mode 100644 src/zz/apropo.31 diff --git a/Makefile b/Makefile index 722c161b..55fd429a 100644 --- a/Makefile +++ b/Makefile @@ -7,7 +7,9 @@ SRC = system syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ midas _teco_ emacs emacs1 rms klh syshst sra mrc ksc eak gren \ bawden _mail_ l lisp libdoc comlap lspsrc nilcom rwk chprog rg \ inquir acount gz sys decsys ecc alan sail kcc kcc_sy c games archy dcp \ - spcwar rwg libmax rat z emaxim rz maxtul + spcwar rwg libmax rat z emaxim rz maxtul aljabr cffk das ell ellen \ + jim jm jpg macrak maxdoc maxsrc mrg munfas paulw reh rlb rlb% share \ + tensor transl wgd zz DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc chprog BIN = sys2 emacs _teco_ lisp liblsp alan inquir sail comlap c decsys moon diff --git a/README.md b/README.md index c9510efa..6a270ab2 100644 --- a/README.md +++ b/README.md @@ -203,10 +203,13 @@ A list of [known ITS machines](doc/machines.md). - LOSS (device). - LSPEED, set tty line parameters. - LUSER, request help from registered list of logged-in users. + - MACSYMA, symboling manipulation system. + - MAXTUL, tools for managing Macsyma. - MAGDMP, standalone program loader/dumper for magtape. - MAGFRM, create tapes for use with MAGDMP. - MAIL, Mail sending client. - MAILT, allows editing mail (from :MAIL) in EMACS. + - MCL, subsystem for compiling individual Macsyma files. - METER, displays system metering information. - MLDEV, MLSLV, Allows access to remote systems as devices (e.g. DB:). - MLIFE, Bill Gosper's Conway Life. diff --git a/bin/lisp/format.extend b/bin/lisp/format.extend new file mode 100755 index 0000000000000000000000000000000000000000..dab1523a132e01329df680a1e8d0ed136e24673d GIT binary patch literal 3194 zcmZ`+OK)4p6+XjDy(&?(NsRa#$)|+3)!oyC0eBn zCY@O?WeQ#DT4u#JEO_hAoo{Vz-f?b!=k4uVZ`}IE=Ju_7cb&NN#=UR9wYeSlx4+v~ znkf`ER7s%iOCgibz@_wRO1I%}A(LK9WpiyatTx}vWj`pi-mDeNONDp>(}YQ4#An4W z4~jS;eyKjTOc_WBbP0X+pFruWff=xHrUYknXYbLAccFP7 z$86RsBFCIrEayn@S*Gv9tx6RVe}$MUR;zU$`kyp&VvKdF947qR4qX1~Q$t+(1?Oq+e(7NJf%xiE{={d-A(h z%L1q;-j*!I$oTPOo{KHOOb+uhwkQ$J)-(vly(bca z*ck`I$rq50 zWYMsEhIAHtApY0yN>ai)cQKk&;cC(E%j@NhQl`9E3W(k26{|Bt*{CLwBcu&-A9dMY zhB!OwaZd?PF|%sz6U|Bv$Wqu?dgvd+783@&h!K>B@-Q zqfY&F(rIvZb}HS54yCwYLajh)2hVWodN!RZW#YiTe0*c+0hZUiVUb^Go|T#Pu;dM*MnDZG zrSDk@Y1&bRd+(6C%N1vtdQ`eDdW5B@`*1{S36>pwu;3TppWMQ)4taah`G@E zOb6Ci&_Xi|@{AaxJJ78MA5H?ZuSca@6vM9Ek#Ingve=E}03(UwL5?{bC!v>eG^5Dq z|4q4npOkKFkgbz3EaS`BtJxAaeOP6myWw528kf+WOhUf#m#X{*cH6HJ6(h4`IgE-^ zmP|&=b0^duRC&8x&|#bT zUHVM|06Oadqnc{665NE?SGovxM1$q5@6_g#6+{xhe{upCH98CyN(1il%J4n{miF>) zA)I4+%jp%M1I-NLp0+G)NM+I6m9hs)?GYFd3A=8^9sURZ`^x?H(2OnpMYpQs{gI( zzg=21sYQPuLEqE~40ve_i@ELsox_Uuz~7pxLnD|g9dMp{r47zvqL`VoBmu<4>W7dr z=ZVn!P86j-*jh(EPVxbW}&FVqYp`-DT_?3-WnVevUvekEZyKVt^8gj`UE$l_x^XX7OJ R*iY&UI(!NCKjl9i{{a-1I_LlZ literal 0 HcmV?d00001 diff --git a/bin/lisp/format.float b/bin/lisp/format.float new file mode 100755 index 0000000000000000000000000000000000000000..8b794047033690df3512eae95b0b75fd76412c19 GIT binary patch literal 7395 zcmbVRU2I%ewO;$2@pyb=JLA}m$E1@UCvKFwV|x-iamWvhGqz)s#F;uaxOSmqdhhKh zO^l&I2AYJCc(8bB;ROVJK|%tF3IS>>1Qilei+BK}AV55DuLNpUULc;3naMS-HGJRN zGqY_I?gOLbXrHt9T6_I|Ywhj7eQWj9uHy8BJTYrh(VXDtjbFHQY5L;GOy9)F?1f8H z=lHRJ|K{@S*=b3fXk0CbU#T2yjff;pi!_#A!oz=LHaZcsE@NRz;&P;4q@k1**>#Ac z`>9ivN-%}l$FacU;-`xK8JqDd03h0UEgU2XNtr z3t+YPMs*)dc+Fs{w2n-f>K=zks~%F#=ohtAB#5r8-7LOE5A9i5E&UJWp-YP$rz-2^ z=O`IAyI8)A(Oq-fH#9}xdqbet5u}J;rH9vxkvA&qg*??LSP()-^;<3Z;O7)^qy;co$4ZOMk{d?MqE_Fzwo{;ujzv*Hw!Dfk$xQFxJ2! z;(W8Q_CDZ0h_na@f*3^B!%xLHb&|c@@l2xSkc2)f?TXQOsU#ZTV`Xh zf%QKmwIdh8AMKs(ofSFEiKy(R1O_oXG6Ny1KOJ$RsXoGDth;atd8ebZBh%w{G*hE8 zy=SM#M$YqfRYS@+*1yVnJHM zM)RRN3F-GO=im>*0u7sUNfESSqWnVM^hM4EM}+bB(qO-sPR7txERIEj16V?h8t%QF zHv^AiRyL7ojaU(lltPbGK3e(<3>##?{va5Hk{C3Q!ACR;n536Ad61o98PL>X-0#Ss zx`It{N~KyRuSb%}dgA{c0`1?Kc#bR}uoleij`Y2E$i9^}g+L^WfsSM%~Zy|61d zfXFN?inPe}APqE$V9V;_o@S!M(@s7gz|g2()jhyFD*wDk&rm;9Z71!2S+J<9T1Y3u z@dxp9s&3Qrv8M_Uevn++`xQ@;uxE*CDX2V%m89-uaw=auDkc_hrTXSKwGclx!nqp|UQnBi1K--lBt3i(F^A)x8 zktu`#nf|p9mX^2zkK^JP6g$8Q8yz1d?PocPh@1@jwva*nhMpya6IuN)W`{dU@8+w) z?{sUW9#~>n9g|rmUDq}}+CnOolR)*j_st(xD))bSiWQT3&?IUN$YPA9MzI}B$hjd$ zslfhphE8!(-N&~x%@2|aEY;Y_3#G5*rO_ph&6!_9n&*4cxog1g?u<~r+8I!Iz-U|)8juh{YR zzkK5Ud#}Fs3$ATwxPpqUBazPlT!7*4=avoizGHlHZff>o-xITw>GKz!lRV_0IIqZr70(_&ao zD=LeE_VH9!lgm8zf6+nBm$t-k>e*EW=97~0Gm-LbeAid4#Kkv3Ka>$OSPg(>5x|le z)L9mB(JsZQ>oiSqGZlbQq={oY2Kbs_s&{NVFkA1 z!vL00p-q~vCVdG_Z{PTZk#p9B)}5K@$tlkBo4GJHZc8o8xt$-6l9;o7fB()mOt;dG z%v_#4XL)h9zT|P8tp>`6W-rf7j@#%l|9$Ox|9Jl=mT%Zb7Ct~L^#d_03QZtwjD|+VjLx&J%(sHSHpW2|!j&%|(n$LS zSvf2yJ@}@tv}w*7_7L>2NYJwkeHZh9Q)2n?QHY?Kg>`K+K|;(trANCV=7$@pdzH<3 z4_hwqp|YTP2pcZ3WNtL?Kf89bp3%*^7_;UnEDeKpu(D2m_Z=%zyg&*lDpI9jgPo+& zRjP&ESmF)>ssb7S^I=yIwWlmdHWYV_WnGN$LIW7so-&e`PTJ*rP&GamZ4a{1;S~0L z?~i%gCv|aRRF5_mijZjPfcD~fl=%H4^I^}2e0Q*}^ST2iyhfiIh+*+|jC$zNE3>^B z>b6VF9JP#@<9w}wO?qNvdL%tFHqDO({NIxKWBkTnZSnM2W(=o0(%1>(AS-IWV1xRo z(|QZ%qd0w}diWf9oM;#t7qeJO<#9?u1hmpFZ$gi@P&fr%v~HAYEibe^yLM}Vr!GBu zEwtlxo(Hb_sf&%9MCReBTRR-3z({p7r@?u(3-W^tV^GWQn_eRl2n3aLB zJeQcO!(@nw&J(&A$DCD2eMi_9+WMu8k3z-}36^UFXf9jvO&xeV1tzt?-ka0FDZPbL zg$9m0x2bqMTHLw|2N|^0=5s7?3Y4|ukNGSCY-0f5i=k?=-OCNV&rrL76pWOKWl>a&1&-Gwv8v=n(dBd9$B!Fpp_ z4$3d*y);EcCGpy80`%t4)!P8v0$8rvRS&%oN`t@_pmdOuqx~yuH)yu58mnXv{dyzV zj(t4qR_*~`(mwWS;*wkC7jWvOv?C0R`x-3T60;yhRiVPQa6Ij*Hq<~L2E*G*McOf{ zmQo7UbTe(zaehls`fmM3bpc=AA-9Yo4`A7`>r^~~fLOcvAOTd<@_87To6V|{n-W5V zpvj%%?7G(V_x_X@pE`#f7d_vry8h6eOwu77Xpcnr8mgsA4|-3)gTC5=+mE1HU0owQ zAwiM^xtRHp;taoSxxaDfqW3qLMB%8{s(*Qjvjs^)uz*92p$YNM^a7qdHJ-IV6(+nh z?6fzRQWAW+pm%OPVwir+?d=)cs40vRCrn%eHRub=VW{2}s=;?M`L0dV=q=L2>}IwxxtC zssUEdadk@Z$C88}L^{PFVc-$(8CqK#k+B_(2$}BIYM^~Y`OD(H(tRDP)dboLKny_r z?(8;ywc*uWx?w$D+wo0r-kj5%zgXTY3n6q0#VGPU(%795?)DRHNf_wFCEz`40R3fQ z*)|v?!=2L|OG~n!)ybZrnX)yq&K~uXl1a$Vc2>M43lY2%Qxh{%Zbpnh?a|$D*WG=S5yfi| z?|HC4_@6sE4?sO!&9b0eO7Eajl@O*)hoZ|O{d@2z`Z$7U43==`w+ZiOjoO}hf!ahk zCRp>Et$h8E<%WJMe<|;6n9yQIKEUg`@?D(N2qPOBaN43{^Il$p0)2pin@T3lo}aUK z0|amdLam9Q^&0{&i;WOm3hFt{rD76lY(eWO6slfSO^8@J)Oxtqgz`A55snBMin(Od zh(u1U-3pKdpR)*EPbH$~U5TfCK&anZGwo{mk9q%bh@Xs-Q9XxN^}LJLBpEA)P60OG zsTGYK&`xyRRB4EWjmcQk$yra_WhIz-e8kcYEam4h;wu|B<_rj&~!F{P%aG+mU@sh!YJYH9NhK zhT?6Z;c@oQeClvb9Ba3rD`TKc)mf6#eefQqbxYrYb=2pv)_&Fq)-$!Md zu%z>ZE=im~Lw_KF8dYn>0VD4MP?E98`Apq!7B+1KgXQ+nM~{k!^9Y(`e{XRp`w zUEBG-ocF)26N1v=Y3s_<9lK$F24uLbB|wq=Rkf+hqPq|8vN2@U&iWQL%c1fxmOS1z+3BD#>eU zl~7^Y-V}vl)ol_UJWK|*JuKijpC(pT&=dQgs!4tIUkMgScJYetWx*FfwxQ~{9T=E@ zhOj*oRwiGt18?S>?%Z(Qors)G)tr7~klqr1b$&zSvhIw;Jpux#pX`!s^^zR`3b4ej f9@ohLQp>)&4pcMr=@e$g)4#ZM_|N=}f8G2COWjI! literal 0 HcmV?d00001 diff --git a/bin/lisp/format.hair b/bin/lisp/format.hair new file mode 100755 index 0000000000000000000000000000000000000000..8d0192dc55b4d8078ee6f0f0b117309f0ec13297 GIT binary patch literal 9634 zcmaJ{U2I!NcAg<6TCRVViWG~EP5a7HY(*Aj%CT(6vJz4xEis`enm-%cvK!G7B{Gpn zhNNOU-L<(`6h@IY+eJ_miy$b9qFuC$cDr!rZ+T$#^(A z?FmPNp=&h)It_VXE)od^lAf49?w?Jd2_6}ZhrSt#CqhDiY&Xd9kU!{|i|G_k>=6CqD991JI!X0>H`; zPcdCeuVqMwcK`l_mMd$y)z!>OdKJpD>0IfawwNwAsHSFeHZ(gGVl8Z%F=UzzW5Qzb zxj-n9@FYXmbj$>JB1|d9W``;ERQ`5)HJx9~ERhlOS~`#a-%`U-npuIlXx#Y(G;ryb zSu)ox;EzPibu%rP@rUErJy;d9St2zR7bBOsYTwDd)|a(=lM*di>(<&S?VnYPJRNK%&P{caj1OQ`Vi2Nc}=p z*lUxrzn`lBY^0?-3kADS@XS`NDmuAzAxM*h(i2zZ-EL7^pw-``*AZ&bw}7@CC`GpZ zwkihd`-B)6xkxSW5?jyMKXumxjR@73@p9B(BeYf!;s7;sA4S`X(031|K@k*br)5ST z^m&v%R)s--TdDfuO z&~@=>ce|Dr;u{ukh{(?3_Tm@2yP|{4)ee&RTk~J+Zo}Nbc7T9+$aLT>6F_fW8;^y1 z)>5^!?IZFHTbB?#0&1h-e0G1! zTNTfu*|?Xi-3M#eNWpleCLj0OHQUNVwAz8Z48;|U6a16fNqX}d)zVebxAEBT|Cj-y zo$sQSpWSDbkX`1vhZ5|j^Iph0b{vk*6jj~V&bYAkF!s$~k=gnz+$9d4PJF-nob-}j z)E}AvDxG-kc^Zh8J#D~SI0|ZFK^zu>U@-K@EcFD<(l=r?f@Fj|Rty}|RmAA%NP6OP zv;L@O%p~i!$|>D}P_yCaTx^brLZpOEvL~{iw)|i?8qm9Kqf`iXGuQ?aAKQB<*&+Lo zf%85B4v0NhZ5M1pL@~by8L&QMH%+axxb=rs@qNv)KwrZkxe7TwOtugO1&t(fYP&{(`(PecWv6r;Ii!8{2tY0 zWdFXHcA`k1EBU33UJ)}7t_Z<=AROI{+^L9R-nBX@~hqklC2cd_nH@k6T7whTui{&?JfT}SmI0cH%6 zm_-m0icUwui5X8cg}{kIG>+?>(17OvYkoIVDsWYzRLP>uKp~$oO3S%Yxx%u_9i1y= zIkQ;EFInVDwv@@}lx(iF#2s;Uxv*Z+)uYs)ewji?y`$yaawW^;a*hUUmP}dZolG7Y zs7orb2Bu_kE7=Nn#3)yl_4yo`&pav_swz;#GAik&$jqv#U)RD_9iuKQcQUJFrtxr< zY^AE|w?gBsWONhJ!l)YRdC&?qt0qb#w?H8=5mYsLmoyuVs8O|0o(;4nTi&FdL#waP zkWxW1$@5}$VpR_A-Z^R3cYH{)AsZUxZ9QLs^E`b4peR z$^gjY3Sb#tN0h9Yd_e&g`KXdLlV4JRMRqG$GkHP*7WtTxHIpY5V3Ch2Su^<+1z2QF z$(qT21z6;MC2J=0sns&iC!R(QDZtV^pk&ROrxjq42bHXu%!h1?8P7kB{F(wR&3q2) z3Ys;~wjrNVvS#v}0xZpZkhjx(wGH_NC2Q84P=KX*Sjn2nDFs+$4nEqM@p>CF$0zN` z*V~XiO2%fOdVpn!C+ubjYn}tiP&D!NV*qvv-QC~gvQ=f*p`14z0TpIQl$2kABh2dv ztKw=dW4b2xfl4!18LgqC1Q;rqhumOep(``Y?>dZVA%>YqX3Ki zhLSaty$Z0%X(ekW^Nm5@Ocr_ZY2>pCu*exDYu4QAxlr( zZ#|8CUICWoH6?4-+2UAipCd<@li^EXa|J2XnRx0 zqsZpG&3En{`Ajcg$0!h`e8bkGs_fkQiICDFyAg19QT!>#5o`LKu}jV_Mr${!a-tbU z>OeZo3!$9ce4o-w8}^Uc7J0ns26!k*84G!s`^9D9EZ-Q;6-h<|KHH@L+z%V?7uOK`Yy66x-m!>v;>-F!`-D-#H5`AcC$ryR_S9^m{XU! zrrK#7Hg%)n_f4-Y>H8-tx?uASD>Jly(XhFKThc*dZc#SM7^li=;e0AU)6O;tx_^z6Mg%~<2_IG z_}H$!y`Ek&2|_SMIPM;L%k7>~6bh`(E_BNI=St%@N8j}s2BAy4R?d*SHteKy8e|06 z=W2m_|M8KB)&n0C^NOuJAr7zJ{PKg}IQN{=h=WIJg++trWC1m;K!F@aDg`1MTeh%X zrb%SYa+s3XA~m$1@)AJfp;Oiy+Ohf< z8m0YbZJ$rEEk^2lDW~L0J|_jXN{|wC(ho}?!VEqjeh)*?y)`>7N(aOM3O(_L3+7hs zMZP}DH@4GdN=nE2ccGfo}WB324Cu+VS0w^k&Eq9!iQQ4!fA|1YkA` z@n^}K_=cSTd@|jN;u1sN1GvDxXMKG;=kh{Ms_)B4*pU+%6yi#4tpBmy(jJ6!n6SR` zUyv2_J#|ph&+Pxw#$)nb_^>creP;Sk`YhM=cGG;igLSuXO6zmvIrhO_?0Cuj9Dt?| zxVpLTySuyRMuiN0Xt1W~Gn}CX_21I6*>~XC|E+m%ZP13|4f2V# zkN%6S9c$S~=0tfHM97}Znp2s_QCV)s$X)ERcriA zYgFZ+k*~lFmqY%Df&LEt)7!q>rtP;awBfF3wS8crzBX;YW1;>w=yxr2stx+P7TR!= zy(gM=&Ukg?7 zJq`*k(2+E=cmJhH@ zH!_#NFS!YSIO0L3*B?mI_!6NcamXfpSp8@rqwA}ykO&zp+{vd)rNSLPQlx*im`yWf zDpN@}q>dtm6~CTC<7QNi7AmX)T0+HgZWV{St|gYs=#ZRBFTPbSrWcL;Rx*9t03wvk zSlNApg_7Tx9#W5LqOgVmapc02bFH8! z3We>m=Vfi^tmpOgJ&i{I1K6s|9&IR+S*{pTmVp~bDo_`)szBOY3jb^}m{cuxQnJaNA zfwe$Mzbm3e7%#pReBh)K9j%5t=tPNQFzH1R4~GJO1YUy-Kx^&Ezig3#*P7}9??-KT-)xbA_tz~l=zG0I2HuZbWZ+$Ek%9M<78!W0 z2_x_xwc*`RGTeFlxoX{hp~<|XS}qSlJnXFly0`w3eRl`4XE{EuRjcCfg_xq>ucP=8 zg#K})6(r|Oj@Z`2ArC?*Cs)U!bmVMEdbqmvqW)u&tp@;pjkf7sm?Sl|Ys^gPG0NnfO+=RMDP&$q+LUx#<5`kqDG;VS?2 zh)8pNmN?pm8`d{HKq0n6H*j!Et(IMX%MQ$H{WJHTW4c~rXwqm|D;P2oiESE{87chd3gpz7AqI4MXq0=vFx`{ovw$bStrt!G*{kM;vncuX3=n$fk^2seDQ0Gf|F{hj?8GF!fmom+pBCc3`*e=s2H_Le%kb3ob$%#MGa zdY{=QZ-rV4^{%nZN}wx_D&27?qe^>pNbmuS{V?HsBxqI6$>IT(DjL39I-FFvWm ziIpZgex*?sK3}k>OiS1Tvl4N}NHNpvaw@UO^%hx_O`pvjkU~KWQ%QH8HD)IxW$O5`Dk}-cIUt6r+@I$8_QkJqIp1> z(|lnMDR8I8aV-g}*ko$PTPg0wChyI|%Oo7EBn}p0Ha8CkV`hD-Qa2nm=C1VoZu4~~;q7{{@lg+i&EI0REw3Sv>U!rzjs%oW5E48Y&0talTRTR13Ib+Wx zQPe>h-j?@ah-y{VnB=AsV0P!oLy`8Fnt47)kXEC+!hD%B5ms$uZ}Z)p#ch z-|$%Gf}QJ$joKMImWyY2SEST8zSENvG5k)w-PmpFs&8j=nM7)&2S0K9LSt7Y6RCJo zf-Rjyhb)>r-tmzP|w&zEX=IoqBd%d$XR zzICRFEh5U@7`D?6Ej8RvXU1ajY_=yCzm#*VYT)7+)sqH17es~Yj8P|n=ddma}V#@E6bvy(|C=1XPbv80_~*w{Xm9iK=H$!dIJEC)s+|HMq;#@*@LGn0iI z*Y%@E1N!!izIo^F^khNbE8M+3b4x!GtC-Dj9h9JuSjtk=a6FS4b3?lxzma$L4cs(l}5$fi2;n={jJF^e!SWTSEP~{^il3Vu~tgiSWqxuQaCf#NcEiNpOItq5b zv3H`w(#NpGYR6RNV~||-fmk^7xm)whwS@}1h_nS(=4xiHLb(-!d3B~6zWLX3HE-IN z7KI(6khxkx8;&$|?Jlg+#R>x_^Z7{ivm%Ad%|$Yp_>$iTL@S>fwPoUI{ji|Nv=d^4{GXlJt-to#_YSotSJ ziGBJo9?P4H)Z+3QU?sEUD^lQ9=U>_lGGS1OiohCRFv8YsDNhtU3B$XXdNZQ&@_l~S z?rZWHnjgij09$oM9F!IN3%Vk0*N4ET4?tkaAR{aS1Pue)TDs4G?ms(wYu~WBsx%2S z*rUBr9`rBLq#i7{K=L|-@Tl4tzc&~w!vI!o;OO#C`J*PM(UH-<=&hIEXHh5g7RH$k z63_99%(C^gwy0Bc^DFy1J2}u@A&o$rj>&M>EX_WrFsn7A*KzCe<>3LFS2D@oC)Rd{ zSQaiHi+kzCnAP^59)d%%qUc#Nstdif*Um=6vUi~O_yg^Sp=E*q*SruCH63E8oDI&w zEtS7LtJN6X51DOh6~dr<-yk(U~FS^VJ30nueX! zf>(PEvjHm-KejQ0bW`HJlab8T9U7uZi(|i+OXLa1<;ezd+2X}zPvNG&xe=Vc-H>vs zz-c5>+VwfeiU4baRgS&gHjA!ce`$qJrSPabk*~Zl4z|9bs#T{gB83s$}(atD3b-3-&6ZZ57U{RTi;Jp-B?IPVox%q5UN6DPu+SZ7n|t}_SlisZQ^Dt-)&9#e ze_!_ZJF73iFnAIS6sUZSU2V-l?Z4sBu{N}TL*ReNLLOE=$8On=WM&R+sHis9wIip} z({uA>14UhFe_UJY)7)2ZHNDcNsj7d+#&Z5Sc2PcRBYwt06764TK;yJ*->a=$@mo&w z{;S(d@4$-00q$RSBnw2In$wEb^smGj(2YJ2XqNM@Yb(_s7U}EGHZ+7|Gk|NwqQL-* zDzKLIWAYD{$(CX%^CIvMYA<$}o}cIPZRGr})LQGKAf zV5h#dmPK|OE{tUoBZ-uq?5VS|NRrv+etovF!eOUw5MXu1w74jW>Y#1|!W`gs#2^?# z^{K~LS+l|BRvqy;x(A82dFL-HKjM|3bcp6R4h0GC)VVcDWQ|JaJ#~)MZWM~zErlW^ zk>~(#Z`|DBmKsWl_jw$ZVJ2n#4c0QOMT`}^ss&Owan15DG zmu2Zm5#l1nuy&j&!^R`0qs#`n8x%E_lol7Xx?0}ckEX%L7*|9Ow{@wxLGXqzNzDNy z6Y*mUhG2nkh#A7+Im9>!+Ym)t_0C4GQFlbVcgku2)KP9mOW~8`xDMcv3SSqP%n}o$2ZTxy(+qf0E*mh-vt{j&vBJ(oC=@k~%1_XWTzNQ65#4q6aos!9 zUn!r@%P?rT4Z+!ftIp*sZMnC6pEJ^{{_V)`_5ES_mp`Y;68(YREK#f4%M2S7`KsD$ zl|V@+~ahw;H!#$eZX^d;2>%g4D%vBq7`Hrc@$@lO~;s=eUXU z7<5F&Al-(J%~#XpjMCCTUYC8?b^O!$=@X8BsNrp1=k-=>xAfp3reF0{^6Z_357US*cN}V(DDwI2|#cQJH=kkx;RTAZPWxx Pw7~c`s~fNQf4Ke!q}%Y; literal 0 HcmV?d00001 diff --git a/bin/lisp/format.macros b/bin/lisp/format.macros new file mode 100755 index 0000000000000000000000000000000000000000..75ca949364e95c04895196dbb65d6295da06b77f GIT binary patch literal 2816 zcmZ8jTW=dx5T4_8jH6uYG)-eu(r(*SG#4j!n^F)h&Boqbh%ejqnuY`_rWB$+B(SY<71rQH0i?WN{LwU?YsK5gfS;3gv>QkCT|FsY1PC^*b( zv?%HwIEl2brA;kOXlX-B_q4=GG>5Vr$Ihj-x{wtbtjk7N=Y4Z?p0I=(Xyuujx7@gA z&19qq@XK0@IV%gF2qsW_N%%RrIolJ-Ya5i4bBdy={EX$g*1NFqP#G&bleQr0RE^Pg zZJVwL)zPNmW#X>w*j#xq0*;3!$<|yxZn<;K^#g`%G2<zO)dr5c@Q&r#aW`M|xGmVK^HA(k%t@3~J|{@Rn&V2-h=I=|BehVY z2aZOi@>yp=iY10|yPI2?I|#5#V3#RT*!8I8trFif-(iV!V_d0Oc)SqktZ&X^2L9o3Mc)q3CK z#&feb3N){+eyB_uW2vh~Pa6%{2zey2*1dMbEE&eBVl*t)YH6D~SRLFPf1S;;d6SS< zX^NSfXG*Qj*|~4}@^raU=aowb z$DH8_&O;!$CdsjMc59OB64+Br%TKP>MRZN`d#3rlula@VTGK|D0}PueQQx8Jn1OO7 z$Ytrgnj<=gB2;gMh76xmt&_RyGmfG36C7=19!Ru8&uMEubRKR4Mv%|ShnmCOEj|=g z7~JJaRXz`xSBCj665|CmecRw=iUQE>1N=yU#x%6P{MXdCzMB~{*9}1b_SXP7p#ghW z-xwUz#wh4d`E{t4D5QKzKV zrf7JGB#I^;GiTVvJVSIuhf4df1a$}3ka$vHD?tu_2n#N!z#xoJk4DlI0s)Eub{ceW zHj!s{J{d4h67`|2Z8L}*(X%>Q6l)Jey`WMKLQoVfa8|p-kkr?_*Hu%Txm{Z6CDeRq zt%*<<_XUmN43GK&fbC{%#USN0JFwWrNF+(o?&(C0gE#LC zpkluDP+N)tocOb1?D*1wrbSZcd`^Cp^D!zV5LsdBk3d3SH-7p3r$rwC{Hwm|(fXhNOTO5M2rkRcfM@vfAEJaQmu2F_?zG@ zOx)4c)omK%N*(v$q7r>QD>uY%d<%Q>kmTjh%Y?ZlQHw4}xVkBT7f3M8Uo1ul#vVul zIHEl|;Zdb06z7(L#Cyq;1-=8A`mrV-`*Em)0>z}T!;SVk#c2JBW;2$TVyi>~K&mq- z0F8oC|Lt1{7@I?^{MXH;EjJzK|7+_B5oo^;1Q9QIu5D!xgeuHh4#&V6KWF6K;Xe`t z)&5OZlT<3my`le&KTF;9NrjdJd=?l{eJg$R>BKpbbLU>V)ih$WWP~T_su+B3J+b literal 0 HcmV?d00001 diff --git a/bin/lisp/format.num b/bin/lisp/format.num new file mode 100755 index 0000000000000000000000000000000000000000..45c03cb7340ce96b8ef1310fa7e47b95ba341326 GIT binary patch literal 5478 zcmZ`-O>7(25uT@|C<+$krKL!WW5#P*wrp9HDO%|HDrvm;A{7W!JqjL^5=}@PcG7ybBys*Pd5g^iqWl~4# z-Apc}7b1n5neV@XtU_q7#mnXr=|UuzN$KfGd|A(#&PBdBp95{s2QW2=X8FNJ*&a~} zQ9W#mC^p*n5~;qYPkOZVu{F`V`)eF&;cY}c0G?oQbRuh%n$W-dUku6srPG;wj2Z@< zfkOa6vV%4ch-_LlF?=#bZpGvk3=ic2Ca)lO_cQd3aF<+b1%cgv;Y#lL1<=e#8$1Q1 z)H^(_nJs|RKLMIi|6Hddr!|;;o{ds0izK{F(Sw{S@&c9J|JV!5OB|iTwBMf$QA!34 zdQlTZQcuk<=tLSkOymnRz?@DblX@c?eMcdfeCsIc%(6_15Y*}U?{Wn6Te`3_NRfkn#I^-6;s zG0H<}eyfV%vm8>EsRkKh9#Uo~qP$_-H?8o{#L#8qQF#Nyw0=CqSaB%*HY(M6qilvq z8rIM<&y$v@J+x7rxdVcrg}|ZZUEpf$N3EfQ@@kMa#&RDM2~)saA!!16g4e}y;tZ__ zXqluFVGqp(J52NT(cOlZ7C?Z8{X`8B8qB+o5OH*~k&w zlIIom^ZaD;y(d2Y-5($Nu~ z`yt`CCEy5Ol{~gg2h2eP*^@ zJZ%hT#I;{6YbD@j&RE5+(}^!FtGhI%Wzh^4@xXo7;OX;J+g~){SC^@6qIrBu3z5Nq zMw2v|@GF>p7T^w1^B~*;TpadhPkMBWbnfm4|g>50Z+>H8uZ}Kzi*WroRfikU8_9Yx>qk_;n!BN{4;8Z zVY<}^;5sVM@9lX_HUOK%VL)unUNg(@hs2BGAJ>(TH+M}nfku5F@X?=Uhn`yn`=f`e z_v)+x-p3;kLZM{`!1B)C7`=3~K6_{CNz6ib%8wh+Mw`^8D;XpH$v=M|@!%MT)KF|& zC|0D6JKuf&z1laf*=X%j3mcVQUOcdKFwruxe^pX)Lar}wg zVoFb>7Z!8!L|tGtY%;b?^V~czZ>?5um_brgV1D=~U&|1&>x4&S+ z?LRl+8wOtMctylw>rb@>)PM%e9Bl>gh>*t{7|uxHb}s^s>PudWp!v|TmOu>_c@+{TbdC`Xh%ll-pJT6XUo+ygT>blfnxGRLy1^&i zRtvC%%E??4llJY*}B}FN< z-+3{{mpyzll(~R4OZ3@mDEfHE{C#JleoCg4+%{apv&%HRVBYYwSy&FlNqTuK2SE`r z3CO*}Z4=M!Z4+ym=j9yCYo(~2h?jgk88j6L(wjAYd%#;ue!Sp{7RG7t52pffk{+CSOEN3? zh9UqDuZ8j_sD1Yr0jC^vo0q7YA<@(v>_pF2F573=(&|()#Ll1R_ z{HtzkRBKyAV#(6XvRy4>^_KM<=yQZb4KYB6DhRIb5Wkr%E-mIFiF9OM&o4$YjN&(m z8)g+!^g=$dl#aZc)R#=pcoD=i$&AUOpy)TWU{i;)SkS;{4`~-sgKV>)m`G=`8T85{ zd_&%BOy#C(+dt>8US^|t+l$)m-!{d~TU0=TjnWC9;sv-!nQ{g5L%l6tYRKU^X7fbo0<21 z@2y_^{_y5VCs?Pu&DrLxCjKe!o?of2dNm>&G=2q{wR!e2237GI4Id1(Q59j#`IoA? z?|b>RdQf%4eBIC2+^R>S(P)+en!m*|ZPMK?siLiqK4Sw%_HVjhJ7PLpSgA6dc}(U+U!p>W%+15zN1^UEwJmc^)$1?||;nlsI&gaP67QgP>S zj^)3#rFRZDGdqVJ`!C(&wr$%h&MH$QL{qS!F-$~Wva8oS@AI1GGo;weM2lVCe)RIU z2Q<^sUv-bKFYtvqwWmF&aq9EfcKXTQoHWa#_v=k;QxE7Lilp0m4IYa2~>4 zo=vUl(NQaPJ}+Jtn1k&nizGcy6WfK~;Ds7|>t!)|fF`EXdV4)9gNO zQklnet`MbTGAFYeYTc4pS?mn+^BXRNGlraveNtyP+h^?cPW2lc8~txFid z<#XVsF&ndaP%(Kij>RmO-;sEn!|yz2HrZfVvTf$4`|G}!uKkN)a=4Jmb2H5 zTrbu?iO_DLIoEtF2&fp0?nnSChNK>{!JjCIc|tbG?_iMAU&h)vyiH+H{iyGUuV5e7 zwFbwY4=s~AGorvtQ6>$f4rDVApZsEX`&oW>`=<}`PoC!Y9z5HB>iq1<-X6Hh3xaw8 zeO2>*ELlO+oGmU!DdF8^j>y&O9O5!7yDTr3lX2X4PXakAdi^;5hl!H{cEZmRki1f5w?~G|sWD(?hm?*AXb;!=Oh0ZtDz>1xEX{kW$M{4*VxQ^*1GqSFNwQ z-9_X8$j|xxE{1sQ5ViJmskLz9pKXg;T1uq}W+%OKXhKB1o#w7UwVx1O{V-%ehq+H+ zu1NelFL8$GdX)Zn&o@T~GYb&?o-qe_j=&c8$hCmG0>hQfoK$cBNFqlqf>@NBu$cpy zC{Uth4p9J}N4h6YGN6?>a2A)qeqKv>Qsnl*h;-E3Ju-5Dohl4C_4=BnY1DFz`GMkL zHiFTp@)dH<|CLT`K5*T}CR7upj=`c;F!fF@Z=8#IHsxKgXxuI^QL_D7k{NafY!+-3C}ZdgbnQk6-?osM{GjpgdPo zHS|c8sKDHb<)d-k{d$Q%9wMVq8wP?U5>O0irTs*wCSMWGG?!Vi2UD#9HU8|WlIU)w z*}MsE(S{>S2ZZ~QT2=-Zw&_b!3aH5x#GZyOT2 zx17?>AtUOSpPquei7$c}LnCw11!TFEhRuYWSQqX9gaKM+G=CtxWgIZVCu<50Ao=@F z|Jt0}w|1}1i2Mz;8GU33%-hBqALn8Suwh`~FIs@ooPd&gHafB|!T*|OR3RXq9&uFZ" "load-info\r" +respond "MAXIMUM TOOLAGE>" "gen-mcl-check\r" +respond "MAXIMUM TOOLAGE>" "declare-file-make\r" +respond "MAXIMUM TOOLAGE>" "quit\r" +respond "*" "(quit)" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;mhayat_rat;mhayat\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;ratmac_rat;ratmac\r" +respond "_" "\032" +type ":kill\r" + +# mforma needs to get recompiled (not sure exactly which +# dependency yet causes the version we've built so far +# not to work, but if recompiled at this point, we're +# able to build macsyma +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((libmax) module))" +respond "274534" "(maklap)" +respond "_" "libmax;mforma\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(setq pure t)" +respond "T" "(load \"liblsp;sharab\")" +respond "276437" "(load \"maxtul;mcldmp (init)\")" +respond "T" "\007" +respond "*" "(dump-mcl 32. t)" +respond "File name->" "\002" +respond ";BKPT" "(quit)" + +respond "*" ":midas maxtul;ts mcl_mcldmp midas\r" +respond "*" ":link maxtul;.good. complr,sys;ts complr\r" +respond "*" ":link liblsp;gcdemn fasl,lisp;\r" + +respond "*" "complr\013" +respond "_" "mrg;macros\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":print maxout;..new. (udir)\r" +type ":vk\r" +respond "*" ":print share2;..new. (udir)\r" +type ":vk\r" + +# Here we actually perform the compilation of Macsyma sources +# For some unknown reason, compilation fails in the same place +# every time (as though COMPLR gets corrupted or its state is +# inconsistent with the ability to compile the next source). +# A random error is raised and a break level entered. Simply +# quitting and restarting the process causes it to pick up +# where it left off and the previously failing source compiles +# fine. The only way I've been able to get past this is by +# exiting COMPLR and restarting it. The number of invocations, +# below, appears to get through the whole list of sources. The +# failures appear at the same places each time, so the number +# of COMPLR invocations needed to make it through all the +# compilations appears to be constant. +# +# We should investigate whether there is a better way to do this, +# but I (EJS) have not found one that works so far. +# +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion +build_macsyma_portion + +respond "*" ":maxtul;maxtul\r" +respond "MAXIMUM TOOLAGE>" "load-info\r" +respond "MAXIMUM TOOLAGE>" "merge-incore-system\r" +respond "MAXIMUM TOOLAGE>" "gen-tags\r" +respond "MAXIMUM TOOLAGE>" "quit\r" +respond "*" "(quit)" + +respond "*" "aljabr\033\023" +respond "*" ":lisp\r" +type "(load \"libmax;module\")" +respond "132170" "(load \"libmax;define\")" +respond "134541" "(load \"libmax;maxmac\")" +respond "140351" "(load \"libmax;displm\")" +respond "141162" "(load \"aljabr;loader\")" +respond "T" "(loader 999)" +respond "(C1)" "quit();" + +respond "*" ":link sys3;ts macsym,maxdmp;loser >\r" + bootable_tapes # make output.tape diff --git a/src/aljabr/*.lisp b/src/aljabr/*.lisp new file mode 100644 index 00000000..fa3ed3ac --- /dev/null +++ b/src/aljabr/*.lisp @@ -0,0 +1,2 @@ +; Used for the creation of MACSYMA +(COMMENT CORE 130. REGPDL 2750. FLPDL 400. FXPDL 1500. SPECPDL 1750.) diff --git a/src/aljabr/complr.163 b/src/aljabr/complr.163 new file mode 100644 index 00000000..81e6c001 --- /dev/null +++ b/src/aljabr/complr.163 @@ -0,0 +1,206 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1981 Massachusetts Institute of Technology ** + +; Do a COMPLR^K and type ^G to quit. Then load in this file. + +; To compile files for a new MACSYMA, all you need do is type +; "(MSCOMP)" and hope for no bugs. (Set FASLP to NIL first if +; you don't want FASL files created; Set REDOALL to T if you want +; all files recompiled.) + +; Use "MAKLAP1" instead of "MAKLAP" to compile (and assemble, unless +; FASLP is set to NIL) a single file. +; Sample calls are: +; (MAKLAP1 (RISCH > DSK JM)) +; to put the output on the MACSYM; (or MAXOUT;) directory. +; The two-arg. format e.g. +; (MAKLAP1 (OUT FASL DSK WHO) (IN FILE DSK USER)) +; is also acceptable. +; (You may reset UNFASLCOMMENTSP (default T), NOLAPP (default T), +; TTYNOTESP (default T), YESWARNTTYP (default T), +; MUZZLEDP (default NIL), and MAPEXP (default NIL).) + +;;; Let files that need to know (e.g. MAXSRC;TRANS1 >) that we +;;; are compiling to INSTALL a new source. + +(DEFUN SSTATUS-FEATURE-MACSYMA-COMPLR () + (EVAL + (READLIST + '( /( S S T A T U S / F E A T U R E / M A C S Y M A - C O M P L R /) )))) +(SSTATUS-FEATURE-MACSYMA-COMPLR) + +(SETQ OUT1 NIL UNDFUNL* NIL FASLP T REDOALL NIL TTYNOTESP T YESWARNTTYP T + UNFASLCOMMENTSP T NOLAPP T MUZZLEDP NIL MMSDIR 'MUNFAS MAPEXP NIL + FILEONE NIL) + +(DEFPROP MACSYMA-MODULE MACSYMA-MODULE-MACRO MACRO) +(DEFPROP MACSYMA-MODULE-MACRO "DSK:LIBMAX;MODULE" AUTOLOAD) + +; Format of files is: FILENAME1 > DSK Source + +(PROG2 + (SETQ FILES1 ; FASL file to MAXDMP; , UNFASL file to MUNFAS; + '((DISPLA > DSK MRG) (NFORMA > DSK MRG) (GRAM > DSK MRG) + (COMPAR > DSK MRG) (TRIGI > DSK MRG) (DB > DSK MRG) + (GRIND > DSK MRG) (MLISP > DSK JPG) + (MEDIT > DSK JPG) (SUPRV > DSK JPG) (COMM > DSK JPG) + (DSKFN > DSK JPG) (CSIMP > DSK PAULW) (MAT > DSK PAULW) + (MATRIX > DSK PAULW) (LESFAC > DSK RAT) (FACTOR > DSK RAT) + (RAT3A > DSK RAT) (RAT3B > DSK RAT) (RAT3C > DSK RAT) + (RAT3D > DSK RAT) (RAT3E > DSK RAT) (NRAT4 > DSK RAT) + (OPERS > DSK MAXSRC) (UTILS > DSK MAXSRC) + (MUTILS > DSK MAXSRC) (MLOAD > DSK MAXSRC) + (SIMP > DSK JM) (RUNTIM > DSK MAXSRC) (INMIS > DSK MAXSRC) + (ASUM > DSK RZ) (SPGCD > DSK RAT) (ERMSGM > DSK MAXSRC) + (MERROR > DSK MAXSRC) (MFORMT > DSK MAXSRC))) + 'FILES1) + +; The following files are not part of the core system +(PROG2 + (SETQ FILES2 ; FASL file to MACSYM; , UNFASL file to MUNFAS; + '(;(TRANSL > DSK TRANSL) (TRANS1 > DSK TRANSL) +; GJC's files no longer automatically compiled at the request of GJC. - JPG +; (TRMODE > DSK TRANSL) (TRANS4 > DSK TRANSL) +; (TRANS3 > DSK TRANSL) +; (TRDATA > DSK TRANSL) (FCALL > DSK TRANSL) +; (TRANS2 > DSK TRANSL) (ACALL > DSK TRANSL) +; (EVALW > DSK TRANSL) (UPDATE > DSK TRANSL) + (FORTRA > DSK MRG) (OPTION > DSK ELLEN) (PRIMER > DSK ELLEN) + (LDISP > DSK MAXSRC) + (SCS > DSK MRG) (OPTIM > DSK MRG) (SININT > DSK JM) + (SIN > DSK JM) (RISCH > DSK JM) (ZERO > DSK JM) + (MATCOM > DSK RAT) (MATRUN > DSK RAT) + (POIS2 > DSK RAT) (POIS3 > DSK RAT) + (RATPOI > DSK RAT) (FLOAT > DSK RAT) (SOLVE > DSK RAT) + (MDOT > DSK MAXSRC) + (ARDS > DSK MAXSRC) (H19 > DSK MAXSRC) (VT100 > DSK MAXSRC) + (TLIMIT > DSK JIM) (LIMIT > DSK JIM) + (ASKP > DSK JIM) (DEFINT > DSK PAULW) (RESIDU > DSK PAULW) + (SPRDET > DSK PAULW) (ALGFAC > DSK PAULW) (IRINTE > DSK MAXSRC) + (NEWINV > DSK PAULW) (LINNEW > DSK PAULW) (EZGCD > DSK RAT) + (EEZ > DSK PAULW) (NEWFAC > DSK PAULW) (HOMOG > DSK RAT) + (UFACT > DSK RAT) (RPART > DSK MACRAK) (LOGARC > DSK MACRAK) + (SERIES > DSK RZ) (NUMTH > DSK RZ) (HAYAT > DSK RAT) + (SCHATC > DSK RZ) (TRGRED > DSK RZ) (NEWDET > DSK RAT) + (POLYRZ > DSK RAT) (ALGSYS > DSK RAT) (NISIMP > DSK RAT) + (NALGFA > DSK RAT) (LAPLAC > DSK MAXSRC) (CPOLY > DSK CFFK) + (PADE > DSK RAT) (SUMCON > DSK MAXSRC) (SYNEX > DSK MAXSRC) + (SUBLIS > DSK MAXSRC) (MMACRO > DSK REH) (BUILDQ > DSK REH) + (RESET > DSK ALJABR))) + 'FILES2) + +; The following are out-of-core "SPLITFILES" +(PROG2 + (SETQ FILES3 ; FASL file and UNFASL file to MAXOUT; + '((COMM2 > DSK JPG) (CSIMP2 > DSK PAULW) (PLOT > DSK JPG) + (PSOLVE > DSK RAT) (OUTMIS > DSK MAXSRC) (COMBIN > DSK RZ) + (TRIGO > DSK MRG) (RATOUT > DSK RAT) (RESULT > DSK RAT) + (MSTUFF > DSK DAS) (SPECFN > DSK WGD) (DESCRI > DSK MAXSRC))) + 'FILES3 + ;; Note that MSCOMP and MAKLAP1 get interned here while OBARRAY is + ;; bound to SOBARRAY. This seems to be why they can be typed from + ;; the compiler Lisp level. + ((LAMBDA (OBARRAY NM) + (SET (SETQ NM (INTERN NM)) (APPEND '(MSCOMP MAKLAP1) (SYMEVAL NM)))) + SOBARRAY 'SAIL-MORE-SYSFUNS)) + +(DEFUN MSCOMP NIL + ((LAMBDA (MUZZLEDP) + (MSCOMP1 FILES1 T NIL) (MSCOMP1 FILES2 NIL NIL) (MSCOMP1 FILES3 NIL T)) T)) + +(DEFUN MSCOMP1 (FILES COREP SPLITP) + ((LAMBDA (DEFAULTF ODEFAULTF) + (PROG (FILE UNFILE IN OUT EXP EXP1 MACSYMP) + A (COND ((NULL FILES) (RETURN '|All finished|))) + (APPLY 'UREAD (SETQ FILE (CAR FILES))) + (SETQ IN (STATUS UREAD)) + (SETQ OUT (COND ((AND OUT1 (NOT FASLP)) OUT1) + (OUT1 (CONS (CAR OUT1) (CONS 'LAP (CDDR OUT1)))) + (SPLITP (CONS (CAR FILE) '(LAP DSK MAXOUT))) + (COREP (CONS (CAR FILE) '(LAP DSK MAXDMP))) + ((EQ (CAR (LAST IN)) 'LIBMAX) + (CONS (CAR FILE) '(LAP DSK LIBMAX))) + (T (CONS (CAR FILE) '(LAP DSK MACSYM))))) + (SETQ MACSYMP (MEMQ (CADDDR OUT) '(MACSYM MAXDMP))) + (COND ((OR REDOALL + (AND (NULL (PROBEF (SETQ UNFILE + (CONS (CAR OUT) + (CONS 'UNFASL (CDDR OUT)))))) + (OR (NOT MACSYMP) + (NULL (PROBEF (SETQ UNFILE + (CONS (CAR OUT) + '(UNFASL DSK MUNFAS)))))))) + (GO B))) + (APPLY 'UREAD UNFILE) + (SETQ ^Q T) + (SETQ EXP (CADR (READ)) EXP1 (PROG2 (READ) (CADR (READ)))) + (COND ((EQ (CAR EXP1) 'THIS) (SETQ EXP EXP1))) + (SETQ EXP (CAR (LAST EXP))) + (SETQ ^Q NIL) + (COND ((EQ (CADR IN) (COND ((ATOM (CAR EXP)) (CADR EXP)) (T (CADDR EXP)))) + (PRINT (CONS IN '(WAS ALREADY COMPILED AND ASSEMBLED))) + (GO C))) + B ;(INITIALIZE) + ;; This is needed to make calls to FORMAT work at compile time. + ;; They are necessary because the obarrays are reset. + (SSTATUS UUOLINKS) +; (REMPROP 'FORMAT 'LSUBR) +; (REMPROP 'FORMAT 'VERSION) +; (LOAD "LIBLSP;LOOP") + ;; Figure out some better way of initializing the (STATUS FEATURES) + ;; list to its initial state. (INITIALIZE) should actually be doing + ;; this. This simply flushes all entries beginning with LIBMAX from + ;; the list. Note that (SSTATUS NOFEATURE LIBMAX-MACROS) explicitly + ;; doesn't work because of obarray problems. + (SSTATUS-FEATURE-MACSYMA-COMPLR) + (DO ((L (STATUS FEATURES) (CDR L)) + (FEATURE) (X)) + ((NULL L)) + (SETQ FEATURE (CAR L)) + (SETQ X (EXPLODEN FEATURE)) + (COND ((> (LENGTH X) 5) (RPLACD (CDR (CDDDDR X)) NIL))) + (SETQ X (MAKNAM X)) + (COND ((SAMEPNAMEP X 'LIBMAX) + (APPLY 'SSTATUS (LIST 'NOFEATURE FEATURE)))) + (COND ((SAMEPNAMEP X 'IOTA) + (APPLY 'SSTATUS (LIST 'NOFEATURE FEATURE))))) + (SETQ DEFAULTF ODEFAULTF) + (SETQ MAPEX NIL BARFP T DATAERRP T LISPERRP T TTYNOTES T + YESWARNTTY T MUZZLED T ARRAYOPEN T IBASE 10. BASE 10. + *NOPOINT NIL USE-STRT7 T DEFMACRO-FOR-COMPILING NIL + MESSAGES-INITIALIZED NIL + DEFMACRO-DISPLACE-CALL NIL) + (COND (FASLP (SETQ FASL T UNFASLCOMMENTS T NOLAP T + OUT (OR OUT1 (CONS (CAR OUT) (CONS 'FASL (CDDR OUT))))) + (COND (MACSYMP (SETQ MSDIR MMSDIR))))) + (COND ((NULL TTYNOTESP) (SETQ TTYNOTES NIL))) + (COND ((NULL YESWARNTTYP) (SETQ YESWARNTTY NIL))) + (COND ((NULL UNFASLCOMMENTSP) (SETQ UNFASLCOMMENTS NIL))) + (COND ((NULL NOLAPP) (SETQ NOLAP NIL))) + (COND ((NULL MUZZLEDP) (SETQ MUZZLED NIL))) + (COND (MAPEXP (SETQ MAPEX T))) + (PRINT (CONS IN '(COMPILATION BEGUN))) + (COND (FILEONE (BREAK FILE-ONE-DONE T))) + (APPLY 'MAKLAP (LIST OUT IN)) + (PRINT (CONS IN '(COMPILATION ENDED))) + (SETQ FILEONE T) + C (SETQ FILES (CDR FILES)) + (GO A))) + DEFAULTF DEFAULTF)) + +(DEFUN MAKLAP1 FEXPR (L) + (PROG (OUT1) + (COND ((CDR L) (COND ((CDDR L) (PRINC '/ +MAKLAP1/ TAKES/ ONLY/ 1/ OR/ 2/ ARGS/.) (ERR))) + (APPLY 'CRUNIT (CDDAR L)) + (SETQ OUT1 (CAR L) L (CDR L)) (ARGCHK OUT1)) + (T (ARGCHK (CAR L)))) + (RETURN (MSCOMP1 L (ASSQ (CAAR L) FILES1) (ASSQ (CAAR L) FILES3))))) + +(DEFUN MCOMPILE FEXPR (L) + (LET ((TTYNOTESP NIL) (MUZZLEDP T)) (APPLY 'MAKLAP1 L))) + +(DEFUN ARGCHK (L) + (COND ((NOT (= (LENGTH L) 4)) (PRINT L) (PRINC '/ +ARG/ TO/ MAKLAP1/ MUST/ BE/ OF/ LENGTH/ 4) (ERR)))) diff --git a/src/aljabr/loader.262 b/src/aljabr/loader.262 new file mode 100644 index 00000000..7f189ccd --- /dev/null +++ b/src/aljabr/loader.262 @@ -0,0 +1,348 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1982 Massachusetts Institute of Technology ** + +; Do "ALJABR^S L^K"; the  (escape) is for loading in LISP symbols. + +; "ALJABR;* LISP" which allocates pdls is automatically loaded in. +; Current contents of that file are: + (COMMENT CORE 130. REGPDL 2750. FLPDL 400. FXPDL 1500. SPECPDL 1750.) + +; Load in "ALJABR;LOADER >". +; Now, all you need do is type "(LOADER version#)" (where version# is an +; integer) and hope for no bugs. When you are through, you must kill +; the job yourself. (LISP;LOCK > may need to be updated as to LISP +; version used.) + +; The End + +; All FASL files loaded here were created from compiled LISP files using +; ALJABR; COMPLR > , except for RATLAP whose source is RAT;RATLAP > . + +;; The code in this file is run only once when a new Macsyma is created. +;; For this reason, it is interpreted and not compiled so that the code +;; can be gc'ed when no longer needed. + +(PROG2 + (SETQ FILES '(ERMSGM ;ERMSGM *MUST* be the first file loaded, since + ;out-of-core-strings generate SQUIDs that refer to it. + MERROR MFORMT MUTILS UTILS + GRAM DISPLA NFORMA MLISP COMM SUPRV MLOAD SIMP OPERS RATLAP + FACTOR RAT3A RAT3B RAT3D RAT3E RAT3C LESFAC SPGCD + INMIS DB COMPAR NRAT4 MATRIX MAT CSIMP + TRIGI ASUM RUNTIM MEDIT DSKFN GRIND)) + 'FILES) + +(SETQ BASE 10. IBASE 10. *NOPOINT T) + +(SETQ MUNFAS T) ; Set to NIL if you don't want the UNFASL read. +(SETQ MAXDMP T) ; Set to NIL if you don't want "Being Loaded" to print. + +(DEFUN STRING-FILE-NAME (FILE) + (COND ((AND INCORE-FILES (NOT (ASSOC FILE INCORE-FILES))) + (PRINC '| +;Out-of-core string file /"|) + (PRINC (NAMESTRING FILE)) + (COND ((PROBEF FILE) + (PRINC '|/" +;has not been merged into /"|) + (PRINC (NAMESTRING INCORE-MESSAGE-FILE)) + (PRINC '|/" +|)) (T (PRINC '|/" is ** MISSING ** +|) (BREAK |MISSING STRING FILE|))))) + ()) + +(DEFUN LOADER (VERSION) + (SETQ $VERSION VERSION SAVENOHACK (READLIST (NCONC (EXPLODEN $VERSION) '(/0)))) + (NOUUO T) + (SETQ *PURE T) + (ALLOC '(LIST (4096. 30000. .1) FIXNUM (512. 9000. .1) + FLONUM (64. 3000. .1) BIGNUM (64. 3000. .1) + SYMBOL (4096. 7200. .05) ARRAY (64. 400. 50.))) + (SETQ PUTPROP '(SUBR FSUBR LSUBR ALPHABET NUMBER GRAD DISSYM OP OPR + RECIP $INVERSE ALIAS REVERSEALIAS NOUN VERB MFEXPR* + NUD LED LBP RBP EVFLAG OPALIAS OP2C DIMENSION AUTOLOAD + OPERATORS EVFUN GRIND LDP RDP MSIMPIND ASSIGN EVOK + $OUTATIVE STRSYM SPECSIMP SYSCONST BINARY MFEXPR*S)) + ;; set up information for shared out-of-core message file + ((LAMBDA (FILE POS) + (SETQ POS (IN FILE)) + (OPEN FILE '(IN ASCII)) + (FILEPOS FILE (* POS 5)) + (SETQ INCORE-FILES (CDR (ASSQ 'FILES (CDR (READ FILE)))))) + (SETQ INCORE-MESSAGE-FILE + (OPEN '((DSK MAXDMP) INCORE >) '(IN FIXNUM))) + () ) + (SETQ INCORE-MESSAGE-FILE (TRUENAME INCORE-MESSAGE-FILE)) + (UWRITE DSK MAXDMP) (SETQ ^R T) + (PRINT '|LISPV: |) + (PRIN1 (STATUS LISPV)) + (PRINT '|Message file: |) + (PRIN1 (NAMESTRING INCORE-MESSAGE-FILE)) (TERPRI) + (PROG NIL A (COND ((NULL FILES) (RETURN NIL)) + (T (READLOOP (CAR FILES)) (SETQ FILES (CDR FILES)) (GO A)))) + (FASLOAD SORT FASL DSK LISP) + ;; Load initializations generated by MDEFVAR. + (LOAD '|MAXDOC;INIT RESET|) + (LOAD '|MAXDOC;INIT NORESE|) + (TOPL) (NOUUO NIL) (NORET NIL) + (SETQ IBASE 10. *NOPOINT T) + ((LAMBDA (MSGFILES ^D) (GC)) (CONS UWRITE MSGFILES) T) + (PURIFY 0 0 'BPORG) + (SETQ PURE NIL FASLOAD NIL *PURE NIL) + (ALLOC '(LIST (16000. 30000. .3) FIXNUM (5000. 9000. .3) + FLONUM (1600. 3000. .3) BIGNUM (1600. 3000. .3) + SYMBOL (6200. 7200. .1) ARRAY (150. 400. 50.))) + (setq INCORE-FILES ()) + (MAPC 'MAKUNBOUND '(INCORE-MESSAGE-FILE + MAXDMP MUNFAS)) + (REMPROP 'STRING-FILE-NAME 'EXPR) ;Leaves NO-OP SUBR definition + (PRINT 'STATUS/ MEMFREE/:/ ) (PRINC (STATUS MEMFREE)) (TERPRI) + (AND (GETL 'PURE-SUSPEND '(SUBR LSUBR EXPR)) + (PRINT 'PURE-SUSPEND)) + (UFILE MSLOCS > DSK MAXDMP) + (SSTATUS WHO1 42. '% 118. 0) + (SSTATUS GCWHO 3) + (*RSET NIL) + (NOINTERRUPT 'TTY) + (SSTATUS FLUSH T) + (GC) + (COND ((GETL 'PURE-SUSPEND '(SUBR LSUBR EXPR)) + (PURE-SUSPEND () '|DSK:MAXDMP;LOSER >|)) + (T + (SUSPEND () '|DSK:MAXDMP;LOSER >|)))) + +(DEFUN READLOOP (FILE) + (PROG (B ^W ^Q) + (SETQ B 'LAP) + FILE (COND ((PROBEF (CONS FILE '(FASL DSK MAXDMP))) + (AND MAXDMP + (PRINT (CONS FILE '(FASL DSK MAXDMP LOADING BEGUN)))) + (COND ((NULL (ERRSET (EVAL (LIST 'FASLOAD FILE 'FASL 'DSK 'MAXDMP)))) + (BREAK |error in FASL file| T) + ((LAMBDA (^Q ^R ^W) (PRINC '|/ +Where do we go from here?/ +|) (EVAL (READ))) + NIL NIL NIL))) + (AND MAXDMP + (PRINT (CONS FILE '(FASL DSK MAXDMP LOADED)))) + (COND ((AND MUNFAS + (ERRSET (EVAL (LIST 'UREAD FILE 'UNFASL 'DSK 'MUNFAS)))) + (AND MAXDMP + (PRINT (CONS FILE '(UNFASL DSK MUNFAS LOADING BEGUN)))) + (SETQ ^W T B 'UNFASL) (GO C)) + (T (RETURN NIL)))) + ((NULL (ERRSET (EVAL (LIST 'UREAD FILE B 'DSK 'MAXDMP)) NIL)) + (PROG (^W) (PRINT (CONS FILE '(FASL NOT FOUND))) + (PRINT (LIST 'PLEASE 'COMPILE FILE '>)) + (PRINT '(THEN TYPE $P TO CONTINUE))) + (BREAK WAITING T) (GO FILE)) + (T (AND MAXDMP + (PRINT (LIST FILE B 'DSK 'MAXDMP 'LOADING 'BEGUN))))) + C (SETQ ^Q T) + CONT (COND ((NULL (ERRSET + (PROG (EXPR *EOF X Y) + (SETQ *EOF (LIST NIL)) + LOOP (COND ((EQ *EOF (SETQ EXPR (READ *EOF))) (RETURN NIL)) + ((EQ B 'UNFASL) + (COND ((AND (EQ (CAR EXPR) 'COMMENT) + (EQ (CADR EXPR) '**FASL**) + (NUMBERP (CADDR EXPR)) + (NOT (ATOM (CADDDR EXPR))) + (SETQ X (GETL (SETQ Y (CADR (CADDDR EXPR))) + '(SUBR FSUBR LSUBR)))) + (SETQ EXPR + (NCONS (LIST Y (CAR X) + (MAKNUM (CADR X)))))) + ((AND (EQ (CAR EXPR) 'QUOTE) + (NOT (ATOM (CADR EXPR))) + (MEMQ (CAADR EXPR) + '(THIS COMPILED ASSEMBLED))) + (SETQ EXPR (CADR EXPR))) + (T (GO LOOP)))) + (T (SETQ EXPR (EVAL EXPR)))) + ((LAMBDA (BASE) (PRINT EXPR)) 8.) + (GO LOOP)))) + (BREAK |error in file| T) + ((LAMBDA (^Q ^R ^W) (PRINC '|/ +Where do we go from here?/ +|) (EVAL (READ))) + NIL NIL NIL)) + (T (SETQ ^W NIL) + (RETURN (AND MAXDMP + (PRINT (LIST FILE B 'DSK + (COND ((EQ B 'UNFASL) 'MUNFAS) (T 'MAXDMP)) + 'LOADED)))))))) + +(DEFUN TOPL NIL + (GCTWA) + (SSTATUS + TOPLE + '(PROGN + (TOPL-FUN) + (SSTATUS TOPLE NIL) (REMPROP 'TOPL-FUN 'EXPR) + (GCTWA) (NOINTERRUPT NIL) + (COND ((EQ (GETCHAR (STATUS JNAME) 1) 'T) (MEVAL '(($PRIMER))))) + (CONTINUE))) + (MAKUNBOUND 'FILES) + (REMPROP 'READLOOP 'EXPR) (REMPROP 'LOADER 'EXPR) + (REMPROP 'LAPTEMPS 'FEXPR) (REMPROP 'LAPCHECK 'EXPR) + (REMPROP 'TOPL 'EXPR)) + +(DEFUN JOB-EXISTS (JNAME) (PROBEF (LIST '(USR *) (STATUS UNAME) JNAME))) + +(DEFUN TOPL-FUN NIL + (PROG (USER USRNAM X JCL I DEFAULTF*) + (SSTATUS TOPLE '(PROG2 (PRINC '| +THIS MACSYMA IS NO GOOD!|) (VALRET '|:KILL +|))) (SETQ USER (LIST 'DSK (STATUS UDIR)) USRNAM (STATUS USERID)) + (SSTATUS FEATURE MACSYMA) + (MTERPRI) + (PRINC '|This is MACSYMA |) + (PRINC $VERSION) (MTERPRI) + (COND ((AND (= (GETCHARN USRNAM 1) 95.) (= (GETCHARN USRNAM 2) 95.) + (= (GETCHARN USRNAM 3) 95.)) ; test for underscore + (PRINC 'PLEASE/ LOG/ IN/!) ($QUIT))) + ;; octal: 232020222022 232222220233 + (SSTATUS TTY 20673799186. 20707877019.) + (SYSCALL 0 'TTYSET TYO + (CAR (STATUS TTY)) (CADR (STATUS TTY)) + (BOOLE 7 1_34. (CADDR (STATUS TTY)))) ; fixes ^L lossage + ; bit 4.8 (%TSCLE) of TTYSTS + (SETQ $PAGEPAUSE (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_25.))) + ; bit 3.8 (%TSMOR) of TTYSTS + ;; (LINEL T) is (1- (CDR (STATUS TTYSIZE))) + (SETQ $LINEL (SETQ LINEL (LINEL T))) + (SETQ SCROLLP (NOT (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_30.)))) + ;; Load the fix file, if one exists. + ;; If :MACSYMA is being run, load MACSYM;FIXnnn > where nnn + ;; is the version number. If :NMACSYMA is being run, load NFXnnn >. + (SETQ X (CONS (MAKNAM (APPEND (COND ((EQ (GETCHAR (STATUS JNAME) 1) 'N) + '(N F X)) + (T '(F I X))) + (EXPLODEN $VERSION))) + '(> DSK MACSYM))) + (COND ((PROBEF X) + (COND ((NULL (ERRSET (LOADFILE X NIL T))) + (TERPRI) (PRINC '|Bad FIX file!|) (ERR))))) + ;; If :DMACSYMA (Debug Macsyma) is being run, then also load the + ;; compile time environment. (LIBMAX;PRELUD >) + ;; This should be made to turn on $DEBUGMODE as well. + (COND ((AND (EQ (GETCHAR (STATUS JNAME) 1) 'D) + (NULL (ERRSET (LOAD '|LIBMAX;PRELUD >|)))) + (TERPRI) (PRINC '|Bad prelude file!|))) + (COND ((NULL (SETQ X (STATUS JCL)))) + ((NULL (CDR X)) (SETQ JCL 'NO)) + ((MEMQ '/; X) + (SETQ X (NREVERSE (CDR (MEMQ '/; (REVERSE X))))) + (COND ((NULL (SETQ JCL (ERRSET (READLIST X) NIL))) + (SETQ JCL (NCONS (IMPLODE X)))))) + ((PROG2 (SETQ JCL (COND ((NULL (SETQ JCL (ERRSET (READLIST X) NIL))) + (IMPLODE X)) + (T (CAR JCL)))) + (EQ JCL 'NEWUSER)) ; sets up super-image mode + (SYSCALL 0 'TTYSET TYO + (CAR (STATUS TTY)) (CADR (STATUS TTY)) + (BOOLE 7 1_19. (CADDR (STATUS TTY)))) + ;; bit 3.2 (%TSSII) of TTYSTS + (SSTATUS TTYINT 26. NIL) + (REMPROP '$QUIT 'SUBR) (SETQ JCL NIL)) + (T (SETQ JCL (CONS JCL T)))) + (SETQ TTYHEIGHT (CAR (STATUS TTYSIZE)) + $PLOTHEIGHT (COND ((< TTYHEIGHT 200.) (- TTYHEIGHT 2)) (T 24.)) + $DIREC (CADR USER) $FILENAME (EXPLODEN USRNAM) I 1) + (COND ((> (LENGTH $FILENAME) 3) (RPLACD (CDDR $FILENAME) NIL))) + LOOP (SETQ X (IMPLODE (APPEND $FILENAME (EXPLODEN I)))) + (COND ((PROBEF (LIST X '> 'DNRF $DIREC)) (SETQ I (1+ I)) (GO LOOP))) + (SETQ $FILENAME (MAKEALIAS X) $DIREC (MAKEALIAS $DIREC)) + (SSTATUS GCTIME 0) + (SETQ STIME0 (TIME) ERRLIST '((ERRLFUN NIL))) + (SETQ SAVEFILE (OPEN '((NUL)) '(OUT FIXNUM))) + (CLOSE SAVEFILE) + (PROG (TTYOPT) + (SETQ TTYOPT (CAR (CDDDDR (SYSCALL 6 'CNSGET TYO)))) + ;; %TOFCI (bit 3.4) = terminal has a 12 bit keyboard. + (SETQ 12-BIT-TTY (NOT (= (BOOLE 1 8_18. TTYOPT) 0))) + ;; %TOMVU (bit 3.9) = terminal can do vertical cursor movement. + ;; However, we must also make sure that the screen size + ;; is within the ITS addressing limits. + (SETQ SMART-TTY (AND (NOT (= (BOOLE 1 256._18. TTYOPT) 0)) + (< TTYHEIGHT 200.) + (< LINEL 128.))) + ;; %TOERS (bit 4.6) = terminal can selectively erase. + ;; %TOMVB (bit 4.4) = terminal can backspace. + ;; %TOOVR (bit 4.1) = terminal can overstrike (i.e. printing one + ;; character on top of another causes both to + ;; appear.) + ;; If it can either selectively erase, or backspace and not + ;; overstrike, then we can do rubout processing. An example of + ;; a terminal which can backspace and overstrike, but is not + ;; selectively erasable is a storage tube display. + (SETQ RUBOUT-TTY + (OR (NOT (= (BOOLE 1 32._27. TTYOPT) 0)) ;%TOERS + (AND (NOT (= (BOOLE 1 8._27. TTYOPT) 0)) ;%TOMVB + (= (BOOLE 1 1_27. TTYOPT) 0)))) ;%TOOVR + ;; %TOCID (bit 3.1) = terminal can insert and delete characters. + ;; If the console has a 12-bit keyboard, an 85 by 50 screen, and + ;; can't ins/del characters, then it must be a Plasma console. + (SETQ PLASMA-TTY + (AND 12-BIT-TTY (= LINEL 84.) (= TTYHEIGHT 50.) + (= 0 (BOOLE 1 1_18. TTYOPT)))) + ) + ;; ***** Vestigial. To be flushed someday. ***** + (SETQ CURSORPOS SMART-TTY) + (SETQ $ERROR_SIZE (COND (SMART-TTY 20.) (T 10.))) + ;; Use block mode I/O for efficiency. .SIOT used instead of .IOT. + ;; See DISPLA for how this is used. + (COND (SMART-TTY + (SETQ DISPLAY-FILE (OPEN '|TTY:| '(TTY OUT IMAGE BLOCK))))) + ;; Sail characters to be supported someday. + ;; (COND (12-BIT-TTY + ;; (SETQ 12-BIT-INPUT (OPEN '|TTY:| '(TTY IN FIXNUM))))) + ;; Load graphic support package for the particular terminal type. + ;; Vectors are drawn if possible. Otherwise, an extended character + ;; set is used. No TCTYP entry exists for the VT100, so look for + ;; a CRTSTY instead. + (COND (PLASMA-TTY (LOAD '((MACSYM) ARDS))) + ((OR (= TTY 13.) (JOB-EXISTS 'H19) (JOB-EXISTS 'H19WHO)) + (LOAD '((MACSYM) H19))) + ((JOB-EXISTS 'VT100) + (LOAD '((MACSYM) VT100)))) + (REMPROP 'JOB-EXISTS 'EXPR) + ;; Why is this necessary? Lisp sets it up to be '(T) by default. + (SETQ MSGFILES (LIST TYO)) + (SETQ TTY-RETURN 'TTYRETFUN) + (SETQ DEFAULTF (OR DEFAULTF* (CONS USER '(NOFILE >)))) + (COND ((EQ JCL 'NO)) + ((AND JCL (NULL (CDR JCL))) + (COND ((OR (PROBEF (SETQ X (LIST (CAR JCL) 'MACSYM 'DSK (CAR JCL)))) + (PROBEF (SETQ X (CONS '|.ALL.| (CDR X))))) + (ERRSET (LOAD-FILE X))))) + (JCL + (COND ((OR (PROBEF (SETQ X (LIST (CAR JCL) 'MACSYM 'DSK + (STATUS HSNAME (CAR JCL))))) + (PROBEF (SETQ X (CONS '|.ALL.| (CDR X))))) + (ERRSET (LOAD-FILE X))))) + ((OR (PROBEF (SETQ X (LIST (STATUS XUNAME) 'MACSYM 'DSK (STATUS HSNAME)))) + (PROBEF (SETQ X (CONS '|.ALL.| (CDR X))))) + (ERRSET (LOAD-FILE X)))) + (SETQ DEFAULTF (OR DEFAULTF* (CONS USER '(NOFILE >)))) + (COND ((GETL 'FIXUP '(SUBR EXPR)) (FIXUP) (REMPROP 'FIXUP 'EXPR))))) + +(DEFUN LAPTEMPS FEXPR (L) + ((LAMBDA (I) (LAPCHECK (LENGTH L)) + (DO Z L (CDR Z) (NULL Z) (DEFSYM (CAR Z) I) (SETQ I (1+ I)))) + VORG)) + +(DEFUN LAPCHECK (N) + (COND ((SIGNP LE (SETQ VLNTH (- VLNTH N))) + (TERPRI) (PRINC 'IMPURE/ AREA/ IS/ TOO/ SMALL) (ERR))) + (SETQ VORG (+ VORG N))) + +(PROGN (NORET T) ; GC shouldn't return core. +; (SSTATUS LOSEF 10.) ; LAP Object Storage Efficiency Factor + (SETQ VORG BPORG) + (GETSP 8.) + (SETQ BPORG (+ BPORG 8.) VLNTH (- BPORG VORG)) + (DEFPROP MACSYMA-MODULE MACSYMA-MODULE-MACRO MACRO) + (DEFPROP MACSYMA-MODULE-MACRO "DSK:LIBMAX;MODULE" AUTOLOAD)) diff --git a/src/aljabr/reset.34 b/src/aljabr/reset.34 new file mode 100644 index 00000000..ba95a148 --- /dev/null +++ b/src/aljabr/reset.34 @@ -0,0 +1,16 @@ + + +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module reset) + +;;;RESETs flags to their initial values. +;See ALJABR;GENRST > for instructions for constructing this file. + +(SETQ IBASE 10. BASE 10. *RSET NIL NOUUO NIL MODULUS NIL ZUNDERFLOW T) +(SETQ $BERLEFACT T $RATSIMPEXPONS NIL $PARSEWINDOW 10. $LISPDISP NIL $NEGDISTRIB T $EXPONENTIALIZE NIL $CAUCHYSUM NIL $HOMOG_HACK NIL $RATPRINT T $INTANALYSIS T $PROGRAMMODE T $TRIGEXPANDTIMES T $INTFACLIM 1000. $NEGSUMDISPFLAG T $PREDERROR T $PSEXPAND NIL $SUMHACK NIL $PACKAGEFILE NIL $VECT_CROSS NIL $DOMAIN '$REAL $LASTTIME '((MLIST) 0. 0.) $GRINDSWITCH NIL $TRIGEXPANDPLUS T $MAXNEGEX 1000. $OPTIONSET NIL $PLOTHEIGHT 22. $NALGFAC T $NUMER_PBRANCH NIL $RATFAC NIL $LINSOLVE_PARAMS T $TRANSRUN T $TLIMSWITCH NIL $DOMXPLUS NIL $SUPERLOGCON T $PRODHACK NIL $RADSUBSTFLAG NIL $SOLVEFACTORS T $LEFTJUST NIL $SIGNBFLOAT T $DISPLAY_FORMAT_INTERNAL NIL $SAVEFACTORS NIL $FORTINDENT 0. $BATCOUNT 0. $NEWFAC NIL $TAYLORDEPTH 3. $ASSUME_POS NIL $RMXCHAR '&] $SAVEDEF T $BFTORAT NIL $%RNUM 0. $DISPLAY2D T $DOMXTIMES NIL $RATEPSILON 2.0E-8 $PARSETIME NIL $ROOTSEPSILON 1.0E-7 $SOLVENULLWARN T $FALSE NIL $LOGABS NIL $LMXCHAR '&[ $CFLENGTH 1. $SUBNUMSIMP NIL $INTEGRATION_CONSTANT_COUNTER 0. $LINEDISP T $FACTORFLAG NIL $ALGDELTA 1.0E-5 $BACKTRACE '$BACKTRACE $LIMSUBST NIL $LIMITDOMAIN '$COMPLEX $MATRIX_ELEMENT_ADD '&+ $MAXPRIME 489318. $RATVARSWITCH T $DEBUGMODE NIL $HALFANGLES NIL $SUBSCRMAP NIL $LISTARITH T $NOINTEGRATE NIL $FORTSPACES NIL $NOLABELS NIL $MOREWAIT NIL $TAYLOR_SIMPLIFIER 'SIMPLIFY $NOUNDISP NIL $DSKALL T $%EMODE T $STARDISP NIL $MAXTAYORDER T $DSKUSE NIL $INCHAR '$C $MAPPRINT T $PIECE '$PIECE $ALGEPSILON 100000000. $%PIARGS T $DSKGC NIL $FPPRINTPREC 0. $DERIVSUBST NIL $TTYINTFUN NIL $DISPTIME NIL $STORENUM 1000. $LOGARC NIL $REFCHECK NIL $SUMEXPAND NIL $ABCONVTEST NIL $RATWTLVL NIL $FLOAT2BF NIL $POINTBOUND 34359738337. $LOGNUMER NIL $ZEROBERN T $MATRIX_ELEMENT_MULT '&* $GCD '$SPMOD $TRIGEXPAND NIL $ERROR_SIZE 20. $TAYLOR_TRUNCATE_POLYNOMIALS T $BOXCHAR '&/" $MAPERROR T $SUMSPLITFACT T $SOLVEEXPLICIT NIL $MULTIPLICITIES '$NOT_SET_YET $SIMP T $SQRTDISPFLAG T $ABSBOXCHAR '&! $NUMER NIL $DEVICE '$DSK $DOSCMXPLUS NIL $SETVAL '$SETVAL $PARTSWITCH NIL $WTLEVEL NIL $GLOBALSOLVE NIL $M1PBRANCH NIL $MATRIX_ELEMENT_TRANSPOSE NIL $INFEVAL NIL $STRDISP T $FACTLIM -1. $LISTCONSTVARS NIL $SOLVE_INCONSISTENT_ERROR T $LOGSIMP T $BREAKUP T $TRANSLATE NIL $DEMOIVRE NIL $MAXPOSEX 1000. $%E_TO_NUMLOG NIL $OFF NIL $TAYLOR_LOGEXPAND NIL $LISTDUMMYVARS T $LINSOLVEWARN T $SOLVERADCAN NIL $FILESIZE 16. $CHANGE_FILEDEFAULTS T $ON T $SPARSE NIL $POLYFACTOR NIL $SIMPSUM NIL $OUTCHAR '$D $%IARGS T $EXPOP 0. $LOGNEGINT NIL $%EDISPFLAG NIL $TRIGINVERSES '$ALL $GAMMALIM 1000000. $FLOAT NIL $DETOUT NIL $EXPON 0. $CONTEXT '$INITIAL $POWERDISP NIL $DOMXEXPT T $RATDENOMDIVIDE T $INFLAG NIL $PFEFORMAT NIL $EXPTDISPFLAG T $ROOTSCONMODE T $VERBOSE NIL $ASSUME_POS_PRED NIL $SOLVEDECOMPOSES T $BFTRUNC T $NOREPEAT T $MYOPTIONS '((MLIST SIMP)) $FILENUM 0. $RATALGDENOM T $KEEPFLOAT NIL $TRIGSIGN T $GENINDEX '$I $LINECHAR '$E $ERRORFUN NIL $MX0SIMP T $GENSUMNUM 0. $EXPTSUBST NIL $LOADPRINT T $FACEXPAND T $DYNAMALLOC NIL $BACKSUBST T $ZETA%PI T $SOLVETRIGWARN T $ERRORMSG T $GRIND NIL $%ENUMER NIL $TTYINTNUM 21. $LOGEXPAND T $MAXTAYDIFF 4. $LHOSPITALLIM 4. $OPSUBST T $SETCHECK NIL $SETCHECKBREAK NIL $RATEXPAND NIL $RATMX NIL $ALGEBRAIC NIL $TAYLOR_ORDER_COEFFICIENTS T $RADEXPAND T $FILE_STRING_PRINT NIL $TRUE T $RESULTANT '$SUBRES $LOGCONCOEFFP NIL $DERIVABBREV NIL $RATWEIGHTS '((MLIST SIMP)) ) +($DEBUGMODE NIL) +($DSKGC NIL) +(COND ((NOT (= $FPPREC 16.)) ($FPPREC 16.) (SETQ $FPPREC 16.))) \ No newline at end of file diff --git a/src/cffk/cpoly.64 b/src/cffk/cpoly.64 new file mode 100644 index 00000000..5e8a84ac --- /dev/null +++ b/src/cffk/cpoly.64 @@ -0,0 +1,901 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module cpoly) + +;;;This is a lisp version of algorithm 419 from the Communications of +;;;the ACM (p 97 vol 15 feb 1972) by Jenkins and Traub. +;;;That algorithm is followed very closely. +;;;Note the following modifications: arrays are indexed from 0 instead +;;;of 1. This means that the variables n and nn are one less than the +;;;acm verson. The zeros are put into the arrays pr\ and pi\, rather than +;;;into their own arrays. The algorithm seems to benefit be taking are +;;;mre 0.01 times the published values. + +(declare + (*expr displa $listofvars meqhk displine) + (special logbas infin smalno are mre cr ci sr si tr ti zr zi n nn bool conv pvr + pvi $partswitch $keepfloat $demoivre $listconstvars $algebraic acp\ + $polyfactor polysc polysc1 $ratfac $programmode) + (flonum logbas infin smalno are mre cr ci sr si tr ti zr zi xx yy cosr sinr bnd + xni t1 t2 otr oti svsr svsi pvr pvi mp ms omp relstp tp hvr hvi e ar + ai br bi x xm f dx df r1 $t hi lo max min acp\) + (fixnum degree n nn j l l1 l2 l3 cnt1 cnt2 jj polysc polysc1)) + +(declare (notype ($cpoly notype) (noshft\ fixnum) (fxshft\ fixnum) + (vrshft\ fixnum) (calct\) (nexth\) (polyev\) + (cdivid\ flonum flonum flonum flonum) (scale\)) + (flonum (errev\ flonum flonum) (cauchy\) (cmod\ flonum flonum)) + (fixnum (cpoly\ fixnum)) + #-PDP10(flonum (*f flonum flonum) (//f flonum flonum) (_f flonum fixnum)) + #-PDP10(*expr *f //f _f) + (*lexpr $rat error)) + +;; The Lisp Machine needs some way of declaring "functional" arrays. +;; It warns about these symbols being referenced as functions but not defined. + +(declare + (array* (flonum pr\ 1. pi\ 1. shr\ 1. shi\ 1. qpr\ 1. qpi\ 1. hr\ 1. hi\ + 1. qhr\ 1. qhi\ 1.))) + +;; Fixed for Twenex systems? + +#+PDP10 +(and (not (get '*f 'subr)) + (mapc '(lambda (x) (putprop x '(arith fasl dsk macsym) 'autoload)) + '(*f //f +f -f _f))) + +;;; It is harder to underflow on lisp machine, but I suppose someday -BEE + +#-PDP10 +(progn 'compile + (defmacro *f (a b) `(*$ ,a ,b)) + (defmacro //f (a b) `(//$ ,a ,b)) + (defmacro +f (a b) `(+$ ,a ,b)) + (defmacro -f (a b) `(-$ ,a ,b)) +#+Multics(defmacro _f (a b) `(fsc ,a ,b)) + ) + +(defmacro cpoly-large-flonum () + #-LISPM '(fsc (lsh -1 -1) 0.) + #+LISPM (let ((a (float 0))) + (%p-dpb -1 1013 a) (%p-dpb -1 0007 a) + (%p-dpb-offset -1 0030 a 1) a)) + +(defmacro cpoly-small-flonum () + #-LISPM '(fsc (rot 1. -10.) 0.) + #+LISPM (%p-dpb 100 0007 (float 0))) + +(defmacro float-precision (pres) + pres ;Ignored on Lisp Machine + #-LISPM `(*$ (fsc (lsh 205. 26.) 0.) ,pres) + #+LISPM (let ((a (float 1))) + (%p-dpb-offset 1 0001 a 1) (- a 1.0))) + +;; #+Franz +;; (defun _f (number scale) somebody-write-this) + +#+LISPM +(defun _f (number scale) + (let ((ans (+ 0.0 number)) + (exp)) + (setq exp (+ scale (%p-ldb 1013 ans))) + (cond ((zerop number) 0.0) + ((> exp 3777) (ferror nil "_F Overflow -- see MC:CFFK;CPOLY")) + ;; Should check zunderflow + ((< exp 0) (ferror nil "_F Underflow -- see MC:CFFK;CPOLY")) + (t (%p-dpb exp 1013 ans) ans)))) + +(setq acp\ 0.2) + +(DEFMFUN $allroots (expr) + (prog (degree nn var res $partswitch $keepfloat $demoivre $listconstvars + $algebraic complex $ratfac den) + (setq $keepfloat t $listconstvars t $algebraic t) + (setq expr (meqhk expr) var (delq '$%i (cdr ($listofvars expr)))) + (or var (setq var (list (gensym)))) + (cond ((not (= (length var) 1.)) + (merror "polynomial not univariate: ~M" var)) + ((setq var (car var)))) + (setq expr ($rat expr '$%i var) + res (reverse (car (cdddar expr)))) + (do ((i (- (length res) (length (caddar expr))) (1- i))) + ((= i 0.)) + (setq res (cdr res))) + (setq den (cddr expr) expr (cadr expr)) + ;;;check denominator is a complex number + (cond ((numberp den) (setq den (list den 0))) + ((eq (car den) (cadr res)) + (setq den (cddr den)) + (cond ((numberp (car den)) + (cond ((null (cddr den)) (setq den (list 0 (car den)))) + ((numberp (caddr den)) + (setq den (list (caddr den) (car den)))) + (t (error '|not a polynomial|)))) + (t (error '|not a polynomial|)))) + (t (error '|not a polynomial|))) + ;;;if the name variable has disappeared, this is caught here + (setq nn 0) + (cond ((numberp expr) (setq expr (list expr 0))) + ((eq (car expr) (car res)) (setq nn 1)) + ((eq (car expr) (cadr res)) + (setq expr (cddr expr)) + (cond ((numberp (car expr)) + (cond ((null (cddr expr)) (setq expr (list 0 (car expr)))) + ((numberp (caddr expr)) + (setq expr (list (caddr expr) (car expr)))) + (t (error '|not a polynomial|)))) + (t (error '|not a polynomial|)))) + (t (error '|not a polynomial|))) + (cond ((= nn 0) + (cond ($polyfactor + ((lambda (cr ci) + (cdivid\ (float (car expr)) (float (cadr expr)) + (float (car den)) (float (cadr den))) + (return (simplify (list '(mplus) + (simplify (list '(mtimes) + '$%i ci)) + cr)))) + 0.0 0.0)) + (t (return (list '(mlist simp))))))) + (setq degree (cadr expr) nn (1+ degree)) + (array pr\ flonum nn) #+LISPM (fillarray 'pr\ '(0.0)) + (array pi\ flonum nn) #+LISPM (fillarray 'pi\ '(0.0)) + (or (*catch 'notpoly + (errset (do ((expr (cdr expr) (cddr expr)) (l) (%i (cadr res))) + ((null expr)) + (setq l (- degree (car expr)) res (cadr expr)) + (cond ((numberp res) (store (pr\ l) (float res))) + (t (or (eq (car res) %i) (*throw 'notpoly nil)) + (setq res (cddr res)) + (store (pi\ l) (float (car res))) + (setq res (caddr res)) + (and res (store (pr\ l) (float res))) + (setq complex t)))))) + ;;;this should catch expressions like sin(x)-x + (progn (*rearray 'pr\) + (*rearray 'pi\) + (error '|not a polynomial|))) + (array shr\ flonum nn) #+LISPM (fillarray 'shr\ '(0.0)) + (array shi\ flonum nn) #+LISPM (fillarray 'shi\ '(0.0)) + (array qpr\ flonum nn) #+LISPM (fillarray 'qpr\ '(0.0)) + (array hr\ flonum degree) #+LISPM (fillarray 'hr\ '(0.0)) + (array qhr\ flonum degree) #+LISPM (fillarray 'qhr\ '(0.0)) + (cond (complex (array qpi\ flonum nn) + #+LISPM (fillarray 'qpi\ '(0.0)) + (array hi\ flonum degree) + #+LISPM (fillarray 'hi\ '(0.0)) + (array qhi\ flonum degree) + #+LISPM (fillarray 'qhi\ '(0.0)))) + (setq nn degree) + (cond (complex (setq res (errset (cpoly\ degree)))) + ((setq res (errset (rpoly\ degree))))) + (*rearray 'shr\) + (*rearray 'shi\) + (*rearray 'qpr\) + (*rearray 'hr\) + (*rearray 'qhr\) + (cond (complex (*rearray 'qpi\) + (*rearray 'hi\) + (*rearray 'qhi\))) + (or res + (mtell "~%Unexpected error. Treat results with caution.")) + (cond ((= nn degree) + (*rearray 'pr\) + (*rearray 'pi\) + (merror "~%No roots found"))) + (setq res nil) + (cond + ((not (= nn 0.)) + (mtell "~%Only ~S out of ~S roots found " + (- degree nn) degree) + (setq expr 0.0) + (do + ((i 0. (1+ i))) + ((> i nn)) + (setq + expr + (simplify + (list '(mplus) + expr + (simplify (list '(mtimes) + (simplify (list '(mplus) + (simplify (list '(mtimes) + '$%i + (pi\ i))) + (pr\ i))) + (simplify (list '(mexpt) + var + (- nn i))))))))) + (setq res (cons expr res))) + ($polyfactor + (setq expr ((lambda (cr ci) + (cdivid\ (pr\ 0) (pi\ 0) + (float (car den)) + (float (cadr den))) + (simplify (list '(mplus) + (simplify (list '(mtimes) + '$%i ci)) + cr))) + 0.0 0.0) + res (cons expr res)))) + (do + ((i degree (1- i))) + ((= i nn)) + (setq expr (simplify (list '(mplus) + (simplify (list '(mtimes) + '$%i + (pi\ i))) + (pr\ i)))) + (setq + res + (cond + ($polyfactor (cons (cond ((or complex (= (pi\ i) 0.0)) + (simplify (list '(mplus) + var + (simplify (list '(mminus) + expr))))) + (t (setq i (1- i)) + (simplify (list '(mplus) + (simplify (list '(mexpt) + var + 2.)) + (simplify (list '(mtimes) + var + (pr\ i))) + (pr\ (1+ i)))))) + res)) + ((cons ((lambda (expr) (cond ($programmode expr) + (t (displine expr)))) + (simplify (list '(mequal) var expr))) + res))))) + (*rearray 'pr\) + (*rearray 'pi\) + (return (simplify (cond ($polyfactor (cons '(mtimes) res)) + ((cons '(mlist) (nreverse res)))))))) + +(defun cpoly\ (degree) + ((lambda (logbas infin smalno are mre xx yy cosr sinr cr ci sr si tr ti zr zi bnd + n polysc polysc1 conv) + (setq mre (*$ 2.0 (sqrt 2.0) are) yy (-$ xx)) + (do ((i degree (1- i))) + ((not (and (= (pr\ i) 0.0) (= (pi\ i) 0.0))) (setq nn i n (1- i)))) + (setq degree nn) + (do ((i 0. (1+ i))) + ((> i nn)) + (store (shr\ i) (cmod\ (pr\ i) (pi\ i)))) + (scale\) + (do nil + ((> 2. nn) + (cdivid\ (-$ (pr\ 1.)) (-$ (pi\ 1.)) (pr\ 0.) (pi\ 0.)) + (store (pr\ 1.) cr) + (store (pi\ 1.) ci) + (setq nn 0.)) + (do ((i 0. (1+ i))) + ((> i nn)) + (store (shr\ i) (cmod\ (pr\ i) (pi\ i)))) + (setq bnd (cauchy\)) + (*catch 'newroot + (do ((cnt1 1. (1+ cnt1))) + ((> cnt1 2.)) + (noshft\ 5.) + (do ((cnt2 1. (1+ cnt2))) + ((> cnt2 9.)) + (setq xx (prog2 nil + (-$ (*$ cosr xx) (*$ sinr yy)) + (setq yy (+$ (*$ sinr xx) + (*$ cosr yy)))) + sr (*$ bnd xx) + si (*$ bnd yy)) + (fxshft\ (* 10. cnt2)) + (cond (conv (store (pr\ nn) zr) + (store (pi\ nn) zi) + (setq nn n n (1- n)) + (do ((i 0. (1+ i))) + ((> i nn)) + (store (pr\ i) (qpr\ i)) + (store (pi\ i) (qpi\ i))) + (*throw 'newroot t)))))) + (or conv (return t))) + (do ((i (1+ nn) (1+ i))) + ((> i degree)) + (store (pr\ i) (_f (pr\ i) polysc1)) + (store (pi\ i) (_f (pi\ i) polysc1))) + (do ((i 0. (1+ i)) (j (- polysc (* polysc1 degree)) (+ j polysc1))) + ((> i nn)) + (store (pr\ i) (_f (pr\ i) j)) + (store (pi\ i) (_f (pi\ i) j))) + nn) + (log 2.0) (cpoly-large-flonum) + (cpoly-small-flonum) (float-precision acp\) + 0.0 0.70710677 0.0 -0.069756474 0.99756405 + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0. 0. 0. nil)) + +(defun noshft\ (l1) + (do ((i 0. (1+ i)) (xni (float nn) (1-$ xni)) (t1 (//$ (float nn)))) + ((> i n)) + (store (hr\ i) (*$ (pr\ i) xni t1)) + (store (hi\ i) (*$ (pi\ i) xni t1))) + (do ((jj 1. (1+ jj))) + ((> jj l1)) + (cond ((> (cmod\ (hr\ n) (hi\ n)) (*$ 10.0 are (cmod\ (pr\ n) (pi\ n)))) + (cdivid\ (-$ (pr\ nn)) (-$ (pi\ nn)) (hr\ n) (hi\ n)) + (setq tr cr ti ci) + (do ((j n (1- j)) (t1) (t2)) + ((> 1. j)) + (setq t1 (hr\ (1- j)) t2 (hi\ (1- j))) + (store (hr\ j) (-$ (+$ (pr\ j) (*f t1 tr)) (*f t2 ti))) + (store (hi\ j) (+$ (pi\ j) (*f t1 ti) (*f t2 tr)))) + (store (hr\ 0.) (pr\ 0.)) + (store (hi\ 0.) (pi\ 0.))) + (t (do ((j n (1- j))) + ((> 1. j)) + (store (hr\ j) (hr\ (1- j))) + (store (hi\ j) (hi\ (1- j)))) + (store (hr\ 0.) 0.0) + (store (hi\ 0.) 0.0))))) + +(defun fxshft\ (l2) + ((lambda (test pasd otr oti svsr svsi bool pvr pvi) + (polyev\) + (setq conv nil) + (calct\) + (do ((j 1. (1+ j))) + ((> j l2)) + (setq otr tr oti ti) + (nexth\) + (calct\) + (setq zr (+$ sr tr) zi (+$ si ti)) + (cond ((and (not bool) test (not (= j l2))) + (cond ((> (*$ 0.5 (cmod\ zr zi)) + (cmod\ (-$ tr otr) (-$ ti oti))) + (cond (pasd (do ((i 0. (1+ i))) + ((> i n)) + (store (shr\ i) (hr\ i)) + (store (shi\ i) (hi\ i))) + (setq svsr sr svsi si) + (vrshft\ 10.) + (and conv (return nil)) + (setq test nil) + (do ((i 0. (1+ i))) + ((> i n)) + (store (hr\ i) (shr\ i)) + (store (hi\ i) (shi\ i))) + (setq sr svsr si svsi) + (polyev\) + (calct\)) + ((setq pasd t)))) + ((setq pasd nil)))))) + (or conv (vrshft\ 10.)) + nil) + t nil 0.0 0.0 0.0 0.0 nil 0.0 0.0)) + +(defun vrshft\ (l3) + (setq conv nil sr zr si zi) + (do ((i 1. (1+ i)) (bool1 nil) (mp) (ms) (omp) (relstp) (tp) (r1)) + ((> i l3)) + (polyev\) + (setq mp (cmod\ pvr pvi) ms (cmod\ sr si)) + (cond ((> (*$ 20.0 (errev\ ms mp)) mp) + (setq conv t zr sr zi si) + (return t))) + (cond ((= i 1.) (setq omp mp)) + ((or bool1 (> omp mp) (not (< relstp 0.05))) + (cond ((> (*$ 0.1 mp) omp) (return t)) (t (setq omp mp)))) + (t (setq tp relstp bool1 t) + (cond ((> are relstp) (setq tp are))) + (setq r1 (sqrt tp) + sr (prog2 nil + (-$ (*$ (1+$ r1) sr) (*f r1 si)) + (setq si (+$ (*$ (1+$ r1) si) (*f r1 sr))))) + (polyev\) + (do ((j 1. (1+ j))) ((> j 5.)) (calct\) (nexth\)) + (setq omp infin))) + (calct\) + (nexth\) + (calct\) + (or bool + (setq relstp (//$ (cmod\ tr ti) (cmod\ sr si)) + sr (+$ sr tr) + si (+$ si ti))))) + +(defun calct\ nil + (do ((i 1. (1+ i)) + ($t) + (hvr (store (qhr\ 0.) (hr\ 0.))) + (hvi (store (qhi\ 0.) (hi\ 0.)))) + ((> i n) + (setq bool (not (> (cmod\ hvr hvi) (*$ 10.0 are (cmod\ (hr\ n) (hi\ n)))))) + (cond ((not bool) (cdivid\ (-$ pvr) (-$ pvi) hvr hvi) (setq tr cr ti ci)) + (t (setq tr 0.0 ti 0.0))) + nil) + (setq $t (-$ (+$ (hr\ i) (*f hvr sr)) (*f hvi si))) + (store (qhi\ i) (setq hvi (+$ (hi\ i) (*f hvr si) (*f hvi sr)))) + (store (qhr\ i) (setq hvr $t)))) + +(defun nexth\ nil + (cond (bool (do ((j 1. (1+ j))) + ((> j n)) + (store (hr\ j) (qhr\ (1- j))) + (store (hi\ j) (qhi\ (1- j)))) + (store (hr\ 0.) 0.0) + (store (hi\ 0.) 0.0)) + (t (do ((j 1. (1+ j)) (t1) (t2)) + ((> j n)) + (setq t1 (qhr\ (1- j)) t2 (qhi\ (1- j))) + (store (hr\ j) (-$ (+$ (qpr\ j) (*f t1 tr)) (*f t2 ti))) + (store (hi\ j) (+$ (qpi\ j) (*f t1 ti) (*f t2 tr)))) + (store (hr\ 0.) (qpr\ 0.)) + (store (hi\ 0.) (qpi\ 0.)))) + nil) + +(defun polyev\ nil + (setq pvr (store (qpr\ 0.) (pr\ 0.)) pvi (store (qpi\ 0.) (pi\ 0.))) + (do ((i 1. (1+ i)) ($t)) + ((> i nn)) + (setq $t (-$ (+$ (pr\ i) (*f pvr sr)) (*f pvi si))) + (store (qpi\ i) (setq pvi (+$ (pi\ i) (*f pvr si) (*f pvi sr)))) + (store (qpr\ i) (setq pvr $t)))) + +(defun errev\ (ms mp) + (-$ (*$ (do ((j 0. (1+ j)) + (e (//$ (*$ (cmod\ (qpr\ 0.) (qpi\ 0.)) mre) (+$ are mre)))) + ((> j nn) e) + (setq e (+$ (cmod\ (qpr\ j) (qpi\ j)) (*$ e ms)))) + (+$ are mre)) + (*$ mp mre))) + +(defun cauchy\ nil + ((lambda (x xm) + (store (shr\ nn) (-$ (shr\ nn))) + (cond ((not (= (shr\ n) 0.0)) + (setq xm (-$ (//$ (shr\ nn) (shr\ n)))) + (cond ((> x xm) (setq x xm))))) + (do ((f)) + (nil) + (setq xm (*$ 0.1 x) f (shr\ 0.)) + (do ((i 1. (1+ i))) ((> i nn)) (setq f (+$ (shr\ i) (*f f xm)))) + (cond ((not (< 0.0 f)) (return t))) + (setq x xm)) + (do ((dx x) (df) (f)) + ((> 5.0e-3 (abs (//$ dx x))) x) + (setq f (shr\ 0.) df f) + (do ((i 1. (1+ i))) + ((> i n)) + (setq f (+$ (*$ f x) (shr\ i)) df (+$ (*$ df x) f))) + (setq f (+$ (*$ f x) (shr\ nn)) dx (//$ f df) x (-$ x dx)))) + (exp (//$ (-$ (log (shr\ nn)) (log (shr\ 0.))) (float nn))) + 0.0)) + +(defun scale\ nil + (do ((i 0. (1+ i)) (j 0.) (x 0.0) (dx 0.0)) + ((> i nn) + (setq x (//$ x (float (- (1+ nn) j))) + dx (//$ (-$ (log (shr\ nn)) (log (shr\ 0.))) (float nn)) + polysc1 (fix (+$ 0.5 (//$ dx logbas))) + x (+$ x (*$ (float (* polysc1 nn)) logbas 0.5)) + polysc (fix (+$ 0.5 (//$ x logbas))))) + (cond ((= (shr\ i) 0.0) (setq j (1+ j))) + (t (setq x (+$ x (log (shr\ i))))))) + (do ((i nn (1- i)) (j (- polysc) (+ j polysc1))) + ((< i 0.)) + (store (pr\ i) (_f (pr\ i) j)) + (store (pi\ i) (_f (pi\ i) j)))) + +;; (defun scale\ nil +;; ((lambda (hi lo max min x l) +;; (do ((i 0. (1+ i))) +;; ((> i nn)) +;; (setq x (shr\ i)) +;; (cond ((> x max) (setq max x))) +;; (cond ((and (not (= x 0.0)) (< x min)) (setq min x)))) +;; (cond ((or (> lo min) (> max hi)) +;; (setq x (//$ lo min)) +;; (cond ((> x 1.0) +;; (cond ((> max (//$ infin x)) +;; ;;;acm has < here but imsl agrees with me +;; (setq x 1.0)))) +;; ((setq x (//$ (*$ (sqrt max) (sqrt min)))))) +;; (setq l (fix (+$ 0.5 (//$ (log x) logbas)))) +;; (cond ((not (= l 0.)) +;; (do ((i 0. (1+ i))) +;; ((> i nn)) +;; (store (pr\ i) (_f (pr\ i) l)) +;; (store (pi\ i) (_f (pi\ i) l))))))) +;; l) +;; (sqrt infin) (//$ smalno are) 0.0 infin 0.0 0.)) + +(defun cdivid\ (ar ai br bi) + ((lambda (r1) (cond ((and (= br 0.0) (= bi 0.0)) (setq cr (setq ci infin))) + ((> (abs bi) (abs br)) + (setq r1 (//f br bi) + bi (+$ bi (*f br r1)) + br (+$ ai (*f ar r1)) + cr (//f br bi) + br (-$ (*f ai r1) ar) + ci (//f br bi))) + ((setq r1 (//f bi br) + bi (+$ br (*f bi r1)) + br (+$ ar (*f ai r1)) + cr (//f br bi) + br (-$ ai (*f ar r1)) + ci (//f br bi))))) + 0.0) + nil) + +(defun cmod\ (ar ai) + (setq ar (abs ar) ai (abs ai)) + (cond ((> ai ar) (setq ar (//f ar ai)) (*$ ai (sqrt (1+$ (*f ar ar))))) + ((> ar ai) (setq ai (//f ai ar)) (*$ ar (sqrt (1+$ (*f ai ai))))) + ((*$ 1.41421357 ar)))) + +;;*page + +;;;this is the algorithm for doing real polynomials. it is algorithm 493 from +;;;acm toms vol 1 p 178 (1975) by jenkins. note that array indexing starts from 0. +;;;the names of the arrays have been changed to be the same as for cpoly. +;;;the correspondence is: p - pr\, qp - qpr\, k - hr\, qk - qhr\, svk - shr\, +;;;temp - shi\. the roots are put in pr\ and pi\. +;;;the variable si appears not to be used here + +(declare (special sr u v a b c d a1 a3 a7 e f g h szr szi lzr lzi are mre n nn nz + type ui vi s $polyfactor arp\) + (flonum a a0 a1 a3 a4 a5 a6 a7 aa are b b0 b1 b2 logbas bb betas betav bnd c c0 + c1 c2 c3 c4 cc cosr d d0 e ee f g h infin kv lzi lzr mp mre ms omp + oss ots otv ovv pv relstp s sinr smalno sr ss svu svv szi szr t1 ts + tss tv tvv u ui v vi vv xx yy zm arp\) + (fixnum cnt degree i iflag j jj l l2 n nn nz type)) + +(declare (fixnum (realit\)) + (notype (rpoly\ fixnum) (fxshfr\ fixnum) (quadit\) (calcsc\) (nextk\) + (newest\) (quadsd\) (quad\ flonum flonum flonum))) + +(setq arp\ 1.0) + +(defun rpoly\ (degree) + ((lambda (logbas infin smalno are mre xx yy cosr sinr aa cc bb bnd sr u v t1 szr + szi lzr lzi nz n polysc polysc1 zerok conv1) + (setq mre are yy (-$ xx)) + (do ((i degree (1- i))) ((not (= (pr\ i) 0.0)) (setq nn i n (1- i)))) + (setq degree nn) + (do ((i 0. (1+ i))) ((> i nn)) (store (shr\ i) (abs (pr\ i)))) + (scale\) + (do nil + ((< nn 3.) + (cond ((= nn 2.) + (quad\ (pr\ 0.) (pr\ 1.) (pr\ 2.)) + (cond ((and $polyfactor (not (= szi 0.0))) + (store (pr\ 2.) (//$ (pr\ 2.) (pr\ 0.))) + (store (pr\ 1.) (//$ (pr\ 1.) (pr\ 0.))) + (store (pi\ 2.) 1.0)) + (t (store (pr\ 2.) szr) + (store (pi\ 2.) szi) + (store (pr\ 1.) lzr) + (store (pi\ 1.) lzi)))) + (t (store (pr\ 1.) (-$ (//$ (pr\ 1.) (pr\ 0.)))))) + (setq nn 0.)) + (do ((i 0. (1+ i))) ((> i nn)) (store (shr\ i) (abs (pr\ i)))) + (setq bnd (cauchy\)) + (do ((i 1. (1+ i))) + ((> i n)) + (store (hr\ i) (//$ (*$ (float (- n i)) (pr\ i)) (float n)))) + (store (hr\ 0.) (pr\ 0.)) + (setq aa (pr\ nn) bb (pr\ n) zerok (= (hr\ n) 0.0)) + (do ((jj 1. (1+ jj))) + ((> jj 5.)) + (setq cc (hr\ n)) + (cond (zerok (do ((j n (1- j))) + ((< j 1.)) + (store (hr\ j) (hr\ (1- j)))) + (store (hr\ 0.) 0.0) + (setq zerok (= (hr\ n) 0.0))) + (t (setq t1 (-$ (//$ aa cc))) + (do ((j n (1- j))) + ((< j 1.)) + (store (hr\ j) (+$ (*$ t1 (hr\ (1- j))) (pr\ j)))) + (store (hr\ 0.) (pr\ 0.)) + (setq zerok (not (> (abs (hr\ n)) + (*$ (abs bb) are 10.0))))))) + (do ((i 0. (1+ i))) ((> i n)) (store (shi\ i) (hr\ i))) + (do ((cnt 1. (1+ cnt))) + ((> cnt 20.) (setq conv1 nil)) + (setq xx (prog2 nil + (-$ (*$ cosr xx) (*$ sinr yy)) + (setq yy (+$ (*$ sinr xx) (*$ cosr yy)))) + sr (*$ bnd xx) + u (*$ -2.0 sr) + v bnd) + (fxshfr\ (* 20. cnt)) + (cond ((> nz 0.) + (store (pr\ nn) szr) + (store (pi\ nn) szi) + (cond ((= nz 2.) + (store (pr\ n) lzr) + (store (pi\ n) lzi) + (cond ((and $polyfactor (not (= szi 0.0))) + (store (pr\ nn) v) + (store (pr\ n) u) + (store (pi\ nn) 1.0))))) + (setq nn (- nn nz) n (1- nn)) + (do ((i 0. (1+ i))) ((> i nn)) (store (pr\ i) (qpr\ i))) + (return nil))) + (do ((i 0. (1+ i))) ((> i n)) (store (hr\ i) (shi\ i)))) + (or conv1 (return nil))) + (cond ($polyfactor + (do ((i degree (1- i))) + ((= i nn)) + (cond ((= (pi\ i) 0.0) + (store (pr\ i) (_f (pr\ i) polysc1))) + (t (store (pr\ i) (_f (pr\ i) (* 2. polysc1))) + (setq i (1- i)) + (store (pr\ i) (_f (pr\ i) polysc1)))))) + (t (do ((i (1+ nn) (1+ i))) + ((> i degree)) + (store (pr\ i) (_f (pr\ i) polysc1)) + (store (pi\ i) (_f (pi\ i) polysc1))))) + (do ((i 0. (1+ i)) (j (- polysc (* polysc1 degree)) (+ j polysc1))) + ((> i nn)) + (store (pr\ i) (_f (pr\ i) j)))) + (log 2.0) (cpoly-large-flonum) + (cpoly-small-flonum) (float-precision arp\) + 0.0 0.70710677 0.0 -0.069756474 0.99756405 + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0. 0. 0. 0. 0. t)) + +(defun fxshfr\ (l2) + ((lambda (type a b c d e f g h a1 a3 a7) + (setq nz 0.) + (quadsd\) + (calcsc\) + (do ((j 1. (1+ j)) (betav 0.25) (betas 0.25) + (oss sr) (ovv v) (tvv) (tss) (ss) (vv) (tv) (ts) (ots) (otv) + (ui) (vi) (s) (svv) (svu) (iflag) (vpass) (spass) (vtry) (stry)) + ((> j l2)) + (nextk\) + (calcsc\) + (newest\) + (setq vv vi ss 0.0) + (or (= (hr\ n) 0.0) (setq ss (-$ (//$ (pr\ nn) (hr\ n))))) + (setq tv 1.0 ts 1.0) + (cond ((not (or (= j 1.) (= type 3.))) + (or (= vv 0.0) (setq tv (abs (//$ (-$ vv ovv) vv)))) + (or (= ss 0.0) (setq ts (abs (//$ (-$ ss oss) ss)))) + (setq tvv 1.0) + (and (< tv otv) (setq tvv (*$ tv otv))) + (setq tss 1.0) + (and (< ts ots) (setq tss (*$ ts ots))) + (setq vpass (< tvv betav) spass (< tss betas)) + (cond ((or spass vpass) + (setq svu u svv v) + (do ((i 0. (1+ i))) ((> i n)) (store (shr\ i) (hr\ i))) + (setq s ss vtry nil stry nil) + (and (do ((bool (not (and spass + (or (not vpass) (< tss tvv)))) + t) + (l50 nil nil)) + (nil) + (cond (bool (quadit\) + (and (> nz 0.) (return t)) + (setq vtry t betav (*$ 0.25 betav)) + (cond ((or stry (not spass)) + (setq l50 t)) + (t (do ((i 0. (1+ i))) + ((> i n)) + (store (hr\ i) + (shr\ i))))))) + (cond ((not l50) + (setq iflag (realit\)) + (and (> nz 0.) (return t)) + (setq stry t betas (*$ 0.25 betas)) + (cond ((= iflag 0.) (setq l50 t)) + (t (setq ui (-$ (+$ s s)) + vi (*$ s s)))))) + (cond (l50 (setq u svu v svv) + (do ((i 0. (1+ i))) + ((> i n)) + (store (hr\ i) (shr\ i))) + (and (or (not vpass) vtry) + (return nil))))) + (return nil)) + (quadsd\) + (calcsc\))))) + (setq ovv vv oss ss otv tv ots ts))) + 0. 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)) + +(defun quadit\ nil + (setq nz 0. u ui v vi) + (do ((tried) (j 0.) (ee) (zm) (t1) (mp) (relstp) (omp)) + (nil) + (quad\ 1.0 u v) + (and (> (abs (-$ (abs szr) (abs lzr))) (*$ 0.01 (abs lzr))) (return nil)) + (quadsd\) + (setq mp (+$ (abs (-$ a (*$ szr b))) (abs (*$ szi b))) + zm (sqrt (abs v)) + ee (*$ 2.0 (abs (qpr\ 0.))) + t1 (-$ (*$ szr b))) + (do ((i 1. (1+ n))) ((> i n)) (setq ee (+$ (*$ ee zm) (abs (qpr\ i))))) + (setq ee (+$ (*$ ee zm) (abs (+$ a t1))) + ee (-$ (*$ (+$ (*$ 5.0 mre) (*$ 4.0 are)) ee) + (*$ (+$ (*$ 5.0 mre) (*$ 2.0 are)) + (+$ (abs (+$ a t1)) (*$ (abs b) zm))) + (*$ -2.0 are (abs t1)))) + (cond ((not (> mp (*$ 20.0 ee))) (setq nz 2.) (return nil))) + (setq j (1+ j)) + (and (> j 20.) (return nil)) + (cond ((not (or (< j 2.) (> relstp 0.01) (< mp omp) tried)) + (and (< relstp are) (setq relstp are)) + (setq relstp (sqrt relstp) + u (-$ u (*$ u relstp)) + v (+$ v (*$ v relstp))) + (quadsd\) + (do ((i 1. (1+ i))) ((> i 5.)) (calcsc\) (nextk\)) + (setq tried t j 0.))) + (setq omp mp) + (calcsc\) + (nextk\) + (calcsc\) + (newest\) + (and (= vi 0.0) (return nil)) + (setq relstp (abs (//$ (-$ vi v) vi)) u ui v vi))) + +(defun realit\ nil + (setq nz 0.) + (do ((j 0.) (pv) (ee) (ms) (mp) (kv) (t1) (omp)) + (nil) + (setq pv (pr\ 0.)) + (store (qpr\ 0.) pv) + (do ((i 1. (1+ i))) + ((> i nn)) + (setq pv (+$ (*$ pv s) (pr\ i))) + (store (qpr\ i) pv)) + (setq mp (abs pv) ms (abs s) ee (*$ (//$ mre (+$ are mre)) (abs (qpr\ 0.)))) + (do ((i 1. (1+ i))) ((> i nn)) (setq ee (+$ (*$ ee ms) (abs (qpr\ i))))) + (cond ((not (> mp (*$ 20.0 (-$ (*$ (+$ are mre) ee) (*$ mre mp))))) + (setq nz 1. szr s szi 0.0) + (return 0.))) + (setq j (1+ j)) + (and (> j 10.) (return 0.)) + (cond ((not (or (< j 2.) + (> (abs t1) (*$ 1.0e-3 (abs (-$ s t1)))) + (not (> mp omp)))) + (return 1.))) + (setq omp mp kv (hr\ 0.)) + (store (qhr\ 0.) kv) + (do ((i 1. (1+ i))) + ((> i n)) + (setq kv (+$ (*$ kv s) (hr\ i))) + (store (qhr\ i) kv)) + (cond ((> (abs kv) (*$ (abs (hr\ n)) 10.0 are)) + (setq t1 (-$ (//$ pv kv))) + (store (hr\ 0.) (qpr\ 0.)) + (do ((i 1. (1+ i))) + ((> i n)) + (store (hr\ i) (+$ (*$ t1 (qhr\ (1- i))) (qpr\ i))))) + (t (store (hr\ 0.) 0.0) + (do ((i 1. (1+ i))) ((> i n)) (store (hr\ i) (qhr\ (1- i)))))) + (setq kv (hr\ 0.)) + (do ((i 1. (1+ i))) ((> i n)) (setq kv (+$ (*$ kv s) (hr\ i)))) + (setq t1 0.0) + (and (> (abs kv) (*$ (abs (hr\ n)) 10.0 are)) (setq t1 (-$ (//$ pv kv)))) + (setq s (+$ s t1)))) + +(defun calcsc\ nil + (setq d (hr\ 0.)) + (store (qhr\ 0.) d) + (setq c (-$ (hr\ 1.) (*$ u d))) + (store (qhr\ 1.) c) + (do ((i 2. (1+ i)) (c0)) + ((> i n)) + (setq c0 (-$ (hr\ i) (*$ u c) (*$ v d))) + (store (qhr\ i) c0) + (setq d c c c0)) + (cond ((not (or (> (abs c) (*$ (abs (hr\ n)) 100.0 are)) + (> (abs d) (*$ (abs (hr\ (1- n))) 100.0 are)))) + (setq type 3.)) + ((not (< (abs d) (abs c))) + (setq type 2. + e (//$ a d) + f (//$ c d) + g (*$ u b) + h (*$ v b) + a3 (+$ (*$ (+$ a g) e) (*$ h (//$ b d))) + a1 (-$ (*$ b f) a) + a7 (+$ (*$ (+$ f u) a) h))) + (t (setq type 1. + e (//$ a c) + f (//$ d c) + g (*$ u e) + h (*$ v b) + a3 (+$ (*$ a e) (*$ (+$ (//$ h c) g) b)) + a1 (-$ b (*$ a (//$ d c))) + a7 (+$ a (*$ g d) (*$ h f))))) + nil) + +(defun nextk\ nil + (cond ((= type 3.) + (store (hr\ 0.) 0.0) + (store (hr\ 1.) 0.0) + (do ((i 2. (1+ i))) ((> i n)) (store (hr\ i) (qhr\ (- i 2.))))) + ((> (abs a1) (*$ (abs (cond ((= type 1.) b) (a))) 10.0 are)) + (setq a7 (//$ a7 a1) a3 (//$ a3 a1)) + (store (hr\ 0.) (qpr\ 0.)) + (store (hr\ 1.) (-$ (qpr\ 1.) (*$ a7 (qpr\ 0.)))) + (do ((i 2. (1+ i))) + ((> i n)) + (store (hr\ i) + (+$ (*$ a3 (qhr\ (- i 2.))) + (-$ (*$ a7 (qpr\ (1- i)))) + (qpr\ i))))) + (t (store (hr\ 0.) 0.0) + (store (hr\ 1.) (-$ (*$ a7 (qpr\ 0.)))) + (do ((i 2. (1+ i))) + ((> i n)) + (store (hr\ i) + (-$ (*$ a3 (qhr\ (- i 2.))) (*$ a7 (qpr\ (1- i)))))))) + nil) + +(defun newest\ nil + ((lambda (a4 a5 b1 b2 c1 c2 c3 c4) + (cond ((= type 3.) (setq ui 0.0 vi 0.0)) + (t (cond ((= type 2.) + (setq a4 (+$ (*$ (+$ a g) f) h) + a5 (+$ (*$ (+$ f u) c) (*$ v d)))) + (t (setq a4 (+$ a (*$ u b) (*$ h f)) + a5 (+$ c (*$ (+$ u (*$ v f)) d))))) + (setq b1 (-$ (//$ (hr\ n) (pr\ nn))) + b2 (-$ (//$ (+$ (hr\ (1- n)) (*$ b1 (pr\ n))) (pr\ nn))) + c1 (*$ v b2 a1) + c2 (*$ b1 a7) + c3 (*$ b1 b1 a3) + c4 (-$ c1 c2 c3) + c1 (+$ a5 (*$ b1 a4) (-$ c4))) + (cond ((= c1 0.0) (setq ui 0.0 vi 0.0)) + (t (setq ui (-$ u + (//$ (+$ (*$ u (+$ c3 c2)) + (*$ v + (+$ (*$ b1 a1) + (*$ b2 a7)))) + c1)) + vi (*$ v (1+$ (//$ c4 c1)))))))) + nil) + 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0)) + +(defun quadsd\ nil + (setq b (pr\ 0.)) + (store (qpr\ 0.) b) + (setq a (-$ (pr\ 1.) (*$ u b))) + (store (qpr\ 1.) a) + (do ((i 2. (1+ i)) (c0)) + ((> i nn)) + (setq c0 (-$ (pr\ i) (*$ u a) (*$ v b))) + (store (qpr\ i) c0) + (setq b a a c0))) + +(defun quad\ (a0 b1 c0) + (setq szr 0.0 szi 0.0 lzr 0.0 lzi 0.0) + ((lambda (b0 d0 e) + (cond ((= a0 0.0) (or (= b1 0.0) (setq szr (-$ (//$ c0 b1))))) + ((= c0 0.0) (setq lzr (-$ (//$ b1 a0)))) + (t (setq b0 (//$ b1 2.0)) + (cond ((< (abs b0) (abs c0)) + (setq e a0) + (and (< c0 0.0) (setq e (-$ a0))) + (setq e (-$ (*$ b0 (//$ b0 (abs c0))) e) + d0 (*$ (sqrt (abs e)) (sqrt (abs c0))))) + (t (setq e (-$ 1.0 (*$ (//$ a0 b0) (//$ c0 b0))) + d0 (*$ (sqrt (abs e)) (abs b0))))) + (cond ((< e 0.0) + (setq szr (-$ (//$ b0 a0)) + lzr szr + szi (abs (//$ d0 a0)) + lzi (-$ szi))) + (t (or (< b0 0.0) (setq d0 (-$ d0))) + (setq lzr (//$ (-$ d0 b0) a0)) + (or (= lzr 0.0) (setq szr (//$ c0 lzr a0))))))) + nil) + 0.0 0.0 0.0)) + +(declare (unspecial logbas infin smalno are mre cr ci sr si tr ti zr zi + n nn bool conv pvr pvi acp\ polysc polysc1 sr u v a + b c d a1 a3 a7 e f g h szr szi lzr lzi are mre n nn nz + type ui vi s arp\)) diff --git a/src/das/mstuff.21 b/src/das/mstuff.21 new file mode 100644 index 00000000..c63f3265 --- /dev/null +++ b/src/das/mstuff.21 @@ -0,0 +1,74 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mstuff) + +(DECLARE (SPLITFILE MSORT) (FIXNUM N)) + +(DEFMFUN $SORT N + (IF (OR (= N 0) (> N 2)) (MERROR "SORT takes 1 or 2 arguments.")) + (LET ((LLIST (ARG 1)) COMPARFUN BFUN) + (IF (NOT ($LISTP LLIST)) + (MERROR "The first argument to SORT must be a list:~%~M" LLIST)) + (SETQ LLIST (APPEND (CDR LLIST) NIL) + COMPARFUN + (MFUNCTION1 (SETQ BFUN (IF (= N 2) (GETOPR (ARG 2)) 'LESSTHAN)))) + (IF (MEMQ BFUN '(LESSTHAN GREAT)) + (SETQ LLIST (MAPCAR #'RATDISREP LLIST))) + (CONS '(MLIST SIMP) (SORT LLIST COMPARFUN)))) + +(DEFUN MFUNCTION1 (FUN) + `(LAMBDA (X Y) (MEVALP `((,',FUN) ((MQUOTE) ,X) ((MQUOTE) ,Y))))) + +(DEFUN LESSTHAN (A B) (GREAT B A)) + +(DECLARE (SPLITFILE MAKEL)) + +(DEFMSPEC $MAKELIST (X) (SETQ X (CDR X)) + (PROG (N FORM ARG A B LV D) + (SETQ N (LENGTH X)) + (IF (OR (< N 3) (> N 4)) + (MERROR "MAKELIST takes 3 or 4 arguments.")) + (SETQ FORM (CAR X) + ARG (CADR X) + A (MEVAL (CADDR X)) + LV (COND ((= N 3) + (IF ($LISTP A) + (MAPCAR #'(LAMBDA (U) (LIST '(MQUOTE) U)) (CDR A)) + (MERROR " +If 3 arguments are given to MAKELIST, +the 3rd argument should evaluate to a list:~%~M" A))) + (T + (SETQ B (MEVAL (CADDDR X))) + (IF (OR (NOT (EQ (TYPEP (SETQ D (SUB* B A))) 'FIXNUM)) + (< D -1)) + (MERROR " +If 4 arguments are given to MAKELIST, the difference of the 3rd +and 4th arguments should evaluate to a non-negative integer:~%~M" D) + (INTERVAL A B))))) + (RETURN + (DO ((LV LV (CDR LV)) (ANS)) + ((NULL LV) (CONS '(MLIST SIMP) (NREVERSE ANS))) + (SETQ ANS (CONS (MEVAL `(($EV) + ,@(LIST (LIST '(MQUOTE) FORM) + (LIST '(MEQUAL SIMP) + ARG + (CAR LV))))) + ANS)))))) + +(DEFUN INTERVAL (I J) + (DO ((NN I (ADD2 1 NN)) (M 0 (1+ M)) (K (SUB* J I)) (ANS)) + ((> M K) (NREVERSE ANS)) + (SETQ ANS (CONS NN ANS)))) + +(DEFMFUN $SUBLIST (A F) + (IF ($LISTP A) + (DO ((A (CDR A) (CDR A)) (X)) + ((NULL A) (CONS '(MLIST SIMP) (NREVERSE X))) + (IF (MEVALP (LIST (NCONS F) (CAR A))) + (SETQ X (CONS (CAR A) X)))) + (MERROR "The first argument to SUBLIST must be a list:~%~M" A))) + +; Undeclarations for the file: +(DECLARE (NOTYPE N)) diff --git a/src/ell/hyp.98 b/src/ell/hyp.98 new file mode 100644 index 00000000..9d3d3f8d --- /dev/null +++ b/src/ell/hyp.98 @@ -0,0 +1,1234 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module hyp) + +;****************************************************************************** +;******************** ********************** +;******************** Hypergeometric Function Simplifier ********************** +;******************** ********************** +;****************************************************************************** + +;; This is a modified version of the original package written by Yannis. +;; There are still many bugs and kludges in the code; the algorithms +;; used are not very general, in short, this package needs to be +;; rewritten with a fresh approach to the problem. This version is the +;; result of ELL's extensions, followed by fixes, extensions, and +;; cleaning up by WGD. --wgd + + +;; Keep this in lowercase because Franz strings are case sensitive + +(load-macsyma-macros rzmac) + +(DECLARE (SPECIAL VAR PAR ZEROSIGNTEST PRODUCTCASE 1//2 -1//2 3//2 + FLDEG FLGKUM CHECKCOEFSIGNLIST SERIESLIST + $EXPONENTIALIZE $BESTRIGLIM $RADEXPAND FAIL-SYM) + (*LEXPR $DIFF ADD MUL) + (MUZZLED T)) + +(SETQ 3//2 (M//T 3 2) FLGKUM T FLDEG T FL1F1 T CHECKCOEFSIGNLIST () + $BESTRIGLIM 3 FAIL-SYM (GENSYM)) + +(DEFMACRO CDRASS (A L) `(CDR (ASSOC ,A ,L))) + +(DEFMACRO NON-INTP (N) `(NOT (INTEGERP ,N))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;:::::::::; +;; ;; +;; Symbolic Arithmetic Macros (to be flushed when nopers supports them) ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(DEFMACRO SIMP (X) `(SIMPLIFYA ,X ())) + +(DEFMACRO SIMP-LIST (L) `(MAPCAR #'(LAMBDA (X) (SIMP X)) ,L)) + +(DEFMACRO MABS (X) `(SIMP `((MABS) ,,X))) + +(DEFMACRO MSQRT (X) `(M^T ,X 1//2)) + +(DEFMACRO MEXPT (X) `(M^T '$%E ,X)) + +(DEFMACRO MLOG (X) `(SIMP `((%LOG) ,,X))) + +(DEFMACRO MSIN (X) `(SIMP `((%SIN) ,,X))) + +(DEFMACRO MCOS (X) `(SIMP `((%COS) ,,X))) + +(DEFMACRO MASIN (X) `(SIMP `((%ASIN) ,,X))) + +(DEFMACRO MATAN (X) `(SIMP `((%ATAN) ,,X))) + +(DEFMACRO MGAMMA (X) `(SIMP `((%GAMMA) ,,X))) + +(DEFMACRO MBINOM (X Y) `(SIMP `((%BINOMIAL) ,,X ,,Y))) + +(DEFMACRO MERF (X) `(SIMP `((%ERF) ,,X))) + +(DEFMACRO =1//2 (X) `(ALIKE1 ,X 1//2)) + +(DEFMACRO =3//2 (X) `(ALIKE1 ,X 3//2)) + +(DEFMACRO =-1//2 (X) `(ALIKE1 ,X -1//2)) + +(DEFMFUN $HGFRED (L1 L2 ARG) + (LET ((VAR ARG) (PAR ARG)) + (HGFSIMP-EXEC (CDR L1) (CDR L2) ARG))) + +(DEFMFUN HGFSIMP-EXEC (L1 L2 ARG) + ;; Copy lists here so that we may do destructive things later + (SETQ L1 (COPY-TOP-LEVEL L1) L2 (COPY-TOP-LEVEL L2)) + (LET ($EXPONENTIALIZE ($RADEXPAND '$ALL) (RESULT (HGFSIMP L1 L2 ARG))) + (IF (OR (NUMBERP RESULT) (NOT (ATOM RESULT))) + RESULT + (FPQFORM L1 L2 ARG)))) + +(DEFUN HGFSIMP (L1 L2 VAR) + (SETQ L1 (SIMP-LIST L1) L2 (SIMP-LIST L2)) + (LET ((RESULT (SIMPG L1 L2)) (LISTCMDIFF)) + (IF (OR (ATOM RESULT) (NOT (EQ (CAAR RESULT) FAIL-SYM))) + RESULT + (IF (SETQ LISTCMDIFF (INTDIFF (CDAR RESULT) (CDR RESULT))) + (SPLITPFQ LISTCMDIFF (CDAR RESULT) (CDR RESULT)) + (DISPATCH-SPEC-SIMP (CDAR RESULT) (CDR RESULT)))))) + +(DEFUN SIMPG (L1 L2) + (LET ((IL (INTERSECTION L1 L2))) + (IFN IL (SIMPG-EXEC L1 L2) (SIMPG-EXEC (DEL** IL L1) (DEL** IL L2))))) + +(DEFUN DEL** (A B) + (IFN A B (DEL** (CDR A) (DELETE (CAR A) B 1.)))) + +(DEFUN INTERSECTION (L1 L2) + (COND ((NULL L1) ()) + ((MEMBER (CAR L1) L2) + (CONS (CAR L1) + (INTERSECTION (CDR L1) (DELETE (CAR L1) L2 1.)))) + (T (INTERSECTION (CDR L1) L2)))) + +(DEFUN SIMPG-EXEC (L1 L2) + (LET (N) + (COND ((MEM-ZERO L1) 1.) + ((SETQ N (MEM-NEG L1)) (MAKE-POLY L1 L2 (- N))) + ((OR (MEM-ZERO L2) (MEM-NEG L2)) + (MERROR "Hypergeometric-series is undefined~%")) + (T (CONS (CONS FAIL-SYM L1) L2))))) + +(DEFUN INTDIFF (L1 L2) + (IFN L1 () + (DO ((L L2 (CDR L)) (A (CAR L1)) (DIF)) + ((NULL L) (INTDIFF (CDR L1) L2)) + (IF (NON-NEG-INTP (SETQ DIF (M-T A (CAR L)))) + (RETURN (LIST A DIF)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;:::::::::; +;; ;; +;; Macros for constructing Macsyma Special Functions ;; +;; ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(DEFMACRO HERMPOL (N ARG) ``((MQAPPLY) (($%HE ARRAY) ,,N) ,,ARG)) + +(DEFMACRO LAGPOL (N A ARG) ``((MQAPPLY) (($%L ARRAY) ,,N ,,A) ,,ARG)) + +(DEFMACRO JACOBPOL (N A B X) ``((MQAPPLY) (($%P ARRAY) ,,N ,,A ,,B) ,,X)) + +(DEFMACRO LEGENPOL (N X) ``((MQAPPLY) (($%P ARRAY) ,,N) ,,X)) + +(DEFMACRO TCHEBYPOL (N X) ``((MQAPPLY) (($%T ARRAY) ,,N) ,,X)) + +(DEFUN GEGENPOL (N V X) + (IF (=0 V) (TCHEBYPOL N X) `((MQAPPLY) (($%C ARRAY) ,N ,V) ,X))) + +(DEFMACRO WHITFUN (K M VAR) ``((MQAPPLY) (($%M ARRAY) ,,K ,,M) ,,VAR)) + +(DEFMACRO BES (A X FLG) + ``((MQAPPLY) (,(IF (EQ ,FLG 'J) '($%J ARRAY) '($%IBES ARRAY)) ,,A) + ,(M*T 2. (MSQRT X)))) + +(DEFMACRO LEGEN (N M X PQ) + ``((MQAPPLY) (,(IF (EQ ,PQ 'Q) '($%Q ARRAY) '($%P ARRAY)) ,,N ,,M) ,,X)) + +(DEFUN MAKE-POLY (L1 L2 N) + (LET ((VECT (CONS (LENGTH L1) (LENGTH L2)))) + (COND ((EQUAL VECT '(2. . 1.)) + (2F1POLYS (CAR L1) (CADR L1) (CAR L2) (- N))) + ((EQUAL VECT '(1. . 1.)) (1F1POLYS (CAR L2) N)) + ((EQUAL VECT '(2. . 0.)) (2F0POLYS (CAR L1) (CADR L1) (- N))) + (T (MAKE-GENL-POLY L1 L2 N))))) + +;; Numbered comment N indicates that a formula similar to N in the +;; mathematical handbook by Abramowitz and Stegun is being applied. +;; If no such formula is in this work then the equation will be explicitly +;; stated in the code. This greatly facilitates error-checking. + +(DEFUN 1F1POLYS (C N) + (LET ((FACT1 (TIMES (EXPT -2. N) (FACTORIAL N))) + (FACT2 (MSQRT (M*T 2. VAR)))) + (COND ((=1//2 C) + (M*T (M//T FACT1 (FACTORIAL (TIMES 2. N))) ;; 13.6.17 + (HERMPOL (TIMES 2. N) FACT2))) + ((=3//2 C) + (M*T (M//T FACT1 (FACTORIAL (ADD1 (TIMES 2. N)))) ;; 13.6.18 + (M//T FACT2) + (HERMPOL (ADD1 (TIMES 2. N)) FACT2))) + (T (M*T (FACTORIAL N) (MGAMMA C) (MGAMMA (M+T C N)) ;; 13.6.9 + (LAGPOL N (M1-T C) VAR)))))) + +(DEFUN 2F0POLYS (A B N) + (IF (=1//2 (MABS (M-T B A))) + + ;; %F([-N/2,1/2-N/2],[],Z) = (-2/Z)^(-N/2) %HE[N](SQRT(-2/Z)) + + (M*T (M^T (M//T -2. VAR) (SETQ N ($MIN A B))) + (HERMPOL (M*T -2. N) (MSQRT (M//T -2. VAR)))) + (IF (EQUAL B (- N)) (EXCH A B)) + (M*T (FACTORIAL N) (M^T VAR N) ;; 13.6.27 + (LAGPOL N (M-T A B) (M//T -1. VAR))))) + +(DEFUN 2F1POLYS (A B C N) + (LET (V) + (IFN (EQUAL A N) (EXCH A B)) ;; CANONICALIZE + (IF (SETQ V (LEGPOL A B C)) V + (SETQ V (CDRASS 'V (VFVP (M//T (M+T B N) 2.))) N (- N)) + (IF (=1//2 (M-T C V)) + (M*T (IF (=0 V) 1. (M*T (FACTORIAL N) + (M//T (APPELL (M*T 2. V) N)))) + (GEGENPOL N V (M-T 1. (M*T 2. PAR)))) + (M*T (FACTORIAL N) (M//T (APPELL (M1+T V) N)) + (JACOBPOL N (M1-T C) (M-T (M*T 2. V) C) + (M-T 1. (M*T 2. PAR)))))))) + +(DEFMACRO LIST-INCR (L) `(MAP (FN (LL) (RPLACA LL (M1+T (CAR LL)))) ,L)) + +(DEFUN MAKE-GENL-POLY (L1 L2 N) + (DO ((RESULT 1.) (EXP 1. (1+ EXP)) (PRODNUM 1.) (PRODEN 1.) (N N (1- N))) + ((ZEROP N) RESULT) + (SETQ PRODNUM (M*T PRODNUM (M*LT L1)) PRODEN (M*T PRODEN (M*LT L2)) + RESULT (M+T RESULT (M*T PRODNUM (M^T VAR EXP) (M//T PRODEN) + (M//T (FACTORIAL EXP))))) + (LIST-INCR L1) + (LIST-INCR L2))) + +(DEFUN DISPATCH-SPEC-SIMP (L1 L2) + (LET ((LEN1 (LENGTH L1)) (LEN2 (LENGTH L2))) + (COND ((AND (LESSP LEN1 2.) (LESSP LEN2 2.)) + (SIMP2>F<2 L1 L2 (CONS LEN1 LEN2))) + ((AND (EQUAL LEN1 2.) (EQUAL LEN2 1.)) + (SIMP2F1 (FIRST L1) (SECOND L1) (FIRST L2))) + (T (FPQFORM L1 L2 VAR))))) + +(DEFUN SIMP2>F<2 (L1 L2 F-VECT) + (COND ((EQUAL F-VECT '(0. . 0.)) (MEXPT VAR)) + ((EQUAL F-VECT '(0. . 1.)) (BES->TRIG (FIRST L2) VAR)) + ((NULL L2) (M^T (M-T 1. VAR) (M-T (FIRST L1)))) + (T (CONFLUENT (FIRST L1) (FIRST L2) VAR)))) + +(DEFUN BES->TRIG (A X) + (LET (N) + (IF (AND (FIXP (SETQ N (M-T A 1//2))) + (LESSP (ABS N) $BESTRIGLIM)) + (M*T (MGAMMA A) (M^T (MSQRT (M//T -1. X)) (M-T A 1//2)) + (M^T '$%PI -1//2) + (SIMP (BES->TRIG-SUM (1- N) (M*T 2. (MSQRT (M-T X)))))) + (IF (EQ (CHECKSIGNTM X) '$NEGATIVE) + (M*T (MGAMMA A) (M^T (M//T -1. X) (M//T (M1-T A) 2.)) + (BES (M1-T A) (M-T X) 'J)) + (M*T (MGAMMA A) (M^T (M//T X) (M//T (M1-T A) 2.)) + (BES (M1-T A) X 'I)))))) + +(DEFUN BES->TRIG-SUM (N Z) + (LET (FAC) + (IF (MINUSP + (PROG1 N (SETQ FAC (M*T '$%PI (IF (MINUSP N) (SETQ N (1- (- N))) N) + 1//2)))) + (M-T (M* `((%COS) ,(M+T Z FAC)) (TRIG-SUM N Z T)) + (M* `((%SIN) ,(M+T Z FAC)) (TRIG-SUM N Z ()))) + (M+T (M* `((%SIN) ,(M-T Z FAC)) (TRIG-SUM N Z T)) + (M* `((%COS) ,(M-T Z FAC)) (TRIG-SUM N Z ())))))) + +(DEFUN TRIG-SUM (N Z FLG) + (COND ((AND FLG (< N 2.)) 1.) + ((AND (NOT FLG) (ZEROP N)) 0.) + (T (DO ((END (IF FLG (1+ (// N 2.)) (// (1+ N) 2.))) (K 1. (1+ K)) + (2K (IF FLG 2. 3.) (+ 2K 2.)) (RESULT (IF FLG 1. (M//T Z)))) + ((= K END) RESULT) + (SETQ RESULT (M+T RESULT + (M//T (M*T (^ -1. K) + (FACTORIAL (+ N 2K))) + (M*T (FACTORIAL 2K) + (FACTORIAL (- N 2K)) + (M^T (M*T 2. Z) 2K))))))))) + +(DEFUN NEGCOEF (X) + (LET ((D (CDRASS 'D (D*U X)))) + (COND ((NULL D) T) + ((EQ (ASKSIGN (M//T D)) '$POSITIVE) ()) + (T T)))) + +(DEFUN KUMMER (A C) + (M*T (MEXPT VAR) (CONFLUENT (M-T C A) C (M-T VAR)))) + +(DEFUN MEM-ZERO (L) + (DO ((LL L (CDR LL))) + ((NULL LL) ()) + (IF (=0 (CAR LL)) (RETURN 'T)))) + +(DEFUN MEM-NEG (L) + (DO ((LL L (CDR LL))) + ((NULL LL) ()) + (IF (AND (FIXP (CAR LL)) (MINUSP (CAR LL))) (RETURN (CAR LL))))) + +(DEFUN SIMP2F1 (A B C) + (COND ((AND (EQUAL A 1.) (EQUAL B 1.) (EQUAL C 2.)) + (M*T (M//T (M-T VAR)) (MLOG (M1+T (M-T VAR))))) + ((AND (OR (=3//2 C) (=1//2 C)) + (TRIG-LOG A B C))) + ((AND (OR (=1//2 (M-T A B)) (=1//2 (M-T B A))) + (HYP-COS A B C))) + ((AND (INTEGERP A) (INTEGERP B) (INTEGERP C)) + (SIMPR2F1 A B C)) + ((AND (INTEGERP (M+T C 1//2)) (INTEGERP (M+T A B))) + (STEP4 A B C)) + ((AND (INTEGERP (M+T (M-T A B) 1//2)) (STEP7 A B C))) + ((LEGFUN A B C)) + ;; Should be extended here. + (T (FPQFORM (LIST A B) (NCONS C) VAR)))) + +(DEFUN STEP7 (A B C) + (PROG (L M N K MN KL SYM SYM1 R) + (SETQ L (S+C A) + SYM (CDRASS 'F L) + MN (CDRASS 'C L) + L (S+C C) + SYM1 (CDRASS 'F L)) + (COND ((NOT (EQUAL (M*T SYM 2.) SYM1)) (RETURN ()))) + (SETQ KL (CDRASS 'C L) + L (S+C B) + R (M-T (M+T 1//2 (CDRASS 'C L)) MN) + M ($NUM MN) + N ($DENOM MN) + K ($NUM KL) + L ($DENOM KL)) + (COND ((EQUAL (* 2. L) N) + (COND ((INTEGERP (// (- K M) N)) + (RETURN (ALGVH K L M N A B C)))))) + (COND ((INTEGERP (// K (* 2. L))) + (COND ((INTEGERP (// M N)) (RETURN (ALGVH K L M N A B C))) + (T (RETURN ())))) + ((INTEGERP (// M N)) (RETURN ())) + ((INTEGERP (// (- (* K N) (* 2. L M)) (* 2. L N))) + (RETURN (ALGVH K L M N A B C)))) + (RETURN ()))) + +(DEFUN GETXY (K L M N) + (PROG (X Y) + (SETQ Y 0.) + LOOP (COND ((INTEGERP (SETQ X + (// (+ Y (// K L) (* -2. (// M N))) + 2.))) + (RETURN (LIST X Y)))) + (SETQ Y (+ 2. Y)) + (GO LOOP))) + +(DECLARE (SPECIAL FUN B)) + +(DEFUN ALGVH (K L M N A B C) + (PROG (X Y XY A-B W) + (SETQ A-B (- A B)) + (SETQ XY (GETXY K L M N) X (CAR XY) Y (CDR XY)) + (COND ((< X 0.) (GO OUT))) + (COND ((< X Y) + (COND ((< (M+T A-B X 1//2) 0.) + (RETURN (F88 X Y A C FUN))) + (T (RETURN (F87 X Y A C FUN))))) + (T (COND ((< (M+T A-B X 1//2) 0.) + (RETURN (F90 X Y A C FUN))) + (T (RETURN (F89 X Y A C FUN)))))) + OUT (SETQ W (* X -1.)) + (COND ((< (- (M+T A-B 1//2) W) 0.) + (RETURN (F92 X Y A C FUN))) + (T (RETURN (F91 X Y A C FUN)))))) + +(DEFUN F87 (X Y A C FUN) + (M*T (M//T (M*T (APPELL C Y) + (APPELL (M-T (M+T C Y) (M+T A X)) (- X Y)) + (APPELL (M-T (M+T C Y) (M+T A X 1//2)) + (M-T (M+T A X 1//2) (M+T A 1//2))))) + (M^T 'ELL (M-T 1. C)) + (M^T (M-T 1. 'ELL) (M-T (M+T Y C) (M+T A 1//2))) + ($DIFF (M*T (M^T 'ELL (M+T A X)) + (M^T (M-T 1. 'ELL) (M-T A)) + ($DIFF (M*T (M^T 'ELL + (M-T (M+T 1//2 X) Y)) + ($DIFF (M*T (M^T 'ELL + (M-T (M+T C Y) 1.)) + (M^T (M-T 1. 'ELL) + (M-T (M+T 1//2 + (M*T 2. A) + (* 2. X)) + (M+T C Y))) + FUN) + 'ELL + X)) + 'ELL + (- X Y))) + 'ELL + Y))) + +(DEFUN F88 (X Y A C FUN) + (M*T (M//T (M*T (APPELL C Y) + (APPELL (M-T (M+T C Y) (M+T A X)) (- X Y)) + (APPELL (M+T A 1//2 X) + (M-T B (M-T X (M-T A 1//2)))))) + (M^T 'ELL (M-T 1. C)) + (M^T (M-T 1. 'ELL) (M-T (M+T Y C) (M+T A 1//2))) + ($DIFF (M*T (M^T 'ELL (M+T A X)) + (M^T (M-T 1. 'ELL) (M-T A)) + ($DIFF (M*T (M^T 'ELL + (M-T C + (M-T X + (M-T 1//2 + (M*T A 2.))))) + (M^T (M-T 1. 'ELL) + (M-T (M+T A X B) (M-T C Y))) + ($DIFF (M*T (M^T 'ELL (M-T B 1.)) + FUN) + 'ELL + (M-T B (M-T A (M-T X 1//2))))) + 'ELL + (- X Y))) + 'ELL + Y))) + +(DEFUN SIMPR2F1 (A B C) + (LET ((INTA? (FIXP A)) (INTB? (FIXP B))) + (COND ((FIXP C) + (COND ((AND INTA? INTB?) + (DERIVINT (- A 1.) (- B A) (1- (- C B)))) + (INTA? (GEREDNO2 B A C)) + (INTB? (GEREDNO2 A B C)) + (T 'FAIL1))) + (INTA? (IF INTB? 'D 'C)) + ((EQ (CAAR A) 'RAT) (IF INTB? 'C 'D)) + (T 'FAILG)))) + +(DEFUN GEREDNO2 (A B C) + (COND ((GREATERP C B) (GEREDF B A C)) (T (GERED2 A B C)))) + +(DEFUN DERIVINT (N M L) + (SUBST VAR + 'PSEY + (M*T (M^T -1. M) + (FACTORIAL (+ N M L 1.)) + (M//T (FACTORIAL N)) + (M//T (FACTORIAL L)) + (M//T (FACTORIAL (+ N M))) + (M//T (FACTORIAL (+ M L))) + ($DIFF (M*T (M^T (M-T 1. 'PSEY) (+ M L)) + ($DIFF (M*T (M^T 'PSEY -1.) + -1. + (MLOG (M-T 1. 'PSEY))) + 'PSEY + L)) + 'PSEY + (+ N M))))) + +(DEFUN HYP-COS (A B C) + (PROG (A2 A1 Z1) + (SETQ A1 (M//T (M-T (M+T A B) 1//2) 2.)) + (SETQ Z1 (M-T 1. VAR)) + (SETQ A2 (M//T C 2.)) + (COND ((EQUAL (M-T (M+T A B) 1//2) C) + (RETURN (M*T (M^T 2. (M-T (M*T A1 2.) 1.)) + (M//T (MSQRT Z1)) + (M^T (M1+T (MSQRT Z1)) + (M-T 1. (M*T 2. A1))))))) + (COND ((EQUAL (M1+T (M*T 2. A1)) C) + (RETURN (M*T (M^T 2. (M-T C 1.)) + (M^T (M1+T (MSQRT Z1)) + (M-T (M-T C 1.))))))))) + +(DEFUN DEGEN2F1 (A B C) + (COND ((EQ (QUEST (M-T C B)) '$NEGATIVE) + (COND ((EQ (QUEST (M-T C A)) '$NEGATIVE) + (GERED1 (LIST A B) (LIST C) 'HGFSIMP)) + (T (GERED2 A B C)))) + ((EQ (QUEST (M-T C A)) '$NEGATIVE) (GERED2 B A C)) + (T (REST-DEGEN A B C)))) + +(DEFUN REST-DEGEN (A B C) + (PROG (M N L) + (COND ((NON-NEG-INTP (SETQ M (M-T A 1.))) + (RETURN (REST-DEGEN-1 A B C M)))) + (COND ((NON-INTP B) (RETURN (REST-DEGEN-2 A B C)))) + (COND ((AND (NON-NEG-INTP (SETQ N (M-T C 1.))) + (NON-NEG-INTP (SETQ M (M-T (M-T A N) 1.))) + (NON-NEG-INTP (SETQ L (M-T B A))) + (EQ (M-T (M-T C A) B) (M-T (M+T M M N L 1.)))) + (RETURN (GERED1 (LIST A B) (LIST C) 'HGFSIMP)))) + (RETURN (HYP-DEG B A C)))) + +(DEFUN REST-DEGEN-1 (A B C M) + (PROG (N L) + (COND ((AND (NON-INTP B) + (NON-INTP (M-T (M-T C A) B)) + (NON-NEG-INTP (M-T (M-T C A) 1.))) + (RETURN (DEG299 A B C)))) + (COND ((AND (NON-NEG-INTP (SETQ N (M-T (M-T C M) 2.))) + (NON-NEG-INTP (SETQ L (M-T B C))) + (EQUAL (M-T (M-T C A) B) (M-T (M+T L M 1.)))) + (RETURN (GERED1 (LIST A B) (LIST C) 'HGFSIMP)))) + (COND ((NON-NEG-INTP (SETQ L (M-T (M-T B M) 1.))) + (RETURN (REST-DEGEN-1A A B C M L)))) + (RETURN (HYP-DEG B A C)))) + +(DEFUN REST-DEGEN-1A (A B C M L) + (PROG (N) + (COND ((AND (NON-NEG-INTP (SETQ N (M-T (M-T (M-T C M) L) 2.))) + (EQUAL (M-T N M) (M-T (M-T C A) B))) + (RETURN (DEG2913 A B C)))) + (COND ((AND (EQUAL C (M-T N)) + (EQUAL (M-T (M-T C A) B) + (M-T (M+T M M L N 2.)))) + (RETURN (DEG2918 A B C)))) + (RETURN (HYP-DEG B A C)))) + +(DEFUN REST-DEGEN-2 (A B C) + (PROG (M L) + (COND ((AND (NON-INTP C) (NON-INTP (M-T (M-T C A) B))) + (RETURN (REST-DEGEN-2A A B C)))) + (COND ((AND (NON-NEG-INTP (SETQ M (M-T C 1.))) + (NON-NEG-INTP (SETQ L (M-T A C))) + (NON-INTP (M-T (M-T C A) B))) + (RETURN (DEG292 A B C)))) + (RETURN (HYP-DEG B A C)))) + +(DEFUN REST-DEGEN-2A (A B C) + (PROG () + (COND ((NON-NEG-INTP (M-T A C)) + (RETURN (GERED1 (LIST A B) (LIST C) 'HGFSIMP)))) + (COND ((NON-NEG-INTP (M-T (M-T C A) 1.)) (RETURN (DEG2917 A B C)))) + (RETURN (HYP-DEG B A C)))) + +(DEFUN QUEST (A) + (COND ((NUMBERP A) (CHECKSIGNTM A)) + ((EQUAL (CAAR A) 'RAT) (CHECKSIGNTM A)) + (T ()))) + +(DEFUN NON-NEG-INTP (N) (IF (INTEGERP N) (NOT (EQ ($SIGN N) '$NEG)))) + +(DEFUN HYP-DEG (A B C) + (PROG () + (COND (FLDEG (SETQ FLDEG ()) + (RETURN (HGFSIMP (LIST A B) (LIST C) VAR)))) + (SETQ FLDEG T) + (RETURN (FPQFORM (LIST A B) (LIST C) VAR)))) + +(DEFUN DEG2913 (A B C) + (M*T (M^T (M-T VAR) (M-T B)) + (HGFSIMP (LIST (M+T B 1. (M-T C)) B) + (LIST (M+T B 1. (M-T A))) + (M//T VAR)))) + +(DEFUN DEG2918 (A B C) + (M*T (M^T VAR (M-T 1. C)) + (M^T (M-T 1. VAR) (M+T C (M-T A) (M-T B))) + (HGFSIMP (LIST (M-T 1. A) (M-T 1. B)) (LIST (M-T 2. C)) VAR))) + +(DEFUN DEG2917 (A B C) + (M*T (M^T VAR (M-T 1. C)) + (HGFSIMP (LIST (M+T A 1. (M-T C)) (M+T B 1. (M-T C))) + (LIST (M-T 2. C)) + VAR))) + +(DEFUN DEG299 (A B C) + (M*T (M^T (M-T VAR) (M-T A)) + (HGFSIMP (LIST A (M+T A 1. (M-T C))) + (LIST (M+T A 1. (M-T B))) + (M//T VAR)))) + +(DEFUN LEGFUN (A B C) + (LET ((1-C (M-T 1. C)) (A-B (M-T A B)) (C-A-B (M-T (M-T C A) B))) + (COND ((=1//2 A-B) (GERED1 (LIST A B) (LIST C) 'LEGF24)) + ((=-1//2 A-B) (LEGF24 (LIST A B) (LIST C) VAR)) + ((=1//2 C-A-B) (LEGF20 (LIST A B) (LIST C) VAR)) + ((=-1//2 C-A-B) (GERED1 (LIST A B) (LIST C) 'LEGF20)) + ((ALIKE1 1-C A-B) (LEGF16 (LIST A B) (LIST C) VAR)) + ((ALIKE1 1-C (M-T A-B)) (GERED1 (LIST A B) (LIST C) 'LEGF16)) + ((ALIKE1 1-C C-A-B) (GERED1 (LIST A B) (LIST C) 'LEGF14)) + ((ALIKE1 1-C (M-T C-A-B)) (LEGF14 (LIST A B) (LIST C) VAR)) + ((ALIKE1 A-B (M-T C-A-B)) (LEGF36 (LIST A B) (LIST C) VAR)) + ((OR (=1//2 1-C) (=-1//2 1-C)) (LEGPOL A B C)) + ((ALIKE1 A-B C-A-B) 'LEGENDRE-FUNCT-TO-BE-DISCOVERED) + (T ())))) + +(DEFUN LEGF20 (L1 L2 VAR) + (PROG (M N B C) + (SETQ B (CADR L1) C (CAR L2)) + (SETQ M (M-T 1. C) N (M-T (M+T B B M))) + (RETURN (M*T (LF N M) + (LEGEN N M (MSQRT (M-T 1. VAR)) 'P))))) + +(DEFUN LEGF24 (L1 L2 VAR) + (PROG (M N A C) + (SETQ A (CAR L1) + C (CAR L2) + M (M-T 1. C) + N (M-T (M+T A A M))) + (RETURN (M*T (LF N M) + (M^T VAR (M+T N M)) + (LEGEN N M (M^T (M-T 1. VAR) -1//2) 'P))))) + +(DEFUN LEGF16 (L1 L2 VAR) + (PROG (M N A C) + (SETQ A (CAR L1) C (CAR L2) M (M-T 1. C) N (M-T A)) + (RETURN (M*T (M^T 2. (M-T N)) + (M^T (M-T VAR 1.) (M//T M -2.)) + (M//T (MGAMMA (M-T 1. M))) + (M^T (M+T VAR 1.) (M+T (M//T M 2.) N)) + (LEGEN N M (M//T (M1+T VAR) (M-T 1. VAR)) 'P))))) + +(DEFUN LF (N M) + (M*T (M^T 2. M) + (M//T (M^T (M-T (M^T VAR 2.) 1.) (M//T M 2.))) + (M//T (MGAMMA (M-T 1. M))))) + +(DEFUN LEGF14 (L1 L2 VAR) + (PROG (M N A C B L) + (SETQ L (S+C (CAR L1)) + A (COND ((EQUAL (CDRASS 'C L) 0.) + (CDRASS 'F L)) + (T (M-T (CDRASS 'F L)))) + C (CAR L2) + M (M-T 1. C) + N (M-T A)) + (RETURN (M*T (M^T (M+T VAR 1.) (M//T M 2.)) + (M^T (M-T VAR 1.) (M//T M -2.)) + (M//T (MGAMMA (M-T 1. M))) + (LEGEN N M (M-T 1. (M*T 2. VAR)) 'P))))) + +(DEFUN LEGF36 (L1 L2 VAR) + (PROG (N M A B) + (SETQ A (CAR L1) B (CADR L1) N (M-T B 1.) M (M-T B A)) + (RETURN (M*T (M^T 2. N) + (MGAMMA (M1+T N)) + (MGAMMA (M1+T (M+T N M))) + (M^T (M+T VAR 1.) + (M+T (M//T M 2.) (M-T N) -1.)) + (M^T (M-T VAR 1.) (M//T M -2.)) + (M//T (MGAMMA (M+T 2. N N))) + (MEXPT (M*T -1 '$%I '$%PI M)) + (LEGEN N M (M//T (M-T 2. VAR) VAR) 'Q))))) + +(DEFUN LEGPOL (A B C) + (PROG (L V) + (COND ((NOT (MEM-NEG (LIST A))) + (RETURN 'FAIL-1-IN-C-1-CASE))) + (SETQ L (VFVP (M//T (M+T B A) 2.))) + (SETQ V (CDR (ASSOC 'V L))) + (COND ((AND (=1//2 V) (EQUAL C 1.)) + (RETURN (LEGENPOL (M-T A) (M-T 1. (M*T 2. VAR)))))) + (COND ((AND (=1//2 C) (=1//2 (M-T B A))) + (RETURN (M*T (FACTORIAL (M-T A)) + (M^T 2. A) + (MULTAUG 1//2 (M-T A)) + (LEGENPOL (M-T A) + (M^T VAR -1//2)))))) + (RETURN ()))) + +(DEFUN MULTAUG (A N) + (IF (=0 N) 1. (M*T A (MULTAUG (M1+T A) (1- N))))) + +(DEFUN GERED1 (L1 L2 SIMPFLG) + (M*T (M^T (M-T 1. VAR) + (M+T (CAR L2) (M-T (CAR L1)) (M-T (CADR L1)))) + (FUNCALL SIMPFLG + (LIST (M-T (CAR L2) (CAR L1)) + (M-T (CAR L2) (CADR L1))) + L2 + VAR))) + +(DEFUN GERED2 (A B C) + (M*T (M^T (M-T 1. VAR) (M-T A)) + (HGFSIMP (LIST A (M-T C B)) (LIST C) (M//T VAR (M-T VAR 1.))))) + +(DEFUN GEREDF (A B C) + (LET (X) + (M+T (M//T (M*T (MGAMMA C) + (MGAMMA (M-T C (M+T A B))) + (M^T VAR (M-T A)) + (HGFSIMP (LIST A (SETQ X (M+T A 1. (M-T C)))) + (LIST (M+T X B)) + (M-T 1. (M//T VAR)))) + (M*T (MGAMMA (M-T C A)) (MGAMMA (M-T C B)))) + (M//T (M*T (MGAMMA C) + (MGAMMA (M+T A B (M-T C))) + (M^T (M-T 1. VAR) (M+T C (M-T A) (M-T B))) + (M^T VAR (M-T A C)) + (HGFSIMP (LIST (M-T C A) (M-T 1. A)) + (LIST (M-T (M1+T C) (M+T A B))) + (M-T 1. (M//T VAR)))) + (M*T (MGAMMA A) (MGAMMA B)))))) + +(DEFUN TRIG-LOG (A B C) + (COND ((=3//2 C) (TRIG-LOG-3 A B)) + ((=1//2 C) (TRIG-LOG-1 A B)) + (T ()))) + +(DEFUN TRIG-LOG-3 (A B) ;; 2F1's with C = 3/2 + (COND ((AND (OR (EQUAL A 1.) (EQUAL B 1.)) + (OR (=1//2 A) (=1//2 B))) + (TRIG-LOG-3-EXEC)) + ((AND (EQUAL A B) (OR (EQUAL A 1.) (=1//2 A))) + (TRIG-LOG-3A-EXEC A)) + ((LET ((TEMP (M+T A B))) (OR (EQUAL TEMP 1.) (EQUAL TEMP 2.))) + (TRIG-SIN A B)) + ((=1//2 (MABS (M-T B A))) (TRIG-3 A B)) + (T ()))) + +(DEFUN TRIG-3 (A B) ;; 15.1.10 + (LET ((Z (MSQRT VAR))) + (M//T (M-T (M^T (M1+T Z) (SETQ A (M-T 3//2 (M+T A B)))) + (M^T (M-T 1. Z) A)) + (M*T 2. A Z)))) + +(DEFUN TRIG-SIN (A B) ;; 15.1.15 and 15.1.16 + (LET (Z) + (COND ((EQUAL (M+T A B) 1.) + (M//T (MSIN (M*T (SETQ B (M-T A B)) + (MASIN (SETQ Z (MSQRT VAR))))) + (M*T B Z))) + ((EQUAL (M+T A B) 2.) + (M//T (MSIN (M*T (SETQ B (M1-T A)) + (SETQ Z (M*T 2. (MASIN (MSQRT VAR)))))) + (M*T B (MSIN Z)))) + (T ())))) + +(DEFUN TRIG-LOG-3-EXEC () ;; 15.1.4 and 15.1.5 + (LET (Z) + (COND ((EQUAL (CHECKSIGNTM VAR) '$POSITIVE) + (M//T (MLOG (M//T (M1+T (SETQ Z (MSQRT VAR))) (M-T 1. Z))) + (M*T 2. Z))) + ((EQUAL (CHECKSIGNTM VAR) '$NEGATIVE) + (M//T (MATAN (SETQ Z (MSQRT (M-T VAR)))) Z)) + (T ())))) + +(DEFUN TRIG-LOG-3A-EXEC (A) ;; 15.1.6 and 15.1.7 + (LET (Z) + (COND ((EQUAL (CHECKSIGNTM VAR) '$POSITIVE) + (M*T (IF (EQUAL A 1.) (M^T (M-T 1 VAR) -1//2) 1.) + (MASIN (SETQ Z (MSQRT VAR))) + (M//T Z))) + ((EQUAL (CHECKSIGNTM VAR) '$NEGATIVE) + (M*T (M^T (SETQ Z (M-T VAR)) -1//2) + (MLOG (M+T (MSQRT Z) (MSQRT (SETQ Z (M-T 1. VAR))))) + (IF (EQUAL A 1.) (M^T Z -1//2) 1.))) + (T ())))) + +(DEFUN TRIG-LOG-1 (A B) ;; 2F1's with C = 1/2 + (LET (X Z $EXPONENTIALIZE) ;; 15.1.17, 11, 18, 12, 9, and 19 + (COND ((=0 (M+T A B)) + (COND ((EQUAL (CHECKSIGNTM VAR) '$POSITIVE) + (MCOS (M*T 2. A (MASIN (MSQRT VAR))))) + ((EQUAL (CHECKSIGNTM VAR) '$NEGATIVE) + (M*T 1//2 + (M+T (M^T (M+T (SETQ X (MSQRT (M-T 1. VAR))) + (SETQ Z (MSQRT (M-T VAR)))) + (SETQ B (M*T 2. B))) + (M^T (M-T X Z) B)))) + (T ()))) + ((EQUAL (M+T A B) 1.) + (COND ((EQUAL (CHECKSIGNTM VAR) '$POSITIVE) + (M//T (MCOS (M*T (M-T A B) (SETQ Z (MASIN (MSQRT VAR))))) + (MCOS Z))) + ((EQUAL (CHECKSIGNTM VAR) '$NEGATIVE) + (M*T 1//2 (M//T (SETQ X (MSQRT (M-T 1. VAR)))) + (M+T (M^T (M+T X (SETQ Z (MSQRT (M-T VAR)))) + (SETQ B (M-T A B))) + (M^T (M-T X Z) B)))) + (T ()))) + ((=1//2 (MABS (M-T B A))) + (COND ((EQUAL (CHECKSIGNTM VAR) '$POSITIVE) + (M*T 1//2 + (M+T (M^T (M1+T (SETQ Z (MSQRT VAR))) + (SETQ B (M-T 1//2 (M+T A B)))) + (M^T (M-T 1. Z) B)))) + ((EQUAL (CHECKSIGNTM VAR) '$NEGATIVE) + (M*T (M^T (MCOS (SETQ Z (MATAN (MSQRT (M-T VAR))))) + (SETQ B (M+T A B -1//2))) + (MCOS (M*T B Z)))) + (T ()))) + (T ())))) + +;; List L contains two elements first the numerator parameter that +;; exceeds the denumerator one and is called "C", second the difference of +;; the two parameters which is called "M". + +(DEFUN DIFFINTPROP-GEN-EXEC (L L1 L2) + (PROG (C M POLY CONSTFACT) + (SETQ C (CAR L) + M (CADR L) + L1 (DELETE C L1 1.) + C (M-T C M) + L2 (DELETE C L2 1.) + POLY ($EXPAND (APPELL (M+T C 'AVGOUSTIS) M)) + CONSTFACT (CREATECONSTFACT C M)) + (RETURN (YANMULT CONSTFACT (DIFFINTPROP-EXEC POLY L1 L2))))) + +(DEFUN CREATECONSTFACT (C M) + (COND ((ZEROP M) 1.) + (T (M*T (M//T (M+T C (SUB1 M))) + (CREATECONSTFACT C (SUB1 M)))))) + +(DEFUN DIFFINTPROP-EXEC (POLY L1 L2) + (DISTRDIFFINTPROP (CREATECOEFPOWLIST-EXEC POLY) L1 L2)) + +(DEFUN DISTRDIFFINTPROP (L L1 L2) + (COND ((NULL L) 0.) + (T (M+T (YANMULT ($FACTOR (CADAR L)) + (DIFFINTPROP (CAAR L) L1 L2)) + (DISTRDIFFINTPROP (CDR L) L1 L2))))) + +(DEFUN DIFFINTPROP (POW L1 L2) + (COND ((ZEROP POW) (HGFSIMP L1 L2 VAR)) + ((EQUAL POW 1.) + (YANMULT (M*T (M//T (M*LT L1) (M*LT L2)) VAR) + (HGFSIMP (LIST-INCR L1) (LIST-INCR L2) VAR))) + (T (SEARCHADDSERIESLIST POW L1 L2)))) + +(DEFUN SEARCHADDSERIESLIST (POW L1 L2) + (PROG (SERIES RES) + (COND ((SETQ SERIES (SEARCHSERIESLISTP SERIESLIST POW)) + (RETURN (EVAL SERIES)))) + (SETQ + SERIESLIST + (APPEND + SERIESLIST + (LIST + (LIST + POW + (SETQ RES + '(YANMULT (M*T (M//T (M*LT L1) (M*LT L2)) VAR) + (DIFFINTPROPRECURSE (SUB1 POW) + (LIST-INCR L1) + (LIST-INCR L2)))))))) + (RETURN (EVAL RES)))) + +(DEFUN DIFFINTPROPRECURSE (POW L1 L2) + (PROG (POLY) + (SETQ POLY ($EXPAND (M^T (M+T 'AVGOUSTIS 1.) POW))) + (RETURN (DIFFINTPROP-EXEC POLY L1 L2)))) + +(DEFUN CREATECOEFPOWLIST-EXEC (POLY) + (PROG (HP CONSTER) + (SETQ CONSTER (CONSTERMINIT POLY 'AVGOUSTIS) + HP ($HIPOW POLY 'AVGOUSTIS)) + (RETURN (APPEND (LIST (LIST 0. CONSTER)) + (CREATECOEFPOWLIST POLY HP))))) + +(DEFUN CREATECOEFPOWLIST (POLY HP) + (COND ((EQUAL HP 1.) + (LIST (LIST 1. ($COEFF POLY 'AVGOUSTIS)))) + (T (APPEND (CREATECOEFPOWLIST POLY (SUB1 HP)) + (LIST (LIST HP + ($COEFF POLY + (M^T 'AVGOUSTIS + HP)))))))) + +(DEFUN CONSTERMINIT (FUN VAR) + (COND ((EQ (CAAR FUN) 'MPLUS) (CONSTERM (CDR FUN) VAR)) + (T (COND ((HYP-FREEVAR FUN) FUN) (T 0.))))) + +(DEFUN CONSTERM (FUN VAR) + (COND ((NULL FUN) 0.) + ((HYP-FREEVAR (CAR FUN)) (M+T (CAR FUN) (CONSTERM (CDR FUN) VAR))) + (T (CONSTERM (CDR FUN) VAR)))) + +(DEFUN SEARCHSERIESLISTP (SERIESLIST POW) + (COND ((NULL SERIESLIST) ()) + ((EQUAL (CAAR SERIESLIST) POW) (CADAR SERIESLIST)) + (T (SEARCHSERIESLISTP (CDR SERIESLIST) POW)))) + +(DEFUN YANMULT (A B) + (IF (EQ (CAAR B) 'MPLUS) (YANMUL A (CDR B)) (M*T A B))) + +(DEFUN YANMUL (A B) + (IFN B 0 (M+T (M*T A (CAR B)) (YANMUL A (CDR B))))) + +(DEFUN FREEVARPAR (EXP) (COND ((HYP-FREEVAR EXP) (FREEPAR EXP)) (T ()))) + +(DECLARE (SPECIAL SERIESLIST VAR PAR ZEROSIGNTEST PRODUCTCASE)) + +(SETQ PAR '$P) + +(DEFUN HYP-FREEVAR (A) + (COND + ((ATOM A) (NOT (EQ A VAR))) + ((ALIKE1 A VAR) ()) + ((AND (NOT (ATOM (CAR A))) (MEMQ 'ARRAY (CDAR A))) + (COND + ((HYP-FREEVAR (CDR A)) T) + (T (MERROR "VARIABLE-OF-INTEGRATION-APPEARED-IN-SUBSCRIPT") + ))) + (T (AND (HYP-FREEVAR (CAR A)) (HYP-FREEVAR (CDR A)))))) + +(DEFUN FREEPAR (EXP) + (COND ((ATOM EXP) (NOT (EQ EXP PAR))) + (T (AND (FREEPAR (CAR EXP)) (FREEPAR (CDR EXP)))))) + +(DEFUN HASPAR (EXP) (COND ((FREEPAR EXP) ()) (T T))) + +(DEFUN CONFLUENT (A C VAR) + (LET (TEMP) + (COND ((ALIKE1 C (M*T 2. A)) + (M*T (MEXPT (M//T VAR 2.)) + (BES->TRIG (M+T A 1//2) (M//T (M^T VAR 2.) 16.)))) + ((FIXP (SETQ TEMP (M-T A C))) + (IF (MINUSP TEMP) (ERFGAMMARED A C VAR) (KUMMER A C))) + ((FIXP A) (KUMMER A C)) + (T (SETQ TEMP (M//T (M1-T C) 2.)) + (M*T (M^T VAR (M-T -1//2 TEMP)) (MEXPT (M//T VAR 2.)) + (WHITFUN (M+T 1//2 TEMP (M-T A)) TEMP VAR)))))) + +(DEFUN HYPREDERF (X) + (M//T (M*T (MSQRT '$%PI) (MERF (SETQ X (MSQRT (M-T X))))) + (M*T 2 X))) + +(DEFUN ERFGAMMARED (A C Z) + (COND ((AND (MNUMP A) (MNUMP C)) (ERFGAMNUMRED A C Z)) + (T (GAMMAREDS A C Z)))) + +(DEFUN GAMMAREDS (A C Z) + (PROG (M NUMPROD RESULT COUNT ATEMP) + (SETQ M (M-T C A)) + (COND ((= M 1.) (RETURN (HYPREDINCGM A Z)))) + (SETQ NUMPROD (APPELL A M) + COUNT 2. + ATEMP A + RESULT (M-T (M*T 2. + NUMPROD + (M//T ATEMP) + (HYPREDINCGM ATEMP Z)) + (M*T 2. + NUMPROD + (M//T (SETQ ATEMP (M+T ATEMP 1.))) + (HYPREDINCGM ATEMP Z)))) + LOOP (COND ((= COUNT M) (RETURN RESULT))) + (SETQ COUNT + (1+ COUNT) + ATEMP + (M+T ATEMP 1.) + RESULT + (M+T RESULT + (M*T (^ -1. COUNT) + (M//T (FACTORIAL (M-T M (1- COUNT)))) + NUMPROD + (M//T ATEMP) + (HYPREDINCGM ATEMP Z)))) + (GO LOOP))) + +(DEFUN HYPREDINCGM (A Z) + (M*T A (M^T (SETQ Z (M-T Z)) (M-T A)) `(($%GAMMAGREEK) ,A ,Z))) + +(DEFUN ERFGAMNUMRED (A C Z) + (IF (FIXP (M-T C 1//2)) (ERFRED A C Z) (GAMMAREDS A C Z))) + +(DEFUN ERFRED (A C Z) + (LET ((N (M-T A 1//2)) (M (M-T C 3//2))) + (COND ((NOT (OR (> N M) (MINUSP N))) (THNO33 N M Z)) + ((AND (MINUSP N) (MINUSP M)) (THNO35 (- N) (- M) Z)) + ((AND (MINUSP N) (PLUSP M)) (THNO34 (- N) M Z)) + (T (GAMMAREDS A C Z))))) + +;; This computes what is uaually known as Pochammer's or Apell's symbol. + +(DEFUN APPELL (A N) + (IF (=0 N) 1 + (DO ((ANS A) (K 1. (1+ K))) + ((EQUAL K N) ANS) + (SETQ ANS (M*T (M+T A K) ANS))))) + +(DEFUN THNO33 (N M X) + (LET ((M-N (- M N))) + (MEVAL (M*T (M//T (M*T (^ -1. M-N) (APPELL 3//2 M-N) + (APPELL (M+T M-N 3//2) N)) + (M*T (APPELL 1. M-N) (APPELL 1//2 N))) + (SUBSTITUTE X 'X + ($DIFF (M*T (MEXPT 'X) + ($DIFF (M*T (MEXPT (M-T 'X)) (HYPREDERF 'X)) + 'X + M-N)) + 'X N)))))) + + + +(DEFUN THNO34 (N M X) + (MEVAL (substitute x 'x + (M*T (^ -1. M) (M//T (M*T (APPELL 3//2 M) (MEXPT 'X)) + (M*T (APPELL 1. M) (APPELL (1+ M) N) + (M^T 'X M))) + ($DIFF (M*T (M^T 'X (+ M N)) + ($DIFF (M*T (MEXPT (M-T 'X)) (HYPREDERF 'X)) + 'X M)) + 'X N))))) + +(DEFUN THNO35 (N M X) + (MEVAL (substitute x 'x + (M*T (M//T (M^T 'X (M-T M 1//2)) (M*T (M^T -1. (TIMES -1. M)) + (APPELL 1. N) (APPELL -1//2 M))) + ($DIFF (M*T (MSQRT 'X) (MEXPT 'X) + ($DIFF (M*T (MEXPT (M-T 'X)) (M^T 'X N) + (HYPREDERF 'X)) + 'X N)) + 'X M))))) + +(DEFUN CHECKSIGNTM (EXPR) + (PROG (ASLIST QUEST ZEROSIGNTEST PRODUCTCASE) + (SETQ ASLIST CHECKCOEFSIGNLIST) + (COND ((ATOM EXPR) (GO LOOP))) + (COND ((EQ (CAAR EXPR) 'MTIMES) (SETQ PRODUCTCASE T))) + LOOP (COND + ((NULL ASLIST) + (SETQ + CHECKCOEFSIGNLIST + (APPEND + CHECKCOEFSIGNLIST + (LIST (CONS EXPR + (LIST (SETQ QUEST (CHECKFLAGANDACT EXPR))))))) + (RETURN QUEST))) + (COND ((EQUAL (CAAR ASLIST) EXPR) (RETURN (CADAR ASLIST)))) + (SETQ ASLIST (CDR ASLIST)) + (GO LOOP))) + +(DEFUN CHECKFLAGANDACT (EXPR) + (COND + (PRODUCTCASE + (SETQ PRODUCTCASE ()) + (FINDSIGNOFTHEIRPRODUCT (FINDSIGNOFACTORS (CDR EXPR)))) + (T (ASKSIGN ($REALPART EXPR))))) + +(DEFUN FINDSIGNOFACTORS (LISTOFACTORS) + (COND ((NULL LISTOFACTORS) ()) + ((EQ ZEROSIGNTEST '$ZERO) '$ZERO) + (T (APPEND (LIST (SETQ ZEROSIGNTEST + (CHECKSIGNTM (CAR LISTOFACTORS)))) + (FINDSIGNOFACTORS (CDR LISTOFACTORS)))))) + +(DEFUN FINDSIGNOFTHEIRPRODUCT (LIST) + (PROG (SIGN) + (COND ((EQ LIST '$ZERO) (RETURN '$ZERO))) + (SETQ SIGN '$POSITIVE) + LOOP (COND ((NULL LIST) (RETURN SIGN))) + (COND ((EQ (CAR LIST) '$POSITIVE) + (SETQ LIST (CDR LIST)) + (GO LOOP))) + (COND ((EQ (CAR LIST) '$NEGATIVE) + (SETQ SIGN (CHANGESIGN SIGN) LIST (CDR LIST)) + (GO LOOP))) + (RETURN '$ZERO))) + +(DEFUN CHANGESIGN (SIGN) + (COND ((EQ SIGN '$POSITIVE) '$NEGATIVE) + (T '$POSITIVE))) + +(SETQ PAR '$P) + +(DEFUN VFVP (EXP) (M2 EXP '(V FREEVARPAR) ())) + +(DEFUN D*U (EXP) + (M2 EXP + '((MTIMES) ((COEFFTT) (D FREEPAR)) ((COEFFTT) (U HASPAR))) + ())) + +(DEFUN FPQFORM (L1 L2 ARG) + `((MQAPPLY) (($%F ARRAY) ,(LENGTH L1) ,(LENGTH L2)) + ,(CONS '(MLIST) L1) + ,(CONS '(MLIST) L2) + ,ARG)) + +(DEFUN SPLITPFQ (L L1 L2) + (PROG (RESULT PRODNUM PRODEN COUNT K A1 B1) + (SETQ RESULT 0. PRODNUM 1. PRODEN 1. COUNT 0. + K (CADR L) A1 (CAR L) B1 (M-T A1 K) L1 (DELETE A1 L1 1.) + L2 (DELETE B1 L2 1.) RESULT (HGFSIMP L1 L2 VAR)) + LOOP (COND ((= COUNT K) (RETURN RESULT))) + (SETQ COUNT (1+ COUNT) + PRODNUM (M*T PRODNUM (M*LT L1)) + PRODEN (M*T PRODEN (M*LT L2)) + RESULT (M+T RESULT + (M*T (MBINOM K COUNT) + (M//T PRODNUM PRODEN) + (M^T VAR COUNT) + (HGFSIMP (SETQ L1 (LIST-INCR L1)) + (SETQ L2 (LIST-INCR L2)) + VAR)))) + (GO LOOP))) + +;; Algor. II from thesis:minimizes differentiations + +(DEFUN ALGII (A B C) + (PROG (M N AP CON SYM M+N) + (COND ((NOT (SETQ SYM (CDRASS 'F (S+C A)))) + (SETQ SYM 0.))) + (SETQ CON (M-T A SYM)) + (SETQ AP SYM) + (SETQ M+N (M+T A B)) + (SETQ M ($ENTIER CON)) + (IF (MINUSP M) (SETQ M (ADD1 M))) + (SETQ AP (M+T (M-T CON M) AP)) + (SETQ N (M+T B AP)) + (COND ((AND (MINUSP (M*T N M)) (GREATERP (ABS M) (ABS N))) + (RETURN (LIST AP (M-T AP N) M+N)))) + (RETURN (LIST AP (M+T AP M) M+N)))) + +;; Algor. 2F1-RL from thesis:step 4:dispatch on a+m,-a+n,1/2+l cases + +(DEFUN STEP4 (A B C) + (PROG (APRIME M N $RATSIMPEXPONENS $RATPRINT NEWF ALGLIST) + (SETQ ALGLIST (ALGII A B C) + APRIME (CADR ALGLIST) + M (CADDR ALGLIST) + N (M-T C 1//2)) + (SETQ $RATSIMPEXPONENS T $RATPRINT NIL) + (SETQ NEWF + ($RATSIMP (SUBST APRIME + 'PSA + (M^T (M+T 1//2 + (M*T (M^T (M-T 1. VAR) + 1//2) + 1//2)) + (M-T 1. + (M*T 2. 'PSA)))))) + (RETURN (SUBST VAR + 'ELL + (ALGIII (SUBST 'ELL VAR NEWF) + M + N + APRIME))))) + +;; Pattern match for s(ymbolic) + c(onstant) in parameter + +(DEFUN S+C (EXP) + (M2 EXP + '((MPLUS) ((COEFFPT) (F NONNUMP)) ((COEFFPP) (C $NUMBERP))) + ())) + +(DEFUN NONNUMP (Z) (COND ((NOT ($NUMBERP Z)) T) (T ()))) + +;; Algor. III from thesis:determines which Differ. Formula to use + +(DEFUN ALGIII (FUN M N APRIME) + (PROG (MM NN) + (SETQ MM (ABS M) NN (ABS N)) + (COND ((AND (NON-NEG-INTP M) (NON-NEG-INTP N)) + (COND ((LESSP M N) (RETURN (F81 FUN M N APRIME))) + (T (RETURN (F85 FUN MM NN APRIME))))) + ((AND (HYP-NEGP N) (HYP-NEGP M)) + (COND ((GREATERP (ABS N) (ABS M)) + (RETURN (F86 FUN MM NN APRIME))) + (T (RETURN (F82 FUN MM NN APRIME))))) + ((AND (HYP-NEGP M) (NON-NEG-INTP N)) (RETURN (F83 FUN MM NN APRIME))) + (T (RETURN (F84 FUN MM NN APRIME)))))) + +;; Formula #85 from Yannis thesis:finds by differentiating F[2,1](a,b,c,z) +;; given F[2,1](a+m,b,c+n,z) where b=-a and c=1/2, n,m integers + +(DEFUN F85 (FUN M N A) + (M*T (APPELL 1//2 N) + (M//T (M^T -1. N)) + (M//T (APPELL (M-T (M+T A M) N) N)) + (M//T (APPELL (M-T 1//2 (M*T A -1.)) N)) + (M//T (APPELL A (- M N))) + (M^T (M-T 1. 'ELL) (M-T (M-T (M1+T N) M) A)) + ($DIFF (M*T (M^T (M-T 1. 'ELL) (M-T (M+T A M) 1.)) + (M^T 'ELL (M-T 1. A)) + ($DIFF (M*T (M^T 'ELL + (M-T (M+T A M -1.) N)) + FUN) + 'ELL + (- M N))) + 'ELL + N))) +;Used to find negative things that are not integers,eg RAT's + +(DEFUN HYP-NEGP (X) + (COND ((EQUAL (ASKSIGN X) '$NEGATIVE) T) (T ()))) + +(DEFUN F81 (FUN M N A) + (M*T (APPELL (M+T 1//2 (- N M)) M) + (APPELL 1//2 (- N M)) + (M//T (M^T -1. M)) + (M//T (APPELL A M)) + (M//T (APPELL (M+T 1//2 N (M-T A M)) M)) + (M//T (APPELL (M-T 1//2 A) (- N M))) + (M//T (APPELL (M+T 1//2 A) (- N M))) + (M^T (M-T 1. 'ELL) (M-T 1. A)) + ($DIFF (M*T (M^T (M-T 1. 'ELL) (M+T A N -1//2)) + ($DIFF (M*T (M^T (M-T 1. 'ELL) -1//2) + FUN) + 'ELL + (- N M))) + 'ELL + M))) + +(DEFUN F82 (FUN M N A) + (M*T (M//T (APPELL (M-T 1//2 N) M)) + (M//T (APPELL (M-T (M+T 1//2 M) N) (- N M))) + (M^T 'ELL (M+T N 1//2)) + (M^T (M-T 1. 'ELL) (M-T (M+T M 1//2 A) N)) + ($DIFF (M*T (M^T (M-T 1. 'ELL) + (M-T (M-T N A) 1//2)) + ($DIFF (M*T (M^T 'ELL -1//2) FUN) + 'ELL + (- N M))) + 'ELL + M))) + +(DEFUN F83 (FUN M N A) + (M*T (APPELL 1//2 N) + (M//T (APPELL (M-T 1//2 A) N)) + (M//T (APPELL (M+T (M-T 1//2 A) N) M)) + (M//T (APPELL (M+T 1//2 A) N)) + (M^T (M-T 1. 'ELL) (M+T M N 1//2)) + (M^T 'ELL (M-T (M+T 1//2 A) N)) + ($DIFF (M*T (M^T 'ELL (M-T (M-T (+ M N) A) 1//2)) + ($DIFF (M*T (M^T (M-T 1. 'ELL) -1//2) + FUN) + 'ELL + N)) + 'ELL + M))) + +(DEFUN F84 (FUN M N A) + (M*T (M//T (M*T (APPELL A M) (APPELL (M-T 1//2 N) N))) + (M^T 'ELL (M-T 1. A)) + ($DIFF (M*T (M^T 'ELL (M-T (M+T A M N) 1//2)) + ($DIFF (M*T (M^T 'ELL -1//2) FUN) + 'ELL + N)) + 'ELL + M))) + +(DEFUN F86 (FUN M N A) + (M*T (M//T (M*T (APPELL (M-T 1//2 N) N) + (APPELL (M-T 1//2 A) (- M N)))) + (M^T 'ELL (M+T N 1//2)) + (M^T (M-T 1. 'ELL) (M+T 1//2 A)) + ($DIFF (M*T (M^T 'ELL A) + (M^T (M-T 1. 'ELL) (M-T M A)) + ($DIFF (M*T (M^T 'ELL + (M-T (M-T (M-T M N) 1//2) + A)) + (M^T (M-T 1. 'ELL) -1//2) + FUN) + 'ELL + (- M N))) + 'ELL + N))) + + \ No newline at end of file diff --git a/src/ell/hypgeo.9 b/src/ell/hypgeo.9 new file mode 100644 index 00000000..6e94ba72 --- /dev/null +++ b/src/ell/hypgeo.9 @@ -0,0 +1,2395 @@ +; -*- LISP -*- +;** (c) Copyright 1981 Massachusetts Institute of Technology ** +;These are the main routines for finding the Laplace Transform +; of special functions --- written by Yannis Avgoustis +; --- modified by Edward Lafferty +; Latest mod by jpg 8/21/81 +; +; This program uses the programs on ELL;HYP FASL. + +(macsyma-module hypgeo) + +(DECLARE (SPECIAL VAR PAR ZEROSIGNTEST PRODUCTCASE CHECKCOEFSIGNLIST + $EXPONENTIALIZE $RADEXPAND)) + +(load-macsyma-macros rzmac) + +(DEFUN BESS + (V Z FLG) + (LIST '(MQAPPLY) + (LIST (COND ((EQ FLG 'J)'($%J ARRAY)) + (T '($%I ARRAY))) + V) + Z)) + +(DEFUN CDRAS(A L)(CDR (ASSOC A L))) + +(DEFUN GM(EXPR)(SIMPLIFYA (LIST '(%GAMMA) EXPR) NIL)) + +(DEFUN SIN%(ARG)(LIST '(%SIN) ARG)) + +(DEFUN NUMP + (X) + (COND ((ATOM X)(NUMBERP X)) + ((NOT (ATOM X))(EQ (CAAR (SIMPLIFYA X NIL)) 'RAT)))) + +(DEFUN COS%(ARG)(LIST '(%COS) ARG)) + +(DEFUN NEGINP (A) (COND ((INTEGERP A)(OR (ZERP A)(MINUSP A))))) + +(DEFUN NOTNUMP(X)(NOT (NUMP X))) + +(DEFUN NEGNUMP + (X) + (COND ((NOT (INTEGERP X)) + (MINUSP (CADR (SIMPLIFYA X NIL)))) + (T (MINUSP X)))) + + + +(DEFUN EXPOR1P(EXP)(OR (EQUAL EXP 1)(EQ EXP '$%E))) + +(DEFUN PARP(A)(EQ A PAR)) + + + +(DEFUN HASVAR(EXP)(COND ((FREEVAR EXP) NIL)(T T))) + + + +(DEFUN ARBPOW1 + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (C NONZERP) + ((MEXPT)(U HASVAR)(V FREEVAR))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN U*ASINX + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) (U NONZERP)((%ASIN)(X HASVAR))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN U*ATANX + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT)(U NONZERP)((%ATAN)(X HASVAR))) + ((COEFFPP)(A ZERP))) + NIL)) + + + +(DEFUN GMINC(A B)(LIST '($GAMMAINCOMPLETE) A B)) + +(DEFUN LITTLESLOMMEL + (M N Z) + (LIST '(MQAPPLY)(LIST '($%S ARRAY) M N) Z)) + +(DEFUN MWHIT(A I1 I2)(LIST '(MQAPPLY)(LIST '($%M ARRAY) I1 I2) A)) + +(DEFUN WWHIT(A I1 I2)(LIST '(MQAPPLY)(LIST '($%W ARRAY) I1 I2) A)) + +(DEFUN PJAC(X N A B)(LIST '(MQAPPLY)(LIST '($%P ARRAY) N A B) X)) + +(DEFUN PARCYL(X N)(LIST '(MQAPPLY)(LIST '($%D ARRAY) N) X)) + + +;...HOPEFULLY AMONG WHATEVER GARBAGE IT RECOGNIZES J[V](W). + +(DEFUN ONEJ + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%J ARRAY) (V TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +;...AMONG GARBAGE RECOGNIZES J[V1](W1)*J[V2](W2) + + +(DEFUN TWOJ + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%J ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%J ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN TWOY + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%Y ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%Y ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN TWOK + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%K ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%K ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEKONEY + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%K ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%Y ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +;...AMONG GARBAGE RECOGNIZES J[V](W)^2. + + +(DEFUN ONEJ^2 + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MEXPT) + ((MQAPPLY)(($%J ARRAY)(V TRUE))(W TRUE)) + 2.)) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEY^2 + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MEXPT) + ((MQAPPLY)(($%Y ARRAY)(V TRUE))(W TRUE)) + 2.)) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEK^2 + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MEXPT) + ((MQAPPLY)(($%K ARRAY)(V TRUE))(W TRUE)) + 2.)) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEI + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%I ARRAY) (V TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN TWOI + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%I ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%I ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN TWOH + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%H ARRAY)(V1 TRUE)(V11 TRUE)) + (W1 TRUE)) + ((MQAPPLY) + (($%H ARRAY)(V2 TRUE)(V21 TRUE)) + (W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEYONEJ + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%Y ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%J ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEKONEJ + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%K ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%J ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEYONEH + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%Y ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY) + (($%H ARRAY)(V2 TRUE)(V21 TRUE)) + (W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEKONEH + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%K ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY) + (($%H ARRAY)(V2 TRUE)(V21 TRUE)) + (W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEIONEJ + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%I ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%J ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEIONEH + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%I ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY) + (($%H ARRAY)(V2 TRUE)(V21 TRUE)) + (W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEHONEJ + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%H ARRAY)(V1 TRUE)(V11 TRUE)) + (W1 TRUE)) + ((MQAPPLY)(($%J ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEIONEY + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%I ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%Y ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEIONEK + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%I ARRAY)(V1 TRUE))(W1 TRUE)) + ((MQAPPLY)(($%K ARRAY)(V2 TRUE))(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEI^2 + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MEXPT) + ((MQAPPLY)(($%I ARRAY)(V TRUE))(W TRUE)) + 2.)) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEH^2 + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MEXPT) + ((MQAPPLY) + (($%H ARRAY)(V1 TRUE)(V2 TRUE)) + (W TRUE)) + 2.)) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONERF + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT)(U NONZERP)((%ERF)(W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONELOG + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT)(U NONZERP)((%LOG)(W HASVAR))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONERFC + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT)(U NONZERP)(($ERFC)(W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEEI + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT)(U NONZERP)(($%EI)(W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEKELLIPTIC + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT)(U NONZERP)(($KELLIPTIC)(W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEE + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT)(U NONZERP)(($%E)(W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEGAMMAINCOMPLETE + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + (($GAMMAINCOMPLETE)(W1 FREEVARPAR)(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEGAMMAGREEK + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + (($GAMMAGREEK)(W1 FREEVARPAR)(W2 TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEHSTRUVE + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($HSTRUVE ARRAY)(V TRUE))(W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONELSTRUVE + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($LSTRUVE ARRAY)(V TRUE))(W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONES + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%S ARRAY)(V1 TRUE)(V2 TRUE))(W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONESLOMMEL + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($SLOMMEL ARRAY)(V1 TRUE)(V2 TRUE)) + (W TRUE))) + ((COEFFPP)(A ZERP))) + NIL)) + +(DEFUN ONEY + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%Y ARRAY) (V TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEK + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%K ARRAY) (V TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONED + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%D ARRAY) (V TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEKBATEMAN + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($KBATEMAN ARRAY) (V TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEH + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%H ARRAY) (V1 TRUE)(V2 TRUE)) + (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEM + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%M ARRAY) (V1 TRUE)(V2 TRUE)) + (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEL + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%L ARRAY) (V1 TRUE)(V2 TRUE)) + (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEC + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%C ARRAY) (V1 TRUE)(V2 TRUE)) + (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONET + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%T ARRAY) (V1 TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEU + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%U ARRAY) (V1 TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEPJAC + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%P ARRAY) (V1 TRUE)(V2 TRUE)(V3 TRUE)) + (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEHE + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%HE ARRAY) (V1 TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEQ + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%Q ARRAY) (V1 TRUE)(V2 TRUE)) + (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEP0 + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY)(($%P ARRAY) (V1 TRUE)) (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN HYP-ONEP + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%P ARRAY) (V1 TRUE)(V2 TRUE)) + (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + +(DEFUN ONEW + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MQAPPLY) + (($%W ARRAY) (V1 TRUE)(V2 TRUE)) + (W TRUE))) + ((COEFFPP) (A ZERP))) + NIL)) + + + + + + + + +;...RECOGNIZES L.T.E. "U*%E^(A*X+E*F(X)-P*X+C)+D". + +(DEFUN LTEP + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MEXPT) + $%E + ((MPLUS) + ((COEFFPT) (A FREEVARPAR) (X VARP)) + ((COEFFPT) (E FREEVARPAR) (F HASVAR)) + ((MTIMES) -1. (P PARP) (X VARP)) + ((COEFFPP) (C FREEVARPAR))))) + ((COEFFPP) (D ZERP))) + NIL)) + +(DEFUN ZERP(A)(EQUAL A 0)) + +(DEFUN NONZERP(A)(NOT (ZERP A))) + +(DEFMFUN $SPECINT (EXP VAR) + (PROG ($radexpand CHECKCOEFSIGNLIST) + (FIND-FUNCTION 'SININT) + (setq $radexpand '$all) + (RETURN (GRASP-SOME-TRIGS EXP)))) + +(declare (special asinx atanx)) +(setq asinx nil atanx nil) +(DEFUN GRASP-SOME-TRIGS + (EXP) + (PROG(U X L ) + (COND ((SETQ L (U*ASINX EXP)) + (SETQ U + (CDRAS 'U L) + X + (CDRAS 'X L) + ASINX + 'T) + (RETURN (DEFINTEGRATE U)))) + (COND ((SETQ L (U*ATANX EXP)) + (SETQ U + (CDRAS 'U L) + X + (CDRAS 'X L) + ATANX + 'T) + (RETURN (DEFINTEGRATE U)))) + (RETURN (DEFINTEGRATE EXP)))) + + + +(DEFUN DEFINTEGRATE + (EXP) + (PROG ($EXPONENTIALIZE) + (SETQ $EXPONENTIALIZE t) + (RETURN (DISTRDEFEXECINIT ($EXPAND (SSIMPLIFYA EXP)))))) + + +(DEFUN DEFEXEC + (EXP VAR) + (PROG(L A) + (SETQ EXP (SIMPLIFYA EXP NIL)) + (COND ((SETQ L (DEFLTEP EXP)) + (SETQ A (CDRAS 'A L)) + (RETURN (NEGTEST L A)))) + (RETURN 'OTHER-DEFINT-TO-FOLLOW-DEFEXEC))) + +(DEFUN NEGTEST + (L A) + (PROG(U E F C) + (COND ((EQ (CHECKSIGNTM ($REALPART A)) '$NEGATIVE) + (SETQ U + (CDRAS 'U L) + E + (CDRAS 'E L) + F + (CDRAS 'F L) + C + (CDRAS 'C L)) + (COND ((ZERP E)(SETQ F 1))) + (RETURN (SUBSTITUTE (MUL -1 A) + 'PSEY + (LTSCALE U + VAR + 'PSEY + C + 0 + E + F))))) + (RETURN 'OTHER-DEFINT-TO-FOLLOW-NEGTEST))) + +(DEFUN LTSCALE + (EXP VAR PAR C PAR0 E F) + (MUL* (POWER '$%E C) + (SUBSTL (SUB PAR PAR0) PAR (LT-EXEC EXP E F)))) + +(DEFUN DEFLTEP + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (U NONZERP) + ((MEXPT) + $%E + ((MPLUS) + ((COEFFPT) (A FREEVAR) (X VARP)) + ((COEFFPT) (E FREEVAR) (F HASVARNOVARP)) + ((COEFFPP) (C FREEVAR))))) + ((COEFFPP) (D ZERP))) + NIL)) + +(DEFUN HASVARNOVARP(A)(AND (HASVAR A)(NOT (VARP A)))) +;it dispatches according to the kind of transform it matches + +(DEFUN EXEC + (EXP VAR PAR) + (PROG(L U A C E F) + (SETQ EXP (SIMPLIFYA EXP NIL)) + (COND ((SETQ L (LTEP EXP)) + (SETQ U + (CDRAS 'U L) + A + (CDRAS 'A L) + C + (CDRAS 'C L) + E + (CDRAS 'E L) + F + (CDRAS 'F L)) + (RETURN (LTSCALE U VAR PAR C A E F)))) + (RETURN 'OTHER-TRANS-TO-FOLLOW))) + +(DEFUN SUBSTL + (P1 P2 P3) + (COND ((EQ P1 P2) P3)(T (SUBSTITUTE P1 P2 P3)))) + +(DEFUN LT-EXEC + (U E F) + (PROG(L) + (COND ((OR ASINX ATANX)(RETURN (LT-ASINATAN U E F)))) + (COND ((ZERP E)(RETURN (LT-SF-LOG U)))) + (COND ((AND (NOT (ZERP E))(SETQ L (C*T^V U))) + (RETURN (LT-EXP L E F)))) + (RETURN (LT-SF-LOG (MUL* U (POWER '$%E (MUL E F))))))) + +(DEFUN C*T^V + (EXP) + (M2 EXP + '((MTIMES) + ((COEFFTT)(C FREEVAR)) + ((MEXPT)(T VARP)(V FREEVAR))) + NIL)) + +(DEFUN LT-ASINATAN + (U E F) + (COND ((ZERP E) + (COND (ASINX (LT-LTP 'ASIN U var NIL)) + (ATANX (LT-LTP 'ATAN U var NIL)) + (T 'LT-ASINATAN-FAILED-1))) + (T 'LT-ASINATAN-FAILED-2))) + +(DEFUN LT-EXP + (L E F) + (PROG(C V) + (SETQ C (CDRAS 'C L) V (CDRAS 'V L)) + (COND ((T^2 F) + (SETQ E (INV (MUL -8 E)) V (ADD V 1)) + (RETURN (F24P146TEST C V E)))) + (COND ((SQROOTT F) + (SETQ E (MUL* E E (INV 4)) V (ADD V 1)) + (RETURN (F35P147TEST C V E)))) + (COND ((T^-1 F) + (SETQ E (MUL -4 E) V (ADD V 1)) + (RETURN (F29P146TEST C V E)))) + (RETURN 'OTHER-LT-EXPONENTIAL-TO-FOLLOW))) + +(DEFUN T^2(EXP)(M2 EXP '((MEXPT)(T VARP) 2) NIL)) + +(DEFUN SQROOTT(EXP)(M2 EXP '((MEXPT)(T VARP)((RAT) 1 2)) NIL)) + +(DEFUN T^-1(EXP)(M2 EXP '((MEXPT)(T VARP) -1) NIL)) + +(DEFUN F24P146TEST + (C V A) + (COND ((NOT (OR (NEGINP A)(NEGINP V)))(F24P146 C V A)) + (T 'FAIL-ON-F24P146TEST))) + +(DEFUN F35P147TEST + (C V A) + (COND ((NOT (NEGINP V))(F35P147 C V A)) + (T 'FAIL-ON-F35P147TEST))) + +(DEFUN F29P146TEST + (C V A) + (COND ((NOT (NEGINP A))(F29P146 C V A)) + (T 'FAIL-ON-F29P146TEST))) + +(DEFUN F1P137TEST + (POW) + (COND ((NOT (NEGINP (ADD POW 1)))(F1P137 POW)) + (T 'FAIL-IN-ARBPOW))) + +(DEFUN F1P137 + (POW) + (MUL* (GM (ADD POW 1))(POWER PAR (SUB (MUL -1 POW) 1)))) + +(DEFUN F24P146 + (C V A) + (MUL* C + (GM V) + (POWER 2 V) + (POWER A (DIV V 2)) + (POWER '$%E (MUL* A PAR PAR)) + (DTFORD (MUL* 2 PAR (POWER A (1//2)))(MUL -1 V)))) + +(DEFUN F35P147 + (C V A) + (MUL* C + (GM (ADD V V)) + (POWER 2 (SUB 1 V)) + (POWER PAR (MUL -1 V)) + (POWER '$%E (MUL* A (1//2)(INV PAR))) + (DTFORD (POWER (MUL* 2 A (INV PAR))(1//2))(MUL -2 V)))) + +(DEFUN F29P146 + (C V A) + (MUL* 2 + (POWER (MUL* A (INV 4)(INV PAR))(DIV V 2)) + (KTFORK A V))) + +(DEFUN KTFORK + (A V) + ((LAMBDA(Z) + (COND ((INTEGERP V)(KMODBES Z V)) + (T (SIMPKTF Z V)))) + (POWER (MUL* A PAR)(1//2)))) + +(DEFUN DTFORD + (Z V) + (COND (((LAMBDA(INV4) + (WHITTINDTEST (ADD (DIV V 2) INV4) INV4)) + (INV 4)) + (PARCYL Z V)) + (T (SIMPDTF Z V)))) + +(DEFUN SIMPDTF + (Z V) + ((LAMBDA(INV2 POW) + (ADD (MUL* (POWER 2 (DIV (SUB V 1) 2)) + Z + (GM (INV -2)) + (INV (GM (MUL* V -1 INV2))) + POW + (HGFSIMP-EXEC (LIST (SUB INV2 + (DIV V + 2))) + (LIST (DIV 3 2)) + (MUL* Z Z INV2))) + (MUL* (POWER 2 (DIV V 2)) + (GM INV2) + POW + (INV (GM (SUB INV2 (MUL V INV2)))) + (HGFSIMP-EXEC (LIST (MUL* V + -1 + INV2)) + (LIST INV2) + (MUL* Z Z INV2))))) + (1//2) + (POWER '$%E (MUL* Z Z (INV -4))))) + +(DEFUN SIMPKTF + (Z V) + ((LAMBDA(DZ2) + (MUL* '$%PI + (1//2) + (INV (sin% (MUL V '$%PI))) + (SUB (MUL* (POWER DZ2 (MUL -1 V)) + (INV (GM (SUB 1 V))) + (HGFSIMP-EXEC NIL + (LIST (SUB 1 + V)) + (MUL* Z + Z + (INV 4)))) + (MUL* (POWER DZ2 V) + (INV (GM (ADD V 1))) + (HGFSIMP-EXEC NIL + (LIST (ADD V + 1)) + (MUL* Z + Z + (INV 4))))))) + (DIV Z 2))) +;dispatches according to the special functions involved in the laplace transformable expression + +(DEFUN LT-SF-LOG + (U) + (PROG(L INDEX1 INDEX11 INDEX2 INDEX21 ARG1 ARG2 REST) + (COND ((SETQ L (TWOJ U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (LT2J REST ARG1 ARG2 INDEX1 INDEX2)))) + (COND ((SETQ L (TWOH U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V11 L) + INDEX2 + (CDRAS 'V2 L) + INDEX21 + (CDRAS 'V21 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST REST + ARG1 + ARG2 + INDEX1 + INDEX11 + INDEX2 + INDEX21 + '2HTJORY)))) + (COND ((SETQ L (TWOY U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST REST + ARG1 + ARG2 + INDEX1 + NIL + INDEX2 + NIL + '2YTJ)))) + (COND ((SETQ L (TWOK U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST REST + ARG1 + ARG2 + INDEX1 + NIL + INDEX2 + NIL + '2KTI)))) + (COND ((SETQ L (ONEKONEY U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST REST + ARG1 + ARG2 + INDEX1 + NIL + INDEX2 + NIL + 'KTIYTJ)))) + (COND ((SETQ L (ONEIONEJ U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + INDEX21 + (CDRAS 'V21 L) + ARG1 + (MUL* (1FACT T T)(CDRAS 'W1 L)) + ARG2 + (CDRAS 'W2 L) + REST + (MUL* (1FACT NIL INDEX1)(CDRAS 'U L))) + (RETURN (LT2J REST ARG1 ARG2 INDEX1 INDEX2)))) + (COND ((SETQ L (ONEIONEH U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + INDEX21 + (CDRAS 'V21 L) + ARG1 + (MUL* (1FACT T T)(CDRAS 'W1 L)) + ARG2 + (CDRAS 'W2 L) + REST + (MUL* (1FACT NIL INDEX1)(CDRAS 'U L))) + (RETURN (FRACTEST1 REST + ARG1 + ARG2 + INDEX1 + INDEX2 + INDEX21 + 'BESSHTJORY)))) + (COND ((SETQ L (ONEYONEJ U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST1 REST + ARG2 + ARG1 + INDEX2 + INDEX1 + NIL + 'BESSYTJ)))) + (COND ((SETQ L (ONEKONEJ U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST1 REST + ARG2 + ARG1 + INDEX2 + INDEX1 + NIL + 'BESSKTI)))) + (COND ((SETQ L (ONEHONEJ U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V11 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST1 REST + ARG2 + ARG1 + INDEX2 + INDEX1 + INDEX11 + 'BESSHTJORY)))) + (COND ((SETQ L (ONEYONEH U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + INDEX11 + (CDRAS 'V21 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST1 REST + ARG2 + ARG1 + INDEX2 + INDEX1 + INDEX11 + 'HTJORYYTJ)))) + (COND ((SETQ L (ONEKONEH U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + INDEX11 + (CDRAS 'V21 L) + ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST1 REST + ARG2 + ARG1 + INDEX2 + INDEX1 + INDEX11 + 'HTJORYKTI)))) + (COND ((SETQ L (ONEIONEY U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (MUL* (1FACT T T)(CDRAS 'W1 L)) + ARG2 + (CDRAS 'W2 L) + REST + (MUL* (1FACT NIL INDEX1)(CDRAS 'U L))) + (RETURN (FRACTEST1 REST + ARG1 + ARG2 + INDEX1 + INDEX2 + NIL + 'BESSYTJ)))) + (COND ((SETQ L (ONEIONEK U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (MUL* (1FACT T T)(CDRAS 'W1 L)) + ARG2 + (CDRAS 'W2 L) + REST + (MUL* (1FACT NIL INDEX1)(CDRAS 'U L))) + (RETURN (FRACTEST1 REST + ARG1 + ARG2 + INDEX1 + INDEX2 + NIL + 'BESSKTI)))) + (COND ((SETQ L (ONEHSTRUVE U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1HSTRUVE REST ARG1 INDEX1)))) + (COND ((SETQ L (ONELSTRUVE U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1LSTRUVE REST ARG1 INDEX1)))) + (COND ((SETQ L (ONES U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1S REST ARG1 INDEX1 INDEX2)))) + (COND ((SETQ L (ONESLOMMEL U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST2 REST + ARG1 + INDEX1 + INDEX2 + 'SLOMMEL)))) + (COND ((SETQ L (ONEY U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1YREF REST ARG1 INDEX1)))) + (COND ((SETQ L (ONEK U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST2 REST + ARG1 + INDEX1 + NIL + 'KTI)))) + (COND ((SETQ L (ONED U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST2 REST ARG1 INDEX1 NIL 'D)))) + (COND ((SETQ L (ONEGAMMAINCOMPLETE U)) + (SETQ ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST2 REST + ARG1 + ARG2 + NIL + 'GAMMAINCOMPLETE)))) + (COND ((SETQ L (ONEKBATEMAN U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST2 REST + ARG1 + INDEX1 + NIL + 'KBATEMAN)))) + (COND ((SETQ L (ONEJ U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1J REST ARG1 INDEX1)))) + (COND ((SETQ L (ONEGAMMAGREEK U)) + (SETQ ARG1 + (CDRAS 'W1 L) + ARG2 + (CDRAS 'W2 L) + REST + (CDRAS 'U L)) + (RETURN (LT1GAMMAGREEK REST ARG1 ARG2)))) + (COND ((SETQ L (ONEH U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST2 REST + ARG1 + INDEX1 + INDEX11 + 'HTJORY)))) + (COND ((SETQ L (ONEM U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1M REST ARG1 INDEX1 INDEX11)))) + (COND ((SETQ L (ONEL U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (INTEGERTEST REST + ARG1 + INDEX1 + INDEX11 + 'L)))) + (COND ((SETQ L (ONEC U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (INTEGERTEST REST + ARG1 + INDEX1 + INDEX11 + 'C)))) + (COND ((SETQ L (ONET U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (INTEGERTEST REST + ARG1 + INDEX1 + NIL + 'T)))) + (COND ((SETQ L (ONEU U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (INTEGERTEST REST + ARG1 + INDEX1 + NIL + 'U)))) + (COND ((SETQ L (ONEHE U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (INTEGERTEST REST + ARG1 + INDEX1 + NIL + 'HE)))) + (COND ((SETQ L (HYP-ONEP U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1P REST ARG1 INDEX1 INDEX11)))) + (COND ((SETQ L (ONEPJAC U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + INDEX21 + (CDRAS 'V3 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (PJACTEST REST + ARG1 + INDEX1 + INDEX2 + INDEX21)))) + (COND ((SETQ L (ONEQ U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1Q REST ARG1 INDEX1 INDEX11)))) + (COND ((SETQ L (ONEP0 U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + 0 + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1P REST ARG1 INDEX1 INDEX11)))) + (COND ((SETQ L (ONEW U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (WHITTEST REST ARG1 INDEX1 INDEX11)))) + (COND ((SETQ L (ONEJ^2 U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (LT1J^2 REST ARG1 INDEX1)))) + (COND ((SETQ L (ONEH^2 U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX11 + (CDRAS 'V2 L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST REST + ARG1 + ARG1 + INDEX1 + INDEX11 + INDEX1 + INDEX11 + '2HTJORY)))) + (COND ((SETQ L (ONEY^2 U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST REST + ARG1 + ARG1 + INDEX1 + NIL + INDEX1 + NIL + '2YTJ)))) + (COND ((SETQ L (ONEK^2 U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (CDRAS 'W L) + REST + (CDRAS 'U L)) + (RETURN (FRACTEST REST + ARG1 + ARG1 + INDEX1 + NIL + INDEX1 + NIL + '2KTI)))) + (COND ((SETQ L (TWOI U)) + (SETQ INDEX1 + (CDRAS 'V1 L) + INDEX2 + (CDRAS 'V2 L) + ARG1 + (MUL* (1FACT T T)(CDRAS 'W1 L)) + ARG2 + (MUL* (1FACT T T) (CDRAS 'W2 L)) + REST + (MUL* (1FACT NIL INDEX1) + (1FACT NIL INDEX2) + (CDRAS 'U L))) + (RETURN (LT2J REST ARG1 ARG2 INDEX1 INDEX2)))) + (COND ((SETQ L (ONEI U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (MUL* (1FACT T T)(CDRAS 'W L)) + REST + (MUL* (1FACT NIL INDEX1)(CDRAS 'U L))) + (RETURN (LT1J REST ARG1 INDEX1)))) + (COND ((SETQ L (ONEI^2 U)) + (SETQ INDEX1 + (CDRAS 'V L) + ARG1 + (MUL* (1FACT T T)(CDRAS 'W L)) + REST + (MUL* (1FACT NIL INDEX1)(CDRAS 'U L))) + (RETURN (LT1J^2 REST ARG1 INDEX1)))) + (COND ((SETQ L (ONERF U)) + (SETQ ARG1 (CDRAS 'W L) REST (CDRAS 'U L)) + (RETURN (LT1ERF REST ARG1)))) + (COND ((SETQ L (ONELOG U)) + (SETQ ARG1 (CDRAS 'W L) REST (CDRAS 'U L)) + (RETURN (LT1LOG REST ARG1)))) + (COND ((SETQ L (ONERFC U)) + (SETQ ARG1 (CDRAS 'W L) REST (CDRAS 'U L)) + (RETURN (FRACTEST2 REST ARG1 NIL NIL 'ERFC)))) + (COND ((SETQ L (ONEEI U)) + (SETQ ARG1 (CDRAS 'W L) REST (CDRAS 'U L)) + (RETURN (FRACTEST2 REST ARG1 NIL NIL 'EI)))) + (COND ((SETQ L (ONEKELLIPTIC U)) + (SETQ ARG1 (CDRAS 'W L) REST (CDRAS 'U L)) + (RETURN (LT1KELLIPTIC REST ARG1)))) + (COND ((SETQ L (ONEE U)) + (SETQ ARG1 (CDRAS 'W L) REST (CDRAS 'U L)) + (RETURN (LT1E REST ARG1)))) + (COND ((SETQ L (ARBPOW1 U)) + (SETQ ARG1 + (CDRAS 'U L) + ARG2 + (CDRAS 'C L) + INDEX1 + (CDRAS 'V L)) + (RETURN (MUL ARG2 (LT-ARBPOW ARG1 INDEX1))))) + (RETURN 'OTHER-J-CASES-NEXT))) + +(DEFUN LT-ARBPOW + (EXP POW) + (COND ((OR (EQ EXP VAR)(ZERP POW))(F1P137TEST POW)))) + +(DEFUN FRACTEST + (R A1 A2 I1 I11 I2 I21 FLG) + (COND ((OR (AND (EQUAL (CAAR I1) 'RAT) + (EQUAL (CAAR I2) 'RAT)) + (EQ FLG '2HTJORY)) + (SENDEXEC R + (COND ((EQ FLG '2YTJ) + (MUL (YTJ I1 A1)(YTJ I2 A2))) + ((EQ FLG '2HTJORY) + (MUL (HTJORY I1 I11 A1) + (HTJORY I2 I21 A2))) + ((EQ FLG 'KTIYTJ) + (MUL (KTI I1 A1)(YTJ I2 A2))) + ((EQ FLG '2KTI) + (MUL (KTI I1 A1)(KTI I2 A2)))))) + (T 'PRODUCT-OF-Y-WITH-NOFRACT-INDICES))) + +(DEFUN FRACTEST1 + (R A1 A2 I1 I2 I FLG) + (COND ((OR (EQUAL (CAAR I2) 'RAT)(EQ FLG 'BESSHTJORY)) + (SENDEXEC R + (COND ((EQ FLG 'BESSYTJ) + (MUL (BESS I1 A1 'J) + (YTJ I2 A2))) + ((EQ FLG 'BESSHTJORY) + (MUL (BESS I1 A1 'J) + (HTJORY I2 I A2))) + ((EQ FLG 'HTJORYYTJ) + (MUL (HTJORY I1 I A1) + (YTJ I2 A2))) + ((EQ FLG 'BESSKTI) + (MUL (BESS I1 A1 'J) + (KTI I2 A2))) + ((EQ FLG 'HTJORYKTI) + (MUL (HTJORY I1 I A1) + (KTI I2 A2)))))) + (T 'PRODUCT-OF-I-Y-OF-NOFRACT-INDEX))) + +(DEFUN FRACTEST2 + (R A1 I1 I11 FLG) + (COND ((OR (EQUAL (CAAR I1) 'RAT) + (EQ FLG 'D) + (EQ FLG 'KBATEMAN) + (EQ FLG 'GAMMAINCOMPLETE) + (EQ FLG 'HTJORY) + (EQ FLG 'ERFC) + (EQ FLG 'EI) + (EQ FLG 'SLOMMEL)) + (SENDEXEC R + (COND ((EQ FLG 'YTJ)(YTJ I1 A1)) + ((EQ FLG 'HTJORY) + (HTJORY I1 I11 A1)) + ((EQ FLG 'D)(DTW I1 A1)) + ((EQ FLG 'KBATEMAN) + (KBATEMANTW I1 A1)) + ((EQ FLG 'GAMMAINCOMPLETE) + (GAMMAINCOMPLETETW A1 I1)) + ((EQ FLG 'KTI)(KTI I1 A1)) + ((EQ FLG 'ERFC)(ERFCTD A1)) + ((EQ FLG 'EI) + (EITGAMMAINCOMPLETE A1)) + ((EQ FLG 'SLOMMEL) + (SLOMMELTJANDY I1 I11 A1))))) + (T 'Y-OF-NOFRACT-INDEX))) + +(DEFUN LT1YREF + (REST ARG1 INDEX1) + (COND ((INTEGERP INDEX1)(LT1Y REST ARG1 INDEX1)) + (T (FRACTEST2 REST ARG1 INDEX1 NIL 'YTJ)))) + +(DEFUN PJACTEST + (REST ARG INDEX1 INDEX2 INDEX3) + (COND ((INTEGERP INDEX1) + (LT-LTP 'ONEPJAC + REST + ARG + (LIST INDEX1 INDEX2 INDEX3))) + (T 'IND-SHOULD-BE-AN-INTEGER-IN-POLYS))) + +(DEFUN EQRAT(A)(COND ((NUMBERP A) NIL)(T (EQUAL (CAAR A) 'RAT)))) + +(DEFUN INTEGERTEST + (R ARG I1 I2 FLG) + (COND ((INTEGERP I1)(DISPATCHPOLTRANS R ARG I1 I2 FLG)) + (T 'INDEX-SHOULD-BE-AN-INTEGER-IN-POLYS))) + +(DEFUN DISPATCHPOLTRANS + (R X I1 I2 FLG) + (SENDEXEC R + (COND ((EQ FLG 'L)(LTW X I1 I2)) + ((EQ FLG 'HE)(HETD X I1)) + ((EQ FLG 'C)(CTPJAC X I1 I2)) + ((EQ FLG 'T)(TTPJAC X I1)) + ((EQ FLG 'U)(UTPJAC X I1))))) + +(DEFUN SENDEXEC(R A)(DISTREXECINIT ($EXPAND (MUL (INIT R) A)))) + +(DEFUN WHITTEST + (R A I1 I2) + (COND ((WHITTINDTEST I1 I2) 'FORMULA-FOR-CONFL-NEEDED) + (T (DISTREXECINIT ($EXPAND (MUL (INIT R) + (WTM A I1 I2))))))) + +(DEFUN WHITTINDTEST + (I1 I2) + (OR (INTEGERP (ADD I2 I2)) + (NEGINP (SUB (SUB (1//2) I2) I1)) + (NEGINP (SUB (ADD (1//2) I2) I1)))) + +(DEFUN INIT(R)(MUL* R (POWER '$%E (MUL* -1 VAR PAR)))) + +(DEFUN LTW + (X N A) + ((LAMBDA(DIVA2) + (MUL* (POWER -1 N) + (INV (FACTORIAL N)) + (POWER X (SUB (INV -2) DIVA2)) + (POWER '$%E (DIV X 2)) + (WWHIT X (ADD (1//2) DIVA2 N) DIVA2))) + (DIV A 2))) + +(DEFUN CTPJAC + (X N V) + ((LAMBDA(INV2) + (MUL* (GM (ADD V V N)) + (INV (GM (ADD V V))) + (GM (ADD INV2 V)) + (INV (GM (ADD V INV2 N))) + (PJAC X N (SUB V INV2)(SUB V INV2)))) + (1//2))) + +(DEFUN TTPJAC + (X N) + ((LAMBDA(INV2) + (MUL* (FACTORIAL N) + (GM INV2) + (INV (GM (ADD INV2 N))) + (PJAC X N (MUL -1 INV2)(MUL -1 INV2)))) + (1//2))) + +(DEFUN UTPJAC + (X N) + ((LAMBDA(INV2) + (MUL* (FACTORIAL (ADD N 1)) + INV2 + (GM INV2) + (INV (GM (ADD INV2 N 1))) + (PJAC X N INV2 INV2))) + (1//2))) + +(DEFUN HETD(X N)(MUL* (POWER '$%E (MUL* X X (INV 4)))(PARCYL X N))) + +(DEFUN ERFCTD + (X) + ((LAMBDA(INV2) + (MUL* (POWER 2 INV2) + (POWER '$%PI (MUL* -1 INV2)) + (POWER '$%E (MUL* -1 INV2 X X)) + (PARCYL (MUL* (POWER 2 INV2) X) -1))) + (1//2))) + +(DEFUN EITGAMMAINCOMPLETE(X)(MUL* -1 (GMINC 0 (MUL -1 X)))) + +(DEFUN SLOMMELTJANDY + (M N Z) + ((LAMBDA(ARG) + (ADD (LITTLESLOMMEL M N Z) + (MUL* (POWER 2 (SUB M 1)) + (GM (DIV (SUB (ADD M 1) N) 2)) + (GM (DIV (ADD M N 1) 2)) + (SUB (MUL* (sin% ARG)(BESS N Z 'J)) + (MUL* (COS% ARG)(BESS N Z 'Y)))))) + (MUL* (1//2) '$%PI (SUB M N)))) + +(DEFUN WTM + (A I1 I2) + (ADD (MUL* (GM (MUL -2 I2)) + (MWHIT A I1 I2) + (INV (GM (SUB (SUB (1//2) I2) I1)))) + (MUL* (GM (ADD I2 I2)) + (MWHIT A I1 (MUL -1 I2)) + (INV (GM (SUB (ADD (1//2) I2) I1)))))) + +(DEFUN GAMMAINCOMPLETETW + (A X) + (MUL* (POWER X (DIV (SUB A 1) 2)) + (POWER '$%E (DIV X -2)) + (WWHIT X (DIV (SUB A 1) 2)(DIV A 2)))) + +(DEFUN DISTREXECINIT + (FUN) + (COND ((EQUAL (CAAR FUN) 'MPLUS)(DISTREXEC (CDR FUN))) + (T (EXEC FUN VAR PAR)))) + +(DEFUN DISTRDEFEXECINIT + (FUN) + (COND ((EQUAL (CAAR FUN) 'MPLUS)(DISTRDEFEXEC (CDR FUN))) + (T (DEFEXEC FUN VAR)))) + +(DEFUN DISTREXEC + (FUN) + (COND ((NULL FUN) 0) + (T (ADD (EXEC (CAR FUN) VAR PAR) + (DISTREXEC (CDR FUN)))))) + +(DEFUN DISTRDEFEXEC + (FUN) + (COND ((NULL FUN) 0) + (T (ADD (DEFEXEC (CAR FUN) VAR) + (DISTRDEFEXEC (CDR FUN)))))) + +(DEFUN YTJ + (I A) + (SUB (MUL* (BESS I A 'J)(LIST '(%COT) (MUL I '$%PI))) + (MUL* (BESS (MUL -1 I) A 'J)(INV (sin% (MUL I '$%PI)))))) + +(DEFUN DTW + (I A) + (MUL* (POWER 2 (ADD (DIV I 2)(INV 4))) + (POWER A (INV -2)) + (WWHIT (MUL* A A (1//2)) + (ADD (DIV I 2)(INV 4)) + (INV 4)))) + +(DEFUN KBATEMANTW + (I A) + ((LAMBDA(IND) + (DIV (WWHIT (ADD A A) IND (1//2)) + (GM (ADD IND 1)))) + (DIV 1 2))) + +(DEFUN KTI + (I A) + (MUL* '$%PI + (1//2) + (INV (sin% (MUL I '$%PI))) + (SUB (BESS (MUL -1 I) A 'I)(BESS I A 'I)))) + +(DEFUN 1FACT + (FLG V) + (POWER '$%E + (MUL* '$%PI + '$%I + (1//2) + (COND (FLG 1)(T (MUL -1 V)))))) + +(DEFUN BESSY(V Z)(LIST '(MQAPPLY)(LIST '($%Y ARRAY) V) Z)) + +(DEFUN KMODBES(Z V)(LIST '(MQAPPLY)(LIST '($%K ARRAY) V) Z)) + + + +(DEFUN TAN%(ARG)(LIST '(%TAN) ARG)) + +(DEFUN DESJY + (V Z FLG) + (COND ((EQ FLG 'J)(BESS V Z 'J))(T (BESSY V Z)))) + +(DEFUN NUMJORY + (V SORT Z FLG) + (COND ((EQUAL SORT 1) + (SUB (DESJY (MUL -1 V) Z FLG) + (MUL* (POWER '$%E (MUL* -1 V '$%PI '$%I)) + (DESJY V Z FLG)))) + (T (SUB (MUL* (POWER '$%E (MUL* V '$%PI '$%I)) + (DESMJY V Z FLG)) + (DESMJY (MUL -1 V) Z FLG))))) + +(DEFUN DESMJY + (V Z FLG) + (COND ((EQ FLG 'J)(BESS V Z 'J))(T (MUL -1 (BESSY V Z))))) + +(DEFUN HTJORY + (V SORT Z) + (COND ((EQUAL (CAAR V) 'RAT) + (DIV (NUMJORY V SORT Z 'J) + (MUL* '$%I (SIN% (MUL V '$%PI))))) + (T (DIV (NUMJORY V SORT Z 'Y)(SIN% (MUL V '$%PI)))))) +;expert on l.t. expressions containing one bessel function of the first kind + +(DEFUN LT1J(REST ARG INDEX)(LT-LTP 'ONEJ REST ARG INDEX)) + +(DEFUN LT1Y(REST ARG INDEX)(LT-LTP 'ONEY REST ARG INDEX)) + +(DEFUN LT2J + (REST ARG1 ARG2 INDEX1 INDEX2) + (COND ((NOT (EQUAL ARG1 ARG2)) + 'PRODUCT-OF-BESSEL-WITH-DIFFERENT-ARGS) + (T (LT-LTP 'TWOJ + REST + ARG1 + (LIST 'LIST INDEX1 INDEX2))))) + +(DEFUN LT1J^2 + (REST ARG INDEX) + (LT-LTP 'TWOJ REST ARG (LIST 'LIST INDEX INDEX))) + +(DEFUN LT1GAMMAGREEK + (REST ARG1 ARG2) + (LT-LTP 'GAMMAGREEK REST ARG2 ARG1)) + +(DEFUN LT1M(R A I1 I2)(LT-LTP 'ONEM R A (LIST I1 I2))) + +(DEFUN LT1P(R A I1 I2)(LT-LTP 'HYP-ONEP R A (LIST I1 I2))) + +(DEFUN LT1Q(R A I1 I2)(LT-LTP 'ONEQ R A (LIST I1 I2))) + +(DEFUN LT1ERF(REST ARG)(LT-LTP 'ONERF REST ARG NIL)) + +(DEFUN LT1LOG(REST ARG)(LT-LTP 'ONELOG REST ARG NIL)) + +(DEFUN LT1KELLIPTIC(REST ARG)(LT-LTP 'ONEKELLIPTIC REST ARG NIL)) + +(DEFUN LT1E(REST ARG)(LT-LTP 'ONEE REST ARG NIL)) + +(DEFUN LT1HSTRUVE(REST ARG1 INDEX1)(LT-LTP 'HS REST ARG1 INDEX1)) + +(DEFUN LT1LSTRUVE(REST ARG1 INDEX1)(LT-LTP 'HL REST ARG1 INDEX1)) + +(DEFUN LT1S + (REST ARG1 INDEX1 INDEX2) + (LT-LTP 'S REST ARG1 (LIST INDEX1 INDEX2))) + +(DEFUN HSTF + (V Z) + (PROG(D32) + (SETQ D32 (DIV 3 2)) + (RETURN (LIST (MUL* (POWER (DIV Z 2)(ADD V 1)) + (INV (GM D32)) + (INV (GM (ADD V D32))) + (INV (GM (ADD V D32)))) + (LIST 'FPQ + (LIST 1 2) + (LIST 1) + (LIST D32 (ADD V D32)) + (MUL* (INV -4) Z Z)))))) + +(DEFUN LSTF + (V Z) + (PROG(HST) + (RETURN (LIST (MUL* (POWER '$%E + (MUL* (DIV (ADD V 1) + -2) + '$%PI + '$%I)) + (CAR (SETQ HST + (HSTF V + (MUL* Z + (POWER '$%E + (MUL* + (1//2) + '$%I + '$%PI))))))) + (CADR HST))))) + +(DEFUN STF + (M N Z) + (LIST (MUL* (POWER Z (ADD M 1)) + (INV (SUB (ADD M 1) N)) + (INV (ADD M N 1))) + (LIST 'FPQ + (LIST 1 2) + (LIST 1) + (LIST (DIV (SUB (ADD M 3) N) 2) + (DIV (ADD* M N 3) 2)) + (MUL* (INV -4) Z Z)))) + +(DEFUN LT-LTP + (FLG REST ARG INDEX) + (PROG(index1 index2 ARGL CONST L L1) + (COND ((OR (ZERP INDEX) + (EQ FLG 'ONERF) + (EQ FLG 'ONEKELLIPTIC) + (EQ FLG 'ONEE) + (EQ FLG 'ONEPJAC) + (EQ FLG 'D) + (EQ FLG 'S) + (EQ FLG 'HS) + (EQ FLG 'LS) + (EQ FLG 'ONEM) + (EQ FLG 'ONEQ) + (EQ FLG 'GAMMAGREEK) + (EQ FLG 'ASIN) + (EQ FLG 'ATAN)) + (GO LABL))) + (COND ((OR (EQ FLG 'HYP-ONEP)(EQ FLG 'ONELOG)) + (GO LABL1))) + (COND ((NOT (EQ (CAR INDEX) 'LIST))(GO LAB))) + (COND ((ZERP (SETQ INDEX1 (CADR INDEX)))(GO LA))) + (COND ((EQ (CHECKSIGNTM (SIMPLIFYA (INV (SETQ INDEX1 + (CADR + INDEX))) + NIL)) + '$NEGATIVE) + (SETQ INDEX1 + (MUL -1 INDEX1) + REST + (MUL* (POWER -1 INDEX1) REST)))) + LA + (COND ((ZERP (SETQ INDEX2 (CADDR INDEX)))(GO LA2))) + (COND ((EQ (CHECKSIGNTM (SIMPLIFYA (INV (SETQ INDEX2 + (CADDR + INDEX))) + NIL)) + '$NEGATIVE) + (SETQ INDEX2 + (MUL -1 INDEX2) + REST + (MUL* (POWER -1 INDEX2) REST)))) + LA2 + (SETQ INDEX (LIST INDEX1 INDEX2)) + (GO LABL) + LAB + (COND ((AND (EQ (CHECKSIGNTM (SIMPLIFYA (INV INDEX) + NIL)) + '$NEGATIVE) + (INTEGERP INDEX)) + (SETQ INDEX (MUL -1 INDEX)) + (SETQ REST (MUL (POWER -1 INDEX) REST)))) + LABL + (SETQ ARGL (F+C ARG)) + (SETQ CONST (CDRAS 'C ARGL) ARG (CDRAS 'F ARGL)) + (COND ((NULL CONST)(GO LABL1))) + (COND ((NOT (EQ (CHECKSIGNTM (SIMPLIFYA (POWER CONST + 2) + NIL)) + '$ZERO)) + (RETURN 'PROP4-TO-BE-APPLIED))) + LABL1 + (COND ((EQ FLG 'ONEY)(RETURN (LTY REST ARG INDEX)))) + (COND ((SETQ L + (D*X^M*%E^A*X ($FACTOR (MUL* REST + (CAR (SETQ + L1 + (REF + FLG + INDEX + ARG))))))) + (RETURN (%$ETEST L L1)))) + (RETURN 'OTHER-CA-LATER))) + +(DEFUN LTY + (REST ARG INDEX) + (PROG(l) + (COND ((SETQ L (D*X^M*%E^A*X REST)) + (RETURN (EXECFY L ARG INDEX)))) + (RETURN 'FAIL-IN-LTY))) + +(DEFUN %$ETEST + (L L1) + (PROG(A Q) + (SETQ Q (CDRAS 'Q L)) + (COND ((EQUAL Q 1)(SETQ A 0)(GO LOOP))) + (SETQ A (CDRAS 'A L)) + LOOP + (RETURN (SUBSTL (SUB PAR A) + PAR + (EXECF19 L (CADR L1)))))) + +(DEFUN REF + (FLG INDEX ARG) + (COND ((EQ FLG 'ONEJ)(J1TF INDEX ARG)) + ((EQ FLG 'TWOJ)(J2TF (CAR INDEX)(CADR INDEX) ARG)) + ((EQ FLG 'HS)(HSTF INDEX ARG)) + ((EQ FLG 'HL)(LSTF INDEX ARG)) + ((EQ FLG 'S)(STF (CAR INDEX)(CADR INDEX) ARG)) + ((EQ FLG 'ONERF)(ERFTF ARG)) + ((EQ FLG 'ONELOG)(LOGTF ARG)) + ((EQ FLG 'ONEKELLIPTIC)(KELLIPTICTF ARG)) + ((EQ FLG 'ONEE)(ETF ARG)) + ((EQ FLG 'ONEM)(MTF (CAR INDEX)(CADR INDEX) ARG)) + ((EQ FLG 'HYP-ONEP)(PTF (CAR INDEX)(CADR INDEX) ARG)) + ((EQ FLG 'ONEQ)(QTF (CAR INDEX)(CADR INDEX) ARG)) + ((EQ FLG 'GAMMAGREEK)(GAMMAGREEKTF INDEX ARG)) + ((EQ FLG 'ONEPJAC) + (PJACTF (CAR INDEX)(CADR INDEX)(CADDR INDEX) ARG)) + ((EQ FLG 'ASIN)(ASINTF ARG)) + ((EQ FLG 'ATAN)(ATANTF ARG)))) + +(DEFUN MTF + (I1 I2 ARG) + (LIST (MUL (POWER ARG (ADD I2 (1//2))) + (POWER '$%E (DIV ARG -2))) + (LIST 'FPQ + (LIST 1 1) + (LIST (ADD* (1//2) I2 (MUL -1 I1))) + (LIST (ADD* I2 I2 1)) + ARG))) + +(DEFUN PJACTF + (N A B X) + (LIST (MUL* (GM (ADD N A 1)) + (INV (GM (ADD A 1))) + (INV (FACTORIAL N))) + (LIST 'FPQ + (LIST 2 1) + (LIST (MUL -1 N)(ADD* N A B 1)) + (LIST (ADD A 1)) + (SUB (1//2)(DIV X 2))))) + +(DEFUN ASINTF + (ARG) + ((LAMBDA(INV2) + (LIST ARG + (LIST 'FPQ + (LIST 2 1) + (LIST INV2 INV2) + (LIST (DIV 3 2)) + (MUL ARG ARG)))) + (1//2))) + +(DEFUN ATANTF + (ARG) + (LIST ARG + (LIST 'FPQ + (LIST 2 1) + (LIST (INV 2) 1) + (LIST (DIV 3 2)) + (MUL* -1 ARG ARG)))) + +(DEFUN PTF + (N M Z) + (LIST (MUL (INV (GM (SUB 1 M))) + (POWER (DIV (ADD Z 1)(SUB Z 1))(DIV M 2))) + (LIST 'FPQ + (LIST 2 1) + (LIST (MUL -1 N)(ADD N 1)) + (LIST (SUB 1 M)) + (SUB (1//2)(DIV Z 2))))) + +(DEFUN QTF + (N M Z) + (LIST (MUL* (POWER '$%E (MUL* M '$%PI '$%I)) + (POWER '$%PI (1//2)) + (GM (ADD* M N 1)) + (POWER 2 (SUB -1 N)) + (INV (GM (ADD N (DIV 3 2)))) + (POWER Z (MUL -1 (ADD* M N 1))) + (POWER (SUB (MUL Z Z) 1)(DIV M 2))) + (LIST 'FPQ + (LIST 2 1) + (LIST (DIV (ADD* M N 1) 2) + (DIV (ADD* M N 2) 2)) + (LIST (ADD N (DIV 3 2))) + (POWER Z -2)))) + +(DEFUN GAMMAGREEKTF + (A X) + (LIST (MUL (INV A)(POWER X A)) + (LIST 'FPQ + (LIST 1 1) + (LIST A) + (LIST (ADD A 1)) + (MUL -1 X)))) + +(DEFUN KELLIPTICTF + (K) + ((LAMBDA(INV2) + (LIST (MUL INV2 '$%PI) + (LIST 'FPQ + (LIST 2 1) + (LIST INV2 INV2) + (LIST 1) + (MUL K K)))) + (1//2))) + +(DEFUN ETF + (K) + ((LAMBDA(INV2) + (LIST (MUL INV2 '$%PI) + (LIST 'FPQ + (LIST 2 1) + (LIST (MUL -1 INV2) INV2) + (LIST 1) + (MUL K K)))) + (1//2))) + +(DEFUN ERFTF + (ARG) + (LIST (MUL* 2 ARG (POWER '$%PI (INV -2))) + (LIST 'FPQ + (LIST 1 1) + (LIST (1//2)) + (LIST (DIV 3 2)) + (MUL* -1 ARG ARG)))) + +(DEFUN LOGTF + (ARG) + (LIST 1 + (LIST 'FPQ (LIST 2 1)(LIST 1 1)(LIST 2)(SUB 1 ARG)))) + +(DEFUN J2TF + (N M ARG) + (LIST (MUL* (INV (GM (ADD N 1))) + (INV (GM (ADD M 1))) + (INV (POWER 2 (ADD N M))) + (POWER ARG (ADD N M))) + (LIST 'FPQ + (LIST 2 3) + (LIST (ADD* (1//2)(DIV N 2)(DIV M 2)) + (ADD* 1 (DIV N 2)(DIV M 2))) + (LIST (ADD 1 N)(ADD 1 M)(ADD* 1 N M)) + (MUL -1 (POWER ARG 2))))) + +(DEFUN D*X^M*%E^A*X + (EXP) + (M2 EXP + '((MTIMES) + ((COEFFTT)(D FREEVARPAR)) + ((MEXPT) (X VARP) (M FREEVARPAR)) + ((MEXPT) + (Q EXPOR1P) + ((MTIMES)((COEFFTT)(A FREEVARPAR)) (X VARP)))) + NIL)) + +(DEFUN EXECF19 + (L1 L2) + (PROG(ANS) + (SETQ ANS (EXECARGMATCH (CAR (CDDDDR L2)))) + (COND ((EQ (CAR ANS) 'DIONIMO) + (RETURN (DIONARGHYP L1 L2 (CADR ANS))))) + (RETURN 'NEXT-FOR-OTHER-ARGS))) + +(DEFUN EXECFY + (L ARG INDEX) + (PROG(ANS) + (SETQ ANS (EXECARGMATCH ARG)) + (COND ((EQ (CAR ANS) 'DIONIMO) + (RETURN (DIONARGHYP-Y L INDEX (CADR ANS))))) + (RETURN 'FAIL-IN-EXECFY))) +;executive for recognizing the sort of argument + +(DEFUN EXECARGMATCH + (ARG) + (PROG(L1) + (COND ((SETQ L1 (A*X^M+C ($FACTOR ARG))) + (RETURN (LIST 'DIONIMO L1)))) + (COND ((SETQ L1 (A*X^M+C ($EXPAND ARG))) + (RETURN (LIST 'DIONIMO L1)))) + (RETURN 'OTHER-CASE-ARGS-TO-FOLLOW))) + +(DEFUN DIONARGHYP + (L1 L2 ARG) + (PROG(A M C) + (SETQ A + (CDRAS 'A ARG) + M + (CDRAS 'M ARG) + C + (CDRAS 'C ARG)) + (COND ((AND (INTEGERP M)(ZERP C)) + (RETURN (F19COND A M L1 L2)))) + (RETURN 'PROP4-AND-AOTHER-CASES-TO-FOLOW))) + + +(DEFUN F+C + (EXP) + (M2 EXP + '((MPLUS)((COEFFPT)(F HASVAR))((COEFFPP)(C FREEVAR))) + NIL)) + +(DEFUN A*X^M+C + (EXP) + (M2 EXP + '((MPLUS) + ((COEFFPT) + (A FREEVAR) + ((MEXPT) (X VARP) (M FREEVAR0))) + ((COEFFPP) (C FREEVAR))) + NIL)) + +(DEFUN FREEVAR0(M)(COND ((EQUAL M 0) NIL)(T (FREEVAR M)))) + +(DEFUN ADDARGLIST + (S K) + (PROG(K1 L) + (SETQ K1 (SUB K 1)) + LOOP + (COND ((ZERP K1) + (RETURN (APPEND (LIST (DIV S K)) L)))) + (SETQ L + (APPEND (LIST (DIV (ADD S K1) K)) L) + K1 + (SUB K1 1)) + (GO LOOP))) + +(DEFUN F19COND + (A M L1 L2) + (PROG(P Q S D) + (SETQ P + (CAADR L2) + Q + (CADADR L2) + S + (CDRAS 'M L1) + D + (CDRAS 'D L1) + L1 + (CADDR L2) + L2 + (CADDDR L2)) + (COND ((AND (NOT (EQ (CHECKSIGNTM (SUB (ADD* P + M + -1) + Q)) + '$POSITIVE)) + (EQ (CHECKSIGNTM (ADD S 1)) + '$POSITIVE)) + (RETURN (MUL D + (F19P220-SIMP (ADD S 1) + L1 + L2 + A + M))))) + (RETURN 'FAILED-ON-F19COND-MULTIPLY-THE-OTHER-CASES-WITH-D))) + +(DEFUN F19P220-SIMP + (S L1 L2 CF K) + (MUL* (GM S) + (INV (POWER PAR S)) + (HGFSIMP-EXEC (APPEND L1 (ADDARGLIST S K)) + L2 + (MUL* CF + (POWER K K) + (POWER (INV PAR) K))))) + +(DEFUN J1TF + (V Z) + (LIST (MUL* (INV (POWER 2 V)) + (POWER Z V) + (INV (GM (ADD V 1)))) + (LIST 'FPQ + (LIST 0 1) + NIL + (LIST (ADD V 1)) + (MUL (INV -4)(POWER Z 2))))) + +(DEFUN DIONARGHYP-Y (L INDEX ARG) + (PROG (A M C) + (SETQ A (CDRAS 'A ARG) + M (CDRAS 'M ARG) + C (CDRAS 'C ARG)) + (COND ((AND (ZERP C) (EQUAL M 1.)) + (RETURN (F2P105V2COND A L INDEX)))) + (COND ((AND (ZERP C) (EQUAL M (INV 2.))) + (RETURN (F50COND A L INDEX)))) + (RETURN 'FAIL-IN-DIONARGHYP-Y))) + +(DEFUN F2P105V2COND (A L INDEX) + (PROG (D M) + (SETQ D (CDRAS 'D L) M (CDRAS 'M L)) + (SETQ M (ADD M 1.)) + (COND ((EQ (CHECKSIGNTM ($REALPART (SUB M INDEX))) + '$POSITIVE) + (RETURN (F2P105V2COND-SIMP D M INDEX A)))) + (RETURN 'FAIL-IN-F2P105V2COND))) + +(DEFUN F50COND (A L V) + (PROG (D M) + (SETQ D (CDRAS 'D L) + M (CDRAS 'M L) + M (ADD M (INV 2.)) + V (DIV V 2.)) + (COND + ((AND (EQ (CHECKSIGNTM ($REALPART (ADD M V (INV 2.)))) + '$POSITIVE) + (EQ (CHECKSIGNTM ($REALPART (SUB (ADD M (INV 2.)) + V))) + '$POSITIVE) + (NOT (INTEGERP (MUL (SUB (ADD M M) (ADD V V 1.)) + (INV 2.))))) + (SETQ A (MUL A A (INV 4.))) + (RETURN (F50P188-SIMP D M V A)))) + (RETURN 'FAIL-IN-F50COND))) + +(DEFUN F2P105V2COND-SIMP (D M V A) + (MUL -2. + (POWER '$%PI -1.) + (GM (ADD M V)) + (POWER (ADD (MUL A A) (MUL PAR PAR)) (MUL -1. (INV 2.) M)) + (LEG2FSIMP (SUB M 1.) + (MUL -1. V) + (MUL PAR + (POWER (ADD (MUL A A) (MUL PAR PAR)) + (INV -2.)))))) + +(DEFUN LEG1FSIMP (M V Z) + (MUL (INV (GM (SUB 1. M))) + (POWER (DIV (ADD Z 1.) (SUB Z 1.)) (DIV M 2.)) + (HGFSIMP-EXEC (LIST (MUL -1. V) (ADD V 1.)) + (LIST (SUB 1. M)) + (SUB (INV 2.) (DIV Z 2.))))) + +(DEFUN LEG2FSIMP (M V Z) + (MUL (POWER '$%E (MUL M '$%PI '$%I)) + (POWER '$%PI (INV 2.)) + (GM (ADD M V 1.)) + (INV (POWER 2. (ADD V 1.))) + (INV (GM (ADD V (DIV 3. 2.)))) + (POWER Z (SUB -1. (ADD M V))) + (POWER (SUB (MUL Z Z) 1.) (MUL (INV 2.) M)) + (HGFSIMP-EXEC (LIST (DIV (ADD M V 1.) 2.) + (DIV (ADD M V 2.) 2.)) + (LIST (ADD V (MUL 3. (INV 2.)))) + (INV (MUL Z Z))))) + \ No newline at end of file diff --git a/src/ellen/option.88 b/src/ellen/option.88 new file mode 100644 index 00000000..709d37bb --- /dev/null +++ b/src/ellen/option.88 @@ -0,0 +1,1048 @@ +;;; -*- Mode:Lisp; Package:Macsyma-*- +;;; OPTIONS functions +;;; (c) Copyright 1980, Massachusetts Institute of Technology + +(macsyma-module option) + +(DECLARE (SPECIAL OPTIONS HISTORY CRU CRF) + (*EXPR OPTIONS NCDR FULLSTRIP1 RETRIEVE URESTORE NONSYMCHK MDESCRIBE)) + +(DEFMSPEC $OPTIONS (X) (SETQ X (CDR X)) + (COND ((NULL X) + (PRINC '|OPTIONS interpreter (Type "EXIT;" to exit.)|) + (TERPRI) (OPTIONS '$ALL)) + ((NONSYMCHK (CAR X) 'OPTIONS)) + (T (CONS '(MLIST) (DOWNS (CAR X)))))) + +(DEFUN OPTIONS (ANS) + (DO ((HISTORY)) (NIL) + (COND ((EQ '$EXIT ANS) (RETURN '$DONE)) + ((OR (EQ '$UP ANS) (EQ '$BACK ANS)) + (SETQ ANS (CADR HISTORY) HISTORY (CDDR HISTORY)) + (DOWN (IF (NULL ANS) '$ALL ANS))) + ((EQ '$TOP ANS) (OPTIONS '$ALL)) + ((ATOM ANS) (DOWN ANS)) + ((OR (EQ '$DOWN (CAAR ANS)) (EQ '$OPTIONS (CAAR ANS))) + (DOWN (CADR ANS))) + ((EQ '$DESCRIBE (CAAR ANS)) (MDESCRIBE (DECODE (CADR ANS)))) + (T (OPT-ERR))) + (SETQ ANS (RETRIEVE NIL NIL)))) + +(DEFUN DOWN (NODE &AUX OPTS) + (SETQ NODE (DECODE NODE) OPTS (DOWNS NODE)) + (COND ((NULL OPTS) (PRINC "No options") (TERPRI)) + (T (SETQ HISTORY (CONS NODE HISTORY) OPTIONS OPTS) + (MENU OPTIONS)))) + +(DEFUN UP (NODE &AUX OPTS) + (SETQ NODE (DECODE NODE) OPTS (UPS NODE)) + (COND ((NULL OPTS) (PRINC "No options") (TERPRI)) + (T (SETQ HISTORY (CONS NODE HISTORY) OPTIONS OPTS) + (MENU OPTIONS)))) + +(DEFUN DOWNS (NODE) (GET NODE 'SUBC)) +(DEFUN UPS (NODE) (GET NODE 'SUPC)) + +(DEFUN DECODE (NODE) + (COND ((NOT (FIXP NODE)) NODE) + ((OR (ZEROP NODE) (NULL (SETQ NODE (NCDR OPTIONS NODE)))) (NOR-ERR)) + (T (CAR NODE)))) + +(DEFUN MENU (OPTS) + (DO ((L OPTS (CDR L)) (I 1 (1+ I))) ((NULL L)) + (PRINC I) (PRINC " - ") (PRINC (FULLSTRIP1 (CAR L))) + (COND ((GET (CAR L) 'KIND) (TYO #\SP) (PRINC (GET (CAR L) 'KIND)))) + (TERPRI))) + + +(DEFUN OPT-ERR () (PRINC "Illegal command to OPTIONS") (TERPRI)) +(DEFUN NOR-ERR () (PRINC "Number out of range") (TERPRI)) + +(DEFUN SUBC FEXPR (X) + (PUTPROP (CAR X) (CADR X) 'KIND) + (PUTPROP (CAR X) (CDDR X) 'SUBC)) + +(DEFUN SUPC FEXPR (X) + (PUTPROP (CAR X) (CADR X) 'KIND) + (PUTPROP (CAR X) (CDDR X) 'SUPC)) + +(DEFUN PRINTNET () (PRNET '$ALL 0) NIL) +(DEFUN PRNET (NODE INDENT) + (TERPRI) + (DO I 1 (1+ I) (> I INDENT) (TYO #\TAB)) (PRINC (FULLSTRIP1 NODE)) + (COND ((GET NODE 'KIND) (TYO #\SP) (PRINC (GET NODE 'KIND)))) + (MAPC #'(LAMBDA (L) (PRNET L (1+ INDENT))) (DOWNS NODE))) + +;;Copyright 1980, Massachusetts Institute of Technology +(SUBC $ALL () $INTERACTION $DEBUGGING $EVALUATION $LISTS $MATRICES + $SIMPLIFICATION $REPRESENTATIONS $PLOTTING $TRANSLATION + $PATTERN-MATCHING $TENSORS) + +(SUBC $ABS (C)) + +(SUBC $ADDROW (C)) + +(SUBC $ALARMCLOCK (C)) + +(SUBC $ALIASES (V)) + +(SUBC $ALGSYS (C)) + +(SUBC $ALLROOTS (C)) + +(SUBC $APPEND (C)) + +(SUBC $APPENDFILE (C)) + +(SUBC $APPLY (C)) + +(SUPC $APROPOS (C) $USER-AIDS $GENERAL-INFO) + +(SUBC $ARRAYS () $ARRAY) + +(SUBC $ARRAYS (V)) + +(SUBC $ARRAY (C)) + +(SUBC $ARRAYINFO (C)) + +(SUBC $ARRAYMAKE (C)) + +(SUBC $ASSUME (C)) + +(SUBC $AT (C)) + +(SUBC $ATOM (C)) + +(SUBC $ATVALUE (C)) + +(SUBC $AUGCOEFMATRIX (C)) + +(SUBC $AUTOMATIC () $TRIGEXPAND $TRIGINVERSES $TRIGSIGN $EXPONENTIALIZE + $LOGARC $DEMOIVRE $LOGEXPAND $RADEXPAND) + +(SUBC $BAKSOLVE (C)) + +(SUBC $BATCH (C)) + +(SUBC $BATCON (C)) + +(SUBC $BERN (C)) + +(SUBC $BERNPOLY (C)) + +(SUBC $BETA (C)) + +(SUBC $BFLOAT (C)) + +(SUPC $BFTRUNC (S) $DISPLAY) + +(SUBC $BREAK (C)) + +(SUBC $CABS (C)) + +(SUBC $CATCH (C)) + +(SUBC $CF (C)) + +(SUBC $CFDISREP (C)) + +(SUBC $CFEXPAND (C)) + +(SUBC $CHANGEVAR (C)) + +(SUBC $CHARPOLY (C)) + +(SUBC $CHR1 (C)) + +(SUBC $CHR2 (C)) + +(SUBC $CHRISTOF (C)) + +(SUBC $CLOSEFILE (C)) + +(SUBC $COEFF (C)) + +(SUBC $COEFMATRIX (C)) + +(SUBC $COL (C)) + +(SUBC $COMEXP (C)) + +(SUBC $COMPILE (C)) + +(SUBC $CONCAT (C)) + +(SUBC $COMMAND-FILES (C) $BATCH $BATCON $DEMO) + +(SUBC $COMPFILE (C)) + +(SUBC $COMPLEX () $REALPART $IMAGPART $RECTFORM $POLARFORM $CABS) + +(SUBC $CONS (C)) + +(SUBC $CONSTANTP (C)) + +(SUBC $CONTENT (C)) + +(SUBC $CONTRACT (C)) + +(SUBC $COPYLIST (C)) + +(SUBC $COVDIFF (C)) + +(SUBC $COPYMATRIX (C) $RATMX $SPARSE $LISTARITH $DETOUT $DOALLMXOPS + $DOMXMXOPS $DOSCMXPLUS $SCALARMATRIXP) + +(SUBC $CURVATURE () $SCURVATURE $RIEMANN $RAISERIEMANN $RINVARIANT $WEYL + $DSCALAR $DALEM $YT) + +(SUBC $DALEM (C)) + +(SUBC $DEBUGMODE (C)) + +(SUBC $DECLARE (C)) + +(SUBC $DEFCON (C)) + +(SUBC $DEFINE (C)) + +(SUBC $DEFMATCH (C)) + +(SUBC $DEFRULE (C)) + +(SUBC $DEFTAYLOR (C)) + +(SUBC $DEBUGGING () $TRACE $DEBUG $DEBUGMODE $BREAK $BINDTEST $OPTIONSET) + +(SUBC $DELETE (C)) + +(SUPC $DERIVABBREV (S) $DISPLAY) + +(SUBC $DEFILE (C)) + +(SUBC $DELTA (C)) + +(SUBC $DEMO (C)) + +(SUBC $DENOM (C)) + +(SUBC $DEPENDS (C)) + +(SUBC $DEPENDENCIES (V)) + +(SUBC $DERIVDEGREE (C)) + +(SUBC $DETERMINANT (C)) + +(SUBC $DESCRIBE (C)) + +(SUBC $DIAGMATRIX (C)) + +(SUBC $DIFF (C) $DEPENDENCIES $GRADEF) + +(SUBC $DISPLAY (C) $POWERDISP $SQRTDISPFLAG $STARDISP $DERIVABBREV + $EXPTDISPFLAG $%EDISPFLAG $BFTRUNC $PFEFORMAT + $NOUNDISP $NOLABELS) + +(SUBC $DISP (C)) + +(SUBC $DISPFUN (C)) + +(SUBC $DISPRULE (C)) + +(SUBC $DISPTERMS (C)) + +(SUBC $DIVIDE (C)) + +(SUBC $DPART (C)) + +(SUBC $DSCALAR (C)) + +(SUBC $DSKGC (C)) + +(SUBC $DUMMY (C)) + + +(SUBC $EDITING () $MACSYMA-LINE-EDITOR $TECO) + +(SUPC $%EDISPFLAG (S) $DISPLAY) + +(SUBC $ECHELON (C)) + +(SUBC $EINSTEIN (C) $RATEINSTEIN $FACRAT) + +(SUBC $EMATRIX (C)) + +(SUBC $ENDCONS (C)) + +(SUBC $ENTERMATRIX (C) $RATMX $SPARSE $LISTARITH $DETOUT $DOALLMXOPS + $DOMXMXOPS $DOSCMXPLUS $SCALARMATRIXP) + +(SUBC $ENTIER (C)) + +(SUBC $EQUAL (C)) + +(SUBC $ERF (C)) + +(SUBC $ERRCATCH (C)) + +(SUBC $ERROR (C)) + +(SUBC $EULER (C)) + +(SUBC $EXP (C)) + +(SUBC $EXPLICIT () $TSETUP $QUANTITIES $CURVATURE) + +(SUBC $EXTEND (C)) + +(SUBC $EZGCD (C)) + +(SUBC $EXPAND (C) $MAXPOSEX $MAXNEGEX) + +(SUBC $EXPANSION () $EXPAND $RATEXPAND) + +(SUPC $EXPONENTIALIZE (S) $EV $SIMPLIFICATION) + +(SUPC $EXPTDISPFLAG (S) $DISPLAY) + +(SUBC $EV (C) $EXPONENTIALIZE $%IARGS $LOGARC $%PIARGS $TRIGSIGN + $TRIGINVERSES) + +(SUBC $EVALUATION () $VARIABLE $FUNCTION $ARRAY $SIMP) + +(SUPC $FACRAT (S) $EINSTEIN $REIMANN $WEYL) + +(SUBC $FACTCOMB (C)) + +(SUBC $FACTOR (C) $RATVARS) + +(SUBC $FACTORSUM (C) $RATVARS) + +(SUBC $FACTORING () $FACTOR $GFACTOR $FACTORSUM $GFACTORSUM $SQFR $PARTITION) + +(SUBC $FASSAVE (C)) + +(SUBC $FASTTIMES (C)) + +(SUBC $FIB (C)) + +(SUBC $FIRST (C)) + +(SUBC $FLOAT (C)) + +(SUBC $FLOATNUMP (C)) + +(SUBC $FORGET (C)) + +(SUBC $FPPREC (C)) + +(SUBC $FREEOF (C)) + +(SUBC $FILES () $FILE-CREATION $FILE-DELETION $SAVE-FILES $COMMAND-FILES) + +(SUBC $FILE-CREATION () $APPENDFILE $CLOSEFILE $FASSAVE $STORE + $SAVE $WRITEFILE) + +(SUBC $FILE-DELETION () $DEFILE $REMFILE) + +(SUBC $FULLMAP (C) $MAPERROR $MAPRAT) + +(SUBC $FULLMAPL (C) $MAPERROR $MAPRAT) + +(SUBC $FUNCTIONS (V)) + +(SUBC $GAMMA (C)) + +(SUBC $GCD (C)) + +(SUBC $GENERAL-INFO () $DESCRIBE $EXAMPLE $OPTIONS $PRIMER $APROPOS) + +(SUBC $GENFACT (C)) + +(SUBC $GENMATRIX (C) $RATMX $SPARSE $LISTARITH $DETOUT $DOALLMXOPS + $DOMXMXOPS $DOSCMXPLUS $SCALARMATRIXP) + +(SUBC $GET (C)) + +(SUBC $GETCHAR (C)) + +(SUBC $GFACTOR (C) $RATVARS) + +(SUBC $GFACTORSUM (C) $RATVARS) + +(SUBC $GRADEF (C)) + +(SUBC $GRADEFS (V)) + +(SUBC $GRAPH (C) $PLOTHEIGHT $LINEL) + +(SUBC $HIPOW (C)) + +(SUBC $HORNER (C)) + +(SUPC $%IARGS (S) $EV $SIMPLIFICATION) + +(SUPC $INCHAR (V)) + +(SUBC $IDENT (C)) + +(SUBC $ILT (C)) + +(SUBC $IMAGPART (C)) + +(SUBC $INDICES (C)) + +(SUBC $INPART (C)) + +(SUBC $INTEGERP (C)) + +(SUBC $INTEGRATE (C)) + +(SUBC $INTOPOIS (C)) + +(SUBC $INFIX (C)) + +(SUBC $INPUT () $SYNTAX $EDITING $RETRIEVE $READ $INCHAR) + +(SUBC $INTERACTION () $INPUT $OUTPUT $FILES $INFORMATION $USER-AIDS + $INFORMATION) + +(SUBC $INFOLISTS (V)) + +(SUBC $INFORMATION () $GENERAL-INFO $SPECIFIC-INFO $INFORMATION-LISTS) + +(SUBC $INFORMATION-LISTS () $INFOLISTS $MYOPTIONS $ALIASES $LABELS + $LABELS $VALUES $FUNCTIONS $RULES $PROPS + $MATCHDECLARES $MODEDECLARES $ARRAYS + $GRADEFS $DEPENDENCIES) +(SUBC $IS (C) $PREDERROR) + +(SUBC $ISOLATE (C)) + +(SUBC $ISQRT (C)) + +(SUBC $KILL (C)) + +(SUBC $LABELS (V)) + +(SUBC $LAMBDA (C)) + +(SUBC $LAPLACE (C)) + +(SUBC $LAST (C)) + +(SUBC $LC (C)) + +(SUBC $LDEFINT (C)) + +(SUBC $LDISP (C)) + +(SUBC $LDISPLAY (C)) + +(SUBC $LENGTH (C)) + +(SUBC $LET (C)) + +(SUBC $LETRULES (C)) + +(SUBC $LETSIMP (C)) + +(SUBC $LHS (C)) + +(SUBC $LIMIT (C)) + +(SUPC $LINEL (V) $DISPLAY $PLOT $GRAPH $MULTIGRAPH $PARAMPLOT) + +(SUBC $LISTS () $CONS $ENDCONS $APPEND $MEMBER $REVERSE $FIRST $REST + $LAST $DELETE $LENGTH $MAPPING) + +(SUPC $LISTARITH (S) $ENTERMATRIX $MATRIX $GENMATRIX $COPYMATRIX + $ADDROW $TRANSPOSE $ECHELON $TRIANGULARIZE + $RANK $DETERMINANT $CHARPOLY) + +(SUBC $LINSOLVE (C)) + +(SUBC $LISTOFVARS (C)) + +(SUBC $LISTP (C)) + +(SUBC $LOADFILE (C)) + +(SUBC $LOCAL (C)) + +(SUBC $LOG (C)) + +(SUBC $LOGOUT (C)) + +(SUBC $LOPOW (C)) + +(SUBC $LORENTZ (C)) + +(SUBC $LPART (C)) + +(SUBC $LRICCICOM (C)) + +(SUPC $LOGARC (S) $EV $SIMPLIFICATION) + +(SUBC $MACSYMA-LINE-EDITOR ()) + +(SUBC $MAKEBOX (C)) + +(SUBC $MAKENONSCALAR (C)) + +(SUBC $MAP (C) $MAPERROR $MAPRAT) + +(SUBC $MAPLIST (C) $MAPERROR $MAPRAT) + +(SUPC $MAPERROR (S) $MAP $MAPLIST $FULLMAP $FULLMAPL) + +(SUBC $MAPPING () $MAP $MAPLIST $FULLMAP $FULLMAPL $SCANMAP) + +(SUPC $MAPRAT (S) $MAP $MAPLIST $FULLMAP $FULLMAPL) + +(SUBC $MATCHDECLARES (V)) + +(SUBC $MATCHDECLARE (C)) + +(SUBC $MATCHFIX (C)) + +(SUBC $MATRICES () $MATRIX-CONSTRUCTION $MATRIX-MANIPULATION) + +(SUBC $MATRIX-CONSTRUCTION () $ENTERMATRIX $MATRIX $GENMATRIX $COPYMATRIX + $ADDROW) + +(SUBC $MATRIX-MANIPULATION () $TRANSPOSE $ECHELON $TRIANGULARIZE + $RANK $DETERMINANT $CHARPOLY) + +(SUBC $MATRIX (C) $RATMX $SPARSE $LISTARITH $DETOUT $DOALLMXOPS + $DOMXMXOPS $DOSCMXPLUS $SCALARMATRIXP) + +(SUBC $MATRIXMAP (C)) + +(SUBC $MATRIXP (C)) + +(SUBC $MAX (C)) + +(SUBC $MAXNEGEX (S) $EXPAND) + +(SUBC $MAXPOSEX (S) $EXPAND) + +(SUBC $MEMBER (C)) + +(SUBC $MIN (C)) + +(SUBC $MINFACTORIAL (C)) + +(SUBC $MINOR (C)) + +(SUBC $MOD (C)) + +(SUBC $MODEDECLARE (C)) + +(SUBC $MODEDECLARES (V)) + +(SUBC $MOTION (C)) + +(SUBC $MULTIGRAPH (C) $PLOTHEIGHT $LINEL) + +(SUBC $MULTTHRU (C)) + +(SUBC $MYOPTIONS (V)) + +(SUBC $NARY (C)) + +(SUBC $NEWDET (C)) + +(SUBC $NONSCALARP (C)) + +(SUBC $NOUNIFY (C)) + +(SUBC $NOFIX (C)) + +(SUPC $NOLABELS (S) $DISPLAY) + +(SUPC $NOUNDISP (S) $DISPLAY) + +(SUBC $NROOTS (C)) + +(SUBC $NTERMS (C)) + +(SUBC $NTERMSG (C)) + +(SUBC $NTERMSRCI (C)) + +(SUBC $NUM (C)) + +(SUBC $NUMBERP (C)) + +(SUBC $NUMERVAL (C)) + +(SUBC $NUMFACTOR (C)) + +(SUBC $OPTIMIZE (C)) + +(SUBC $OPTIONS (C) $DOWN $UP $BACK $DESCRIBE $EXIT) + +(SUBC $ORDERGREAT (C)) + +(SUBC $ORDERLESS (C)) + +(SUBC $OTHER-TRANSFORMATIONS () $TRIGREDUCE $TRIGEXPAND $FACTCOMB $LOGCONTRACT) + +(SUBC $OUTOFPOIS (C)) + +(SUBC $OUTCHAR (V)) + +(SUBC $OUTPUT () $PRINT $DISPLAY $OUTCHAR) + +(SUBC $PARAMPLOT (C) $PLOTHEIGHT $LINEL) + +(SUBC $PART-FUNCTIONS () $PART $INPART $LHS $RHS %NUM $DENOM $COEFF $$FIRST + $REST $LAST $RATCOEF) + +(SUBC $PART (C)) + +(SUBC $PARTFRAC (C)) + +(SUBC $PARTITION (C) $RATVARS) + +(SUPC $PFEFORMAT (S) $DISPLAY) + +(SUPC $%PIARGS (S) $EV $SIMPLIFICATION) + +(SUBC $PICKAPART (C)) + +(SUBC $PLAYBACK (C)) + +(SUBC $PLOG (C)) + +(SUBC $PLOT (C) $PLOTHEIGHT $LINEL) + +(SUPC $PLOTHEIGHT (V) $PLOT $GRAPH $MULTIGRAPH $PARAMPLOT) + +(SUBC $PLOTTING () $PLOT $GRAPH $MULTIGRAPH $PARAMPLOT) + +(SUBC $POISDIFF (C)) + +(SUBC $POISEXPT (C)) + +(SUBC $POISINT (C)) + +(SUBC $POISMAP (C)) + +(SUBC $POISPLUS (C)) + +(SUBC $POISSIMP (C)) + +(SUBC $POISSUBST (C)) + +(SUBC $POISTIMES (C)) + +(SUBC $POISTRIM (C)) + +(SUBC $POLARFORM (C)) + +(SUBC $POLYSIGN (C)) + +(SUBC $POSTFIX (C)) + +(SUPC $POWERDISP (S) $DISPLAY) + +(SUBC $POWERSERIES (C)) + +(SUPC $PREDERROR (S) $IS) + +(SUBC $PREDICATES () $IS $ZEROEQUIV $ASSUME $FORGET) + +(SUBC $PREFIX (C)) + +(SUBC $PRIMER (C)) + +(SUBC $PRINT (C)) + +(SUBC $PRINTPOIS (C)) + +(SUBC $PRINTPROPS (C)) + +(SUBC $PRODUCT (C)) + +(SUBC $PROPS (V)) + +(SUBC $PROPERTIES (C)) + +(SUBC $PROPVARS (C)) + +(SUBC $PSI (C)) + +(SUBC $PUT (C)) + +(SUBC $QPUT (C)) + +(SUBC $QUANTITIES () $CHRISTOF $MOTION $RICCICOM $NTERMSRCI $LRICCICOM + $EINSTEIN $NTERMSG) + +(SUBC $QUIT (C)) + +(SUBC $QUNIT (C)) + +(SUBC $QUOTIENT (C)) + +(SUBC $RADCAN (C)) + +(SUBC $RAISERIEMANN (C)) + +(SUBC $RANDOM (C)) + +(SUBC $RANK (C)) + +(SUBC $RAT (C)) + +(SUBC $RATCOEF (C)) + +(SUBC $RATDENOM (C)) + +(SUBC $RATDIFF (C)) + +(SUBC $RATDISREP (C)) + +(SUPC $RATEINSTEIN (S) $EINSTEIN) + +(SUBC $RATEXPAND (C)) + +(SUBC $RATIONAL () $EXPAND $MULTTHRU $XTHRU $COMBINE $FACTOR $FACTORSUM + $FACTOROUT $SQFR $RATSIMP $PARTFRAC) + +(SUPC $RATMX (S) $ENTERMATRIX $MATRIX $GENMATRIX $COPYMATRIX + $ADDROW $TRANSPOSE $ECHELON $TRIANGULARIZE + $RANK $DETERMINANT $CHARPOLY) + +(SUBC $RATNUMER (C)) + +(SUBC $RATNUMP (C)) + +(SUBC $RATP (C)) + +(SUPC $RATRIEMANN (S) $RIEMANN) + +(SUBC $RATSIMP (C)) + +(SUBC $RATSUBST (C)) + +(SUPC $RATVARS (V)) + +(SUBC $RATWEIGHT (C)) + +(SUPC $RATWEYL (S) $WEYL) + +(SUBC $READ (C)) + +(SUBC $REALPART (C)) + +(SUBC $REALROOTS (C)) + +(SUBC $RECTFORM (C)) + +(SUBC $REM (C)) + +(SUBC $REMAINDER (C)) + +(SUBC $REMARRAY (C)) + +(SUBC $REMBOX (C)) + +(SUBC $REMCON (C)) + +(SUBC $REMFILE (C)) + +(SUBC $REMFUNCTION (C)) + +(SUBC $REMLET (C)) + +(SUBC $REMOVE (C)) + +(SUBC $REMRULE (C)) + +(SUBC $RETRIEVE (C)) + +(SUBC $REMTRACE (C)) + +(SUBC $REMVALUE (C)) + +(SUBC $RENAME (C)) + +(SUBC $RESET (C)) + +(SUBC $RESIDUE (C)) + +(SUBC $REPRESENTATIONS () $GENERAL $CRE $TRANSFORMATIONS $SUBSTITUTIONS + $PART-FUNCTIONS) + +(SUBC $REST (C)) + +(SUBC $REVERSE (C)) + +(SUBC $RESTORE (C)) + +(SUBC $RESULTANT (C)) + +(SUBC $REVEAL (C)) + +(SUBC $RHS (C)) + +(SUBC $RICCICOM (C)) + +(SUBC $RIEMANN (C) $RATRIEMANN $FACRAT) + +(SUBC $RINVARIENT (C)) + +(SUBC $RISCH (C)) + +(SUBC $ROW (C)) + +(SUBC $RULES (V)) + +(SUBC $SAVE-FILES (C) $LOADFILE $RESTORE) + +(SUBC $SAVE (C)) + +(SUBC $SCANMAP (C)) + +(SUBC $SCURVATURE (C)) + +(SUBC $SEND (C)) + +(SUBC $SETELMX (C)) + +(SUBC $SETUP (C)) + +(SUBC $SHOW (C)) + +(SUBC $SHOWTIME (C)) + +(SUBC $SIGN (C)) + +(SUBC $SIGNUM (C)) + +(SUBC $SIMP (S)) + +(SUBC $SIMPLIFICATION () $AUTOMATIC $SIMP-RULES) + +(SUBC $SOLVE (C)) + +(SUPC $SPARSE (S) $ENTERMATRIX $MATRIX $GENMATRIX $COPYMATRIX + $ADDROW $TRANSPOSE $ECHELON $TRIANGULARIZE + $RANK $DETERMINANT $CHARPOLY) + +(SUBC $SPECIFIC-INFO () $TRACE $UNTRACE $GRIND $DISPRULE $PROPERTIES + $PRINTPROPS $PLAYBACK $DISPFUN $ARRAYINFO) + +(SUBC $SQFR (C) $RATVARS) + +(SUBC $SQRT (C)) + +(SUBC $SRRAT (C)) + +(SUBC $STARDISP (C)) + +(SUBC $STATUS (C)) + +(SUBC $STORE (C)) + +(SUBC $STRING (C)) + +(SUBC $STRINGOUT (C)) + +(SUBC $SUBMATRIX (C)) + +(SUBC $SUBST (C)) + +(SUBC $SUBSTINPART (C)) + +(SUBC $SUBSTITUTIONS () $SUBST $RATSUBST $SUBSTPART $SUBSTINPART) + +(SUBC $SUBSTPART (C)) + +(SUBC $SUM (C)) + +(SUBC $SYMBOL (C)) + +(SUBC $SYNTAX () $PREFIX $INFIX $POSTFIX $NARY $MATCHFIX $NOFIX $SYMBOL) + +(SUBC $TAYLOR (C)) + +(SUBC $TELLRAT (C)) + +(SUBC $TELLSIMP (C)) + +(SUBC $TELLSIMPAFTER (C)) + +(SUBC $TENSORS () $EXPLICIT $INDICIAL) + +(SUBC $THROW (C)) + +(SUBC $TLDEFINT (C)) + +(SUBC $TLIMIT (C)) + +(SUBC $TOTALDISREP (C)) + +(SUBC $TRACE (C) $UNTRACE $REMTRACE) + +(SUBC $TRANSFORMATIONS () $RATIONAL $OTHER-TRANSFORMATIONS) + +(SUBC $TRANSLATE (C) $TRANSRUN $MODEDECLARE) + +(SUBC $TRANSPOSE (C)) + +(SUPC $TRANSRUN (S) $EVALUATION) + +(SUBC $TRIANGULARIZE (C)) + +(SUBC $TRIG () $TRIGSWITCHES $TRIGEXPAND $TRIGREDUCE) + +(SUBC $TRIGEXPAND (C S)) + +(SUPC $TRIGINVERSES (S) $EV $SIMPLIFICATION) + +(SUBC $TRIGREDUCE (C)) + +(SUPC $TRIGSIGN (S) $EV $SIMPLIFICATION) + +(SUBC $TRIGSWITCHES () $%PIARGS $%IARGS $TRIGINVERSES $TRIGSIGN + $EXPONENTIALIZE $LOGARC) + +(SUBC $TSETUP (C)) + +(SUBC $SCANMAP (C)) + +(SUBC $SIMPLIFICATION () $EXPANSION $FACTORING $TRIG) + +(SUBC $SOLVE (C) $SOLVEFACTORS $SOLVERADCAN) + +(SUPC $SOLVEFACTORS (S) $SOLVE) + +(SUPC $SOLVERADCAN (S) $SOLVE) + +(SUPC $SQRTDISPFLAG (S) $DISPLAY) + +(SUPC $STARDISP (S) $DISPLAY) + +(SUBC $TRANSLATION () $TRANSLATE $COMPFILE $MODEDECLARE) + +(SUBC $TRIGFUNCTION () %SIN %COS %TAN %COT %CSC %SEC + %ASIN %ACOS %ATAN %ACOT %ACSC %ASEC + %SINH %COSH %TANH %COTH %CSCH %SECH + %ASINH %ACOSH %ATANH %ACOTH %ACSCH %ASECH) + +(SUBC $UNDIFF (C)) + +(SUBC $UNIVERSALS () $TIMEDATE $WHO $BUG $MAIL $SEND) + +(SUBC $UNORDER (C)) + +(SUBC $UNSTORE (C)) + +(SUBC $UNTRACE (C)) + +(SUBC $USER-AIDS () $PRIMER $DESCRIBE $OPTIONS $EXAMPLE $APROPOS $VISUAL-AIDS) + +(SUBC $VALUES (V)) + +(SUBC $VERBIFY (C)) + +(SUBC $VISUAL-AIDS () $REVEAL $ISOLATE $PICKAPART) + +(SUBC $WEYL (C) $RATWEYL $FACRAT) + +(SUBC $WRITEFILE (C)) + +(SUBC $XTHRU (C)) + +(SUBC $YT (C)) + +(SUBC $ZETA (C)) + +(SUBC $ZEROEQUIV (C)) + +(SUBC %SIN (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN + $LOGARC) + +(SUBC %COS (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN + $LOGARC) + +(SUBC %TAN (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN + $LOGARC) + +(SUBC %COT (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN + $LOGARC) + +(SUBC %CSC (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN + $LOGARC) + +(SUBC %SEC (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN + $LOGARC) + +(SUBC %ASIN (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ACOS (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ATAN (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ACOT (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ACSC (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ASEC (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %SINH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN) + +(SUBC %COSH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN) + +(SUBC %TANH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN) + +(SUBC %COTH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN) + +(SUBC %CSCH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN) + +(SUBC %SECH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGEXPAND $EXPONENTIALIZE $HALFANGLES $TRIGSIGN) + +(SUBC %ASINH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ACOSH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ATANH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ACOTH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ACSCH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC %ASECH (C) $FLOAT $NUMER $BFLOAT $%PIARGS $%IARGS $TRIGINVERSES + $TRIGSIGN $LOGARC) + +(SUBC |&.| (C) $DOTASSOC $DOTSCRULES $DOTCONSTRULES $DOTEXPTSIMP + $DOTDISTRIB $ASSUMESCALAR) diff --git a/src/ellen/primer.213 b/src/ellen/primer.213 new file mode 100644 index 00000000..c9ebe570 --- /dev/null +++ b/src/ellen/primer.213 @@ -0,0 +1,297 @@ +;;;-*-lisp-*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;To run this primer interpreted, the following files must be LOADFILED into ;; +;;MACSYMA: MRG;MACROS FASL, ELLEN;CHECK >, ELLEN;SCRIPT >, and this file. ;; +;;I do not recommend doing that, however. -Ellen ;; +;;(C) Copyright 1979, Massachusetts Institute of Technology ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(DECLARE (SPECIAL CLABEL DLABEL NSP TB LP RP SCRIPTINDEX LISPREADTABLE + $% $LABELS $LINENUM $INCHAR $OUTCHAR + LINEL GCT $SHOWTIME $LASTTIME) + (UNSPECIAL *) + (*EXPR MEVAL STRIPDOLLAR DISPLA MGRIND MAKSTRING ADD2LNC RETRIEVE) + (*FEXPR $LOADFILE) (FASLOAD MACROS FASL DSK MRG)) + +(DECLARE (EVAL (READ))) +(SETSYNTAX '/# 'MACRO 'TYI) +(SETSYNTAX '/" 'MACRO 'READTEXT) +(DEFUN READTEXT () + (LAMBIND ((READTABLE (GET 'PRIMER 'ARRAY))) + (DO ((S (READ) (READ)) (NL)) ((EQ '/" S) `(TEXT ',(NREVERSE NL))) + (SETQ NL (CONS S NL)) + (IF (EQ '/@ S) + (LAMBIND ((READTABLE LISPREADTABLE)) (SETQ NL (CONS (READ) NL))))))) + +(SETSYNTAX #~ 'MACRO 'NOFILL) +(DEFUN NOFILL () + (DO ((C (TYI) (TYI)) (CL)) + ((= #~ C) `(PRINC ',(MAKNAM (NREVERSE CL)))) + (SETQ CL (CONS C CL)))) + +(*ARRAY 'PRIMER 'READTABLE T) +(LAMBIND ((READTABLE (GET 'PRIMER 'ARRAY))) + (DO I ## (1+ I) (> I #@) (SETSYNTAX I 1 I)) + (DO I #a (1+ I) (> I #z) (SETSYNTAX I 1 I)) + (SETSYNTAX #` 'SINGLE #`) + (SETSYNTAX #@ 'SINGLE #@) + (SETSYNTAX #" 'SINGLE #")) + +(DECLARE (COUTPUT (READ))) +(DEFUN IF MACRO (X) + (COND ((NULL (CDDDR X)) `(COND (,(CADR X) ,(CADDR X)))) + (T `(COND (,(CADR X) ,(CADDR X)) (T . ,(CDDDR X)))))) + +(SETQ LISPREADTABLE READTABLE + SCRIPTINDEX '(($INTRO (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN)) + ($CONSOLEPRIMER (SCRIPT INTRO DSK ELLEN) + (CHECK FASL DSK ELLEN)) + ($HELP (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN)) + ($SYNTAX (SCRIPT INTRO DSK ELLEN)(CHECK FASL DSK ELLEN)) + ($SIMPLIFICATION (SCRIPT INTRO DSK ELLEN) + (CHECK FASL DSK ELLEN)) + ($SCRATCHPAD (SCRIPT INTRO DSK ELLEN) + (CHECK FASL DSK ELLEN)) + ($ASSIGNMENT (SCRIPT AUX DSK ELLEN) + (CHECK FASL DSK ELLEN)) + ($FILING (SCRIPT AUX DSK ELLEN) + (CHECK FASL DSK ELLEN)) + ($STRINGCOMMANDS (SCRIPT AUX DSK ELLEN) + (CHECK FASL DSK ELLEN)) + ($MATRICES (SCRIPT MATRIX DSK ELLEN) + (CHECK FASL DSK ELLEN)) + ($SHARE (SHARE SCRIPT DSK ELLEN)) + ($ABSIMP (SHARE SCRIPT DSK ELLEN)) + ($ROMBER (SHARE SCRIPT DSK ELLEN)) + ($FFT (SHARE SCRIPT DSK ELLEN)) + ($DESOLN (SHARE SCRIPT DSK ELLEN)) + ($UNITS (SHARE SCRIPT DSK ELLEN)) + ($ARRAY (SHARE SCRIPT DSK ELLEN)) + ($DIMEN (SHARE SCRIPT DSK ELLEN)) + ($DUMP (SHARE SCRIPT DSK ELLEN)) + ($FACT (SHARE SCRIPT DSK ELLEN)) + ($INTPOL (SHARE SCRIPT DSK ELLEN)) + ($MATCH (MATCH SCRIPT DSK MRG)))) + + +(DEFUN $PRIMER FEXPR (X) + (SETQ X (COND (X (CAR X)) + ((SEENP (STATUS UNAME) '$CONSOLEPRIMER) '$HELP) + (T '$CONSOLEPRIMER))) + (*CATCH 'PQUIT (SCRIPT X T)) + '$DONE) + +(DEFUN SEENP (USER SC) + (PROGB (IN) + (SETQ IN (OPEN '(USER PROFIL DSK ALJABR) 'IN)) + (DO ((U (READ IN 'EOF) (READ IN 'EOF))) ((EQ U 'EOF) (CLOSE IN) NIL) + (COND ((EQ USER (CAR U)) (CLOSE IN) (RETURN (MEMQ SC (CDR U)))))))) + +(DEFUN SEEN (USER SC) + (PROGB (IN OUT) + (SETQ IN (OPEN '(USER PROFIL DSK ALJABR) 'IN) + OUT (OPEN '(USER PROFIL DSK ALJABR) 'OUT)) + (DO ((U (READ IN NIL) (READ IN NIL)) (SUCCESS)) + ((NULL U) (IFN SUCCESS (PRINT (LIST USER SC) OUT))) + (IFN (EQ USER (CAR U)) T (SETQ SUCCESS T) (RPLACD U (CONS SC (CDR U)))) + (PRINT U OUT)) + (CLOSE IN) (CLOSE OUT))) + +(DEFUN SCRIPT (SC TOP) + (SETQ SC (GETSCRIPT SC TOP)) + (*CATCH 'EXIT (DO () ((NULL SC)) (TERPRI) (EVAL (CAR SC)) + (SETQ SC (CDR SC))))) + +(DEFUN GETSCRIPT (SC TOP) + (PROGB (*) + (COND ((GET SC 'SCRIPT)) + ((AND (SETQ * (CDR (ASSQ SC SCRIPTINDEX))) + (DO ((L * (CDR L))) ((NULL L) T) + (APPLY '$LOADFILE (CAR L))) + (GET SC 'SCRIPT))) + (T (TERPRI) (PRINC '|No such script.|) (COND (TOP (ERR))))))) + +(DEFUN TEXT (L) + (TERPRI) (TYO TB) + (DO ((X) (W) (WD 8)) ((NULL L)) (DECLARE (FIXNUM W WD)) + (IF (NOT (EQ '/@ (CAR L))) (SETQ X (CAR L) W (FLATC X)) + (SETQ L (CDR L) X (STRGRIND (EVAL (CAR L))) W (LENGTH X))) + (COND ((>= (+ 3 W WD) LINEL) (TERPRI) (SETQ WD 0))) + (IF (ATOM X) (PRINC X) (MAPC 'TYO X)) (TYO NSP) + (SETQ L (CDR L) WD (+ 1 W WD)))) + + +(DEFUN EXIT () (*THROW 'EXIT NIL)) +(DEFUN PQUIT () (*THROW 'PQUIT NIL)) + + +(DEFUN YESORNO () + (TERPRI) + (DO ANS (RETRIEVE NIL NIL) (RETRIEVE NIL NIL) NIL + (COND ((MEMQ ANS '($YES $YEP $YEAH $Y $YUP $SURE $OK $T)) (RETURN T)) + ((MEMQ ANS '($NO $N $NOPE $NIL)) (RETURN NIL)) + (T (PRINC '|Was that a YES or a NO?|) + (TERPRI))))) + +(DEFUN MREAD () + (SETQ CLABEL (MAKLABEL $INCHAR $LINENUM)) (ADD2LNC CLABEL $LABELS) + (TERPRI) (PRLABEL CLABEL) (SET CLABEL (RETRIEVE NIL NIL))) + +(DEFUN MPRINEVAL () + (PROGB (TIME) + (SETQ TIME (RUNTIME) GCT (STATUS GCTIME) $% (MEVAL (EVAL CLABEL))) + (SETQ DLABEL (MAKLABEL $OUTCHAR $LINENUM)) (ADD2LNC DLABEL $LABELS) + (DISPLA `((MLABLE) ,DLABEL ,(SET DLABEL $%))) + (SETQ $LASTTIME (LIST '(MLIST SIMP) + (COMPUTIME (RUNTIME) TIME) + (COMPUTIME (STATUS GCTIME) GCT))) + (COND ($SHOWTIME (IF (NOT (ZEROP (CHARPOS T))) (TERPRI)) + (PRINC '|time=|) (PRINC (CADR $LASTTIME)) (PRINC '| msec.|) + (TERPRI))) + (SETQ $LINENUM (1+ $LINENUM)) + $%)) + +(DEFUN MACSYMA (FORM) + (SETQ CLABEL (MAKLABEL $INCHAR $LINENUM)) (ADD2LNC CLABEL $LABELS) + (TERPRI) (PRLABEL CLABEL) (MAPC 'PRINC (MAKSTRING FORM)) (TYO #;) + (SET CLABEL FORM) (MPRINEVAL)) + +(DEFUN MAKLABEL (C N) (IMPLODE (NCONC (EXPLODEN C) (EXPLODEN N)))) + +(DEFUN PRLABEL (L) (PRINC '|(|) (PRINC (STRIPDOLLAR L)) (PRINC '|) |)) + +(DEFUN CLINE (X) + (TERPRI) + (TYO TB) + (MGRIND X T)) ;MGRIND take OUTPUT file as 2nd arg -- RWK + + +(DEFUN CENTER (X) (DISPLA (LIST '(MLABLE) NIL X))) + + + +(DEFUN DEFSCRIPT FEXPR (F) (PUT (CAR F) (CDR F) 'SCRIPT) (CAR F)) + +(DEFUN MACSYM () + (DO ((X)) ((NOT (ATOM X)) (CAR X)) + (MREAD) (SETQ X (ERRSET (MPRINEVAL))))) + +(DEFUN INCHK (PAT) + (DO ((X (MREAD) (MREAD))) (NIL) + (COND ((OR (EQ '$EXIT X)(EQ '$QUIT X)) + (EXIT)) + ((EQ '$NO X) + (TERPRI) (PRINC '|O.K., I'll do it for you.|) + (RETURN (MACSYMA PAT))) + ((PALIKE PAT X) (RETURN (MPRINEVAL))) + (T (TERPRI) (PRINC '|Try again.|) (TERPRI))))) + +(DEFUN OUTCHK (PAT) + (DO X (MACSYM) (MACSYM) (PALIKE PAT X) + (TERPRI) (PRINC '|Try again.|) (TERPRI))) + + +(DEFUN INCHKP (P) + (DO ((X (MREAD) (MREAD))(Y)) (NIL) + (IF (SETQ Y (FUNCALL P X)) (RETURN (COND ((NOT (EQ Y 'NOLABEL)) + (MPRINEVAL)))) + (TERPRI) (PRINC '|Try again.|)))) + +(DEFUN OUTCHK2 (PRED) + (DO X (MACSYM)(MACSYM) + (COND ((OR (EQ '$EXIT X) (EQ '$QUIT X)) (EXIT)) + ((EQ '$NO X)) + ((FUNCALL PRED X))) + (TERPRI) (PRINC '|Try again.|) (TERPRI))) + +(DEFUN PALIKE (PAT X) + (COND ((EQ PAT X)) + ((EQ 'DLABEL PAT) (PALIKE DLABEL X)) + ((ATOM PAT) (AND (ATOM X) (EQUAL (MEVAL PAT) (MEVAL X)))) + ((ATOM X) NIL) + ((EQ (CAAR PAT) (CAAR X)) + (SETQ PAT (CDR PAT) X (CDR X)) + (DO () ((NOT (PALIKE (CAR PAT) (CAR X)))) + (COND ((NULL PAT) (IF (NULL X) (RETURN T))) + ((NULL X) (RETURN NIL)) + (T (SETQ PAT (CDR PAT) X (CDR X)))))))) + +(DEFUN DECODE (X L) + (COND ((NOT (EQ (TYPEP X) 'FIXNUM)) (NOR-ERR)) + ((OR (NOT (> X 0)) (> X (LENGTH L))) (NOR-ERR)) + ((SETQ X (NTHCDR (1- X) L)) (CAR X)) + (T (NOR-ERR)))) + +(DEFUN SPELLCHECK (X L) + (COND ((NOT (ISITIN X L)) (SPELL-ERR)) + (T X))) + +(DEFUN MENU (OPTS) + (DO ((L OPTS (CDR L)) (I 1 (1+ I))) ((NULL L)) + (PRINC I) (PRINC '| - |) (PRINC (FULLSTRIP1 (CAR L))) + (COND ((GET (CAR L) 'KIND) (TYO NSP) (PRINC (GET (CAR L) 'KIND)))) + (TERPRI))) + +(DEFUN SPELL-ERR () (PRINC '|No such script. Try again.|) (TERPRI)) +(DEFUN OPT-ERR () (PRINC '|Illegal command to OPTIONS|) (TERPRI)) +(DEFUN NOR-ERR () (PRINC '|Number out of range|) (TERPRI)) + + +(DEFUN SELECT (L) (IF (EQ '$EXIT (SETQ L (SELECT1 L))) (PQUIT) (SCRIPT L NIL))) + +(DEFUN SELECT1 (L) + (DO ((ANS)) (NIL) + (MENU L) + (SETQ ANS (RETRIEVE NIL NIL)) + (COND ((FIXP ANS) (IF (SETQ ANS (DECODE ANS L)) (RETURN ANS))) + ((ATOM ANS) (IF (SETQ ANS (SPELLCHECK ANS L))(RETURN ANS)))))) + +(DEFUN CMDCHKP (CMD) + (DO ((X (MREAD) (MREAD))) (NIL) + (COND ((OR (EQ '$EXIT X)(EQ '$QUIT X)) + (EXIT)) + ((EQ '$NO X) + (TERPRI) (PRINC '|O.K., I'll do it for you.|) + (RETURN (MACSYMA CMD))) + ((CMDCHKP2 CMD X)(RETURN (MPRINEVAL))) + (T (TERPRI) (PRINC '|Try again.|))))) + + +(DEFUN CMDCHKP2 (C D) + (COND ((ATOM D) + (TERPRI) (PRINC '|Oops, you typed the ; too soon.|) NIL) + ((NOT (EQ (CAAR C)(CAAR D))) + (CMDCHKP3 (CAAR D)(CAAR C)) NIL) + ((EQ '$% (CADR D))) + ((NOT (EQUAL (CADR C)(CADR D))) + (TERPRI) (PRINC '|Use |) + (PRINC (FULLSTRIP1 (CADR C))) NIL) + ((NOT (PALIKE C D)) NIL) + (T T))) + + +(DEFUN CMDCHKP3 (E C) + (COND ((MEMQ (CAR (PLIST E)) '(SUBR LSUBR EXPR FEXPR)) + (TERPRI)(PRINC '|Please use the |) + (PRINC (FULLSTRIP1 C)) + (PRINC '| command.|)) + (T (TERPRI) (PRINC '|Check your spelling.|)))) + +(DEFUN INOUTCHK (CMD PAT) + (DO ((X (MREAD) (MREAD))) (NIL) + (COND ((ATOM X) + (TERPRI) (PRINC '|Aw, come on, this is easy.|) NIL) + ((NOT (EQ CMD (CAAR X))) + (COND ((MEMQ (CAR (PLIST (CAAR X))) '(SUBR LSUBR EXPR FEXPR)) + (TERPRI)(PRINC '|Please use the |) + (PRINC (FULLSTRIP1 CMD)) + (PRINC '| command.|)) + (T (TERPRI) (PRINC '|Check your spelling.|))) NIL) + ((PALIKE PAT (MPRINEVAL))(RETURN T))) + (TERPRI) (PRINC '|Try again.|)(TERPRI))) + +(DEFUN ISITIN (A L) + (COND ((ATOM L) (EQ A L)) + (T (DO () ((NULL L) NIL) + (COND ((ISITIN A (CAR L)) (RETURN T)) + (T (SETQ L (CDR L)))))))) + \ No newline at end of file diff --git a/src/emaxim/edbuf.39 b/src/emaxim/edbuf.39 new file mode 100755 index 00000000..7c314ebd --- /dev/null +++ b/src/emaxim/edbuf.39 @@ -0,0 +1,280 @@ +;; -*- Mode: Lisp; Package: Macsyma; Ibase: 8 -*- + +(macsyma-module edbuf) + +;; Macsyma display-oriented expression editor +;; Buffer management functions +;; See EMAXIM;ED > and EMAXIM;EDCOM > for more information. +;; Written: Feb 17, 1979 By RZ, based on a version by CWH and BEE +;; Rewritten: June 2, 1979 by CWH for Macsyma Users' Conference + +;; Global variables and structure definitions. + +(load-macsyma-macros edmac) + +;; Creating new expressions -- By copying old ones and typing in new ones + +;; Add a newly created expression to some buffer. Which buffer and whether or +;; not it becomes the selected expression is determined by the numerical +;; argument. +;; Currently copy region and copy expression immediately stick things in +;; a buffer. Later they will simply push it on the kill pdl and +;; things can be brought back anyplace. + +(defun add-exp-to-buffer (exp argument) + (cond + ;;Empty buffer. + ((and (null (expression-list current-buffer)) + (or (not argument) (= argument 0))) + (setf (expression-list current-buffer) (list exp)) + (make-current-exp exp)) + ;;If no argument given, add the expression to the buffer immediately + ;;after the current one and make the new expression current. + ;;With zero argument, add it after the current one but don't + ;;change which one is current. + ((or (not argument) (= argument 0)) + (do ((e-list (expression-list current-buffer) (cdr e-list))) + ((null e-list) + (ed-internal-error 'add-exp-to-buffer + "Current expression not in current buffer.")) + (cond ((eq (car e-list) current-exp) + (rplacd e-list (cons exp (cdr e-list))) + (return nil)))) + (cond ((null argument) + (make-current-exp exp) + (setf (current-exp-distance-from-top current-buffer) + (1+ (current-exp-distance-from-top current-buffer)))))) + ;;Add the expression to the end of a different buffer. + (t (let* ((buffer-name + (read-line "Buffer to insert expression into (~A): " + (buffer-name previous-buffer))) + (buffer (select-buffer buffer-name))) + (setf (expression-list current-buffer) + (nconc (expression-list current-buffer) (list exp))) + (make-current-exp exp) + (setf (current-exp-distance-from-top buffer) 100.))))) + +(set-key 'copy-region "C-c") +(defcom copy-region ((argument n)) +"Creates a new expression from the region and enters it in the current buffer. +With no argument, makes the new expression be current. +With 0 argument, don't change which expression is current. +With any other argument, prompt for a buffer in which to insert the new expression." + (add-exp-to-buffer (make-exp (region-as-mexp current-exp)) n)) + +(set-key 'copy-expression "M-c") +(defcom copy-expression ((argument n)) +"Creates a new expression from the current one and enters it in the current buffer. +With no argument, makes the new expression be current. +With 0 argument, don't change which expression is current. +With any other argument, prompt for a buffer in which to insert the new expression." + (add-exp-to-buffer (make-exp (cadr (displayed current-exp))) n)) + +(set-key 'insert-expression "M-i") +(defcom insert-expression ((argument n) + (read-expression exp + "Insert expression: ~A" + (if n "(no evaluation) " ""))) +"Creates a new expression from one read in the minibuffer. +If a numeric argument is given, don't evaluate the entered expression." + ;;Since we're not calling replace-region, must do this ourselves. + (if (expression-list current-buffer) + (setq exp (subst (region-as-mexp current-exp) '$% exp))) + (if (not n) (setq exp (meval exp))) + (add-exp-to-buffer (make-exp exp) nil)) + +(set-key 'replace-expression "M-r") +(defcom replace-expression ((argument n) + (read-expression exp + "Replace expression: ~A" + (if n "(no evaluation) " ""))) +"Replace the current expression with one read from the minibuffer. +If a numeric argument is given, don't evaluate the entered expression." + (if (not (region-contains-top-node?)) (top-level)) + (replace-region n exp)) + +; Add yank-expression here at some point. + + +; Changing expressions within the buffer. + +(set-key 'first-expression "M-a") +(set-key 'first-expression "M-<") +(defcom first-expression ((discard-argument)) +"Makes the first expression in the buffer be the current one." + (if (not (expression-list current-buffer)) + (ed-error "No expressions in this buffer.")) + (make-current-exp (car (expression-list current-buffer))) + (setf (current-exp-distance-from-top current-buffer) 0)) + +(set-key 'last-expression "M-e") +(set-key 'last-expression "M->") +(defcom last-expression ((discard-argument)) +"Makes the last expression in the buffer be the current one." + (if (not (expression-list current-buffer)) + (ed-error "No expressions in this buffer.")) + (make-current-exp (car (last (expression-list current-buffer)))) + (setf (current-exp-distance-from-top current-buffer) 100.)) + +(set-key 'previous-expression "M-p") +(defcom previous-expression () +"Selects the expression preceding the current one as current." + (if (not (expression-list current-buffer)) + (ed-error "No expressions in this buffer.")) + (if (eq (car (expression-list current-buffer)) current-exp) + (ed-error "Current expression is first expression in buffer.")) + (do ((e-list (expression-list current-buffer) (cdr e-list))) + ((eq (cadr e-list) current-exp) (make-current-exp (car e-list)))) + (setf (current-exp-distance-from-top current-buffer) + (max 0 (1- (current-exp-distance-from-top current-buffer))))) + +(set-key 'next-expression "M-n") +(defcom next-expression () +"Selects the expression following the current one as current." + (if (not (expression-list current-buffer)) + (ed-error "No expressions in this buffer.")) + (let ((exp-list (memq current-exp (expression-list current-buffer)))) + (if (null (cdr exp-list)) + (ed-error "Current expression is last expression in buffer.")) + (make-current-exp (cadr exp-list)) + (setf (current-exp-distance-from-top current-buffer) + (1+ (current-exp-distance-from-top current-buffer))))) + +(set-key 'transpose-expression "M-t") +(defcom transpose-expression () +"Transpose the current expression with the one below it. +The current expression remains current." + + (if (null (expression-list current-buffer)) + (ed-error "No expressions in this buffer.")) + (if (null (cdr (expression-list current-buffer))) + (ed-error "Only one expression in this buffer.")) + (do ((el (expression-list current-buffer) (cdr el))) + ((null el) + (ed-internal-error 'transpose-expression + "Current expression not in current buffer.")) + (cond ((eq (car el) current-exp) + (if (null (cdr el)) + (ed-error "Current expression is last in current buffer.")) + (rplaca el (cadr el)) + (rplaca (cdr el) current-exp) + (setf (current-exp-distance-from-top current-buffer) + (1+ (current-exp-distance-from-top current-buffer))) + (return nil))))) + +; Deleting expressions from a buffer. + +(set-key 'delete-expression "M-d") +(defcom delete-expression () +"Delete the current expression from the current buffer. +If the current expression is the last one in the buffer, the previous one is +selected. Otherwise, the following expression is selected." + + (if (null (expression-list current-buffer)) + (ed-error "No expressions in this buffer.")) + (cond + ;;Current exp is at the top of the buffer. + ((eq current-exp (car (expression-list current-buffer))) + (pop (expression-list current-buffer)) + (if (expression-list current-buffer) + (make-current-exp (car (expression-list current-buffer))))) + ;;Here exp-list is that part of the expression list beginning + ;;just before the current expression. + (t (let ((exp-list (do ((el (expression-list current-buffer) (cdr el))) + ((eq (cadr el) current-exp) el)))) + (rplacd exp-list (cddr exp-list)) + (cond + ;;Current exp is last in buffer. Make preceding one + ;;become current. If it was the only expression on the + ;;screen, be careful not to let distance-from-top go negative. + ((null (cdr exp-list)) + (make-current-exp (car exp-list)) + (setf (current-exp-distance-from-top current-buffer) + (max 0 (1- (current-exp-distance-from-top current-buffer))))) + ;;If there exists an expression after the current one, make + ;;it now become current. + (t (make-current-exp (cadr exp-list)))))))) + +(set-key 'kill-following-expressions "M-k") +(defcom kill-following-expressions ((argument n)) +"Delete the expressions following the current expression. +All equations following the current expression are removed from the current +buffer. With a negative argument, those equations preceding the current +expression are removed from the current buffer. The current expression is +not removed." + + (if (null (expression-list current-buffer)) + (ed-error "No expressions in this buffer.")) + (if (not n) (setq n 1)) + (do ((el (expression-list current-buffer) (cdr el))) + ((null el) + (ed-internal-error 'kill-following-expressions + "Current expression missing from current buffer.")) + (cond ((eq (car el) current-exp) + (cond ((> n 0) + (rplacd el nil)) + ((< n 0) + (setf (expression-list current-buffer) el) + (setf (current-exp-distance-from-top current-buffer) 0))) + (return nil))))) + +;; Commands for adjusting a window onto a buffer. + + +(set-key 'new-window '("C-l" "FORM")) +(defcom new-window ((argument n)) +"Adjust the window onto the current buffer. +With no argument, completely redisplay the screen and leave the current +window where it is. With an argument of n, make the current expression +be the nth from the top of the buffer." + (if n + (setf (current-exp-distance-from-top current-buffer) n) + (full-redisplay))) + + +;; Changing and listing buffers + +(set-key 'select-buffer "C-x" "b") +(defcom select-buffer ((discard-argument) + (read-line name + "Select Buffer (~A): " + (buffer-name previous-buffer))) +"Selects the specified buffer as the named buffer. +If carriage return is typed in response to the prompt, then the previously +selected buffer is made current. The previously selected buffer is shown +in parenthesis in the prompt." + + (let ((new-buffer (if (string-equal name "") + previous-buffer + (find-buffer-from-name name)))) + (cond ((null new-buffer) + (setq new-buffer (make-buffer buffer-name name)) + (push new-buffer buffer-list))) + (make-current-buffer new-buffer) + new-buffer)) + +(defun find-buffer-from-name (buffer-name) + (do ((bl buffer-list (cdr bl))) + ((null bl) nil) + (if (string-equal buffer-name (buffer-name (car bl))) + (return (car bl))))) + +(set-key 'list-buffers "C-x" "C-b") +(defcom list-buffers ((discard-argument)) + "Lists the currently active buffers." + (cursorpos 0 0) + (cursorpos 'L) ;Clear to EOL + (format t " # ~15A~15A~15A~%" "Buffer" "(Mode)" "Expressions") + (cursorpos 'L) + (format t "~%") + (do ((bl (reverse buffer-list) (cdr bl)) + (i 1 (1+ i))) + ((null bl)) + (cursorpos 'L) + (format t "~3D ~15A~15A~4D~%" + i + (buffer-name (car bl)) + (buffer-mode (car bl)) + (length (expression-list (car bl))))) + (setq screen-exp-list nil) ;Kludge to say that screen image + (setq supress-redisplay t)) ;destroyed. diff --git a/src/emaxim/edctl.22 b/src/emaxim/edctl.22 new file mode 100755 index 00000000..f98dab46 --- /dev/null +++ b/src/emaxim/edctl.22 @@ -0,0 +1,857 @@ +;; -*- Mode: Lisp; Package: Macsyma; Ibase: 8 -*- + +(macsyma-module edctl) + +;; Macsyma display-oriented expression editor +;; Control function package +;; See CWH;ED > and CWH;EDCOM > for more information. +;; Written: Feb 17, 1979 By RZ, based on a version by CWH and BEE +;; Rewritten: June 2, 1979 by CWH for Macsyma Users' Conference + +;; Global variables and structure definitions. + +(load-macsyma-macros edmac) + +;; Initialize the static variables. These are preserved between invocations of +;; the editor. + +(setq buffer-list nil + mark-pdl nil + kill-pdl nil +; current-exp nil + supress-redisplay nil + %kbd-control #o400 + %kbd-meta #o1000 + %kbd-control-meta (+ %kbd-control %kbd-meta) + ) + +(defun $displayedit (&rest exps) + (unwind-protect (progn (ed-prologue) + (display-edit exps)) + (ed-epilogue))) + +(defun display-edit (exp-list &aux buffer) + (cond (exp-list + (setq exp-list (mapcar #'make-exp exp-list)) + (setq buffer (make-buffer buffer-name (make-buffer-name) + expression-list exp-list + current-exp (car exp-list))) + (push buffer buffer-list) + (make-current-buffer buffer)) + ((null buffer-list) + (setq buffer (make-buffer buffer-name (make-buffer-name))) + (push buffer buffer-list) + (make-current-buffer buffer))) + (full-redisplay) + (*catch 'exit-editor (ed-command-loop)) + (and (boundp 'current-exp) + (cadr (body current-exp)))) + + +;; Create an expression from one in the macsyma internal format. ED format +;; expressions are usually labelled "exp". Those in macsyma format are +;; labelled "mexp". + +(defun make-exp (mexp &optional (label nil)) + (cond (label (setq label (make-symbol label))) + (t (setq label (makelabel $outchar)) + (setq $linenum (1+ $linenum)))) + (setq mexp (list nil (nformat-all mexp))) + (setq mexp (make-expression body mexp displayed mexp region mexp)) + (label-exp mexp label) + mexp) + +; For changing an expression's label. +(defun label-exp (exp label) + (mset label (cadr (body exp))) + (setf (expression-label exp) label)) + +; Used for switching between buffers. +(defun make-current-buffer (buffer) + (cond ((not (and (boundp 'current-buffer) + (eq buffer current-buffer))) + (setq previous-buffer + (if (boundp 'current-buffer) current-buffer buffer)) + (setq current-buffer buffer) + (if (expression-list buffer) + (make-current-exp (current-exp buffer)))))) + +;; Used for switching between expressions within a given buffer. +;; Makes "exp" be the current expression. Note that "current expression" +;; is defined with respect to a buffer. + +(defun make-current-exp (exp) + (cond ((not (and (boundp 'current-exp) + (eq exp current-exp))) + (if (boundp 'current-exp) + (setf (region-boxed? current-exp) nil)) + (setq current-exp exp) + (setf (region-boxed? exp) t) + (setf (current-exp current-buffer) exp) +; (set '$% (cadr (region exp))) +; (set '$%% (cadr (displayed exp))) +; (set '$%%% (cadr (body exp))) + ))) + +;; Generates new buffer names. +;; (format nil ...) creates a string. Format is special and +;; interned on the macsyma package in the lisp machine. + +(setq buffer-name-count 1) +(defun make-buffer-name () + (cond ((null buffer-list) "Main") + (t (setq buffer-name-count (1+ buffer-name-count)) + (format nil "Buffer ~D" buffer-name-count)))) + +; Simple, isn't it. Well, it won't be for long. +(defun ed-command-loop () + (do () + (nil) + (*catch 'command-loop + (ed-dispatch (read-key t nil) single-char-table nil)) + (cond (supress-redisplay (setq supress-redisplay nil)) + ((not (zerop (listen)))) ;Don't redisplay on typeahead + (need-full-redisplay (full-redisplay)) + (t (redisplay))))) + +;; Takes a character in internal format and a dispatch table and numeric +;; argument. Looks up function to find what to do with arg. When echoing +;; character, should use raw output so character 7 gets printed as pi and not a +;; bell. + +(defun ed-dispatch (char table arg) + (declare (fixnum char)) + (let* ((function (get-key table char))) + (if (not function) + (if (eq table single-char-table) + (ed-error "Undefined key: ~A" + (char-to-descriptor char)) + (ed-error "Undefined key: Control-x ~A" + (char-to-descriptor char))) + (ed-dispatch-command function arg char)))) + +;; Takes a command defined with DEFCOM, a numeric argument (if any) and an +;; invoking character (if any) and calls the command. + +(defun ed-dispatch-command (function arg char) + (if (not (fboundp function)) + (if char + (ed-error "Undefined command on ~A: ~A" + (char-to-descriptor char) + function) + (ed-error "Undefined command: ~A" (symbol-to-descriptor function)))) + (let ((arg-action (get function 'ed-arg-action)) + (char-action (get function 'ed-char-action)) + (arg-list nil)) + (if (eq arg-action 'pass) (push arg arg-list)) + (if (eq char-action 'pass) (push char arg-list)) + (setq arg-list (nreverse arg-list)) + (caseq arg-action + ((pass discard) (apply function arg-list)) + (t (if arg + (dotimes (i (abs (fixnum-identity arg))) + (apply function arg-list)) + (apply function arg-list))) + ))) + +;; For signalling errors. Throws back into command loop and does a redisplay +;; immediately after. + +(defun ed-error (&rest args) + (cond ((not (null args)) + (minibuffer-clear) + (apply 'minibuffer-print args))) + (tv-beep) + (*throw 'command-loop nil)) + +(defun ed-internal-error (function message &optional datum) + (dotimes (i 3) (tv-beep)) + (minibuffer-clear) + (minibuffer-print + "Macsyma Display Toplevel internal error -- please report to CWH or RZ:~%") + (if datum + (minibuffer-print "~A: ~A -- ~S" function message datum) + (minibuffer-print "~A: ~A" function message)) + (*throw 'command-loop nil)) + +;; Redisplay + +;; The purpose of this function is to look at what is currently on the screen +;; and what should be on the screen. It finds out what is different between +;; them and updates the screen. This algorithm can become arbitrarily hairy. +;; Right now, it simply recognizes EQness of expressions and makes no attempt +;; to optimize the redisplay of a single expression. + +;; Screen state information: +;; If this list gets too long, may want to create a structure. +;; +;; screen-exp-list -- list of expressions displayed on the screen. +;; Equation at the top of this list is one at the top of the screen. +;; The needed information for each expression is the displayed region, +;; the label, the reveal depth, and whether its command region is +;; boxed. If its command region is boxed, then we must know the command +;; region and the region-length (i.e. where the box is). +;; +;; screen-buffer-name -- name displayed +;; screen-exp-list-length -- expression count displayed. + + +;; Stolen from MRG;DISPLA. Find the height in characters of an expression. +;; Later, we may want to save the dimension list returned to optimize +;; redisplay. This will lose completely if the expression has to be broken +;; across two lines -- fix later. We have a big problem here -- displa is +;; assuming that the expression is simplified, but we are handing it +;; non-simplified expressions. Either we can patch displa or start simplifying +;; everything. + +(defun dimension-exp (exp) + (if (region-boxed? exp) (box-region exp)) + (let ((displayp t) (mratp (checkrat exp)) (^r ^r) (maxht 1) (maxdp 0) + (width 0) (height 0) (depth 0) (level 0) (size 2) (break 0) (right 0) + (lines 1) bkpt (bkptwd 0) (bkptht 1) (bkptdp 0) (bkptout 0) (bkptlevel 0) + more-^w) + (checkbreak (dimension (cadr (displayed exp)) nil 'mparen 'mparen 0 0) + width) + (if (region-boxed? exp) (unbox-region exp)) + (max (+ maxht maxdp) (+ bkptht bkptdp)))) + +;; Produce a new list of expressions to appear on the screen. Heights +;; of expressions stored in them. The expressions in this list are +;; the actual expressions in the buffer. The screen-list, however, +;; is a copy of a previously generated list. +;; If current buffer is empty, returns nil. + +(defun generate-new-screen-image + (&aux (upward-exp-list nil) ;Exps above the current exp + (downward-exp-list nil) ;Exps below the current exp + total-height ;How many lines needed + screen-image) ;List of exps to display + (cond ((expression-list current-buffer) + (setq total-height (dimension-exp current-exp)) + (setq screen-image (list current-exp)) + (setf (expression-height current-exp) total-height) + + ;;Split the expression list into two lists -- those above the + ;;current expression (in reverse order) and those below the current + ;;expression. + (do ((el (expression-list current-buffer) (cdr el))) + ((eq (car el) current-exp) (setq downward-exp-list (cdr el))) + (push (car el) upward-exp-list)) + + ;;If distance from the top is less than the number of expressions + ;;above us, cut them off. + (if (> (length upward-exp-list) + (current-exp-distance-from-top current-buffer)) + (setq upward-exp-list + (firstn (current-exp-distance-from-top current-buffer) + upward-exp-list))) + + ;;Now redimension every equation on the screen. Since some + ;;equations above us may have grown, the distance from the top will + ;;be the same it was before or will decrease. + (setf (current-exp-distance-from-top current-buffer) 0) + (*catch 'screen-full + (progn + (do ((ul upward-exp-list (cdr ul))) + ((null ul)) + (setf (expression-height (car ul)) (dimension-exp (car ul))) + (setq total-height (+ total-height + (expression-height (car ul)) 1)) + ;;DISPLA clobbers line following last line of expression + ;;displayed. + (if (>= (+ total-height 1) expr-area-height) + (*throw 'screen-full t)) + (push (car ul) screen-image) + (setf (current-exp-distance-from-top current-buffer) + (1+ (current-exp-distance-from-top current-buffer)))) + (do ((dl downward-exp-list (cdr dl))) + ((null dl)) + (setf (expression-height (car dl)) (dimension-exp (car dl))) + (setq total-height (+ total-height + (expression-height (car dl)) 1)) + (if (>= (+ total-height 1) expr-area-height) + (*throw 'screen-full t)) + (setq screen-image (nconc screen-image (list (car dl))))))) + screen-image))) + +;; The real thing. Maybe we should be storing vertical position on screen in +;; each expression. + +(defun redisplay () + (let ((new-exp-list (generate-new-screen-image))) + + ;;Redisplay the expression region. + (do ((old-list screen-exp-list (cdr old-list)) + (new-list new-exp-list (cdr new-list)) + (old-height-from-top 0 (+ old-height-from-top + (expression-height (car old-list)) 1)) + (new-height-from-top 0 (+ new-height-from-top + (expression-height (car new-list)) 1))) + (nil) + (cond + + ;;Just as many old equations as new. Clear whatever of the + ;;bottom portion of the old equations that might be left over. + ((and (null old-list) (null new-list)) + (if (> old-height-from-top new-height-from-top) + (dctl-clear-lines new-height-from-top + (- old-height-from-top new-height-from-top))) + (return nil)) + + ;;More new equations than old. Quit comparison and finish + ;;displaying new equations. + ((null old-list) + (do ((list new-list (cdr list)) + (height-from-top new-height-from-top + (+ height-from-top + (expression-height (car list)) 1))) + ((null list)) + (display-expression (car list) height-from-top)) + (return nil)) + + ;;More old equations than new. Quit comparison and erase from + ;;current position to last equation displayed. + ((null new-list) + (do ((list old-list (cdr list)) + (lines-to-clear 0 (+ 1 lines-to-clear + (expression-height (car list))))) + ((null list) + (dctl-clear-lines new-height-from-top (1- lines-to-clear)))) + (return nil)) + + ;;Got the same expressions on the same line. Skip to next + ;;expression. + ((and (= old-height-from-top new-height-from-top) + (same-exp-image (car new-list) (car old-list)))) + + ;;Display the expression on the current line if we can't scroll + ;;regions of the screen. + (t (display-expression (car new-list) new-height-from-top)) + )) + +; ;;Display the expression on the current line if we can't scroll +; ;;regions of the screen. +; ((not idel-lines-available?) +; (display-expression (car new-list) new-height-from-top)) + +; ;;First look to see if the new expression is anywhere below us +; ;;on the screen. If it is, bring it up to where we are. +; ((do ((ol (cdr old-list) (cdr ol)) +; (lines-to-scroll (1+ (expression-height (car old-list))))) +; ((null ol) nil) +; (cond ((same-exp-image (car new-list) (car ol)) +; (dctl-scroll-region-up ...) +; (setq old-list ol) +; (return t))))) + +; ;;Otherwise, see if the old expression is anywere below is in +; ;;the new screen image. If so, move it down to where it belongs. + + (setq screen-exp-list (mapcar 'rdis-copy-expression new-exp-list)) + + ;;Redisplay the mode line. + (cond ((or (not (eq screen-buffer-name (buffer-name current-buffer))) + (not (= screen-exp-list-length + (length (expression-list current-buffer))))) + (display-mode-line) + (setq screen-buffer-name (buffer-name current-buffer)) + (setq screen-exp-list-length + (length (expression-list current-buffer))))) + + ;;Home the cursor. ITS won't send any characters if the cursor + ;;is already up there. + (cursorpos 0 0))) + +;; This is really a kludge for our current mode of using this thing. We're +;; going to need something better if people start hacking macros, like EQUAL of +;; the displayed portions of the two expressions, whereby the screen expression +;; has been entirely copied. + +(defun same-exp-image (new-exp screen-exp) + (and (eq (displayed new-exp) (displayed screen-exp)) + (eq (expression-label new-exp) (expression-label screen-exp)) + (= (reveal-depth new-exp) (reveal-depth screen-exp)) + (= (length (operand new-exp)) (length (operand screen-exp))) + (or (and (not (region-boxed? new-exp)) + (not (region-boxed? screen-exp))) + (and (region-boxed? new-exp) + (region-boxed? screen-exp) + (eq (cadr (region new-exp)) (cadr (region screen-exp))) + (eq (save-pdl new-exp) (save-pdl screen-exp)) + (= (region-length new-exp) (region-length screen-exp)))))) + +;; This function only used by the redisplay for storing screen state +;; information, so don't have to copy whole thing. Maybe we should create a +;; special structure for the screen image. Region and region-length only have +;; to be remembered for screen-current-exp. + +(defun rdis-copy-expression (exp) + (make-expression displayed (displayed exp) + operand (append (operand exp) nil) + expression-label (expression-label exp) + expression-height (expression-height exp) + reveal-depth (reveal-depth exp) + region-boxed? (region-boxed? exp) + ;;The followning slots only needed for the current + ;;expression. Copy region cons so that the screen + ;;version won't also get clobbered. Displaying + ;;this won't work since region not part of + ;;displayed. + save-pdl (save-pdl exp) + region (list nil (cadr (region exp))) + region-length (region-length exp) + )) + +;; Completely restores the screen image. +;; Later make this move current expression to the top of the screen. + +(defun full-redisplay () + (setq need-full-redisplay nil) + (cursorpos 'C) ;Clear screen + (let ((screen-image (generate-new-screen-image))) + (display-expressions screen-image) + (setq screen-exp-list + (mapcar 'rdis-copy-expression screen-image))) + (display-mode-line) + (minibuffer-clear) + (cursorpos 0 0) + (setq screen-buffer-name (buffer-name current-buffer)) + (setq screen-exp-list-length (length (expression-list current-buffer))) + ) + + +;; Dispatch Tables +;; +;; The expression editor's idea of what a character is follows that of the Lisp +;; Machine. The low order eight bits of the character is a single key portion, +;; with 0-177 being alphanumeric. Bits 9 and 10 are set if control key or +;; meta keys were depressed, respectively. These bits can also be set for +;; a given character by typing a control, meta or control-meta prefix. +;; The item associated with each character is a symbol, which contains +;; a function to call and associated information about that function. + +;; The "single-char-table" array contains those functions which are associated +;; with a single keystroke command. +;; 0-177 Alphanumeric characters +;; 200-377 Other single-key characters +;; 400-777 Control characters +;; 1000-1377 Meta characters +;; 1400-1777 Control-Meta characters (not used currently) + +;; The "c-x-prefix-table" array contains those functions associated with a control-x +;; prefix. + +;; Stick this elsewhere. +#+MacLisp (defmacro make-array (size) `(array nil t ,size)) + +;; Don't clobber the table if it already exists. For debugging purposes. + +(cond ((not (boundp 'single-char-table)) + (setq single-char-table-size #o1400) + (setq single-char-table (make-array single-char-table-size)) + (setq c-x-prefix-table-size #o1400) + (setq c-x-prefix-table (make-array c-x-prefix-table-size)))) + +;; Take a description of the form Control-Meta-rubout and return the corresponding +;; character object. + +(defun descriptor-to-char (descriptor) + (setq descriptor (string descriptor)) + (let ((character 0) + (symbolic-name)) + (if (or (string-search "C-" descriptor) + (string-search "Control-" descriptor)) + (setq character (+ 1_8 character) + descriptor (substring descriptor + (1+ (string-search "-" descriptor))))) + (if (or (string-search "M-" descriptor) + (string-search "Meta-" descriptor)) + (setq character (+ 1_9 character) + descriptor (substring descriptor + (1+ (string-search "-" descriptor))))) + (setq symbolic-name (assq (intern (make-symbol (string-upcase descriptor))) + descriptor-to-char-alist)) + (if symbolic-name + (+ character (cdr symbolic-name)) + (+ character (character descriptor))))) + +;; Take a character object and return a desciption. +;; On lispm, use special characters. + +(defun char-to-descriptor (char &optional (brief nil)) + (let ((descriptor "") + (symbolic-name)) + (if (not (= 0 (logand char %kbd-control))) + (setq descriptor (string-append descriptor (if brief "C-" "Control-")))) + (if (not (= 0 (logand char %kbd-meta))) + (setq descriptor (string-append descriptor (if brief "M-" "Meta-")))) + (setq symbolic-name (rassoc (logand char #o377) descriptor-to-char-alist)) + (if symbolic-name + (string-append descriptor (string (car symbolic-name))) + (string-append descriptor (string (logand char #o 377)))))) + +(setq descriptor-to-char-alist + '((ALT . #o33) (SPACE . #o40) (CALL . #o203) + (BREAK . #o201) (CLEAR . #o202) (ESCAPE . #o204) + (BACKNEXT . #o205) (HELP . #o206) (RUBOUT . #o207) + (BS . #o210) (TAB . #o211) (LINE . #o212) + (VT . #o213) (FORM . #o214) (RETURN . #o215))) + + +;; Key binding functions + +;; Single characters are specified as C-M-A or Control-Meta-A. Case matters in +;; the final letter. "C-" and "M-" set control and meta bits respectively. +;; (set-key 'exit-editor "C-x" "C-c") will associate "exit-editor" with C-x +;; C-c. Prefix characters may want to be generalized later on. + +(defun set-key (function first-char &optional (second-char nil) &aux table) + (cond (second-char (setq table c-x-prefix-table) + (setq first-char second-char)) + (t (setq table single-char-table))) + (if (atom first-char) + (aset function table (descriptor-to-char first-char)) + (mapcar #'(lambda (key) + (aset function table (descriptor-to-char key))) + first-char))) + +(defcom assign-key ((discard-argument) + (read-line command "Command Name: ") + (read-key key "On Key: ")) + "Associate a single key with a command. +The name of the command is asked for first, then the key to associate it +with. When asked for the key, actually type the key you wish to place the +command on, not a description of the key. " + + (setq command (descriptor-to-symbol command)) + (let ((table)) + (cond ((= key (descriptor-to-char "Control-x")) + (setq key (read-key nil t " (prefix character) ")) + (setq table c-x-prefix-table)) + (t (setq table single-char-table))) + (aset command table key))) + + +;; Returns function associated with a given key. If function not there or +;; reference beyond array bounds, then return nil. + +(defun get-key (table char) + (declare (fixnum char)) + (cond ((eq table single-char-table) + (and (< char single-char-table-size) (aref single-char-table char))) + ((eq table c-x-prefix-table) + (and (< char c-x-prefix-table-size) (aref c-x-prefix-table char))) + (t (ed-internal-error 'get-key "Random table" table)))) + +;; Read a virtual character from the minibuffer, i.e. a single character from +;; the Lisp Machine's point of view. Note that CONTROL-PREFIX, META-PREFIX, +;; and CONTROL-META-PREFIX are now wired in functions. +;; Note on terminology here: A key is a virtual character -- something that +;; can be typed on a 12-bit keyboard in a single keystroke. A character +;; is something that can be typed on the keyboard in use in a single keystroke. + +(defun read-key (&optional (clear-on-multiple-keystroke nil) (echo-key t) + &rest format-args) + (setq *multiple-keystroke-char-typed* nil) + (if format-args (apply 'minibuffer-print format-args)) + (let* ((char (read-char)) + (function (get-key single-char-table char)) + (control-bit 0) + (meta-bit 0)) + (cond ((memq function '(control-prefix meta-prefix control-meta-prefix)) + (setq *multiple-keystroke-char-typed* t) + (if clear-on-multiple-keystroke (minibuffer-clear)) + (cond ((eq function 'control-prefix) + (minibuffer-print "Control-") + (setq control-bit %kbd-control)) + ((eq function 'meta-prefix) + (minibuffer-print "Meta-") + (setq meta-bit %kbd-meta)) + ((eq function 'control-meta-prefix) + (minibuffer-print "Control-Meta-") + (setq control-bit %kbd-control meta-bit %kbd-meta))) + (setq char (read-char)))) + ;;If a multiple keystroke character is typed, the key is always echoed. + ;;Global used in lieu of multiple value return. + (if (or *multiple-keystroke-char-typed* echo-key) + (minibuffer-print "~A" (char-to-descriptor char))) + (+ char control-bit meta-bit))) + +;; Prefix Keys + +(set-key 'control-prefix "C-^") +(set-key 'meta-prefix "") +(putprop 'control-prefix +"Sets the control bit of the next character typed. +For example, typing this key and then typing /"A/" is equivalent +to typing /"Control-A/"." 'ed-documentation) +(putprop 'meta-prefix +"Sets the meta bit of the next character typed. +For example, typing this key and then typing /"A/" is equivalent +to typing /"Meta-A/"." 'ed-documentation) + +(set-key 'control-x-prefix "C-x") +(defcom control-x-prefix ((argument n)) +"This command is a prefix character." + ;;First arg to read-key means clear screen if no argument present + ;;Second arg means always echo character typed. + ;;Third arg is message. + (if (not n) (minibuffer-clear)) + (ed-dispatch (read-key nil t "Control-x ") c-x-prefix-table n)) + +; Argument accumulators + +(set-key 'accumulate-argument + '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9" + "C-0" "C-1" "C-2" "C-3" "C-4" "C-5" "C-6" "C-7" "C-8" "C-9" + "M-0" "M-1" "M-2" "M-3" "M-4" "M-5" "M-6" "M-7" "M-8" "M-9")) + +; Fix this up later to work like C-U in clearing to end of line. +; Must have character redisplay by then, though. +(defcom accumulate-argument ((argument n) (character c)) + "This forms part of the next command's numeric argument." + (setq c (- (logand c #o377) #/0)) + (cond ((not n) (minibuffer-clear) + (minibuffer-print "Argument: ~D " c)) + ;; This is a special case hack to distinguish "-" from "-1", + ;; i.e. so that "-3" does not become -13. + ;; If we come here, "Argument: -1 " is displayed. + ((eq n 'negation) + (cond ((not (= c 1)) + (dotimes (i 2) (cursorpos 'X)) + (minibuffer-print "~D " c)))) + ((= n 0) + (cond ((not (= c 0)) + (dotimes (i 2) (cursorpos 'X)) + (minibuffer-print "~D " c)))) + (t (cursorpos 'B) ;Backward char + (minibuffer-print "~D " c))) + (setq n (cond ((not n) c) + ((eq n 'negation) (- c)) + ((< n 0) (+ (* n 10.) (- c))) + (t (+ (* n 10.) c)))) + (let ((char (read-key nil nil))) + (if (not (or (memq (get-key single-char-table char) + '(accumulate-argument multiply-argument-by-4 + negate-argument)) + *multiple-keystroke-char-typed*)) + (minibuffer-print "~A" (char-to-descriptor char))) + (ed-dispatch char single-char-table n))) + +(set-key 'multiply-argument-by-4 "C-u") +(defcom multiply-argument-by-4 ((argument n)) +"Multiply the number of times to do the following command by 4." + (cond (n (cursorpos minibuffer-vpos 10.) + (cursorpos 'L) + (minibuffer-print "~D " (* n 4))) + (t (minibuffer-clear) + (minibuffer-print "Argument: 4 "))) + (let ((char (read-key nil nil))) + (if (not (or (memq (get-key single-char-table char) + '(accumulate-argument multiply-argument-by-4 + negate-argument)) + *multiple-keystroke-char-typed*)) + (minibuffer-print "~A" (char-to-descriptor char))) + (ed-dispatch char single-char-table (if n (* n 4) 4)))) + +(set-key 'negate-argument '("-" "C--" "M--")) +(defcom negate-argument ((argument n)) +"Negate the numeric argument." + (cond (n (cursorpos minibuffer-vpos 10.) + (cursorpos 'L) + (minibuffer-print "~D " (- n))) + (t (minibuffer-clear) + (minibuffer-print "Argument: -1 "))) + (let ((char (read-key nil nil))) + (caseq (get-key single-char-table char) + (accumulate-argument + (ed-dispatch char single-char-table (if n (- n) 'negation))) + ((multiply-argument-by-4 negate-argument) + (ed-dispatch char single-char-table (if n (- n) -1))) + (t (if (not *multiple-keystroke-char-typed*) + (minibuffer-print "~A" (char-to-descriptor char))) + (ed-dispatch char single-char-table (if n (- n) -1)))))) + +; Documentation Commands +; Translates "FORWARD-BRANCH" to "Forward Branch" for purposes of printing. +(defun symbol-to-descriptor (symbol) + (setq symbol (string symbol)) + (do ((old-string symbol (substring old-string (1+ index))) + (new-string "" (string-append new-string + (string-capitalize + (substring old-string 0 index)) + " ")) + (index)) + (nil) + (setq index (string-search "-" old-string)) + (if (not index) + (return (string-append new-string (string-capitalize old-string)))))) + +; We really need a general purpose translation function. Write one at some point. +; (setq descriptor (string-translate descriptor '(#/-) '(#\SP))) +(defun descriptor-to-symbol (descriptor) + (setq descriptor (string-upcase (string-trim '(#\SP) (string descriptor)))) + (do ((old-string descriptor (substring old-string (1+ index))) + (new-string "" (string-append new-string (substring old-string 0 index) "-")) + (index)) + (nil) + (setq index (string-search " " old-string)) + (if (not index) + (return (intern (string-append new-string old-string)))))) + +;; Turn off interrupts here so can describe control-g. +;; *** Note *** A quickie kludge was added here to need-full-redisplay +;; to allow multiple key descriptions without redisplay. Be sure to +;; fix asap. Right thing to do is record how many lines of current window +;; have been messed up and only redisplay as needed. + +(set-key 'describe-key '("?" "C-?" "M-?" "HELP")) +(defcom describe-key ((discard-argument) (read-key first-char "Describe Key: ")) +"Describes the command associated with a given key." + (let ((function) + (second-char)) + (setq function (get-key single-char-table first-char)) + ;; Need a more general way of doing this. + (when (eq function 'control-x-prefix) + (setq second-char (read-key nil t " (prefix character) ")) + (setq function (get-key c-x-prefix-table second-char))) + ;;Flush when we get multiple windows in. + (if (and need-full-redisplay (fixp need-full-redisplay)) + (cursorpos need-full-redisplay 0) + (cursorpos 0 0)) + (cursorpos 'L) + (format t "~A" (char-to-descriptor first-char)) + (if second-char + (format t " ~A" (char-to-descriptor second-char))) + (format t " is ~A.~%" + (if function (symbol-to-descriptor function) "an undefined key")) + (if function + (format t "~A~%" + (or (get function 'ed-documentation) + "No documentation found.")))) + (setq supress-redisplay t) + ;;Change this to (setq screen-exp-list nil) when multiple windows are in. + (setq need-full-redisplay (car (cursorpos)))) + +(defcom describe-command ((discard-argument) + (read-line name "Describe Command: ")) +"Describes a command specified by its long name." + (cursorpos 0 0) + (cursorpos 'L) + (setq name (descriptor-to-symbol name)) + (if (get name 'ed-documentation) + (format t "~A~%" (get name 'ed-documentation)) + (format t "No documentation found for ~A.~%" name)) + (setq supress-redisplay t) + (setq need-full-redisplay t)) + +(defcom list-keys ((discard-argument)) +"Lists those keys which are associated with editor commands." + (cursorpos 0 0) + (cursorpos 'L) + (make-key-listing #+lispm standard-output #+maclisp tyo) + ;;Supress redisplay of this command, but do a full redisplay after + ;;next command is typed. + (setq supress-redisplay t) + (setq need-full-redisplay t)) + +; Once we start maintaining a list of commands. +; (defcom list-commands ((discard-argument)) +; "Lists all commands which are part of the display toplevel. +; If the command is associated with a key, then the key is also listed. Ony +; the first line of documentation for each command is printed. For more +; documentation on a command, use the /"Describe Command/" extended command." + +; Walk through the key dispatch tables and print the key, its binding, +; and the first line of documentation. +(defun make-key-listing (stream) + (format stream "Macsyma Display Toplevel -- Command Summary~2%") + (format stream "Single Character Commands~2%") + (make-key-listing-table single-char-table single-char-table-size stream) + (format stream "~2%Control-x Prefix Commands~2%") + (make-key-listing-table c-x-prefix-table c-x-prefix-table-size stream)) + +; Search a single table. +(defun make-key-listing-table (table size stream &aux function documentation) + (format stream "~8A~30A~A~%" "Key" "Command" "Description") + (format stream "~8A~30A~A~%" "---" "-------" "-----------") + (do i 0 (1+ i) (= i size) + ;;Don't display Sail characters if using an Ascii keyboard. + (setq function + #-lispm (if (or 12-bit-kbd-available? + (= i #o33) + (> i #o37)) + (get-key table i)) + #+lispm (get-key table i)) + (cond (function + (setq documentation (get function 'ed-documentation)) + (if documentation + (setq documentation + (substring documentation 0 + (min (- linel 38.) + (or (string-search-char #\CR documentation) + (string-length documentation)))))) + (format stream "~8A~30A~A~%" + (char-to-descriptor i t) + (symbol-to-descriptor function) + (if documentation documentation "Not documented.")))))) + + +; Miscellaneous stuff. + +(set-key 'extended-command-prefix "M-x") +(defcom extended-command-prefix + ((argument n) + (read-line command + "Extended Command: ~A" + (if n (format nil "(argument = ~D) " n) ""))) +"Invoke a command by specifying its long name." + (setq command (descriptor-to-symbol command)) + (ed-dispatch-command command n nil)) + +(set-key 'command-quit "C-g") +(set-key 'command-quit "C-x" "C-g") +(defcom command-quit ((discard-argument)) +"Abort the current command and return to editor toplevel." + (minibuffer-clear)) + +(set-key 'no-op " ") +(defcom no-op ((discard-argument)) +"Does nothing other than redisplaying the screen. +Useful for reconstructing the screen image after a message or documentation +has been printed." nil) + +(set-key 'debug-it "~") +(defcom debug-it ((discard-argument)) +"Break into Lisp. Control-G takes you back to editor toplevel." + (setq need-full-redisplay t) + #+its (enable-echoing) + #+its (unwind-protect (break debug) (disable-echoing)) + #+lispm (break debug)) + +(set-key 'exit-editor "C-z") +(set-key 'exit-editor "C-x" "C-c") +(defcom exit-editor ((discard-argument)) +"Exit the editor." + (*throw 'exit-editor nil)) + +;; Rethink this. Need ways to eval Lisp and Macsyma forms. +;; What about typing monitor commands? + +(set-key 'eval-macsyma-expression "C-x" "C-e") +(set-key 'eval-macsyma-expression "M-") +(defcom eval-macsyma-expression ((discard-argument) + (read-expression exp "Evaluate: ")) +"Evaluate a Macsyma expression." + (if (expression-list current-buffer) + (setq exp (subst (region-as-mexp current-exp) '$% exp))) + (meval exp)) + +(set-key 'return-to-emacs "C-x" "z") +(defcom return-to-emacs ((discard-argument)) +"Return to Emacs from Macsyma." + #+its (setq need-full-redisplay t) + (minibuffer-print " [into emacs] ") + #+its (ledit) + #+lispm (ed) + ) diff --git a/src/emaxim/edexp.174 b/src/emaxim/edexp.174 new file mode 100755 index 00000000..7f90dabc --- /dev/null +++ b/src/emaxim/edexp.174 @@ -0,0 +1,656 @@ +;; -*- Mode: Lisp; Package: Macsyma; Ibase: 8 -*- + +(macsyma-module edexp) + +;; Macsyma display-oriented expression editor +;; Expression Manipulation functions +;; See EMAXIM;ED > and EMAXIM;EDCOM > for more information. +;; Written: Feb 17, 1979 By RZ, based on a version by CWH and BEE +;; Rewritten: June 2, 1979 by CWH for Macsyma Users' Conference + +;; Global variables and structure definitions. + +(load-macsyma-macros edmac) + +;; Expression manipulation primitives + +(defun region-as-mexp (exp) + (if (= (region-length exp) 1) + (cadr (region exp)) + (cons (list (operator exp)) + (firstn (region-length exp) (cdr (region exp)))))) + +; Modify the current level of the expression so that the region is boxed. +; Needed for dimensioning and displaying the current expression. +(defun box-region (exp) + (rplacd (region exp) + (cons ($box (region-as-mexp exp)) + (nthcdr (1+ (region-length exp)) (region exp))))) + +; Undo the effects of the above. +(defun unbox-region (exp) + (let ((boxed-exp (cadr (cadr (region exp))))) + (cond ((= 1 (region-length exp)) + (rplaca (cdr (region exp)) boxed-exp)) + (t (rplacd (last boxed-exp) (cddr (region exp))) + (rplacd (region exp) (cdr boxed-exp)))))) + +; Note: Save pdl format has been changed. For CDR transitions, it is +; (CDR . ). For CAR transitions, it is +; (CAR . ). + +(defun pop-save-pdl () + (if (null (save-pdl current-exp)) + (ed-internal-error 'pop-save-pdl "Attempt to pop save pdl when empty.") + (let ((top-of-pdl (pop (save-pdl current-exp)))) + (caseq (car top-of-pdl) + (CDR (setf (region current-exp) (cdr top-of-pdl))) + (CAR (setf (region current-exp) (cadr top-of-pdl)) + (setf (operand current-exp) (cddr top-of-pdl)) + (setf (operator current-exp) (caar (cddr top-of-pdl)))) + (t (ed-internal-error 'pop-save-pdl "Garbage on save pdl" top-of-pdl)))))) + + +;; Movement commands -- modifying the expression region. + +;; Later, check iteration count and do the first two checks only +;; the first time around. Make empty expression-list check be option +;; to defcom? + +(set-key 'forward-branch '("C-f" |/|)) +(defcom forward-branch () +"Move the region forward a single branch at this level. +The width of the region does not change. If the region +contains the last branch of this level, no action is taken." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + (if (region-contains-last-branch?) + (ed-error "Region contains the last branch of this level.")) + (push `(CDR . ,(region current-exp)) + (save-pdl current-exp)) + (pop (region current-exp))) + +(set-key 'backward-branch '("C-b" |/|)) +(defcom backward-branch () +"Move the region backward a single branch at this level. +The width of the region does not change. If the region +contains the first branch of this level, no action is taken." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + (if (region-contains-first-branch?) + (ed-error "Region contains the first branch of this level.")) + (pop-save-pdl)) + +(set-key 'previous-level '("C-p" |/ |)) +(defcom previous-level () +"Move the region up to the previous level. +The width of the region becomes a single branch. If the region already +is at the top level of the current expression, no action is taken." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + (do () + ((eq (caar (save-pdl current-exp)) 'CAR)) + (pop-save-pdl)) + (pop-save-pdl) + (setf (region-length current-exp) 1)) + +(set-key 'next-level '("C-n" |/|)) +(defcom next-level () +"Move the region down to the next level. +The region becomes a single branch wide. If the region +is at a terminal node of the current expression, i.e. contains +a single symbol, no action is taken." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-terminal-node?) + (ed-error "Region contains a terminal branch.")) + (push `(CAR ,(region current-exp) . ,(operand current-exp)) + (save-pdl current-exp)) + (setf (region current-exp) (cadr (region current-exp))) + (setf (operand current-exp) (region current-exp)) + (setf (operator current-exp) (caar (operand current-exp))) + (setf (region-length current-exp) 1) + ) + +(set-key 'top-level '("<" |/|)) +(defcom top-level ((discard-argument)) +"Move the region up to the top level. +The region becomes a single branch wide, and contains the entire expession." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + (do () + ((region-contains-top-node?)) + (previous-level))) + +(set-key 'grow-region "M-f") +(defcom grow-region () +"Increase the width of the region by one. +Extend the region forward to include the next branch at this level. If the +region would then include the entire expression, then the region is moved up +a level. If the region already contains the entire expression, no action is +taken." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + ;;Wrong kind of operator. + (if (not (memq (operator current-exp) '(MPLUS MTIMES MNCTIMES MLIST))) + (ed-error "Cannot grow the region at this node.")) + ;;Region at far right end of the expression, but doesn't contain + ;;the first branch. + (if (region-contains-last-branch?) + (ed-error "Region contains the last branch of this level.")) + (cond + ;;Extension would make region include every branch at this level, + ;;so move up a level. + ((= (length (cdr (operand current-exp))) + (1+ (region-length current-exp))) + (previous-level)) + (t (setf (region-length current-exp) + (1+ (region-length current-exp)))))) + +(set-key 'shrink-region "M-b") +(defcom shrink-region () +"Decrease the size of the region by one. +Shrink the region to contain one less branch at this level. If the width of +the region is one, and the branch it contains is not terminal, then the +region is moved down a level and then extended to include all but the last +branch." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (cond ((= (region-length current-exp) 1) + ;;Region includes an entire node. Step down and extend to include + ;;all but last branch. + (cond ((region-contains-terminal-node?) + (ed-error "Region contains a terminal node.")) + ((not (memq (caar (cadr (region current-exp))) + '(MPLUS MTIMES MNCTIMES MLIST))) + (ed-error "Cannot shrink the region at this node.")) + (t (next-level) + (setf (region-length current-exp) + (length (cddr (operand current-exp))))))) + (t (setf (region-length current-exp) (1- (region-length current-exp)))))) + +(set-key 'first-branch "C-a") +(defcom first-branch ((discard-argument)) +"Move the region to the first branch at this level. +The width of the region stays the same. If the region contains the entire +expression, no action is taken." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + (if (region-contains-first-branch?) + (ed-error "Region contains the first branch of this level.")) + (do () + ((region-contains-first-branch?)) + (backward-branch))) + +(set-key 'last-branch "C-e") +(defcom last-branch ((discard-argument)) +"Move the region to the last branch at this level. +The width of the region stays the same. If the region contains the entire +expression, no action is taken." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + (if (region-contains-last-branch?) + (ed-error "Region contains the last branch of this level.")) + (do () + ((region-contains-last-branch?)) + (forward-branch))) + + +;; Expression modification -- deleting portions of expressions + +(set-key 'delete-region "C-d") +(defcom delete-region () +"Delete the subexpression contained in the region from this level. +If the region contains the entire expression, then the expression +itself is removed from the buffer. If the region contains all but one +term of a sum or product, then the region is replaced with that term +alone." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (cond + ;;The region is the same as the body of the expression, so delete + ;;the entire expression. + ((region-contains-top-node?) (delete-expression)) + (t (cond ((equal (region-length current-exp) 1) + (push (cadr (region current-exp)) kill-pdl)) + (t (push (cons (list (operator current-exp) + 'spread + (region-length current-exp)) + (firstn (region-length current-exp) + (cdr (region current-exp)))) + kill-pdl))) + (rplacd (region current-exp) + (nthcdr (region-length current-exp) (cdr (region current-exp)))) + (setf (region-length current-exp) 1) + + ;;Normally, when a branch is deleted, the region is moved to + ;;the following branch and its width is made 1. + ;;If we delete all branches to the end + ;;of this level, then move the region to the previous branch. + (if (null (cdr (region current-exp))) + (pop-save-pdl)) + ;;If there were only two branches at this level when we started, + ;;then we now have an operator applied to one term. + ;;If the operator applied to one expression is the expression + ;;itself, or not meaningful with a single operand, (such as + ;;MQUOTIENT), then just leave the expression. Use "replace-region" + ;;rather than rplaca so that (A + B) + C --> A + B + C merging happens + ;;correctly and so that assignment of the label takes place if + ;;the region is the top node in the structure. + (cond ((and (region-contains-entire-level?) + (memq (operator current-exp) + '(MPLUS MTIMES MNCTIMES MEXPT MNCEXPT MQUOTIENT MEQUAL))) + (previous-level) + (replace-region t (cadr (cadr (region current-exp))))))))) + +; This command isn't too winning. +; Also, redisplay can't handle it since it doesn't modify the region. + +; (set-key 'rubout-expression "RUBOUT") +; (defcom rubout-expression () +; "Delete the branch just before the region from this level." +; (if (region-contains-top-node?) +; (ed-error "Region contains the entire expression.")) +; (if (region-contains-first-branch?) +; (ed-error "Region contains the first branch of this level.")) +; (if (not (memq (operator current-exp) +; '(MPLUS MTIMES MNCTIMES MLIST))) +; (ed-error "Cannot delete a branch at this level.")) +; (let ((save-region-length (region-length current-exp))) +; (setf (region-length current-exp) 1) +; (backward-branch) +; (delete-region) +; (setf (region-length current-exp) save-region-length))) + +; Rewrite this in terms of delete-region and movement functions. + +(set-key 'kill-following-branches "C-k") +(defcom kill-following-branches ((argument n)) +"Delete the branches following the last branch in the region. +Those branches at the current level following the last branch contained in the +region are deleted from the level. With a negative argument, those branches +preceding the first branch contained in the region are deleted from the level. +If the region is at the top level of the current expression or at the far right +or left end of the current level respectively, no action is taken." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + (if (not (memq (operator current-exp) '(MPLUS MTIMES MNCTIMES MLIST))) + (ed-error "Cannot delete branches at this level.")) + (if (not n) (setq n 1)) + (cond ((= n 0)) + (t (cond ((> n 0) + (if (region-contains-last-branch?) + (ed-error "Region contains the last branch at this level.")) + ;;Splice out stuff from region to end of level. + (rplacd (nthcdr (region-length current-exp) + (region current-exp)) nil)) + ((< n 0) + (if (region-contains-first-branch?) + (ed-error "Region contains the first branch at this level.")) + ;;Splice out stuff between operator and region. + (rplacd (operand current-exp) (cdr (region current-exp))) + ;;Move region to far left edge of level. + (do () + ((region-contains-first-branch?)) + (pop-save-pdl)))) + ;;If the region is the only thing that's left, move up one level. + (cond ((region-contains-entire-level?) + (previous-level) + ;;If there's only one term left at the old level, pull it + ;;up a level. + (if (null (cddr (cadr (region current-exp)))) + (replace-region t (cadr (cadr (region current-exp)))))))))) + +; Another way of writing this. Nearly independent of representation. +; (defun kill-following-branches () +; (let ((save-region-length (region-length current-exp))) +; (dotimes (i (1- save-region-length)) (shrink-region)) +; (dotimes (i save-region-length) (forward-branch)) +; (do () +; ((region-contains-last-branch?)) +; (grow-region)) +; (delete-region) +; (dotimes (i (1- save-region-length)) (backward-branch)) +; (dotimes (i (1- save-region-length)) (grow-region)))) + +; And yet another. But far less efficient. +; (defun kill-preceding-branches () +; (let ((save-region-length (region-length current-exp))) +; (dotimes (i (1- save-region-length)) (shrink-region)) +; (backward-branch) +; (do () +; ((region-contains-first-branch?)) +; (backward-branch) +; (grow-region)) +; (delete-region) +; (dotimes (i (1- save-region-length)) (grow-region)))) + + +;; Modifying expressions -- Inserting and replacing expressions + +;; If you're ever clobbering anything into the region, you should +;; be calling this function. + +(set-key 'replace-region "C-r") +(defcom replace-region ((argument n) + (read-expression exp + "Replace region: ~A" + (if n "(no evaluation) " ""))) +"Replace the region with an expression read from the minibuffer. +If a numeric argument is given, don't evaluate the entered expression." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + ;; Should we be rebinding % instead? Of course. We would + ;; have to simplify the region before binding, though. + (setq exp (subst (region-as-mexp current-exp) '$% exp)) + (if (null n) (setq exp (meval exp))) + ;; Operator must be associative to merge levels. Structural + ;; simplification being made here. (A + (B + C) + D) --> (A + B + C + D) + ;; Maybe we should always be simplifying the body, i.e. letting the + ;; simplifier do this. (Redundant knowledge) + (cond ((and (memq (operator current-exp) '(MPLUS MTIMES MNCTIMES)) + (not (atom exp)) + (eq (caar exp) (operator current-exp))) + ;; The region will soon contain this new expression + ;; so its length should be the same as that of the + ;; expression. + (let ((new-region-length (length (cdr exp)))) + (rplacd (last exp) + (nthcdr (1+ (region-length current-exp)) + (region current-exp))) + (rplacd (region current-exp) (cdr exp)) + (setf (region-length current-exp) new-region-length))) + (t (rplacd (region current-exp) + (cons (nformat-all exp) + (nthcdr (1+ (region-length current-exp)) + (region current-exp)))) + (setf (region-length current-exp) 1))) + ;; Make sure the expression label is bound to the expression + ;; body. Not necessary if inner part of expression clobbered. + (if (eq (body current-exp) (region current-exp)) + (mset (expression-label current-exp) (cadr (body current-exp))))) + +;; (defcom replace-region-operator ((discard-argument) +;; (read-line function-name "Replace function: ")) +;; "Replace the region operator." +;; (cond ((null operator) +;; (ed-error)) +;; ((let ((temp (cvt-name function-name))) +;; (setq operator temp) +;; (rplaca operand (list temp)))))) + +;; (defun cvt-name (nm) +;; (setq nm (implode (nreverse nm))) +;; (setq nm (or (cdr (assq nm '((+ . MPLUS) (* . MTIMES) (^ . MEXPT) +;; (** . MEXPT) (|.| . MNCTIMES) (^^ . MNCEXPT)))) +;; nm))) + +;; (defun insert-from-echo () +;; (insert-by-cursor (nformat-all (read-from-echo-area '|Insert:|)))) + +;; (defun insert-from-echo-eval () +;; (insert-by-cursor +;; (nformat-all +;; (meval (read-from-echo-area '|Insert:|))))) + +;; (defun insert-by-cursor (temp) +;; (let ((temp (subst (cadr region) '$% temp))) +;; (cond ((and (null (atom temp)) +;; (eq (caar temp) operator) +;; (eq 'spread (cadar temp))) +;; (rplacd region +;; (append (cdr temp) (cdr region))) +;; (setq region-length (caddar temp))) +;; (t (rplacd region +;; (cons temp (cdr region))))) +;; (setq redisplay t))) + +;; Modifying expressions -- using marks and kill-pdls + +;; (defun top-kill-pdl () +;; (cond ((null kill-pdl) (ed-error)) +;; (t (insert-by-cursor (car kill-pdl))))) + +;; (defun pop-kill-pdl () +;; (cond ((null kill-pdl) (ed-error)) +;; (t (insert-by-cursor (car kill-pdl)) +;; (setq kill-pdl (cdr kill-pdl))))) + +;; (defun mark-point () +;; (cond ((> argument 1) +;; (pop-mark-into-point)) +;; (t +;; (setq mark-pdl (cons (list operator operand region +;; (displayed current-exp)) +;; mark-pdl))))) + +;; (defun full-memq (a e) +;; (cond ((eq a e)) +;; ((atom e) nil) +;; ((or (full-memq a (car e)) +;; (full-memq a (cdr e)))))) + +;; (defun pop-mark-into-point () +;; (cond ((null mark-pdl) (ed-error)) +;; ((and (full-memq (cadddr (car mark-pdl)) (body current-exp)) +;; (full-memq (caddar mark-pdl) (cadddr (car mark-pdl)))) +;; (setq operator (caar mark-pdl) +;; operand (cadar mark-pdl) +;; region (caddar mark-pdl)) +;; (setf (displayed current-exp) (cadddr (car mark-pdl))))) +;; (t (setq mark-pdl (cdr mark-pdl)) +;; (ed-error))) + +; (defun exchange-mark-point () +; (mark-point) +; (rplaca (cdr mark-pdl) +; (prog2 0 (car mark-pdl) +; (rplaca mark-pdl (cadr mark-pdl)))) +; (pop-mark-into-point)) + + +; Make this work with negative args for moving stuff backwards. +(set-key 'transpose-branch "C-t") +(defcom transpose-branch ((argument n)) +"Transpose the region with the branch immediately following it. +The domain and width of the region remains the same. If given a negative +argument, then transpose the region with the branch at the same level +immediately preceding it." + + (if (null (expression-list current-buffer)) + (ed-error "Current Buffer is empty.")) + (if (region-contains-top-node?) + (ed-error "Region contains the entire expression.")) + (if (null n) (setq n 1)) + (cond ((> n 0) + (if (region-contains-last-branch?) + (ed-error "Region contains the last branch of this level.")) + (transpose-branch-forward n)) + ((< n 0) + (if (region-contains-first-branch?) + (ed-error "Region contains the last branch of this level.")) + (transpose-branch-backward (- n))))) + +(defun transpose-branch-forward (n) + (do ((i 0 (1+ i))) + ((or (= i n) (region-contains-last-branch?))) + (let ((next-branch + (nthcdr (1+ (region-length current-exp)) (region current-exp)))) + (rplacd (nthcdr (region-length current-exp) (region current-exp)) + (cdr next-branch)) + (rplacd next-branch (cdr (region current-exp))) + (rplacd (region current-exp) next-branch) + (forward-branch)))) + +(defun transpose-branch-backward (n) + (do ((i 0 (1+ i))) + ((or (= i n) (region-contains-first-branch?))) + (let ((current-branch (cdr (region current-exp)))) + (rplacd (region current-exp) + (nthcdr (1+ (region-length current-exp)) (region current-exp))) + (rplacd (nthcdr (1- (region-length current-exp)) current-branch) + (region current-exp)) + (backward-branch) + (rplacd (region current-exp) current-branch)))) + + +;; Manipulating expressions with standard macsyma commands + +;; There is some lossage here. Expressions are stored internally +;; in "nformat" form, i.e. in the form in which they are displayed. +;; Generally, they will be stripped of simp flags since only the +;; displayer looks at them. When passing them back to Macsyma, though, +;; any remaining simp flags must be ignored. Simp flags are left on +;; %LOG, %SIN, and others, while taken off of MPLUS, MTIMES, etc. +;; So this is done by binding DOSIMP to T, and calling SIMPLIFY. +;; This is what the SSIMPLIFYA function does. (Name sucks) +;; If MEVAL is being called, we don't need to do this, since it ignores +;; simp flags anyway. + +;; If the first argument to REPLACE-REGION is NIL, the expression +;; is evaluated and simplified before being formatted. + +(set-key 'simplify-region '("C-s" "s")) +(defcom simplify-region ((discard-argument)) +"Simplifies the expression in the region. +No evaluation of the expression takes place." + (minibuffer-clear) + (minibuffer-print "Simplify region.") + (replace-region t (ssimplifya (region-as-mexp current-exp)))) + +(set-key 'evaluate-region "v") +(defcom evaluate-region ((discard-argument)) +"Evaluates and simplifies the expression in the region." + (minibuffer-clear) + (minibuffer-print "Evaluate region.") + (replace-region nil (region-as-mexp current-exp))) + +(set-key 'add-to-region "+") +(defcom add-to-region ((argument n) + (read-expression term + "Add to region: ~A" + (if n "(no evaluation) " ""))) +"Add the expression contained in the region to one read from the minibuffer. +If a numeric argument is given, don't evaluate the entered expression." + (replace-region n `((mplus) ,(region-as-mexp current-exp) ,term))) + +(set-key 'multiply-to-region "*") +(defcom multiply-to-region ((argument n) + (read-expression factor + "Multiply to region: ~A" + (if n "(no evaluation) " ""))) +"Multiply the expression in the region to one read from the minibuffer. +If a numeric argument is given, don't evaluate the entered expression." + (replace-region n `((mtimes) ,(region-as-mexp current-exp) ,factor))) + +(set-key 'divide-region "//") +(defcom divide-region ((argument n) + (read-expression factor + "Divide region by: ~A" + (if n "(no evaluation) " ""))) +"Divide the expression in the region by one read from the minibuffer. +If a numeric argument is given, don't evaluate the entered expression." + (replace-region n `((mquotient) ,(region-as-mexp current-exp) ,factor))) + +(set-key 'exponentiate-region "^") +(defcom exponentiate-region ((argument n) + (read-expression exponent + "Exponentiate region: ~A" + (if n "(no evaluation) " ""))) +"Exponentiate the expression contained in the region. +If a numeric argument is given, don't evaluate the entered expression." + (replace-region n `((mexpt) ,(region-as-mexp current-exp) ,exponent))) + +; Do we need to simplify the values returned by $expand, $factor, etc? +(set-key 'expand-region "e") +(defcom expand-region ((discard-argument)) +"Expand the expression contained in the region. +The expression is first simplified before being given to EXPAND." + (minibuffer-clear) + (minibuffer-print "Expand region.") + (replace-region t ($expand (ssimplifya (region-as-mexp current-exp))))) + +(set-key 'factor-region "f") +(defcom factor-region ((discard-argument)) +"Factor the expression contained in the region. +The expression is first simplified before being given to FACTOR." + (minibuffer-clear) + (minibuffer-print "Factor region.") + (replace-region t ($factor (ssimplifya (region-as-mexp current-exp))))) + +(set-key 'differentiate-region "d") +(defcom differentiate-region ((discard-argument) + (read-expression var "Differentiate with respect to: ")) +"Differentiate the expression contained in the region. +The expression is first simplified before being given to DIFF." + (replace-region t ($diff (ssimplifya (region-as-mexp current-exp)) var))) + +(set-key 'integrate-region "i") +(defcom integrate-region ((discard-argument) + (read-expression var "Integrate with respect to: ")) +"Integrate the expression contained in the region. +The expression is first simplified before being given to INTEGRATE." + (replace-region t ($integrate (ssimplifya (region-as-mexp current-exp)) var))) + +(set-key 'multthru-region "m") +(defcom multthru-region ((discard-argument)) +"Invoke MULTTHRU on the region." + (minibuffer-clear) + (minibuffer-print "Multthru region. (distribute products over sums)") + (replace-region t ($multthru (region-as-mexp current-exp)))) + +(set-key 'partfrac-region "p") +(defcom partfrac-region ((discard-argument) + (read-expression var "Partial fraction decomposition with respect to:")) +"Expand the region in partial fractions. +The expansion is performed with respect to the specified main variable, and +the expression is simplified before the expansion is done." + (replace-region t ($partfrac (ssimplifya (region-as-mexp current-exp)) var))) + +(set-key 'ratsimp-region "r") +(defcom ratsimp-region ((discard-argument)) +"Invoke RATSIMP on the region." + (minibuffer-clear) + (minibuffer-print "Ratsimp region.") + (replace-region t ($ratsimp (region-as-mexp current-exp)))) + +;; Changing an expression's label and the binding of the label. +;; Better to use read-expression than read-line since user could insert random +;; characters like space or : into label and not be able to reference it. + +(set-key 'assign-expression ":") +(defcom assign-expression ((discard-argument) + (read-expression label "Assign region to: ")) +"Change the label of the current expression. +The label also represents a macsyma variable, and this variable gets bound +to the current expression." + (label-exp current-exp label)) + diff --git a/src/emaxim/edits.99 b/src/emaxim/edits.99 new file mode 100644 index 0000000000000000000000000000000000000000..f429d1c140ecabe77206461d00a6e570d124d264 GIT binary patch literal 9158 zcmc&)ZFAek5$?B+H2u=aAJ|da3Q7o>l;09Fwnw69Ta9F?B5l`+qZ9;=Bq|Wc;6)N= zGWqR&cJB@VDauYVoe4c261cm)y=UL|)a{c0g-<6sQcvhO&gWe^3&P7_g2$5}%onqu zOGl$1$MaV_b#v33nfLxoM`fZ&MRAeuY;JbDZUsdklmrW3XR%5P6_L7`XDZKQoyv5b z+1b1!9o;*nAdM&wGo@0R1u3?lVIfZ%C`J8~{eK^wbo+<&OeR*(z0(uC8taT^I#U#< z_&Ey-Y_rR2-(_)8sPxIk3pJw7;}&(ke*85ZEa?2Z7V()P0z&~^sZ3ZKEvWbIm27d) z?=yvSb!}-7(Lc*n(VnGZ=knebCwh~E&NlUQI#!uVLnWBJO!O#7=qkwKV3erb9JR>G zuqeTEq{eX?Gt2oduuXIj`4zxHnCTpd;e`QssA;4qh$0m|VgB&x*U*k*hy!Ta5%5Dt z!vR4Sap7BZ^P(J&v5~q8690M%yuDD*=2*G2xdC!`f+##M)dhKZ5fo)kV}&oq7jnid zO!HKh;pAIAvy@@vophQkws!Er$%)Q1B#tBF>`94(Ggie^(Xcmse@53jizrhdoI(x^ z=j*}C{t$vA`up(p;Ke)geWJ&^L<2o8t^+WD7rpc0VECRuYVhXl@XeW>-XHX2`q!BL zcKC3Qip5+}p|V+=28o??zW<&lbvl?dREf%h1$EkwI>PNiTtM~m%bLyM`vJ~$i_hWk zJ@_;v2ZQ}1Ci$S@OE#F&Op2X1XkFI>tlXGHUdrsbX zqEcX3C>obZLY+N-1PqtXZTCHWdoI9NDDi5|W>;kKr6Mm2azQF&s#!3f#;oujj01K< z263q4A`b)X^pLiTVle@%#X>{b+&qI-J?{~1hiP8VgLz?%=Ybw$?TzDcF|~TfO3UVi z)vEZ3Vj$=9QF1@Hf;ic9pOdkQr_?4G>V$okCH1-Hr6Lnie|~CGVt{`OB@xdmB?GX3 zIf{NgPexp;lxpaIEv1eX9aA!{=rpCgoJZxH#+jbc{!xpfEV!oY7?=i>>m-I*>l@g_ z%G9$Y$Y%kYFuQ+tR`8%xMyN$4%ty4*YC+DX%02@&?_4Owx%iPhn86pC-?dL+dh6WE zrWcRNW0`qR3FVie?WI2!8*ZU6j_KmE*@F#Yx9YGttFaSBI3 zo}R<~vMN8JZI4-sQyRxNX*r`jPA7254(yWvR-#}qi-vu{R^VXbD+zc@?<4qxbh{uG zPBn>>XLlG$P&|ggB3?4VVhSX$ry4FAKhp`vmKgCm%gT8HX~tJ7W$|SouEI+S3LtA^ zJH=y0TH>zQ2~~E&B7;{aJsuOAYfZB94G3yCp~5B?FX>_clh@^(!ygR3ghPvSwl|;I zXSO^B-pg$?VxVAe?Y;V+Jl}6Tvw6l)FfT-`bPi;Pr#Vk8$lCo>`ibp8rY6EPm!IlK zYa0U%K!FxwX_4u~pTH^r1jp1-rh-cc zh_`T>uwGZTnHN>;aJFyeozuFX>=!NDlDzKZV|K`{$7H<5QLf^jZsaZGEg%_V4Wdlii;K%5Hpfm(Sd%cNEqT@V-RcTzfK@ zgj=^mtK^row3>EHvdb_=`Wlt-9osn~e-My&;&A)yO9oZ3{TpO+7kE;|_BdCdR1)@_ zdjPDtrqAGfhzMA63g;#&OjGUa@v6_@9Q_+;T{Yyy>6zgD^J}M!xf11L?S+G0-G?)B z=dMv7$6T^?zN8qg>?xia8yICoCKx8%Vn9(S33vuV09|RKPu%EDLXfNkpBpLT#>k(8W3`kqtSDj!zu7QWYG;+CDtCR;0o;&2HSX3 zPR#i!laPbXTZobzX%&)wlT`vB9?iVhk}urgJLGtfnwER-7r$ z8gY!q(hT)skcfuZfNpf8NdX0>1qBUC6eE)JS4XtO{pJb}4=~akc^8YksqI7iY8K4H zM%sl1Fdea-+XVSMAOg2hQ(}0`{Dv|evN9nNJ7hCI-h?XDMy3fwahFEk1RP>yggNMO`4af4LUSRN` z|9IX^I!Zg#Vm2&GKHjOs&}f+|)3XSg7P=^sGrYStFVofS8(Eu4^tf|xvaF^R*5Fse zCUI<7J2t(ecT}%tFX(&#dq2mpHIah0(C*=j1v<2OXCF5RFvahG*%zDtf#{e0CtEH9 z0G_5aWwzMkvFiHfo$=A4n08XiO`(-ZwE!42X#q7+hjOp3fIfO5%K9bgteNM6M13}x z$S;R1Lua)+IEWZSqS6WU^V1})w>Xj}Q8Qqis~|!`$jPU4mRopWv%oieK~S|6>fKxH zD8LC)NY3CA6l=~T-~}Vehm8*0-MwPwtq{B1Lawa&@j<(R%kvU@kML!za``( z9eQ?Q+{baWxb4gwz!4eu<^X~d&v0@$X!u87#SKT-Z6t*P4_6a7i7V~8eA_g~?Gtq# z-glArEK^C0Fo9Bcc|F=8CGv8RF4Ks6+2FykB&{_kyNbMcD_m8y4$k}g-?n@s@C_&qVXNK1YgJQF$cMqq)zQ)u1^k4%v0;M@H}74qNo%^!%hn=l$WE^Vc8Q z^=U;-7-r8P1-)ZnuPw(oe{*p9X1GGfVC5*>d$r1{2m=S$=)US7pVfU`qV({&p`3?t%z_x{Ad6bu5`;emf~A#kd2Xz;I(GcR4ehNC_0HYU!_^_y6g${{v@&?_Pi6!{ zwAdJlFUK4=^5g{@rd zL-TNBFqzWDcLs0g4?Yae_IrIe2(t(+6j6Cz^r1x;Kj8lb{{JYe%v~k>Hj|#eLRp1# zj>?H-kWYwS#DFi?$SAIHRSdlhHL?#0C~~#J#3d3V(-wUnDa1O(LD$_~Ttidc9XIEy zoRltwVCkrGEn)Q)4*6C$-btr1Vrr1B?}z4!8<((h@%Byc{MirG=+JP+gTI>KS_K^) zSFYS5v|6xK%&hb}tM_Gk4RH8=q5vSA2L}-!1$!W8ZQiFicun?#KLDw6Bja^AF4z3P xH}vZXTZLW{$!uWbduT*xcR`|SBnctRbM&}FV@%<$) z-P=pbIG&a^ZwgI1FUslO-fY%wpd5AzwN0%vx(Yfc{kC@6dt)oCHo-bx&8P8}wW&0n zKfNMV<>WJ`bw#DB;6jPryz;fyG`~Fg<@|CsKcjDDVgG%4b%~*+byQlX$yE5WQ~_rl z^4>SjgrKYAC*SJ@9X&gsqpzNQMbEc%{p$hoy>fzAiZJfF|m!nM9@ zZ4lAR2F`xoT4~qv*=?-oXAe6QIS$%9r>*fxP>`{$5z+a!O7X)`bJoAv>JzC3>TZ^llBL zlFXJhtWNiyz!7`_#3ZR~pu`6i8c$1&|8UC!c$ZVG!@@*6hp0{dK8?HK^L;)DIc!yI z5C5Lxho~S(h##3;7iqRu&ZlalOu_N|jskodFDSsN_boX3JYATO-Y)X@Sg_26;LNSw zSHwYqMGhDgo}IS%MJh!;wu5bdgCqWuH_2 zt@6B7_U_1p&w-w-33)=*`6RbU@Y2*#4(8JdzUYleDkGyA7cG+*^By+-OY%B_% zVzA9qOUtIpS`uPUa<|^n!eY|#StfuOw~}WjuuHC~Fv!5Ep8e4`UjFjp#}Q}`Bk%=S zB;kY=ou{?4g8q9e5QpFVOyJO#lmA{e!%;%19=!qGjS&(4Ok!=Vq6ko zNEHF+GXZXA(PTcIKH=XiUJQrMuU-vw>cM(&P;Q}3(J=7%lsXVZx{`0?`(ZLhVe5VD z9NQV5T!>B~Y&V>=##fWj2Fe>00=k3HTOO2ThIm3PMxizSkdR2XnxH*el}KEQWv!2i zK-hD!1M{&E*A7^aaw|`Xs_SBlw1{<4BpR4`k3Cm-k0(+J}u_HP$;*-l(<%6?k#95 zR}XOVDXh0QGSlAMfu#a96OgU8B%EJeK($-&*Gg0yWx7;3{%Nu`t(9?*QusX<^R>a$ z&>qRQHc8nU=jf$vQq>tvl0ub>T%mlwtvd~VXprv%nn7}g%;wyXcnw1|Ipaa%Ugt-980X#;)7a@1 zq%uYI*ZFtsHv}0UX&je7(>SUIBA-YGWBl9JI` z@%GWfn`-y?p=xvy>g!NjT;=)$#Qn7N9?bU9q5mmFoepyfbbC9s3AEp}#%GbRG?y0u z{r2uer1p2BcPGcl+iq*yDzRT&c9_Iz9E-9c{#Mal`u=CeiRV#iz zNgrOaq5fb(dzSJ04K-fs7K}iR1DZB*rPN{MCSEtFY)xHjm+|{b8c_6#d_R8P#Qa5x z%cVn;u7;0F@q|G;=h5zUeH~s9RgUKex;YNcu-N2H1!=FIq&i0(!H&w4-D;=(|$i+lwA~<39m^86-{qX z8Cp79?zT-t^I-wE6C6OavS@NU+}r*DZ{3}!j!d)Ly(c4|rF;)}9L>BZEVKVPCU{<< Ml+pgabh<$FALx}*oB#j- literal 0 HcmV?d00001 diff --git a/src/jim/askp.85 b/src/jim/askp.85 new file mode 100644 index 00000000..73481706 --- /dev/null +++ b/src/jim/askp.85 @@ -0,0 +1,103 @@ +;;; -*- Mode: Lisp; Package: Macsyma -*- +;;; +;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ** +;;; +;;; Toplevel Functions: ($ASKINTEGER EXP ) +;;; +;;; EXP -> any Macsyma expression. +;;; -> $EVEN, $ODD, $INTEGER. +;;; If not given, defaults to $INTEGER. +;;; +;;; returns -> $YES, $NO, $UNKNOWN. +;;; +;;; If LIMITP is non-NIL the facts collected will be consed onto the list +;;; INTEGER-INFO. +;;; +;;; Implementors Functions: (ASK-INTEGER ) +;;; same as $ASKINTEGER with less error checking and +;;; requires two arguments. +;;; +;;; Support Functions: ASK-EVOD -> is a symbol an even or odd number? +;;; ASK-INTEGERP -> is a symbol an integer? +;;; ASK-PROP -> ask the user a question about a symbol. +;;; + +(macsyma-module askp) + +(declare (special limitp integer-info) + (fixnum n) + (*expr evod free $numberp integerp retrieve $featurep + sratsimp ssimplifya ratnump)) + +(defmfun $askinteger n + (if (or (> n 2) (< n 1)) (wna-err '$askinteger)) + (if (= n 1) (ask-integer (arg 1) '$integer) + (if (memq (arg 2) '($even $odd $integer)) + (ask-integer (arg 1) (arg 2)) + (improper-arg-err (arg 2) '$askinteger)))) + +(defmfun ask-integer (x even-odd) + (setq x (sratsimp (sublis '((z** . 0) (*z* . 0)) x))) + (cond ((or (not (free x '$%pi)) (not (free x '$%i)) (ratnump x)) '$no) + ((eq even-odd '$integer) (ask-integerp x)) + (t (ask-evod x even-odd)))) + +(defun ask-evod (x even-odd) + (let ((evod-ans (evod x)) (is-integer (integerp x))) + (cond ((equal evod-ans even-odd) '$yes) + ((and ($numberp x) (not is-integer)) '$no) + ((and is-integer evod-ans) '$no) + ((eq (setq evod-ans + (ask-prop x + (if (eq even-odd '$even) '|even| '|odd|) + '|number|)) + '$yes) + (ask-declare x even-odd) '$yes) + ((eq evod-ans '$no) + (if is-integer + (if (eq even-odd '$even) (ask-declare x '$odd) + (ask-declare x '$even))) + '$no) + (t '$unknown)))) + +(defun ask-integerp (x) + (let (integer-ans) + (if (and (mplusp x) (fixp (cadr x))) (setq x (addn (cddr x) t))) + (cond ((integerp x) '$yes) + (($numberp x) '$no) + (($featurep x '$noninteger) '$no) + ((eq (setq integer-ans (ask-prop x '|integer| nil)) '$yes) + (ask-declare x '$integer) '$yes) + ((eq integer-ans '$no) + (ask-declare x '$noninteger) '$no) + (t '$unknown)))) + +(defun ask-declare (x property) + (when (atom x) + (meval `(($declare) ,x ,property)) + (if limitp + (setq integer-info (cons `(($kind) ,x ,property) integer-info))))) + +(defun ask-prop (object property fun-or-number) + (if fun-or-number (setq fun-or-number (list '| | fun-or-number))) +;;; Asks the user a question about the property of an object. +;;; Returns only $yes, $no or $unknown. + (do ((end-flag) (answer)) + (end-flag (cond ((memq answer '($yes $y)) '$yes) + ((memq answer '($no $n)) '$no) + ((memq answer '($unknown $uk)) '$unknown))) + (setq answer (retrieve + `((mtext) |Is | ,object + ,(if (member (getcharn property 1) + '(#/a #/e #/i #/o #/u)) + '| an | + '| a |) + ,property ,@fun-or-number |?|) + nil)) + (cond + ((memq answer '($yes $y $no $n $unknown $uk)) + (setq end-flag t)) + (t (mtell + "~%Acceptable answers are Yes, Y, No, N, Unknown, Uk~%"))))) + +(declare (notype n)) diff --git a/src/jim/limit.273 b/src/jim/limit.273 new file mode 100644 index 00000000..b0b6f9c6 --- /dev/null +++ b/src/jim/limit.273 @@ -0,0 +1,2616 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module limit) + + +;;; ************************************************************** +;;; ** ** +;;; ** LIMIT PACKAGE ** +;;; ** ** +;;; ************************************************************** + + +;;; TOP LEVEL FUNCTION(S): $LIMIT $LDEFINT + +(DECLARE (GENPREFIX L) + (SPECIAL ERRORSW errrjfflag raterr ORIGVAL $LHOSPITALLIM LOW* + IND* *INDICATOR LIMFUNC + HALF%PI NN* DN* numer denom EXP VAR VAL VARLIST + *ZEXPTSIMP? $TLIMSWITCH ORIGVAL + $LOGARC *LIMORDER TAYLORED LOGCOMBED + $EXPONENTIALIZE LHP? LHCOUNT + $RATFAC GENVAR COMPLEX-LIMIT LNORECURSE + LOGINPROD? $LIMSUBST $LOGABS A + context global-assumptions limit-assumptions + limit-top limitp integer-info old-integer-info + behavior-count behavior-count-now $KEEPFLOAT $logexpand) + (*LEXPR $LIMIT limit-list $FACTOR FACTOR $EXPAND + $RATSIMP $RAT $RATCOEF context) + (*expr $trigexpand) + (FIXNUM NARGS BEHAVIOR-COUNT BEHAVIOR-COUNT-NOW)) + +(load-macsyma-macros rzmac) + +(DEFMVAR INFINITIES '($INF $MINF $INFINITY) + "The types of infinities recognized by Macsyma. + INFINITY is complex infinity") + +(DEFMVAR REAL-INFINITIES '($INF $MINF) + "The real infinities, INF is positive infinity, MINF negative infinity") + +(DEFMVAR INFINITESIMALS '($ZEROA $ZEROB) + "The infinitesimals recognized by Macsyma. ZEROA zero from above, + ZEROB zero from below") + +(defmvar RD* NIL "The full implications of this flag have yet to be determined. + It appears in LIMIT and DEFINT.......") + +(defmvar simplimplus-problems () "A list of all problems in the stack of + recursive calls to simplimplus") + +(defmvar limit-answers () "An association list for storing limit answers") + +(defmvar preserve-direction () "Makes LIMIT return Direction info.") + +(if (not (boundp 'integer-info)) (setq integer-info ())) + +(if (not (boundp 'behavior-count)) (setq behavior-count 4)) + +;; This should be made to give more information about the error. +;(DEFun DISCONT () +; (cond (errorsw (*throw 'errorsw t)) +; (t (merror "Discontinuity Encountered")))) + +(DEFUN PUTLIMVAL (E V) + (let ((exp (cons '(%limit) (list e var val)))) + (cond ((not (assolike exp limit-answers)) + (setq limit-answers (cons (cons exp v) limit-answers)) + v) + (t ())))) + +(DEFun GETLIMVAL (E) + (let ((exp (cons '(%limit) (list e var val)))) + (assolike exp limit-answers))) + +(DEFMACRO LIMIT-CATCH (EXP VAR VAL) + `(LET ((ERRORSW T)) + (LET ((ANS (*CATCH 'ERRORSW + (*CATCH 'LIMIT (LIMIT ,EXP ,VAR ,VAL 'THINK))))) + (COND ((OR (NULL ANS) (EQ ANS T)) ()) + (T ANS))))) + +(defmfun $limit nargs +(let ((global-assumptions ()) (limit-assumptions ()) + (old-integer-info ()) + ($keepfloat t) (limit-top t)) + (if (not limitp) + (progn (setq old-integer-info integer-info) + (setq integer-info ()))) + + (unwind-protect + (let ((exp1 ()) (rd* t) (lhcount $lhospitallim) (behavior-count-now 0) + (d ()) (exp ()) (var ()) (val ()) (dr ()) + (*indicator ()) (taylored ()) (origval ()) + (logcombed ()) (lhp? ()) ($logexpand t) + (varlist ()) (ans ()) (genvar ()) (loginprod? ()) + (limit-answers ()) (limitp t) (simplimplus-problems ())) + (prog () + (if (not (or (= nargs 3) (= nargs 4) (= nargs 1))) (wna-err '$limit)) +;;;Is it a LIST of Things? + (if (setq ans (apply #'limit-list (listify nargs))) (return ans)) + (setq exp1 (specrepcheck (arg 1))) + (cond ((= nargs 1) (setq var 'foo val 0)) + (t (setq var (arg 2)) + (cond (($constantp var) + (merror + "Second argument cannot be a constant - LIMIT"))) + (setq val (arg 3)) + (if (eq val '$zeroa) (setq dr '$plus)) + (if (eq val '$zerob) (setq dr '$minus)))) + (cond ((= nargs 4) + (if (not (memq (arg 4) '($plus $minus))) + (merror + "Fourth argument must be either PLUS or MINUS - LIMIT")) + (setq dr (arg 4)))) + (cond ((and (atom var) (not (among var val))) + (setq exp exp1)) +;;;Var is funny so make it a gensym. + (t (let ((realvar var)) + (setq var (gensym)) + (setq exp (substitute var realvar exp1)) + (putprop var realvar 'limitsub)))) + (if (and (not $limsubst) (not (eq var 'foo))) + (if (limunknown exp) + (return `((%limit) ,@(cons exp1 (cdr (listify nargs))))))) + (setq varlist (ncons var) genvar nil origval val) +;;;Limit is going to want to make its own assumptions about the variable +;;;based on what the calling program knows. Old assumptions are saved +;;;for restoration upon exit. + (if (not (= nargs 1)) (limit-context (arg 2) origval dr)) +;;;Transform the limit value. + (cond ((not (infinityp val)) + (if (not (zerop2 val)) + (setq exp (subin (m+ var val) exp))) + (setq val (cond ((eq dr '$plus) '$zeroa) + ((eq dr '$minus) '$zerob) + (t 0))) + (setq origval 0))) + (if (eq val '$minf) (setq val '$inf + origval '$inf + exp (subin (m* -1 var) exp))) + (setq exp (resimplify + (factosimp (tansc (lfibtophi + (limitsimp ($expand (hide exp) 1 0) + var)))))) +;;;Resimplify in light of new assumptions. + (setq d (*catch 'mabs (mabs-subst exp var val))) + (cond ((eq d 'both) (or (setq ans (both-side exp var val)) + (nounlimit exp var val))) + ((eq d '$und) (return '$und)) + ((eq d 'retn) (return (nounlimit exp var val))) + (t (setq exp d))) + (setq ans (limit-catch exp var val)) + (cond ((null ans) + (if (or (real-epsilonp val) + (real-infinityp val)) + (return (nounlimit exp var val)))) + (t (return (clean-limit-exp ans)))) + (cond ((setq ans (both-side exp var val)) + (return (clean-limit-exp ans))) + (t (return (nounlimit exp var val)))))) + (restore-assumptions)))) + +(defun clean-limit-exp (exp) + (setq exp (restorelim exp)) + (if preserve-direction exp (ridofab exp))) + +(defun limit-list nargs + (let (((exp1 . rest) (listify nargs))) + (cond ((mbagp exp1) + `(,(car exp1) ,@(mapcar + #'(lambda (x) + (apply '$limit `(,x ,@rest))) + (cdr exp1)))) + (t ())))) + +(defun limit-context (var val direction) ;Only works on entry! + (cond (limit-top + (mapc 'forget (setq global-assumptions (cdr ($facts var)))) + (assume '((mgreaterp) epsilon 0)) + (assume '((mlessp) epsilon 1.0e-8)) + (assume '((mgreaterp) prin-inf 1.0e+8)) + (setq limit-assumptions + (make-limit-assumptions global-assumptions var val direction)) + (setq limit-top ())) + (t ())) + limit-assumptions) + +(defun make-limit-assumptions (old-assumptions var val direction) + (prog (new-assumptions) + (setq new-assumptions (use-old-context old-assumptions var val)) + (mapc #'assume new-assumptions) + (if (or (null var) (null val)) (return ())) + (cond ((and (not (infinityp val)) (null direction)) (return ())) + ((eq val '$inf) + (setq new-assumptions `(,(assume `((mgreaterp) ,var 1.0e+8)) + ,@new-assumptions)) + (return new-assumptions)) + ((eq val '$minf) + (setq new-assumptions `(,(assume `((mgreaterp) 1.0e+8 ,var)) + ,@new-assumptions)) + (return new-assumptions)) + ((eq direction '$plus) + (setq new-assumptions `(,(assume `((mgreaterp) ,var 0)) ;All limits + ,@new-assumptions)) ;around 0 + (return new-assumptions)) + ((eq direction '$minus) + (setq new-assumptions `(,(assume `((mgreaterp) 0 ,var)) + ,@new-assumptions)) + (return new-assumptions)) + (t (return ()))))) + +(defun use-old-context (old-assumptions var val) + (setq var (ridofab var)) + (cond ((null old-assumptions) ()) + ((not (infinityp val)) + (do ((list old-assumptions (cdr list)) + (pred) (part1) (part2) (assumptions)) + ((null list) assumptions) + (setq pred (caar (car list)) + part1 (cadr (car list)) + part2 (caddr (car list))) + (if (memq pred '(mgreaterp mlessp)) + (push (make-assump pred part1 part2 var val) + assumptions)))))) + +(defun make-assump (pred part1 part2 var val) + (cond ((eq part1 var) + (cond ((and (free part2 '$inf) + (free part2 '$minf) + (free part2 '$infinity)) + `((,pred) ,part1 ,(m+t part2 (m*t -1 val)))) + (t `((,pred) ,part1 ,part2)))) + ((eq part2 var) + (cond ((and (free part1 '$inf) + (free part1 '$minf) + (free part1 '$infinity)) + `((,pred) ,(m+t part1 (m*t -1 val)) ,part2)) + (t `((,pred) ,part1 ,part2)))))) + +(defun restore-assumptions () +;;;Hackery until assume and forget take reliable args. Nov. 9 1979. +;;;JIM. + (do ((assumption-list limit-assumptions (cdr assumption-list))) + ((null assumption-list) t) + (forget (car assumption-list))) + (forget '((mgreaterp) epsilon 0)) + (forget '((mlessp) epsilon 1.0e-8)) + (forget '((mgreaterp) prin-inf 1.0e+8)) + (cond ((and (not (null integer-info)) + (not limitp)) + (do ((list integer-info (cdr list))) + ((null list) t) + (I-$remove `(,(cadar list) ,(caddar list)))) + (setq integer-info old-integer-info))) + (do ((assumption-list global-assumptions (cdr assumption-list))) + ((null assumption-list) t) + (assume (car assumption-list)))) + +(DEFUN BOTH-SIDE (EXP VAR VAL) + (let ((preserve-direction t)) + (let ((la ($LIMIT EXP VAR VAL '$PLUS)) + (lb ($LIMIT EXP VAR VAL '$MINUS))) + (cond ((ALIKE1 (ridofab LA) (ridofab LB)) (ridofab la)) + ((and (not (free la '%limit)) + (not (free la '%limit))) ()) + (t '$und))))) + +;; Warning: (*CATCH NIL ...) will catch all throws. +;; NIL should not be used as a tag name. + +(DEFUN LIMUNKNOWN (F) (*CATCH 'limunknown (LIMUNKNOWN1 (SPECREPCHECK F)))) + +(DEFUN LIMUNKNOWN1 (F) + (COND ((mapatom f) nil) + ((OR (NOT (GET (CAAR F) 'OPERATORS)) + (MEMQ (CAAR F) '(%SUM %PRODUCT %SIGNUM MNCEXPT)) +;Special function code here i.e. for li[2](x). + (and (eq (caar f) 'mqapply) + (not (get (subfunname f) 'specsimp)))) + (IF (NOT (FREE F VAR)) (*THROW 'limunknown T))) + (T (MAPC #'LIMUNKNOWN1 (CDR F)) NIL))) + +(DEFUN FACTOSIMP(E) + (IF (INVOLVE E '(%GAMMA)) (SETQ E ($MAKEFACT E))) + (COND ((INVOLVE E '(MFACTORIAL)) + (SETQ E (SIMPLIFY ($MINFACTORIAL E)))) + (T E))) + +(DEFUN GETSIGNL (Z) + (let ((z (ridofab z))) + (if (not (free z var)) (setq z ($limit z var val))) + (let ((sign ($asksign z))) + (cond ((eq sign '$pos) 1) + ((eq sign '$neg) -1) + ((eq sign '$zero) 0))))) + +(defun restorelim (exp) + (cond ((null exp) nil) + ((atom exp) (or (get exp 'limitsub) exp)) + ((eq (caar exp) 'mrat) + (cons (car exp) + (cons (restorelim (cadr exp)) + (restorelim (cddr exp))))) + (t (cons (car exp) (mapcar #'restorelim (cdr exp)))))) + + +(DEFUN MABS-SUBST (EXP VAR VAL) ; RETURNS EXP WITH MABS REMOVED, OR THROWS. + (let ((d (involve exp '(mabs)))) + (cond ((null d) exp) + (t (cond + ((not (and (equal ($imagpart (limit d var val 'think)) 0) + (equal ($imagpart var) 0))) (*throw 'mabs 'retn)) + (t (DO ((ANS D (INVOLVE EXP '(MABS))) (a () ())) + ((NULL ANS) EXP) + (SETQ A (MABS-SUBST ANS VAR VAL)) + (SETQ D (LIMIT A VAR VAL T)) + (cond + ((or (null a) (null d)) + (if (not (OR (eq val '$zeroa) + (eq val '$zerob) + (REAL-INFINITYP VAL))) (*THROW 'MABS 'BOTH))) + ((AND A D) + (COND ((ZEROP1 D) (SETQ D (BEHAVIOR A VAR VAL)) + (if (ZEROP1 D) (*THROW 'MABS 'RETN)))) + (if (OR (EQ D '$ZEROA) (EQ D '$INF) (RATGREATERP D 0)) + (SETQ EXP (SUBSTITUTE A `((MABS) ,ANS) EXP))) + (if (OR (EQ D '$ZEROB) (EQ D '$MINF) (RATGREATERP 0 D)) + (SETQ EXP (SUBSTITUTE (M* -1 A) `((MABS) ,ANS) EXP))) + (if (EQ D '$UND) (*THROW 'MABS '$UND))) + (t (*THROW 'MABS 'RETN)))))))))) + +(DEFUN INFCOUNT (EXP) + (COND ((ATOM EXP) + (COND ((INFINITYP EXP) 1) + (T 0))) + (T (+ (INFCOUNT (CAR EXP)) (INFCOUNT (CDR EXP)))))) + +(DEFUN SIMPINF (EXP) + (LET ((INFC (INFCOUNT EXP)) NEXP) + (COND + ((= INFC 0) EXP) + ((= INFC 1) (SETQ INFC (inf-typep exp)) + ($LIMIT (SUBST VAR INFC EXP) VAR INFC)) + (t + (SETQ NEXP (CONS (CAR EXP) (MAPCAR 'SIMPINF (CDR EXP)))) + (SETQ INFC (INFCOUNT NEXP)) + (cond + ((AMONG '$UND NEXP) '$UND) + ((AMONGL '(%LIMIT $IND) NEXP) EXP) + ((mtimesp nexp) + (COND ((MEMBER 0 NEXP) + (COND ((> INFC 0) '$UND) + (T 0))) + ((MEMQ '$INFINITY NEXP) '$INFINITY) + (T (SIMPLIMIT NEXP VAR VAL)))) + ((mexptp nexp) + (COND ((AND (EQ (CADR NEXP) '$INF) (EQ (CADDR NEXP) '$INF)) '$INF) + (T (SIMPINF (m^ '$%E (m* (CADDR EXP) `((%LOG) ,(CADR EXP)))))))) + ((< INFC 2) (SIMPINF NEXP)) + ((mplusp nexp) + (COND ((MEMQ '$INFINITY (CDR NEXP)) '$INFINITY) + (T (SETQ INFC (inf-typep nexp)) + (COND + ((AMONGL (DELETE INFC + (copy-top-level '($infinity $minf inf))) + NEXP) + '$UND) + (T INFC))))) + (T NEXP)))))) + +(defun simpab (small) + (cond ((null small) ()) + ((memq small '($zeroa $zerob $inf $minf $infinity)) small) + ((not (free small '$ind)) '$ind) ;Not exactly right but not + ((not (free small '$und)) '$und) ;causing trouble now. + ((mapatom small) small) + ((and (not (free-infp small)) + (or (not (free small '$zeroa)) + (not (free small '$zerob)))) + (*throw 'limit t)) ;Terrible loss, can do better + (t (let ((preserve-direction t) + (new-small (subst 'epsilon '$zeroa + (subst (m- 'epsilon) '$zerob small)))) + (limit new-small 'epsilon '$zeroa 'think))))) + + +;;;*I* INDICATES: T => USE LIMIT1,THINK, NIL => USE SIMPLIMIT. +(DEFUN LIMIT (EXP VAR VAL *I*) + (COND + ((AMONG '$UND EXP) '$UND) + ((EQ VAR EXP) VAL) + ((ATOM EXP) EXP) + ((NOT (AMONG VAR EXP)) + (COND ((AMONGL '($INF $MINF $INFINITY $IND) EXP) + (SIMPINF EXP)) + (T EXP))) + ((GETLIMVAL EXP)) + (T (PUTLIMVAL EXP (COND ((AND $TLIMSWITCH + (NULL TAYLORED) + (TLIMP EXP)) + (TAYLIM EXP *I*)) + ((RATP EXP VAR) (RATLIM EXP)) + ((OR (EQ *I* T) (RADICALP EXP VAR)) + (LIMIT1 EXP VAR VAL)) + ((EQ *I* 'THINK) + (COND ((or (mtimesp exp) (mexptp exp)) + (LIMIT1 EXP VAR VAL)) + (T (SIMPLIMIT EXP VAR VAL)))) + (T (SIMPLIMIT EXP VAR VAL))))))) + +(defun limitsimp (exp var) + (limitsimp-dispatch (sin-sq-cos-sq-sub exp) var)) +;Hack for sin(x)^2+cos(x)^2. + +(defun limitsimp-dispatch (exp var) + (cond ((or (atom exp) + (mnump exp) + (freeof var exp)) exp) + ((mexptp exp) + (limitsimp-expt exp var)) + (t (subst0 (cons (cons (caar exp) ()) + (mapcar #'(lambda (x) + (limitsimp-dispatch x var)) + (cdr exp))) + exp)))) + + +(defun limitsimp-expt (exp var) + (cond ((and (mexptp exp) + (not (freeof var (cadr exp))) + (not (freeof var (caddr exp)))) + (m^ '$%e (simplify `((%log) ,exp)))) + (t exp))) + +(defun sin-sq-cos-sq-sub (exp) ;Hack ... Hack + (let ((arg (involve exp '(%sin %cos)))) + (cond + ((null arg) exp) + (t (let ((new-exp ($substitute (m+t 1 (m- (m^t `((%sin) ,arg) 2))) + (m^t `((%cos) ,arg) 2) + ($substitute + (m+t 1 (m- (m^t `((%cos) ,arg) 2))) + (m^t `((%sin) ,arg) 2) + exp)))) + (cond ((not (involve new-exp '(%sin %cos))) new-exp) + (t exp))))))) + +(defun expand-trigs (x var) + (cond ((atom x) x) + ((mnump x) x) + ((and (or (eq (caar x) '%sin) + (eq (caar x) '%cos)) + (not (free (cadr x) var))) + ($trigexpand x)) + (t (simplify (cons (ncons (caar x)) + (mapcar '(lambda (x) + (expand-trigs x var)) + (cdr x))))))) + + +(DEFUN TANSC (E) + (COND ((NOT (INVOLVE E + '(%COT %CSC %BINOMIAL + %SEC %COTH %SECH %CSCH + %ACOT %ACSC %ASEC %ACOTH + %ASECH %ACSCH))) + E) + (T ($RATSIMP (TANSC1 E))))) + +(DEFUN TANSC1 (E &aux tem) + (COND ((ATOM E) E) + ((AND (SETQ E (CONS (CAR E) (MAPCAR 'TANSC1 (CDR E)))) ())) + ((SETQ TEM (ASSQ (CAAR E) '((%COT . %TAN) (%COTH . %TANH) + (%SEC . %COS) (%SECH . %COSH) + (%CSC . %SIN) (%CSCH . %SINH)))) + (TANSC1 (m^ (LIST (NCONS (CDR TEM)) (CADR E)) -1.))) + ((SETQ TEM (MEMQ (CAAR E) '(%SINH %COSH %TANH))) + (let (($EXPONENTIALIZE t)) + (RESIMPLIFY E))) + ((SETQ TEM (ASSQ (CAAR E) '((%ACSC . %ASIN) (%ASEC . %ACOS) + (%ACOT . %ATAN) (%ACSCH . %ASINH) + (%ASECH . %ACOSH) (%ACOTH . %ATANH)))) + (LIST (NCONS (CDR TEM)) (m^t (CADR E) -1.))) + ((AND (EQ (CAAR E) '%BINOMIAL) (AMONG VAR (CDR E))) + (m// `((MFACTORIAL) ,(CADR E)) + (m* `((MFACTORIAL) ,(m+t (CADR E) (m- (CADDR E)))) + `((MFACTORIAL) ,(CADDR E))))) + (t E))) + +(DEFUN HYPEREX (EX) + (COND ((NOT (INVOLVE EX + '(%SIN %COS %TAN %ASIN %ACOS %ATAN + %SINH %COSH %TANH %ASINH %ACOSH %ATANH))) + EX) + (T (HYPEREX0 EX)))) + +(DEFUN HYPEREX0 (EX) + (COND ((ATOM EX) EX) + ((eq (caar ex) '%sinh) + (m// (m+ (m^ '$%e (cadr ex)) (m- (m^ '$%e (m- (cadr ex))))) + 2)) + ((eq (caar ex) '%cosh) + (m// (m+ (m^ '$%e (cadr ex)) (m^ '$%e (m- (cadr ex)))) + 2)) + ((AND (MEMQ (CAAR EX) + '(%SIN %COS %TAN %ASIN %ACOS %ATAN %SINH + %COSH %TANH %ASINH %ACOSH %ATANH)) + (AMONG VAR EX)) + (HYPEREX1 EX)) + (T (CONS (CAR EX) (MAPCAR #'HYPEREX0 (CDR EX)))))) + +(DEFUN HYPEREX1 (EX) + (LET ( ;; Can't exponentialize now because complex plane isn't handled right yet + ;; ($EXPONENTIALIZE T) + ($LOGARC T)) + (SSIMPLIFYA EX))) + +(DEFUN LIMIT1 (EXP VAR VAL) + (prog () + (let ((lhprogress? lhp?) (lhp? ()) (ans ())) + (COND ((SETQ ans (AND (NOT (ATOM EXP)) + (GETLIMVAL EXP))) + (RETURN ans)) + ((and (not (INFINITYP VAL)) + (SETQ ans (SIMPLIMSUBST VAL EXP))) + (RETURN ans)) + (t nil)) + +;;;NUMDEN* => (numerator . denominator) + (LET (((n . dn) (NUMDEN* EXP))) + (COND + ((NOT (AMONG VAR DN)) + (RETURN (SIMPLIMIT (M// (SIMPLIMIT N VAR VAL) DN) + VAR + VAL))) + ((NOT (AMONG VAR N)) + (RETURN (SIMPLIMIT (M* N + (SIMPLIMEXPT DN + -1. + (SIMPLIMIT DN + VAR + VAL) + -1.)) + VAR + VAL))) + ((AND (RADICALP N VAR) (RADICALP DN VAR)) + (RETURN (RADLIM (m* N (m^ DN -1.)) + N + DN))) + ((AND LHPROGRESS? + (/#ALIKE N (CAR LHPROGRESS?)) + (/#ALIKE DN (CDR LHPROGRESS?))) + (*THROW 'LHOSPITAL NIL))) + (RETURN (LIMIT2 N DN VAR VAL)))))) + +(DEFUN /#ALIKE (E F) + (cond ((ALIKE1 E F) + t) + (t (let ((deriv (sdiff (m// e f) var))) + (cond ((=0 deriv) + t) + ((=0 ($ratsimp deriv)) + t) + (t nil)))))) + +(DECLARE (SPECIAL N DN)) + +(DEFUN LIMIT2 (N DN VAR VAL) + (PROG (N1 D1 lim-SIGN GCP SHEUR-ANS) + (setq n (hyperex n) + dn (hyperex dn)) +;;;Change to uniform limit call. + (COND ((INFINITYP VAL) (SETQ D1 (LIMIT DN VAR VAL NIL)) + (SETQ N1 (LIMIT N VAR VAL NIL))) + (T (COND ((SETQ N1 (SIMPLIMSUBST VAL N)) NIL) + (T (SETQ N1 (LIMIT N VAR VAL NIL)))) + (COND ((SETQ D1 (SIMPLIMSUBST VAL DN)) NIL) + (T (SETQ D1 (LIMIT DN VAR VAL NIL)))))) + (COND ((OR (NULL N1) (NULL D1)) (RETURN NIL)) + (T (SETQ N1 (SRATSIMP N1) D1 (SRATSIMP D1)))) + (COND ((OR (INVOLVE N '(MFACTORIAL)) (INVOLVE DN '(MFACTORIAL))) + (let ((ANS (limfact2 n dn var val))) + (COND (ANS (RETURN ANS)))))) + (COND ((AND (ZEROP2 N1) (ZEROP2 D1)) + (COND ((NOT (EQUAL (SETQ GCP (GCPOWER N DN)) 1)) + (RETURN (COLEXPT N DN GCP))) + ((and (real-epsilonp val) + (not (free n '%log)) + (not (free dn '%log))) + (return (liminv (m// n dn)))) + ((SETQ N1 (TRY-LHOSPITAL-QUIT N DN NIL)) + (RETURN N1)))) + ((AND (ZEROP2 N1) (NOT (MEMQ D1 '($IND $UND)))) (RETURN 0)) + ((ZEROP2 D1) + (SETQ N1 (RIDOFAB N1)) + (return (SIMPLIMTIMES `(,N1 ,(SIMPLIMEXPT DN -1 D1 -1)))))) + (SETQ N1 (RIDOFAB N1)) + (SETQ D1 (RIDOFAB D1)) + (COND ((OR (EQ D1 '$UND) + (AND (EQ N1 '$UND) (NOT (REAL-INFINITYP D1)))) + (RETURN '$UND)) + ((EQ D1 '$IND) (RETURN '$UND)) + ((EQ N1 '$IND) (RETURN (COND ((INFINITYP D1) 0) + ((EQUAL D1 0) '$UND) + (T '$IND)))) ;SET LB + ((AND (REAL-INFINITYP D1) (MEMQ N1 '($INF $UND $MINF))) + (COND ((EXPFACTORP N DN) (RETURN (EXPFACTOR N DN VAR))) + ((AND (NOT (ATOM DN)) (NOT (ATOM N)) + (COND ((NOT (EQUAL (SETQ GCP (GCPOWER N DN)) 1.)) + (RETURN (COLEXPT N DN GCP))) + ((AND (EQ '$INF VAL) + (OR (INVOLVE DN '(MFACTORIAL %GAMMA)) + (INVOLVE N '(MFACTORIAL %GAMMA)))) + (RETURN (LIMFACT N DN)))))) + ((EQ N1 D1) (SETQ lim-SIGN 1.) + (GO CP)) + (T (SETQ lim-SIGN -1.) (GO CP)))) + ((AND (INFINITYP D1) (INFINITYP N1)) (GO CP)) + (t (RETURN (SIMPLIMTIMES `(,N1 ,(m^ d1 -1)))))) +CP (SETQ N ($EXPAND N)) + (SETQ DN ($EXPAND DN)) + (COND ((mplusp n) + (let ((MAXI-TERMS (maxi (cdr n))) + (NEW-N ())) + (SETQ NEW-N (COND ((NOT (NULL (CDR MAXI-TERMS))) + (m+l MAXI-TERMS)) + (T (CAR MAXI-TERMS)))) + (COND ((NOT (ALIKE1 NEW-N N)) + (RETURN (LIMIT (M// NEW-N DN) VAR '$INF 'THINK)))) + (SETQ N1 (CAR MAXI-TERMS)))) + (T (SETQ N1 N))) + (COND ((mplusp dn) + (let ((MAXI-TERMS (maxi (cdr dn))) + (NEW-DN ())) + (SETQ NEW-DN (COND ((NOT (NULL (CDR MAXI-TERMS))) + (m+l MAXI-TERMS)) + (T (CAR MAXI-TERMS)))) + (COND ((NOT (ALIKE1 NEW-DN DN)) + (RETURN (LIMIT (M// N NEW-DN) VAR '$INF 'THINK)))) + (SETQ D1 (CAR MAXI-TERMS)))) + (T (SETQ D1 DN))) + (SETQ SHEUR-ANS (SHEUR0 N1 D1)) + (COND ((or (MEMQ SHEUR-ANS '($INF $ZEROA)) + (free sheur-ans var)) + (RETURN (SIMPLIMTIMES `(,lim-SIGN ,SHEUR-ANS)))) + ((AND (ALIKE1 SHEUR-ANS DN) + (NOT (mplusp n)))) + ((MEMQ (SETQ N1 (cond ((expfactorp n1 d1) (EXPFACTOR N1 D1 VAR)) + (t ()))) + '($INF $ZEROA)) + (RETURN N1)) + ((NOT (NULL (SETQ N1 (cond ((expfactorp n dn) (EXPFACTOR N DN VAR)) + (t ()))))) + (RETURN N1)) + ((AND (ALIKE1 SHEUR-ANS DN) (NOT (MPLUSP N)))) + ((not (alike1 sheur-ans (m// n dn))) + (RETURN (SIMPLIMIT (M// ($EXPAND (M// N SHEUR-ANS)) + ($EXPAND (M// DN SHEUR-ANS))) + VAR + VAL)))) + (cond ((and (NOT (AND (EQ VAL '$INF) (EXPP N) (EXPP DN))) + (SETQ N1 (TRY-LHOSPITAL-quit N DN NIL)) + (NOT (EQ N1 '$UND))) + (RETURN N1))) + (*THROW 'LIMIT T))) + + +(DEFUN EXPFACTORP (N DN) + (DO ((LIST (APPEND (COND ((MTIMESP N) (CDR N)) + (T (NCONS N))) + (COND ((MTIMESP DN) (CDR DN)) + (T (NCONS DN)))) + (CDR LIST)) + (RATEXP? T) ;IS EVERY ELEMENT SO FAR A POLY^RAT? + (ONE-RAT? NIL) ;IS THERE AT LEAST ONE POLY^RAT WHICH IS NOT + (FACTOR NIL)) ;A POLY^POLY? + ((OR (NULL LIST) + (NOT RATEXP?)) + (AND RATEXP? ONE-RAT?)) + (SETQ FACTOR (CAR LIST)) + (SETQ RATEXP? (OR (POLYP FACTOR) + (AND (MEXPTP FACTOR) + (POLYP (CADR FACTOR)) + (RATP (CADDR FACTOR) VAR)))) + (SETQ ONE-RAT? (OR ONE-RAT? + (AND (MEXPTP FACTOR) + (RATP (CADDR FACTOR) VAR) + (NOT (POLYP (CADDR FACTOR)))))))) + +(DEFUN EXPFACTOR (N DN VAR) ;ATTEMPS TO EVALUATE LIMIT BY GROUPING + (PROG (HIGHEST-DEG) ; TERMS WITH SIMILAR EXPONENTS. + (LET ((NEW-EXP (EXPPOLY N))) ;EXPPOLY UNRATS EXPON + (SETQ N (CAR NEW-EXP) ;AND RTNS DEG OF EXPONS + HIGHEST-DEG (CDR NEW-EXP))) + (COND ((NULL N) (RETURN NIL))) ;NIL MEANS EXPON IS NOT + (LET ((NEW-EXP (EXPPOLY DN))) ;A RAT FUNC. + (SETQ DN (CAR NEW-EXP) + HIGHEST-DEG (MAX HIGHEST-DEG (CDR NEW-EXP)))) + (COND ((NULL DN) (RETURN NIL))) + (RETURN + (DO ((ANSWER 1.) + (DEGREE HIGHEST-DEG (1- DEGREE)) + (NUMERATOR N) + (DENOMENATOR DN) + (NUMFACTORS NIL) + (DENFACTORS NIL)) + ((= DEGREE -1.) + (M* ANSWER + (LIMIT (M// NUMERATOR DENOMENATOR) + VAR + '$INF + 'THINK))) + (LET ((NEWNUMER-FACTOR (GET-NEWEXP&FACTORS + NUMERATOR + DEGREE + VAR))) + (SETQ NUMERATOR (CAR NEWNUMER-FACTOR) + NUMFACTORS (CDR NEWNUMER-FACTOR))) + (LET ((NEWDENOM-FACTOR (GET-NEWEXP&FACTORS + DENOMENATOR + DEGREE + VAR))) + (SETQ DENOMENATOR (CAR NEWDENOM-FACTOR) + DENFACTORS (CDR NEWDENOM-FACTOR))) + (SETQ ANSWER (LIMIT (M^ (M* ANSWER + (M// NUMFACTORS DENFACTORS)) + (COND ((> DEGREE 0) VAR) + (T 1))) + VAR + '$INF 'think)) + (COND ((EQ ANSWER '$UND) (RETURN NIL)) + ((MEMBER ANSWER '($INF $MINF 0)) ;Really? ZEROA ZEROB? + (RETURN ANSWER)) + (T NIL)))))) + +(DEFUN EXPPOLY (EXP) ;RETURNS EXPRESSION WITH UNRATTED EXPONENTS + (DO ((FACTOR NIL) + (HIGHEST-DEG 0) + (NEW-EXP 1) + (EXP (COND ((MTIMESP EXP) + (CDR EXP)) + (T (NCONS EXP))) + (CDR EXP))) + ((NULL EXP) (CONS NEW-EXP HIGHEST-DEG)) + (SETQ FACTOR (CAR EXP)) + (SETQ NEW-EXP + (M* (COND ((or (NOT (MEXPTP FACTOR)) + (NOT (RATP (CADDR FACTOR) VAR))) + FACTOR) + (T (SETQ HIGHEST-DEG + (MAX HIGHEST-DEG + (RATDEGREE (CADDR FACTOR)))) + (m^ (cadr factor) (unrat (caddr factor))))) + NEW-EXP)))) + +(DEFUN UNRAT (EXP) ;RETURNS UNRATTED EXPRESION + (LET ((N-DN (NUMDEN* EXP))) + (LET ((TEM ($DIVIDE (CAR N-DN) (CDR N-DN)))) + (M+ (CADR TEM) + (M// (CADDR TEM) + (CDR N-DN)))))) + +(DEFUN GET-NEWEXP&FACTORS (EXP DEGREE VAR) ;RETURNS (CONS NEWEXP FACTORS) + (DO ((TERMS (COND ((MTIMESP EXP)(CDR EXP)); SUCH THAT + (T (NCONS EXP))) ; NEWEXP*FACTORS^(VAR^DEGREE) + (CDR TERMS)) ; IS EQUAL TO EXP. + (FACTORS 1) + (NEWEXP 1) + (FACTOR NIL)) + ((NULL TERMS) + (CONS NEWEXP + FACTORS)) + (SETQ FACTOR (CAR TERMS)) + (COND ((NOT (MEXPTP FACTOR)) + (COND ((= DEGREE 0) + (SETQ FACTORS (M* FACTOR FACTORS))) + (T (SETQ NEWEXP (M* FACTOR NEWEXP))))) + ((OR (= DEGREE -1) + (= (RATDEGREE (CADDR FACTOR)) + DEGREE)) + (SETQ FACTORS (M* (M^ (CADR FACTOR) + (LEADING-COEF (CADDR FACTOR))) + FACTORS) + NEWEXP (M* (M^ (CADR FACTOR) + (M- (CADDR FACTOR) + (M* (LEADING-COEF (CADDR FACTOR)) + (M^ VAR DEGREE)))) + NEWEXP))) + (T (SETQ NEWEXP (M* FACTOR NEWEXP)))))) + +(DEFUN LEADING-COEF (RAT) + (RATLIM (M// RAT (M^ VAR (RATDEGREE RAT))))) + +(DEFUN RATDEGREE (RAT) + (LET ((N-DN (NUMDEN* RAT))) + (- (DEG (CAR N-DN)) + (DEG (CDR N-DN))))) + +(DEFUN LIMFACT2 (N D VAR VAL) + (LET ((N1 (REFLECT0 N VAR VAL)) + (D1 (REFLECT0 D VAR VAL))) + (COND ((AND (ALIKE1 N N1) + (ALIKE1 D D1)) + NIL) + (T (LIMIT (m// N1 D1) VAR VAL 'THINK))))) + +(DEFUN REFLECT0 (EXP VAR VAL) + (COND ((ATOM EXP) EXP) + ((AND (EQ (CAAR EXP) 'MFACTORIAL) + (LET ((ARGVAL (LIMIT (CADR EXP) VAR VAL 'THINK))) + (OR (EQ ARGVAL '$MINF) + (AND (NUMBERP ARGVAL) + (> 0 ARGVAL))))) + (REFLECT (CADR EXP))) + (T (CONS (NCONS (CAAR EXP)) + (MAPCAR (FUNCTION + (LAMBDA (TERM) + (REFLECT0 TERM VAR VAL))) + (CDR EXP)))))) + +(DEFUN REFLECT (ARG) + (M* -1. + '$%PI + (M^ (LIST (NCONS 'MFACTORIAL) + (M+ -1. + (M* -1. ARG))) + -1.) + (M^ (LIST (NCONS '%SIN) + (M* '$%PI ARG)) + -1.))) + +(DEFUN LIMFACT (N D) + (let ((ANS ())) + (SETQ N (STIRLING0 N) + D (STIRLING0 D)) + (SETQ ANS ($LIMIT (m// N D) VAR '$INF)) + (COND ((and (atom ans) + (not (MEMQ ANS '(UND IND )))) ans) + ((eq (caar ans) '%limit) ()) + (t ans)))) + +(DEFUN STIRLING0 (E) + (COND ((ATOM E) E) + ((AND (SETQ E (CONS (CAR E) (MAPCAR 'STIRLING0 (CDR E)))) + NIL)) + ((AND (EQ (CAAR E) '%GAMMA) + (AMONG VAR (CADR E))) + (STIRLING (CADR E))) + ((AND (EQ (CAAR E) 'MFACTORIAL) + (AMONG VAR (CADR E))) + (m* (CADR E) (STIRLING (CADR E)))) + (T E))) + +(DEFUN STIRLING (X) + (SUBSTITUTE X '$Z + '((MTIMES SIMP) + ((MEXPT SIMP) 2 ((RAT SIMP) 1 2)) + ((MEXPT SIMP) $%PI ((RAT SIMP) 1 2)) + ((MEXPT SIMP) $Z ((MPLUS SIMP) ((RAT SIMP) -1 2) $Z)) + ((MEXPT SIMP) $%E ((MTIMES SIMP) -1 $Z))))) + +(DEFUN NO-ERR-SUB (V E &AUX ANS) + (LET ((ERRORSW T) (ERRRJFFLAG T) (*ZEXPTSIMP? T)) + ;; (*CATCH '(ERRORSW RATERR) (SRATSIMP (SUBIN V E))) + ;; broken on the Lispm + (SETQ ANS (*CATCH 'ERRORSW + (*CATCH 'RATERR + (SRATSIMP (SUBIN V E))))) + (COND ((NULL ANS) T) ; Ratfun package returns NIL for failure. + (T ANS)))) ; Simplifier returns T for failure. + +(DEFUN SIMPLIMSUBST (V E) + (PROG (ANS) + (SETQ ANS (NO-ERR-SUB (RIDOFAB V) E)) + (COND ((EQ ANS T) + (RETURN NIL)) + ((INVOLVE E '(MFACTORIAL)) NIL) + ((AND (MEMQ V '($ZEROA $ZEROB)) (=0 ANS)) + (SETQ ANS (BEHAVIOR E VAR V)) + (RETURN (COND ((EQUAL ANS 1) '$ZEROA) + ((EQUAL ANS -1) '$ZEROB) + (T ANS)))) + (T (RETURN ANS))))) + +;;;returns (cons numerator denomenator) +(defun numden* (e) + (let ((e (factor (simplify e))) + (numer ()) (denom ())) + (cond ((atom e) + (setq numer (cons e numer))) + ((mtimesp e) + (mapc 'forq (cdr e))) + (t (forq e))) + (cond ((null numer) + (setq numer 1.)) + ((null (cdr numer)) + (setq numer (car numer))) + (t (setq numer (m*l numer)))) + (cond ((null denom) + (setq denom 1.)) + ((null (cdr denom)) + (setq denom (car denom))) + (t (setq denom (m*l denom)))) + (cons (factor numer) (factor denom)))) + +;;;FACTOR OR QUOTIENT +;;;Setq's the special vars numer and denom from numden* +(DEFUN FORQ (E) + (COND ((AND (MEXPTP E) + (null (pos-neg-p (caddr e)))) + (SETQ DENOM (cons (m^ (CADR E) (m* -1. (CADDR E))) DENOM))) + (T (SETQ numer (cons E NUMER))))) + +;;;Predicate to tell whether an expression is pos,zero or neg as var -> val. +;;;returns T if pos,zero. () if negative or don't know. +(defun pos-neg-p (exp) + (let ((ans (limit exp var val 'think))) + (cond ((and (not (memq ans '($und $ind $infinity))) + (equal ($imagpart ans) 0)) + (let ((sign (getsignl ans))) + (cond ((or (equal sign 1) + (equal sign 0)) + t) + ((equal sign -1) nil)))) + (t 'UNKNOWN)))) + +(DECLARE (UNSPECIAL N DN)) + +(SETQ LIMFUNC '(%LOG %SIN %COS %TAN %SINH %COSH %TANH MFACTORIAL + %ASIN %ACOS %ATAN %ASINH %ACOSH %ATANH)) + +(DEFUN EXPP (E) + (COND ((RADICALP E VAR) NIL) + ((MEMQ (CAAR E) LIMFUNC) NIL) + ((SIMPLEXP E) T) + ((DO ((E (CDR E) (CDR E))) + ((NULL E) NIL) + (AND (EXPP (CAR E)) (RETURN T)))))) + +(DEFUN SIMPLEXP (E) + (AND (mexptp e) + (RADICALP (CADR E) VAR) + (AMONG VAR (CADDR E)) + (RADICALP (CADDR E) VAR))) + + +(DEFUN GCPOWER (A B) + ($GCD (GETEXP A) (GETEXP B))) + +(DEFUN GETEXP (EXP) + (COND ((and (MEXPTP EXP) + (free (caddr exp) var) + (eq (ask-integer (caddr exp) '$integer) '$yes)) + (CADDR EXP)) + ((MTIMESP EXP) (GETEXPLIST (CDR EXP))) + (T 1.))) + +(DEFUN GETEXPLIST (LIST) + (COND ((NULL (CDR LIST)) + (GETEXP (CAR LIST))) + (T ($GCD (GETEXP (CAR LIST)) + (GETEXPLIST (CDR LIST)))))) + +(DEFUN LIMROOT (EXP POWER) + (COND ((OR (ATOM EXP) (NOT (MEMQ (CAAR EXP) '(MTIMES MEXPT)))) + (LIMROOT (LIST '(MEXPT) EXP 1) POWER)) ;This is strange-JIM. + ((mexptp exp) (m^ (CADR EXP) + (sRATSIMP (m* (CADDR EXP) (m^ POWER -1.))))) + (T (m*l (MAPCAR #'(LAMBDA (X) + (LIMROOT X POWER)) + (CDR EXP)))))) + +;NUMERATOR AND DENOMENATOR HAVE EXPONENTS WITH GCD OF GCP. +;;; Used to call simplimit but some of the transformations used here +;;; were not stable w.r.t. the simplifier, so try keeping exponent separate +;;; from bas. + +(DEFUN COLEXPT (N DN GCP) + (let ((bas (m* (LIMROOT N GCP) (LIMROOT DN (m* -1. GCP)))) + (expo gcp) + baslim expolim) + (setq baslim (limit bas var val 'think)) + (setq expolim (limit expo var val 'think)) + (SIMPLIMexpt bas expo baslim expolim))) + +;;; This function will transform an expression such that either all logarithms +;;; contain arguments not becoming infinite or are of the form +;;; LOG(LOG( ... LOG(VAR))) This reduction takes place only over the operators +;;; MPLUS, MTIMES, MEXPT, and %LOG. + +(DEFUN LOG-RED-CONTRACT (FACS) + (DO ((L FACS (CDR L)) + (CONSTS ()) + (LOG ())) + ((NULL L) + (IF LOG (CONS (CADR LOG) (M*L CONSTS)) + ())) + (COND ((FREEOF VAR (CAR L)) (PUSH (CAR L) CONSTS)) + ((MLOGP (CAR L)) + (IF (NULL LOG) (SETQ LOG (CAR L)) + (RETURN ()))) + (T (RETURN ()))))) + +(DEFUN LOG-REDUCE (X) + (COND ((ATOM X) X) + ((FREEOF VAR X) X) + ((MPLUSP X) + (DO ((L (CDR X) (CDR L)) + (SUM ()) + (WEAK-LOGS ()) + (STRONG-LOGS ()) + (TEMP)) + ((NULL L) (M+L `(((%LOG) ,(M*L STRONG-LOGS)) + ((%LOG) ,(M*L WEAK-LOGS)) + ,@SUM))) + (SETQ X (LOG-REDUCE (CAR L))) + (COND ((MLOGP X) + (IF (INFINITYP (LIMIT (CADR X) VAR VAL 'THINK)) + (PUSH (CADR X) STRONG-LOGS) + (PUSH (CADR X) WEAK-LOGS))) + ((AND (MTIMESP X) (SETQ TEMP (LOG-RED-CONTRACT (CDR X)))) + (IF (INFINITYP (LIMIT (CAR TEMP) VAR VAL 'THINK)) + (PUSH (M^ (CAR TEMP) (CDR TEMP)) STRONG-LOGS) + (PUSH (M^ (CAR TEMP) (CDR TEMP)) WEAK-LOGS))) + (T (PUSH X SUM))))) + ((MTIMESP X) + (DO ((L (CDR X) (CDR L)) + (ANS 1)) + ((NULL L) ANS) + (SETQ ANS ($EXPAND (M* (LOG-REDUCE (CAR L)) ANS))))) + ((MEXPTP X) (M^T (LOG-REDUCE (CADR X)) (CADDR X))) + ((MLOGP X) + (IFN (INFINITYP (LIMIT (CADR X) VAR VAL 'THINK)) + X + (COND ((EQ (CADR X) VAR) X) + ((MPLUSP (CADR X)) + (LET ((STRONGL (MAXI (CDADR X)))) + (M+ (LOG-REDUCE `((%LOG) ,(CAR STRONGL))) + `((%LOG) ,(M// (CADR X) (CAR STRONGL)))))) + ((MTIMESP (CADR X)) + (DO ((L (CDADR X) (CDR L)) + (ANS 0)) + ((NULL L) ANS) + (SETQ ANS + (M+ (LOG-REDUCE + (SIMPLIFY `((%LOG) ,(LOG-REDUCE (CAR L))))) + ANS)))) + (T (LET ((RED-LOG (SIMPLIFY `((%LOG) + ,(LOG-REDUCE (CADR X)))))) + (IF (ALIKE1 RED-LOG X) + X + (LOG-REDUCE RED-LOG))))))) + (T X))) + + +(defun ratlim (e) + (cond ((memq val '($inf $infinity)) + (setq e (substitute (m^t 'x -1) var e))) + ((eq val '$minf) + (setq e (substitute (m^t -1 (m^t 'x -1)) var e))) + ((eq val '$zerob) + (setq e (substitute (m- 'x) var e))) + ((eq val '$zeroa) + (setq e (substitute 'x var e))) + ((setq e (substitute (m+t 'x val) var e)))) + (let* ((e (let (($ratfac ())) + ($rat (sratsimp e) 'x))) + ((h n . d) e) + (g (genfind h 'x)) + (nd (lodeg n g)) + (dd (lodeg d g))) + (cond ((and + (setq e + (subst var + 'x + (sratsimp + (m// + ($ratdisrep `(,h ,(locoef n g) . 1)) + ($ratdisrep `(,h ,(locoef d g) . 1)))))) + (greaterp nd dd)) + (cond ((not (memq val + '($zerob $zeroa $inf $minf))) + 0) + ((not (equal ($imagpart e) 0)) + 0) + ((null (setq e (getsignl ($realpart e)))) + 0) + ((equal e 1) '$zeroa) + ((equal e -1) '$zerob) + (t 0))) + ((equal nd dd) e) + ((not (memq val '($zerob $zeroa $infinity $inf $minf))) + (*throw 'limit t)) + ((eq val '$infinity) '$infinity) + ((not (equal ($imagpart e) 0)) '$infinity) + ((null (setq e (getsignl ($realpart e)))) '$infinity) + ((equal e 1) '$inf) + ((equal e -1) '$minf) + (t 0)))) + +(DEFUN LODEG (N X) (IF (OR (ATOM N) (NOT (EQ (CAR N) X))) 0 (LOWDEG (CDR N)))) + +(DEFUN LOCOEF (N X) (IF (OR (ATOM N) (NOT (EQ (CAR N) X))) N (CAR (LAST N)))) + + +(defun behavior (exp var val) ; returns either -1, 0, 1. + (if (= behavior-count-now behavior-count) + 0 + (let ((behavior-count-now (1+ behavior-count-now)) pair sign) + (cond ((real-infinityp val) + (setq val (cond ((eq val '$inf) '$zeroa) + ((eq val '$minf) '$zerob))) + (setq exp (sratsimp (subin (m^ var -1) exp))))) + (cond ((eq val '$infinity) 0) ; Needs more hacking for complex. + ((and (mtimesp exp) + (prog2 (setq pair (partition exp var 1)) + (not (mtimesp (cdr pair))))) + (setq sign (getsignl (car pair))) + (if (not (eq (typep sign) 'fixnum)) + 0 + (* sign (behavior (cdr pair) var val)))) + ((and (=0 (no-err-sub (ridofab val) exp)) + (mexptp exp) + (free (caddr exp) var) + (equal (getsignl (caddr exp)) 1)) + (let ((bas (cadr exp)) (expo (caddr exp))) + (behavior-expt bas expo))) + (t (behavior-by-diff exp var val)))))) + +(defun behavior-expt (bas expo) + (let ((behavior (behavior bas var val))) + (COND ((= behavior 1) 1) + ((= behavior 0) 0) + ((eq (ask-integer expo '$integer) '$yes) + (cond ((eq (ask-integer expo '$even) '$yes) 1) + (t behavior))) + ((ratnump expo) + (cond ((evenp (cadr expo)) 1) + ((oddp (caddr expo)) behavior) + (t 0))) + (t 0)))) + +(defun behavior-by-diff (exp var val) + (cond ((not (or (eq val '$zeroa) (eq val '$zerob))) 0) + (t (let ((old-val val) (old-exp exp)) + (setq val (ridofab val)) + (do ((ct 0 (1+ ct)) + (exp (sratsimp (sdiff exp var)) (sratsimp (sdiff exp var))) + (n () (not n)) + (ans ())) + ((> ct 4) 0) ;This do wins by a return. + (setq ans (no-err-sub val exp)) ;Why not do an EVENFN and ODDFN + ;test here. + (cond ((eq ans t) + (return (behavior-numden old-exp var old-val))) + ((=0 ans) ()) ;Do it again. + (t (setq ans (getsignl ans)) + (COND (N (RETURN ANS)) + ((EQUAL ANS 1) + (RETURN (if (EQ old-val '$zeroa) 1 -1))) + ((equal ans -1) + (RETURN (if (EQ old-val '$zeroa) -1 1))) + (t (return 0)))))))))) + +(defun behavior-numden (exp var val) + (let ((num ($num exp)) (denom ($denom exp))) + (cond ((equal denom 1) 0) ;Could be hacked more from here. + (t (let ((num-behav (behavior num var val)) + (denom-behav (behavior denom var val))) + (cond ((or (= num-behav 0) (= denom-behav 0)) 0) + ((= num-behav denom-behav) 1) + (t -1))))))) + +(DEFUN TRY-LHOSPITAL (N D IND) +;;;Make one catch for the whole bunch of lhospital trials. + (let ((ans (LHOSPITAL-catch N D IND))) + (cond ((null ans) ()) + ((not (free-infp ans)) (simpinf ans)) + ((not (free-epsilonp ans)) (simpab ans)) + (t ans)))) + +(DEFUN TRY-LHOSPITAL-QUIT (N D IND) + (let ((ans (lhospital-catch n d ind))) + (cond ((null ans) (*THROW 'LIMIT T)) + ((not (free-infp ans)) (simpinf ans)) + ((not (free-epsilonp ans)) (simpab ans)) + (t ans)))) + +(defun lhospital-catch (n d ind) + (cond ((> 0 lhcount) + (setq lhcount $lhospitallim) + (*throw 'lhospital nil)) + ((equal lhcount $lhospitallim) + (let ((lhcount (m+ lhcount -1))) + (*catch 'lhospital (lhospital n d ind)))) + (t (setq lhcount (m+ lhcount -1)) + (prog1 (lhospital n d ind) + (setq lhcount (m+ lhcount 1)))))) +;If this succeeds then raise LHCOUNT. + +(DEFUN LHOSPITAL (N D IND) + (IF (MTIMESP N) + (SETQ N (m*l (MAPCAR #'(LAMBDA (TERM) (LHSIMP TERM VAR VAL)) + (CDR N))))) + (IF (MTIMESP D) + (SETQ D (m*l (MAPCAR #'(LAMBDA (TERM) (LHSIMP TERM VAR VAL)) + (CDR D))))) + (let (((n . d) (lhop-numden n d)) + const nconst dconst) + (SETQ LHP? (AND (NULL IND) (CONS N D))) + (desetq (nconst . n) (var-or-const n)) + (desetq (dconst . d) (var-or-const d)) + (setq n (sdiff n var) d (sdiff d var)) + (if (or (not (free n '%derivative)) (not (free d '%derivative))) + (*throw 'lhospital ())) + (setq N (expand-trigs (TANSC n) var)) + (setq D (expand-trigs (TANSC d) var)) + (desetq (const . (n . d)) (remove-singularities n d)) + (setq const (m* const (m// nconst dconst))) + (simpinf + (COND (IND (let ((ans (LIMIT2 N D VAR VAL))) + (if ans (m* const ans)))) + (t (let ((ans (LIMIT + (cond ((mplusp n) + (m+l (mapcar #'(lambda (x) + (sratsimp (m// x d))) + (cdr n)))) + (t ($multthru (sratsimp (M// N D))))) + VAR VAL 'think))) + (if ans (m* const ans)))))))) + +;Hueristics for picking the right way to express a LHOSPITAL problem. +(defun lhop-numden (num denom) + (cond ((let ((log-num (involve num '(%log)))) + (cond ((null log-num) ()) + ((< (num-of-logs (factor (sratsimp (sdiff (m^ num -1) var)))) + (num-of-logs (factor (sratsimp (sdiff num var))))) + (psetq num (M^ denom -1) denom (m^ num -1))) + (t t)))) + ((let ((log-denom (involve denom '(%log)))) + (cond ((null log-denom) ()) + ((< (num-of-logs (sratsimp (sdiff (m^ denom -1) var))) + (num-of-logs (sratsimp (sdiff denom var)))) + (psetq denom (M^ num -1) num (m^ denom -1))) + (t t)))) + ((let ((exp-num (%einvolve num))) + (cond (exp-num (cond ((%e-right-placep exp-num) t) + (t (psetq num (m^ denom -1) + denom (m^ num -1))))) + (t ())))) + ((let ((exp-den (%einvolve denom))) + (cond (exp-den (cond ((%e-right-placep exp-den) t) + (t (psetq num (m^ denom -1) + denom (m^ num -1))))) + (t ())))) + ((let ((scnum (involve num '(%sin)))) + (cond (scnum (cond ((trig-right-placep '%sin scnum) t) + (t (psetq num (m^ denom -1) + denom (m^ num -1))))) + (t ())))) + ((let ((scden (involve denom '(%sin)))) + (cond (scden (cond ((trig-right-placep '%sin scden) t) + (t (psetq num (m^ denom -1) + denom (m^ num -1))))) + (t ())))) + ((or (oscip num) (oscip denom))) + ((or (polyinx num var ()) + (polyinx denom var ()))) + ((or (polyinx (m^ num -1) var ()) + (polyinx (m^ denom -1) var ())) + (psetq num (m^ denom -1) denom (m^ num -1))) + ((frac num) + (psetq num (m^ denom -1) denom (m^ num -1)))) + (cons num denom)) + +;i don't know what to do here for some cases, may have to be refined. +(defun num-of-logs (exp) + (cond ((mapatom exp) 0) + ((equal (caar exp) '%log) + (m+ 1 (num-of-log-l (cdr exp)))) + ((and (mexptp exp) (mnump (caddr exp))) + (m* (simplify `((mabs) ,(caddr exp))) + (num-of-logs (cadr exp)))) + (t (num-of-log-l (cdr exp))))) + +(defun num-of-log-l (list) + (do ((temp list (cdr temp)) (ans 0)) + ((null temp) ans) + (setq ans (m+ ans (num-of-logs (car temp)))))) + +(defun %e-right-placep (%e-arg) + (let ((%e-arg-diff (sdiff %e-arg var))) + (cond + ((free %e-arg-diff var)) ;simple cases + ((or (and (mexptp denom) + (equal (cadr denom) -1)) + (polyinx (m^ denom -1) var ())) ()) + ((let ((%e-arg-diff-lim (ridofab (limit %e-arg-diff var val 'think))) + (%e-arg-exp-lim (ridofab (limit (m^ '$%e %e-arg) var val 'think)))) + (cond ((equal %e-arg-diff-lim %e-arg-exp-lim) t) + ((and (mnump %e-arg-diff-lim) (mnump %e-arg-exp-lim)) t) + (t ()))))))) + +(defun trig-right-placep (trig-type arg) + (let ((arglim (ridofab (limit arg var val 'think))) + (triglim (ridofab (limit `((,trig-type) ,arg) var val 'think)))) + (cond ((and (equal arglim 0) (equal triglim 0)) t) + ((and (infinityp arglim) (infinityp triglim)) t) + (t ())))) + +;Takes a numerator and a denominator. If they tries all combinations of +;products to try and make a simpler set of subproblems for LHOSPITAL. +(defun remove-singularities (numer denom) + (cond + ((or (null numer) (null denom) + (atom numer) (atom denom) + (not (mtimesp numer)) ;Leave this here for a while. + (not (mtimesp denom))) + (cons 1 (cons numer denom))) + (t + (let (((num-consts . num-vars) (var-or-const numer)) + ((denom-consts . denom-vars) (var-or-const denom)) + (const 1)) + (if (not (mtimesp num-vars)) + (setq num-vars (list num-vars)) + (setq num-vars (cdr num-vars))) + (if (not (mtimesp denom-vars)) + (setq denom-vars (list denom-vars)) + (setq denom-vars (cdr denom-vars))) + (do ((nl num-vars (cdr nl)) + (num-list (append num-vars ())) + (den-list denom-vars den-list-temp) + (den-list-temp (append denom-vars ()))) + ((null nl) (cons (m* const (m// num-consts denom-consts)) + (cons (m*l num-list) (m*l den-list-temp)))) + (do ((dl den-list (cdr dl))) + ((null dl) t) + (cond ((or (%einvolve (car nl)) + (%einvolve (car nl))) t) + (t (let ((lim (*catch 'limit + (simpinf + (simpab (limit (m// (car nl) (car dl)) + var val 'think)))))) + (cond ((or (eq lim t) (eq lim ()) + (equal (ridofab lim) 0) + (infinityp lim) + (not (free lim '$inf)) + (not (free lim '$minf)) + (not (free lim '$infinity)) + (not (free lim '$ind)) + (not (free lim '$und))) + ()) + (t (setq const (m* lim const)) + (setq num-list (delete (car nl) + num-list 1)) + (setq den-list-temp + (delete (car dl) + den-list-temp 1)) + (return t)))))))))))) + +(defun var-or-const (expr) + (setq expr ($factor expr)) + (cond ((atom expr) + (cond ((eq expr var) (cons 1 expr)) + (t (cons expr 1)))) + ((free expr var) (cons expr 1)) + ((mtimesp expr) + (do ((l (cdr expr) (cdr l)) + (const 1) (varl 1) (lim ())) + ((null l) (cons const varl)) + (cond ((free (car l) var) + (setq const (m* (car l) const))) + ((and (setq lim (limit (car l) var val 'think)) + (free-infp lim) + (not (equal (ridofab lim) 0))) + (setq const (m* lim const))) + (t (setq varl (m* (car l) varl)))))) + (t (cons 1 expr)))) + +(DEFUN LHSIMP (TERM VAR VAL) + (COND ((ATOM TERM) TERM) + ((NOT (EQ (CAAR TERM) 'MFACTORIAL)) TERM) + (T + (LET ((TERM-VALUE (LIMIT TERM VAR VAL 'THINK))) + (COND ((NOT (MEMQ TERM-VALUE + '($INF $MINF $UND $IND $INFINITY $ZEROA $ZEROB))) + TERM-VALUE) + (T TERM)))))) + +(DEFUN BYLOG (EXPO BAS) + (SIMPLIMEXPT '$%E + (SETQ BAS + (TRY-LHOSPITAL-QUIT (simplify `((%log) ,(TANSC BAS))) + (m^ expo -1) + NIL)) + '$%E BAS)) + +(DEFUN SIMPLIMEXPT (BAS EXPO BL EL) + (COND + ((OR (EQ BL '$UND) (EQ EL '$UND)) '$UND) + ((ZEROP2 BL) + (COND ((EQ EL '$INF) (IF (EQ BL '$ZEROA) BL 0)) + ((EQ EL '$MINF) (IF (EQ BL '$ZEROA) '$INF '$INFINITY)) + ((eq EL '$IND) '$ind) + ((eq el '$INFINITY) '$UND) + ((ZEROP2 EL) (BYLOG EXPO BAS)) +;;;Needs more code here for limit(x^(-a),x,0,plus) or minus. + ((AND (NOT (MNUMP EL)) (EQ BL '$ZEROB)) (*THROW 'LIMIT t)) + (T (COND ((EQUAL (GETSIGNL EL) -1) + (COND ((EQ BL '$ZEROA) '$INF) + ((EQ BL '$ZEROB) + (COND ((EVEN1 EL) '$INF) + ((eq (ask-integer el '$integer) '$yes) + (cond ((eq (ask-integer el '$even) '$yes) + '$inf) + (t '$minf))))) ;Gotta be ODD. + (T (SETQ BAS (BEHAVIOR BAS VAR VAL)) + (COND ((EQUAL BAS 1) '$INF) + ((EQUAL BAS -1) '$MINF) + (t (*throw 'limit t)))))) + ((AND (MNUMP EL) + (MEMQ BL '($ZEROA $ZEROB))) + (COND ((EVEN1 EL) '$ZEROA) + ((AND (EQ BL '$ZEROB) + (RATNUMP EL) + (EVENP (CADDR EL))) 0) + (T BL))) + ((AND (EQUAL (getsignl el) 1) + (EQ BL '$ZEROA)) BL) + (T 0))))) + ((EQ BL '$INFINITY) + (COND ((ZEROP2 EL) (BYLOG EXPO BAS)) + ((EQ EL '$MINF) 0) + ((EQ EL '$INF) '$INFINITY) + ((MEMQ EL '($INFINITY $IND)) '$UND) + ((EQUAL (SETQ EL (GETSIGNl EL)) 1) '$INFINITY) + ((NULL EL) '$UND) + ((EQUAL EL -1) 0))) + ((EQ BL '$INF) + (COND ((EQ EL '$INF) '$INF) + ((EQUAL EL '$MINF) 0) + ((ZEROP2 EL) (BYLOG EXPO BAS)) + ((MEMQ EL '($INFINITY $IND)) '$UND) + (T (COND ((ZEROP (GETSIGNl EL)) 1) + ((RATGREATERP 0 EL) '$ZEROA) + (T '$INF))))) + ((EQ BL '$MINF) + (COND ((ZEROP2 EL) (bylog expo bas)) + ((EQ EL '$INF) '$UND) + ((EQUAL EL '$MINF) 0) +;;;Why not generalize this. We can ask about the number. -Jim 2/23/81 + ((MNUMP EL) (COND ((MNEGP EL) + (COND ((EVEN1 EL) '$ZEROA) + (T (cond + ((eq (ask-integer el '$integer) '$yes) + (cond ((eq (ask-integer el '$even) + '$yes) '$ZEROA) + (t '$zerob))) + (t 0))))) + (T (COND + ((EVEN1 EL) '$INF) + ((eq (ask-integer el '$integer) '$yes) + (cond ((eq (ask-integer el '$even) '$yes) + '$inf) + (t '$minf))) + (T '$infinity))))) + (LOGINPROD? (*THROW 'LIP? 'LIP!)) + (T '$UND))) + ((EQUAL (SIMPLIFY (RATDISREP (RIDOFAB BL))) 1) + (IF (INFINITYP EL) (BYLOG EXPO BAS) 1)) + ((AND (EQUAL (RIDOFAB BL) -1) + (INFINITYP EL)) '$IND) ;LB + ((EQ BL '$IND) (COND ((OR (ZEROP2 EL) (INFINITYP EL)) '$UND) + ((NOT (EQUAL (GETSIGNl EL) -1)) '$IND) + (T '$UND))) + ((EQ EL '$INF) (COND ((ABLESS1 BL) + (COND ((EQUAL (GETSIGNl BL) 1) '$ZEROA) + (T 0))) + ((EQUAL (GETSIGNL BL) -1) '$INFINITY) + (T '$INF))) + ((EQ EL '$MINF) (COND ((NOT (ABLESS1 BL)) + (COND ((EQUAL (GETSIGNl BL) 1) '$ZEROA) + (T 0))) + ((RATGREATERP 0 BL) '$INFINITY) + (T '$INF))) + ((EQ EL '$INFINITY) + (if (equal val '$infinity) + '$und ;Not enough info to do anything. + (let (((real-el . imag-el) (trisplit expo))) + (setq real-el (limit real-el var origval nil)) + (COND ((EQ real-el '$MINF) 0) + ((and (EQ real-el '$INF) + (not (equal (ridofab (limit imag-el var origval nil)) + 0))) '$INFINITY) + (T '$IND))))) + + ((EQ EL '$IND) '$IND) + ((ZEROP2 EL) 1) + (T (m^ BL EL)))) + +(defun even1 (x) + (cond ((numberp x) (and (fixp x) (evenp x))) + ((and (mnump x) (evenp (cadr x)))))) + +(DEFUN ABLESS1 (BL) + (SETQ BL (NMR BL)) + (COND ((MNUMP BL) + (AND (RATGREATERP 1. BL) (RATGREATERP BL -1.))) + (T (EQUAL (GETSIGNl (M1- `((mabs) ,BL))) -1.)))) + +(DEFUN SIMPLIMIT (EXP VAR VAL) + (COND + ((EQ VAR EXP) VAL) + ((OR (ATOM EXP) (MNUMP EXP)) EXP) + ((AND (NOT (INFINITYP VAL)) + (NOT (AMONGL '(%SIN %COS %TAN %ATANH %COSH %SINH %TANH MFACTORIAL) + EXP)) + (NOT (inf-typep exp)) + (SIMPLIMSUBST VAL EXP))) + ((eq (caar exp) '%limit) (*throw 'limit t)) + ((mplusp exp) (SIMPLIMPLUS EXP)) + ((mtimesp exp) (SIMPLIMTIMES (CDR EXP))) + ((mexptp exp) (SIMPLIMEXPT (CADR EXP) (CADDR EXP) + (LIMIT (CADR EXP) VAR VAL 'THINK) + (LIMIT (CADDR EXP) VAR VAL 'THINK))) + ((mlogp exp) (SIMPLIMLN (CADR EXP))) + ((MEMQ (CAAR EXP) '(%SIN %COS)) + (SIMPLIMSC EXP (CAAR EXP) (LIMIT (CADR EXP) VAR VAL 'THINK))) + ((EQ (CAAR EXP) '%TAN) (SIMPLIM%TAN (CADR EXP))) + ((EQ (CAAR EXP) '%ATAN) (SIMPLIM%ATAN (LIMIT (CADR EXP) VAR VAL 'THINK))) + ((MEMQ (CAAR EXP) '(%SINH %COSH)) + (SIMPLIMSCH (CAAR EXP) (LIMIT (CADR EXP) VAR VAL 'THINK))) + ((EQ (CAAR EXP) 'MFACTORIAL) + (SIMPLIMFACT (CADR EXP) VAR VAL (LIMIT (CADR EXP) VAR VAL 'THINK))) + ((MEMQ (CAAR EXP) '(%ERF %TANH)) + (SIMPLIM%ERF-%TANH (CAAR EXP) (CADR EXP))) + ((MEMQ (CAAR EXP) '(%ACOS %ASIN)) + (SIMPLIM%ASIN-%ACOS (CAAR EXP) (LIMIT (CADR EXP) VAR VAL 'THINK))) + ((EQ (CAAR EXP) '%ATANH) + (SIMPLIM%ATANH (LIMIT (CADR EXP) VAR VAL 'THINK))) + ((EQ (CAAR EXP) '%ACOSH) + (SIMPLIM%ACOSH (LIMIT (CADR EXP) VAR VAL 'THINK))) + ((EQ (CAAR EXP) '%ASINH) + (SIMPLIM%ASINH (LIMIT (CADR EXP) VAR VAL 'THINK))) + ((and (eq (caar exp) 'mqapply) + (eq (subfunname exp) '$li)) + (simplim$li (subfunsubs exp) (subfunargs exp) val)) + ((and (eq (caar exp) 'mqapply) + (eq (subfunname exp) '$psi)) + (simplim$psi (subfunsubs exp) (subfunargs exp) val)) + ((and (eq (caar exp) var) + (memq 'array (car exp)) + (andmapc #'(lambda (sub-exp) + (free sub-exp var)) + (cdr exp))) + exp) ;LIMIT(B[I],B,INF); -> B[I] + (T (if $limsubst + (let ((head (cond ((memq 'array (car exp)) + (list (caar exp) 'array)) + (t (list (caar exp)))))) + (SIMPLIFY (CONS head + (MAPCAR #'(LAMBDA (A) + (LIMIT A VAR VAL 'THINK)) + (CDR EXP))))))))) + +(DEFUN LIMINV (E) + (setq e (RESIMPLIFY (SUBST (M// 1 VAR) VAR E))) + (let ((new-val (cond ((eq val '$zeroa) '$inf) + ((eq val '$zerob) '$minf)))) + (if new-val (let ((preserve-direction t)) + ($limit e var new-val)) (*throw 'limit t)))) + +(DEFUN SIMPLIMTIMES (EXP) + (PROG (SIGN PROD Y NUM DENOM FLAG ZF FLAG2 EXP1) + (SETQ PROD (SETQ NUM (SETQ DENOM 1)) EXP1 EXP) +LOOP + (SETQ Y (LET ((LOGINPROD? (INVOLVE (CAR EXP1) '(%LOG)))) + (*CATCH 'LIP? (LIMIT (CAR EXP1) VAR VAL 'THINK)))) + (COND ((EQ Y 'LIP!) (RETURN (liminv (cons '(mtimes simp) exp)))) + ((ZEROP2 Y) + (SETQ NUM (M* NUM (CAR EXP1))) + (COND ((EQ Y '$ZEROA) + (COND (ZF NIL) + (T (SETQ ZF 1)))) + ((EQ Y '$ZEROB) + (COND (ZF (SETQ ZF (TIMES -1 ZF))) + (T (SETQ ZF -1)))))) + ((NOT (MEMQ Y '($INF $MINF $INFINITY $IND $UND))) + (SETQ PROD (M* PROD Y))) + ((EQ Y '$UND) + (RETURN '$UND)) + ((EQ Y '$IND) + (SETQ FLAG2 T)) + (T (SETQ DENOM (M* DENOM (CAR EXP1))) + (COND ((EQ Y '$INFINITY) (SETQ FLAG Y)) + ((EQ FLAG '$INFINITY) NIL) + ((NULL FLAG) (SETQ FLAG Y)) + ((EQ Y FLAG) (SETQ FLAG '$INF)) + (T (SETQ FLAG '$MINF))))) + (SETQ EXP1 (CDR EXP1)) + (COND ((NULL EXP1) + (COND ((AND (EQUAL NUM 1) (EQUAL DENOM 1)) + (RETURN (IF FLAG2 '$IND PROD))) + ((EQUAL DENOM 1) + (COND ((NULL ZF) (RETURN 0)) + (T (SETQ SIGN (GETSIGNL PROD)) + (COND ((eq sign 'complex) (RETURN 0)) + (SIGN (SETQ ZF (TIMES ZF SIGN)) + (RETURN + (COND ((EQUAL ZF 1) '$ZEROA) + ((EQUAL ZF -1) '$ZEROB) + (T 0)))) + (T (RETURN 0)))))) + ((EQUAL NUM 1) + (RETURN (COND (FLAG2 '$UND) + ((or (EQUAL (SETQ SIGN (GETSIGNL PROD)) 0) + (null sign)) + (*throw 'limit t)) + ((EQUAL SIGN -1) + (COND ((EQ FLAG '$INF) '$MINF) + ((EQ FLAG '$INFINITY) FLAG) + (T '$INF))) + (T FLAG)))) + (T (GO DOWN)))) + (T (GO LOOP))) + DOWN + (COND ((OR (NOT (AMONG VAR DENOM)) + (NOT (AMONG VAR NUM))) + (*THROW 'LIMIT t))) + (RETURN (let ((ans (LIMIT2 NUM (M^ DENOM -1) VAR VAL))) + (if ans + (SIMPLIMTIMES (LIST PROD ans)) + (*throw 'limit t)))))) + +;;;PUT CODE HERE TO ELIMINATE FAKE SINGULARITIES?? + +(defun simplimplus (exp) + (cond ((memalike exp simplimplus-problems) + (*throw 'limit t)) + (t (unwind-protect + (progn (push exp simplimplus-problems) + (let ((ans (*catch 'limit (simplimplus1 exp)))) + (cond ((or (eq ans ()) + (eq ans t) + (among '%limit ans)) + (let ((new-exp (sratsimp exp))) + (cond ((not (alike1 exp new-exp)) + (setq ans + (limit new-exp var val 'think)))) + (cond ((or (eq ans ()) + (eq ans t)) + (*throw 'limit t)) + (t ans)))) + (t ans)))) + (pop simplimplus-problems))))) + +(DEFUN SIMPLIMPLUS1 (EXP) + (PROG (SUM Y INFL INFINITYL MINFL INDL) + (SETQ SUM 0.) + (DO ((EXP (CDR EXP) (CDR EXP)) (F)) + ((OR Y (NULL EXP)) NIL) + (SETQ F (LIMIT (CAR EXP) VAR VAL 'THINK)) + (COND ((EQ F '$UND) (SETQ Y T)) + ((NOT (MEMQ F '($INF $MINF $INFINITY $IND))) + (SETQ SUM (M+ SUM F))) + ((EQ F '$IND) (PUSH (CAR EXP) INDL)) + (infinityl (*throw 'limit t)) +;;;Don't know what to do with an '$infinity and an $inf or $minf + ((EQ F '$INF) (PUSH (CAR EXP) INFL)) + ((EQ F '$MINF) (PUSH (CAR EXP) MINFL)) + ((eq f '$infinity) + (cond ((or infl minfl) + (*throw 'limit t)) + (t (push (car exp) infinityl)))))) + (COND (Y (RETURN '$UND)) + ((NOT (OR INFL MINFL INDL INFINITYL)) + (RETURN (COND ((ATOM SUM) SUM) + ((or (not (free sum '$zeroa)) + (not (free sum '$zerob))) + (simpab SUM)) + (T SUM)))) + (t (cond ((null infinityl) + (cond (INFL (COND ((NULL MINFL) (RETURN '$INF)) + (T (GO OON)))) + (MINFL (RETURN '$MINF)) + (T (RETURN '$IND)))) + (t (setq infl (append infl infinityl)))))) + +OON (SETQ Y (M+L (APPEND MINFL INFL))) + (cond ((alike1 exp (setq y (sratsimp (log-reduce (hyperex y))))) + (cond ((not (infinityp val)) + (SETQ INFL (CNV INFL VAL)) ;THIS IS HORRIBLE!!!! + (SETQ MINFL (CNV MINFL VAL)))) + (let ((val '$inf)) + (COND ((ANDMAPC (FUNCTION (LAMBDA (J) (RADICALP J VAR))) + (APPEND INFL MINFL)) + (SETQ Y (RHEUR INFL MINFL))) + (T (SETQ Y (SHEUR INFL MINFL)))))) + (t (SETQ Y (LIMIT Y VAR VAL 'THINK)))) + (COND ((or (eq y ()) + (eq y t)) (return ())) + ((INFINITYP Y) (RETURN Y)) + (t (RETURN (M+ SUM Y)))))) + +(DEFUN SHEUR0 (N D) + (let ((orig-n n)) + (COND ((/#ALIKE N D) 1) + ((and (free n var) + (free d var)) + (m// n d)) + (T (SETQ N (CPA N D NIL)) + (COND ((EQUAL N 1.) + (cond ((oscip orig-n) '$UND) + (t '$inf))) + ((EQUAL N -1.) '$ZEROA) + ((EQUAL N 0.) (m// orig-n d))))))) + + +;;;L1 is a list of INF's and L2 is a list of MINF's. Added together +;;;it is indeterminate. +(DEFUN SHEUR (L1 L2) + (LET ((TERM (SHEUR1 L1 L2))) + (COND ((EQUAL TERM '$INF) '$INF) + ((EQUAL TERM '$MINF) '$MINF) + (t (let ((new-num (m+l (mapcar #'(lambda (num-term) + (m// num-term (car l1))) + (append l1 l2))))) + (cond ((limit2 new-num (m// 1 (car l1)) var val)))))))) + +;To chicken to throw this code out yet. +(comment ((not (alike1 term (m+ (m+l l1) (m+l l2)))) + (LET ((LIM1 (LIMIT1 TERM VAR VAL)) + (LIM2 (M+L (MAPCAR #'(LAMBDA (J) + (LIMIT1 (M// J TERM) VAR VAL)) + `(,@L1 ,@L2))))) + (COND + ((OR (AND (EQUAL LIM1 0.) + (MEMQ LIM2 '($INF $MINF $UND $IND))) + (AND (EQUAL LIM2 0.) + (MEMQ LIM1 '($INF $MINF $UND $IND)))) + (limit2 ($RATSIMP (M// (M+ (M+L L1) (M+L L2)) TERM)) + (M^ TERM -1) var val)) + (T (SIMPLIMTIMES `(,LIM1 ,LIM2)))))) + (t (*throw 'limit t))) + +(DEFUN FRAC (EXP) + (COND ((ATOM EXP) NIL) + (T (SETQ EXP (NFORMAT EXP)) + (COND ((AND (EQ (CAAR EXP) 'MQUOTIENT) + (AMONG VAR (CADDR EXP))) + T))))) + +(DEFUN ZEROP2 (Z) (=0 (RIDOFAB Z))) + +(DEFUN RAISE (A) (M+ A '$ZEROA)) + +(DEFUN LOWER (A) (M+ A '$ZEROB)) + +(DEFUN SINCOSHK (EXP1 L SC) + (COND ((EQUAL L 1) (LOWER L)) + ((EQUAL L -1) (RAISE L)) + ((AMONG SC L) L) + ((MEMQ VAL '($ZEROA $ZEROB)) (SPANGSIDE EXP1 L)) + (T L))) + +(DEFUN SPANGSIDE (E L) + (SETQ E (BEHAVIOR E VAR VAL)) + (COND ((EQUAL E 1) (RAISE L)) + ((EQUAL E -1) (LOWER L)) + (T L))) + +(DEFUN RIDOFAB (E) + (IF (AMONG '$ZEROA E) (SETQ E (SUBSTITUTE 0 '$ZEROA E))) + (IF (AMONG '$ZEROB E) (SETQ E (SUBSTITUTE 0 '$ZEROB E))) + E) + +(DEFUN SIMPLERD (EXP) + (AND (mexptp exp) + (OR (AND RD* (NOT (AMONG VAR (CADDR EXP)))) + (MNUMP (CADDR EXP))) + (POLYP (CADR EXP)))) + +(DEFUN BRANCH1 (EXP VAL) + (COND ((POLYP EXP) NIL) + ((SIMPLERD EXP) (ZEROP2 (SUBIN VAL (CADR EXP)))) + (T (APPLY 'OR + (MAPCAR (FUNCTION (LAMBDA (J) (BRANCH1 J VAL))) + (CDR EXP)))))) + +(DEFUN BRANCH (EXP VAL) + (COND ((POLYP EXP) NIL) + ((OR (SIMPLERD EXP) (mtimesp exp)) + (BRANCH1 EXP VAL)) + ((mplusp exp) (ANDMAPC #'(LAMBDA (J) + (BRANCH J VAL)) + (CDR EXP))))) + +(DEFUN SER0 (E N D VAL) + (COND ((AND (BRANCH N VAL) (BRANCH D VAL)) + (SETQ NN* NIL) + (SETQ N (SER1 N)) + (SETQ D (SER1 D)) +;;;NN* gets set by POFX, called by SER1, to get a list of exponents. + (SETQ NN* (RATMIN NN*)) + (SETQ N (sratsimp (m^ n (m^ var nn*)))) + (SETQ D (sratsimp (m^ d (m^ var nn*)))) + (COND ((MEMQ VAL '($ZEROA $ZEROB)) NIL) + (T (SETQ VAL 0.))) + (RADLIM E N D)) + (T (TRY-LHOSPITAL-QUIT N D NIL)))) + +(DEFUN RHEUR (L1 L2) + (PROG (ANS M1 M2) + (SETQ M1 (MAPCAR (FUNCTION ASYMREDU) L1)) + (SETQ M2 (MAPCAR (FUNCTION ASYMREDU) L2)) + (SETQ ANS (m+l (APPEND M1 M2))) + (COND ((RPTROUBLE (m+l (APPEND L1 L2))) + (RETURN (LIMIT (SIMPLIFY (RDSGET (m+l (APPEND L1 L2)))) + VAR + VAL + NIL))) + ((mplusp ans) (RETURN (SHEUR M1 M2))) + (T (RETURN (LIMIT ANS VAR VAL T)))))) + +(DEFUN RPTROUBLE (RP) + (NOT (EQUAL (RDDEG RP NIL) (RDDEG (ASYMREDU RP) NIL)))) + +(DEFUN RADICALP (EXP VAR) + (COND ((POLYinx EXp var ())) + ((mexptp exp) (COND ((EQUAL (CADDR EXP) -1.) + (RADICALP (CADR EXP) VAR)) + ((SIMPLERD EXP)))) + ((MEMQ (CAAR EXP) '(MPLUS MTIMES)) + (ANDMAPC (FUNCTION (LAMBDA (J) (RADICALP J VAR))) + (CDR EXP))))) + +(DEFUN INVOLVE (E NN*) + (COND ((ATOM E) NIL) + ((MNUMP E) NIL) + ((AND (MEMQ (CAAR E) NN*) (AMONG VAR (CADR E))) (CADR E)) + (T (ORMAPC (FUNCTION (LAMBDA (J) (INVOLVE J NN*))) + (CDR E))))) + +(DEFUN NOTINVOLVE (EXP NN*) + (COND ((ATOM EXP) T) + ((MNUMP EXP) T) + ((MEMQ (CAAR EXP) NN*) (NOT (AMONG VAR (CADR EXP)))) + ((ANDMAPC (FUNCTION (LAMBDA (J) (NOTINVOLVE J NN*))) + (CDR EXP))))) + +(DEFUN SHEUR1 (L1 L2) + (PROG (ANS) + (SETQ L1 (CAR (MAXI L1))) + (SETQ L2 (CAR (MAXI L2))) + (SETQ ANS (CPA L1 L2 T)) + (RETURN (COND ((=0 ANS) (m+ l1 l2)) + ((EQUAL ANS 1.) '$INF) + (T '$MINF))))) + +(DEFUN ZERO-LIM (CPA-LIST) + (DO ((L CPA-LIST (CDR L))) + ((NULL L) ()) + (AND (EQ (CAAR L) 'GEN) + (ZEROP2 (LIMIT (CADAR L) VAR VAL 'THINK)) + (RETURN T)))) + +(DEFUN CPA (R1 R2 FLAG) + (let ((t1 r1) + (t2 r2)) + (COND ((ALIKE1 T1 T2) 0.) + ((FREE T1 VAR) + (COND ((FREE T2 VAR) 0.) + (T (LET ((LIM-ANS (LIMIT1 T2 VAR VAL))) + (COND ((NOT (MEMQ LIM-ANS '($INF $MINF $UND $IND))) 0.) + (T -1.)))))) + ((FREE T2 VAR) + (LET ((LIM-ANS (LIMIT1 T1 VAR VAL))) + (COND ((NOT (MEMQ LIM-ANS '($INF $MINF $UND $IND))) 0.) + (T 1.)))) + (t (cond ((MTIMESP T1) (SETQ T1 (CDR T1))) + (T (SETQ T1 (LIST T1)))) + (COND ((MTIMESP T2) (SETQ T2 (CDR T2))) + (T (SETQ T2 (LIST T2)))) + (SETQ T1 (MAPCAR (FUNCTION ISTRENGTH) T1)) + (SETQ T2 (MAPCAR (FUNCTION ISTRENGTH) T2)) + (let ((ans (ISMAX T1)) + (D (ISMAX T2))) + (COND ((or (null ans) (null d) + (EQ (CAR ANS) 'GEN) (eq (car d) 'gen)) 0.)) + (if (EQ (CAR ANS) 'VAR) (SETQ ANS (ADD-UP-DEG T1))) + (if (EQ (CAR D) 'VAR) (SETQ D (ADD-UP-DEG T2))) + ;Cant just just compare dominating terms if there are indeterm- + ;inates present; e.g. X-X^2*LOG(1+1/X). So check for this. + (cond ((OR (ZERO-LIM T1) + (ZERO-LIM T2)) + (cpa-indeterm ans d t1 t2 flag)) + ((ISGREATERP ANS D) 1.) + ((ISGREATERP D ANS) -1.) + (t 0))))))) + +(defun cpa-indeterm (ans d t1 t2 flag) + (cond ((NOT (EQ (CAR ANS) 'VAR)) + (SETQ ANS (GATHER ANS T1) D (GATHER D T2)))) + (let ((*INDICATOR (AND (EQ (CAR ANS) 'EXP) + FLAG)) + (test ())) + (SETQ TEST (CPA1 ANS D)) + (COND ((AND (ZEROP1 TEST) + (OR (EQUAL ($RADCAN (M// (CADR ANS) (CADR D))) 1.) + (AND (POLYP (CADR ANS)) + (POLYP (CADR D)) + (EQUAL (LIMIT (M// (CADR ANS) (CADR D)) VAR '$INF 'think) + 1.)))) + (let ((new-term1 (m// t1 (cadr ans))) + (new-term2 (m// t2 (cadr d)))) + (CPA new-term1 new-term2 FLAG))) + (t 0)))) + +(DEFUN ADD-UP-DEG (STRENGTHL) + (DO ((STL STRENGTHL (CDR STL)) + (POXL) + (DEGL)) + ((NULL STL) (LIST 'VAR (M*L POXL) (M+L DEGL))) + (cond ((EQ (CAAR STL) 'VAR) + (push (cadar stl) poxl) + (push (caddar stl) degl))))) + +(DEFUN CPA1 (P1 P2) + (PROG (FLAG S1 S2) + (COND ((EQ (CAR P1) 'GEN) (RETURN 0.))) + (SETQ FLAG (CAR P1)) + (SETQ P1 (CADR P1)) + (SETQ P2 (CADR P2)) + (COND + ((EQ FLAG 'VAR) + (SETQ S1 (ISTRENGTH P1)) + (SETQ S2 (ISTRENGTH P2)) + (RETURN + (COND + ((ISGREATERP S1 S2) 1.) + ((ISGREATERP S2 S1) -1.) + (*INDICATOR + (SETQ *INDICATOR NIL) + (COND + ((AND (POLY? P1 VAR) (POLY? P2 VAR)) + (SETQ P1 (M- P1 P2)) + (COND ((ZEROP1 P1) 0.) + (T (GETSIGNl (HOT-COEF P1))))) + (T + (SETQ S1 + (RHEUR (LIST P1) + (LIST (m*t -1 P2)))) + (COND ((ZEROP2 S1) 0.) + ((RATGREATERP S1 0.) 1.) + (T -1.))))) + (T 0.)))) + ((EQ FLAG 'EXP) + (SETQ P1 (CADDR P1)) + (SETQ P2 (CADDR P2)) + (COND ((AND (POLY? P1 VAR) (POLY? P2 VAR)) + (SETQ P1 (M- P1 P2)) + (RETURN (COND ((OR (ZEROP1 P1) + (NOT (AMONG VAR P1))) + 0.) + (T (GETSIGNl (HOT-COEF P1)))))) + ((AND (RADICALP P1 VAR) (RADICALP P2 VAR)) + (SETQ S1 + (RHEUR (LIST P1) + (LIST (m*t -1 P2)))) + (RETURN (COND ((EQ S1 '$INF) 1.) + ((EQ S1 '$MINF) -1.) + ((MNUMP S1) + (COND ((RATGREATERP S1 0.) 1.) + ((RATGREATERP 0. S1) -1.) + (T 0.))) + (T 0.)))) + (T (RETURN (CPA P1 P2 T))))) + ((EQ FLAG 'LOG) + (SETQ P1 (TRY-LHOSPITAL (ASYMREDU P1) (ASYMREDU P2) NIL)) + (RETURN (COND ((ZEROP2 P1) -1.) + ((REAL-INFINITYP P1) 1.) + (T 0.))))))) + +(SETQ *LIMORDER '(NUM LOG VAR EXP FACT GEN)) + +;;;EXPRESSIONS TO ISGREATERP ARE OF THE FOLLOWING FORMS +;;; ("VAR" POLY DEG) +;;; ("EXP" %E^EXP) +;;; ("LOG" LOG(EXP)) +;;; ("FACT" ) +;;; ("GEN" ) + +(DEFUN ISGREATERP (A B) + (let ((TA (car a)) + (TB (car b))) + (COND ((or (eq ta 'gen) + (eq tb 'gen)) ()) + ((AND (EQ TA TB) (EQ TA 'VAR)) + (RATGREATERP (CADDR A) (CADDR B))) + ((MEMQ TA (CDR (MEMQ TB *LIMORDER))))))) + +(DEFUN ISMAX (L) + (cond ((null l) ()) + ((atom l) ()) + ((= (length l) 1) (car l)) ;If there is only 1 thing give it back. + ((andmapc #'(lambda (x) + (not (eq (car x) 'gen))) l) + + (do ((l1 (cdr l) (cdr l1)) + (temp-ans (car l)) + (ans ())) + ((null l1) ans) + (cond ((isgreaterp temp-ans (car l1)) + (setq ans temp-ans)) + ((isgreaterp (car l1) temp-ans) + (setq temp-ans (car l1)) + (setq ans temp-ans)) + (t (setq ans ()))))) + (t ()))) + +(DEFUN MAXI (L) ;RETURNS LIST OF HIGH TERMS + (COND ((ATOM L) NIL) + (T (DO ((L (CDR L) (CDR L)) + (HI-TERM (CAR L)) + (HI-TERMS (NCONS (CAR L))) + (COMPARE NIL)) + ((NULL L) HI-TERMS) + (SETQ COMPARE (LIMIT (M// (CAR L) HI-TERM) VAR val 'THINK)) + (COND + ((INFINITYP COMPARE) + (SETQ HI-TERMS (NCONS (SETQ HI-TERM (CAR L))))) + ((EQ COMPARE '$UND) + (LET ((COMPARE2 (LIMIT (M// HI-TERM (CAR L)) VAR val 'THINK))) + (COND ((ZEROP2 COMPARE2) + (SETQ HI-TERMS (NCONS (SETQ HI-TERM (CAR L))))) + (T NIL)))) + ((ZEROP2 COMPARE) NIL) +;;;COMPARE IS IND OR FINITE-VALUED + (T (SETQ HI-TERMS (APPEND HI-TERMS (NCONS (CAR L)))))))))) + +(DEFUN RATMAX (L) + (PROG (ANS) + (COND ((ATOM L) (RETURN NIL))) + L1 (SETQ ANS (CAR L)) + L2 (SETQ L (CDR L)) + (COND ((NULL L) (RETURN ANS)) + ((RATGREATERP ANS (CAR L)) (GO L2)) + (T (GO L1))))) + +(DEFUN RATMIN (L) + (PROG (ANS) + (COND ((ATOM L) (RETURN NIL))) + L1 (SETQ ANS (CAR L)) + L2 (SETQ L (CDR L)) + (COND ((NULL L) (RETURN ANS)) + ((RATGREATERP (CAR L) ANS) (GO L2)) + (T (GO L1))))) + +(DEFUN POFX (E) + (COND ((atom e) + (cond ((eq e var) + (setq nn* (cons 1 nn*))) + (t ()))) + ((OR (MNUMP E) (NOT (AMONG VAR E))) NIL) + ((AND (mexptp e) (EQ (CADR E) VAR)) + (SETQ NN* (CONS (CADDR E) NN*))) + ((SIMPLERD E) NIL) + (T (MAPC (FUNCTION POFX) (CDR E))))) + +(DEFUN SER1 (E) + (COND ((MEMQ VAL '($ZEROA $ZEROB)) NIL) + (T (SETQ E (SUBIN (M+ VAR VAL) E)))) + (SETQ E (RDFACT E)) + (COND ((POFX E) E))) + +(DEFUN GATHER (IND L) + (PROG (ANS) + (SETQ IND (CAR IND)) + LOOP (COND ((NULL L) + (RETURN (LIST IND (m*l ANS)))) + ((EQUAL (CAAR L) IND) + (SETQ ANS (CONS (CADAR L) ANS)))) + (SETQ L (CDR L)) + (GO LOOP))) + +(DEFUN ISTRENGTH (TERM) + (COND ((MNUMP TERM) (LIST 'NUM TERM)) + ((ATOM TERM) (COND ((EQ TERM VAR) + (LIST 'VAR VAR 1.)) + (T (LIST 'num TERM)))) + ((NOT (AMONG VAR TERM)) (LIST 'num TERM)) + ((RADICALP TERM VAR) (LIST 'VAR TERM (RDDEG TERM NIL))) + ((mplusp TERM) + (let ((temp (ISMAX (MAPCAR (FUNCTION ISTRENGTH) (CDR TERM))))) + (cond ((not (null temp)) temp) + (t `(gen ,term))))) + ((mtimesp term) + (let ((TEMP (MAPCAR (FUNCTION ISTRENGTH) (CDR TERM))) + (temp1 ())) + (setq temp1 (ismax temp)) + (COND ((null temp1) `(gen ,term)) + ((eq (car temp1) 'log) `(log ,temp)) + ((EQ (CAR TEMP1) 'VAR) (ADD-UP-DEG TEMP)) + (T `(gen ,TEMP))))) + ((AND (mexptp term) + (REAL-INFINITYP (LIMIT TERM VAR VAL T))) + (COND ((AND (AMONG VAR (CADDR TERM)) + (MEMQ (CAR (ISTRENGTH (SETQ TERM (LOGRED TERM)))) + '(VAR EXP FACT)) + (REAL-INFINITYP (LIMIT TERM VAR VAL T))) + (LIST 'EXP (m^ '$%E TERM))) + ((NOT (AMONG VAR (CADDR TERM))) + (let ((TEMP (ISTRENGTH (CADR TERM)))) + (cond ((not (alike1 temp term)) + (RPLACA (CDR TEMP) TERM) + (AND (EQ (CAR TEMP) 'VAR) + (RPLACA (CDDR TEMP) + (M* (CADDR TEMP) (CADDR TERM)))) + TEMP) + (t `(gen ,term))))) + (T (LIST 'GEN (m^ '$%E TERM))))) + ((AND (EQ (CAAR TERM) '%LOG) + (REAL-INFINITYP (LIMIT TERM VAR VAL T))) + (let ((stren (istrength (cadr term)))) + (COND ((MEMQ (CAR stren) '(LOG VAR)) + `(LOG ,TERM)) + ((eq (car stren) 'exp) + (istrength (car (cddadr stren)))) + (T `(GEN ,TERM))))) + ((EQ (CAAR TERM) 'MFACTORIAL) + (LIST 'FACT TERM)) + ((let ((TEMP (HYPEREX TERM))) + (AND (NOT (ALIKE1 TERM TEMP)) + (ISTRENGTH TEMP)))) + (T (LIST 'GEN TERM)))) + +(DEFUN LOGRED (S1) + (OR (AND (EQ (CADR S1) '$%E) (CADDR S1)) + (m*t (CADDR S1) `((%LOG) ,(CADR S1))))) + +(DEFUN ASYMREDU (RD) + (COND ((ATOM RD) RD) + ((MNUMP RD) RD) + ((NOT (AMONG VAR RD)) RD) + ((POLYINX RD VAR T)) + ((SIMPLERD RD) + (COND ((EQ (CADR RD) VAR) RD) + (T (MABS-SUBST + (FACTOR ($EXPAND (M^ (POLYINX (CADR RD) VAR T) + (CADDR RD)))) + VAR + VAL)))) + (T (SIMPLIFY (CONS (LIST (CAAR RD)) + (MAPCAR (FUNCTION ASYMREDU) + (CDR RD))))))) + +(DEFUN RDFACT (RD) + (let ((DN** ()) (NN** ())) + (COND ((ATOM RD) RD) + ((MNUMP RD) RD) + ((NOT (AMONG VAR RD)) RD) + ((POLYP RD) + (FACTOR RD)) + ((SIMPLERD RD) + (COND ((EQ (CADR RD) VAR) RD) + (T (SETQ DN** (CADDR RD)) + (SETQ NN** (FACTOR (CADR RD))) + (COND ((mtimesp nn**) + (m*l (MAPCAR (FUNCTION + (LAMBDA (J) + (m^ j dn**))) + (CDR NN**)))) + (T RD))))) + (T (SIMPLIFY (CONS (NCONS (CAAR RD)) + (MAPCAR #'RDFACT (CDR RD)))))))) + +(DEFUN CNV (EXPL VAL) + (MAPCAR #'(LAMBDA (E) + (SUBSTITUTE (COND ((EQ VAL '$ZEROB) + (m* -1 (m^ var -1))) + ((EQ VAL '$ZEROA) + (m^ var -1)) + ((eq val '$minf) + (m* -1 var)) + (T (m^ (m+ VAR (m* -1 val)) -1.))) + VAR + E)) + EXPL)) + +(DEFUN PWTAYLOR (EXP VAR L TERMS) + (PROG (COEF ANS C MC) + (COND ((=0 TERMS) (RETURN NIL)) ((=0 L) (SETQ MC T))) + (SETQ C 0.) + (GO TAG1) + LOOP (SETQ C (ADD1 C)) + (COND ((OR (GREATERP C 10.) (EQUAL C TERMS)) + (RETURN (m+l ANS))) + (T (SETQ EXP (SDIFF EXP VAR)))) + TAG1 (SETQ COEF ($RADCAN (SUBIN L EXP))) + (COND ((=0 COEF) (SETQ TERMS (ADD1 TERMS)) (GO LOOP))) + (SETQ + ANS + (APPEND + ANS + (LIST + (m* COEF + (m^ `((MFACTORIAL) ,C) -1) + (m^ (IF MC VAR (m+t (m*t -1 L) VAR)) C))))) + (GO LOOP))) + +(DEFUN RDSGET (E) + (COND ((POLYP E) E) + ((SIMPLERD E) (RDTAY E)) + (T (CONS (LIST (CAAR E)) + (MAPCAR (FUNCTION RDSGET) (CDR E)))))) + +(DEFUN RDTAY (RD) + (COND ($TLIMSWITCH ($RATDISREP ($TAYLOR RD VAR VAL 1.))) + (T (LRDTAY RD)))) + +(DEFUN LRDTAY (RD) + (PROG (VARLIST P C E D $RATFAC) + (SETQ VARLIST (NCONS VAR)) + (SETQ P (RATNUMERATOR (CDR (RATREP* (CADR RD))))) + (COND ((LESSP (LENGTH P) 3.) (RETURN RD))) + (SETQ E (CADDR RD)) + (SETQ D (PDEGR P)) + (SETQ C (m^ VAR (m* D E))) + (SETQ D ($RATSIMP (VARINVERT (m* (PDIS P) (m^ VAR (m- D))) + VAR))) + (SETQ D (PWTAYLOR (m^ D E) VAR 0. 3.)) + (RETURN (M* C (VARINVERT D VAR))))) + +(DEFUN VARINVERT (E VAR) (SUBIN (m^t VAR -1.) E)) + +(DEFUN DEG (P) + (PROG (VARLIST) + (SETQ VARLIST (LIST VAR)) + (RETURN ((LAMBDA ($RATFAC) + (NEWVAR P) + (PDEGR (CADR (RATREP* P)))) + NIL)))) + +(DEFUN RAT-NO-RATFAC (E) + ((LAMBDA ($RATFAC) + (NEWVAR E) + (RATREP* E)) + NIL)) +(SETQ LOW* NIL) + +(DEFUN RDDEG (RD LOW*) + (COND ((OR (MNUMP RD) + (NOT (AMONG VAR RD))) + 0.) + ((POLYP RD) + (DEG RD)) + ((SIMPLERD RD) + (M* (DEG (CADR RD)) (CADDR RD))) + ((mtimesp rd) + (ADDN (MAPCAR #'(LAMBDA (J) + (RDDEG J LOW*)) + (CDR RD)) NIL)) + ((and (mplusp rd) + (SETQ RD (ANDMAPCAR #'(LAMBDA (J) (RDDEG J LOW*)) + (CDR RD)))) + (COND (LOW* (RATMIN RD)) + (T (RATMAX RD)))))) + +(DEFUN PDEGR (PF) + (COND ((OR (ATOM PF) (NOT (EQ (CAADR (RATF VAR)) (CAR PF)))) + 0.) + (LOW* (CADR (REVERSE PF))) + (T (CADR PF)))) +;There is some confusion here. We need to be aware of Branch cuts etc.... +;when doing this section of code. It is not very carefully done so there +;are bugs still lurking. Another misfortune is that LIMIT or its inferiors +;somtimes decides to change the limit VAL in midstream. This must be corrected +;since LIMIT's interaction with the data base environment must be maintained. +;I'm not sure that this code can ever be called with VAL other than $INF but +;there is a hook in the first important cond clause to cathc them anyway. + +(DEFUN ASY (N D) + (let ((num-power (rddeg n nil)) + (den-power (rddeg d nil)) + (coef ()) (coef-sign ()) (power ())) + (setq coef (m// ($RATCOEF N VAR num-power) ($ratcoef d var den-power))) + (setq coef-sign (getsignl coef)) + (setq power (m// num-power den-power)) + (cond ((eq (ask-integer power '$integer) '$integer) + (cond ((eq (ask-integer power '$even) '$even) '$even) + (t '$odd)))) ;Can be extended from here. + (COND ((or (eq val '$minf) + (eq val '$zerob) + (eq val '$zeroa) + (equal val 0)) ()) ;Can be extended to cover some these. + ((RATGREATERP den-power num-power) + (COND ((EQUAL coef-sign 1.) '$ZEROA) + ((equal coef-sign -1) '$zerob) + ((equal coef-sign 0) 0) + (t 0))) + ((RATGREATERP num-power den-power) + (COND ((EQUAL coef-sign 1.) '$INF) + ((equal coef-sign -1) '$minf) + ((equal coef-sign 0) 0) ;Questionable! + ((null coef-sign) '$infinity))) + (T coef)))) + +(DEFUN RADLIM (E N D) + (PROG (NL DL) + (COND ((EQ VAL '$INFINITY) (*THROW 'LIMIT NIL)) + ((EQ VAL '$MINF) + (SETQ NL (m* var -1)) + (SETQ N (SUBIN nl n)) + (SETQ D (SUBIN NL D)) + (SETQ VAL '$INF))) ;This is the Culprit. Doesn't tell the DATABASE. + (COND ((EQ VAL '$INF) + (SETQ NL (ASYMREDU N)) + (SETQ DL (ASYMREDU D)) + (COND + ((OR (RPTROUBLE N) (RPTROUBLE D)) + (RETURN (LIMIT (m* (RDSGET N) (m^ (RDSGET D) -1.)) VAR VAL T))) + (T (RETURN (ASY NL DL)))))) + (SETQ NL (LIMIT N VAR VAL T)) + (SETQ DL (LIMIT D VAR VAL T)) + (COND ((AND (ZEROP2 NL) (ZEROP2 DL)) + (COND ((OR (POLYP N) (POLYP D)) + (RETURN (TRY-LHOSPITAL-QUIT N D T))) + (T (RETURN (SER0 E N D VAL))))) + (T (RETURN ($RADCAN (RATRAD (m// N D) N D NL DL))))))) + +(DEFUN RATRAD (E N D NL DL) + (PROG (N1 D1) + (COND ((EQUAL NL 0) (RETURN 0)) + ((ZEROP2 DL) + (SETQ N1 NL) + (COND ((equal dl 0) (SETQ D1 '$INFINITY)) ;No direction Info. + ((EQ DL '$ZEROA) + (SETQ D1 '$INF)) + ((EQUAL (SETQ D (BEHAVIOR D VAR VAL)) 1) + (SETQ D1 '$INF)) + ((EQUAL D -1) (SETQ D1 '$MINF)) + (T (*THROW 'LIMIT NIL)))) + ((ZEROP2 NL) + (SETQ D1 DL) + (COND ((EQUAL (SETQ N (BEHAVIOR N VAR VAL)) 1) + (SETQ N1 '$ZEROA)) + ((EQUAL N -1) (SETQ N1 '$ZEROB)) + (T (SETQ N1 0)))) + (T (RETURN ($RADCAN (RIDOFAB (SUBIN VAL E)))))) + (RETURN (SIMPLIMTIMES (LIST N1 D1))))) + +(DEFUN SIMPLIMLN (ARG) + (LET* ((ARGLIM (LIMIT ARG VAR VAL 'THINK)) + (REAL-LIM (RIDOFAB ARGLIM))) + (IF (=0 REAL-LIM) + (cond ((eq arglim '$ZEROA) '$MINF) + ((eq arglim '$ZEROB) '$INFINITY) + (T (LET ((DIR (BEHAVIOR ARG VAR VAL))) + (COND ((EQUAL DIR 1) '$MINF) + ((EQUAL DIR -1) '$INFINITY) + (T (*THROW 'LIMIT T)))))) + (cond ((eq arglim '$INF) '$INF) + ((memq arglim '($MINF $INFINITY)) '$INFINITY) + ((memq arglim '($IND $UND)) '$UND) + ((equal arglim 1) + (let ((dir (behavior arg var val))) + (if (equal dir 1) '$zeroa 0))) + (T (SIMPLIFY `((%LOG) ,REAL-LIM))))))) + +(DEFUN SIMPLIMFACT (EXP VAR VAL ARG) + (COND ((EQ ARG '$INF) '$INF) + ((MEMQ ARG '($MINF $INFINITY $UND $IND)) '$UND) + ((AND (INTEGERP ARG) (> 0 ARG)) + (LET ((DIR (LIMIT (m+ exp (m* arg -1)) VAR VAL 'THINK)) + (EVENP (INTEGERP (QUOTIENT ARG 2.0)))) + (COND ((OR (AND EVENP + (EQ DIR '$ZEROA)) + (AND (NOT EVENP) + (EQ DIR '$ZEROB))) + '$MINF) + ((OR (AND EVENP + (EQ DIR '$ZEROB)) + (AND (NOT EVENP) + (EQ DIR '$ZEROA))) + '$INF) + (T (*THROW 'LIMIT NIL))))) + (T (SIMPFACT (LIST '(MFACTORIAL) (RIDOFAB ARG)) 1 NIL)))) + +(defun simplim%erf-%tanh (fn arg) + (let ((arglim (limit arg var val 'think))) + (cond ((eq arglim '$inf) 1) + ((eq arglim '$minf) -1) + ((eq arglim '$infinity) + (let (((rpart . ipart) (trisplit arg)) + (ans ()) (rlim ())) + (setq rlim (limit rpart var origval 'think)) + (cond ((eq fn '%tanh) + (cond ((equal rlim '$inf) 1) + ((equal rlim '$minf) -1))) + ((eq fn '%erf) + (setq ans + (limit (m* rpart (m^t ipart -1)) var origval 'think)) + (setq ans ($asksign (m+ `((mabs) ,ans) -1))) + (cond ((or (eq ans '$pos) (eq ans '$zero)) + (cond ((eq rlim '$inf) 1) + ((eq rlim '$minf) -1) + (t '$und))) + (t '$und)))))) + ((eq arglim '$und) '$und) + ((memq arglim '($zeroa $zerob $ind)) arg) +;;;Ignore tanh(%pi/2*%I) and multiples of the argument. + (t (simplify (list (ncons fn) arg)))))) + +(DEFUN SIMPLIM%ATAN (EXP1) + (COND ((ZEROP2 EXP1) EXP1) + ((EQ EXP1 '$INF) HALF%PI) + ((EQ EXP1 '$MINF) + (m*t -1. HALF%PI)) + (T `((%ATAN) ,EXP1)))) + +(DEFUN SIMPLIMSCH (SCH ARG) + (COND ((REAL-INFINITYP ARG) + (COND ((EQ SCH '%SINH) ARG) (T '$INF))) + ((EQ ARG '$INFINITY) '$INFINITY) + ((EQ ARG '$UND) '$UND) + (T (LET (($EXPONENTIALIZE T)) + (RESIMPLIFY (LIST (NCONS SCH) (RIDOFAB ARG))))))) + +(DEFUN SIMPLIMSC (EXP FN ARG) + (COND ((MEMQ ARG '($INF $MINF $IND)) '$IND) + ((MEMQ ARG '($UND $INFINITY)) '$UND) + ((MEMQ ARG '($ZEROA $ZEROB)) + (COND ((EQ FN '%SIN) ARG) + (T (m+ 1 '$zerob)))) + ((SINCOSHK EXP + (SIMPLIFY (LIST (NCONS FN) (RIDOFAB ARG))) + FN)))) + +(DEFUN SIMPLIM%TAN (ARG) + (let ((arg1 (ridofab (limit arg var val 'think)))) + (COND + ((MEMQ ARG1 '($INF $MINF $INFINITY $IND $UND)) '$UND) + ((PIP ARG1) + (let ((C (TRIGRED (PIP ARG1)))) + (COND ((not (equal ($imagpart arg1) 0)) '$infinity) + ((AND (EQ (CAAR C) 'RAT) + (EQUAL (CADDR C) 2) + (GREATERP (CADR C) 0)) + (SETQ ARG1 (BEHAVIOR ARG VAR VAL)) + (COND ((= ARG1 1) '$INF) + ((= ARG1 -1) '$MINF) + (T '$UND))) + ((AND (EQ (CAAR C) 'RAT) + (EQUAL (CADDR C) 2) + (LESSP (CADR C) 0)) + (SETQ ARG1 (BEHAVIOR ARG VAR VAL)) + (COND ((= ARG1 1) '$MINF) + ((= ARG1 -1) '$INF) + (T '$UND))) + (T (*throw 'limit ()))))) + ((equal arg1 0) + (setq arg1 (behavior arg var val)) + (cond ((equal arg1 1) '$zeroa) + ((equal arg1 -1) '$zerob) + (t 0))) + (t (SIMP-%TAN (LIST '(%TAN) ARG1) 1. NIL))))) + +(DEFUN SIMPLIM%ASINH (ARG) + (COND ((MEMQ ARG '($INF $MINF $ZEROA $ZEROB $IND $UND)) + ARG) + ((EQ ARG '$INFINITY) '$UND) + (T (SIMPLIFY (LIST '(%ASINH) (RIDOFAB ARG)))))) + +(DEFUN SIMPLIM%ACOSH (ARG) + (COND ((EQUAL (RIDOFAB ARG) 1.) '$ZEROA) + ((EQ ARG '$INF) ARG) + ((EQ ARG '$MINF) '$INFINITY) + ((MEMQ ARG '($UND $IND $INFINITY)) '$UND) + (T (SIMPLIFY (LIST '(%ACOSH) (RIDOFAB ARG)))))) + +(DEFUN SIMPLIM%ATANH (ARG) + (COND ((ZEROP2 ARG) ARG) + ((MEMQ ARG '($IND $UND $INFINITY $MINF $INF)) + '$UND) + ((EQUAL (SETQ ARG (RIDOFAB ARG)) 1.) '$INF) + ((EQUAL ARG -1.) '$MINF) + (T (SIMPLIFY (LIST '(%ATANH) ARG))))) + +(DEFUN SIMPLIM%ASIN-%ACOS (FN ARG) + (COND ((MEMQ ARG '($UND $IND $INF $MINF $INFINITY)) + '$UND) + ((AND (EQ FN '%ASIN) + (MEMQ ARG '($ZEROA $ZEROB))) + ARG) + (T (SIMPLIFY (LIST (NCONS FN) (RIDOFAB ARG)))))) + +(defun simplim$li (order arg val) + (cond ((and (not (equal (length order) 1)) + (not (equal (length arg) 1))) (*throw 'limit ())) + (t (setq order (car order) arg (car arg)))) + (cond ((not (equal order 2)) (*throw 'limit ())) + (t (let (((rpart . ipart) (trisplit arg))) + (cond ((not (equal ipart 0)) (*throw 'limit ())) + (t (setq rpart (limit rpart var val 'think)) + (cond ((eq rpart '$zeroa) '$zeroa) + ((eq rpart '$zerob) '$zerob) + ((eq rpart '$minf) '$minf) + ((eq rpart '$inf) '$infinity) + (t (simplify (subfunmake '$li (list order) + (list rpart))))))))))) + +(defun simplim$psi (order arg val) + (cond ((and (not (equal (length order) 1)) + (not (equal (length arg) 1))) (*throw 'limit ())) + (t (setq order (car order) arg (car arg)))) + (cond ((not (equal order 0)) (*throw 'limit ())) + (t (let (((rpart . ipart) (trisplit arg))) + (cond ((not (equal ipart 0)) (*throw 'limit ())) + (t (setq rpart (limit rpart var val 'think)) + (cond ((eq rpart '$zeroa) '$minf) + ((eq rpart '$zerob) '$inf) + ((eq rpart '$inf) '$inf) + ((eq rpart '$minf) '$und) + ((equal (getsignl rpart) -1) (*throw 'limit ())) + (t (simplify (subfunmake '$psi (list order) + (list rpart))))))))))) + +(COMMENT MORE FUNCTIONS FOR LIMIT TO HANDLE) + +(DEFUN LFIBTOPHI (E) + (COND ((NOT (INVOLVE E '($FIB))) E) + ((EQ (CAAR E) '$FIB) + ((LAMBDA (LNORECURSE) + ($FIBTOPHI (LIST '($FIB) (LFIBTOPHI (CADR E))))) + T)) + (T (CONS (CAR E) + (MAPCAR (FUNCTION LFIBTOPHI) (CDR E)))))) + +;;; FOLLOWING CODE MAKES $LDEFINT WORK + +(DEFMFUN $LDEFINT (EXP VAR LL UL &aux $logabs ans a1 a2) + (SETQ $LOGABS T ANS (SININT EXP VAR) + A1 ($LIMIT ANS VAR UL '$MINUS) + A2 ($LIMIT ANS VAR LL '$PLUS)) + (AND (MEMQ A1 '($INF $MINF $INFINITY $UND $IND)) + (SETQ A1 (NOUNLIMIT ANS VAR UL))) + (AND (MEMQ A2 '($INF $MINF $INFINITY $UND $IND)) + (SETQ A2 (NOUNLIMIT ANS VAR LL))) + ($EXPAND (M- A1 A2))) + +(DEFUN NOUNLIMIT (EXP VAR VAL) + (SETQ EXP (RESTORELIM EXP)) + (NCONC (LIST '(%LIMIT) EXP VAR (RIDOFAB VAL)) + (COND ((EQ VAL '$ZEROA) '($PLUS)) + ((EQ VAL '$ZEROB) '($MINUS))))) + +(DEFUN HIDE (EXP) + (COND ((ATOM EXP) EXP) + ((let ((FUNC (MEMQ (CAAR EXP) '(%INTEGRATE %LIMIT %DERIVATIVE %SUM)))) + (cond ((not (null func)) + (HIDELIM EXP (CAR FUNC))) + (t ())))) + (T (CONS (CAR EXP) (MAPCAR 'HIDE (CDR EXP)))))) + +(DEFUN HIDELIM (EXP FUNC) + (COND ((OR (EQ FUNC '%INTEGRATE) (EQ FUNC '%SUM)) + (SETQ FUNC (GENSYM)) + (PUTPROP FUNC + (COND ((OR (NULL (CDDDR EXP)) + (NOT (EQ VAR (third EXP)))) + (HIDELIMA EXP)) + ((AND (NOT (AMONG VAR (fourth EXP))) + (NOT (AMONG VAR (fifth EXP)))) + EXP) + (T (NOUNLIMIT EXP VAR VAL))) + 'LIMITSUB)) + ((EQ FUNC '%LIMIT) + (SETQ FUNC (GENSYM)) + (PUTPROP FUNC + (COND ((EQ VAR (fourth EXP)) + (NCONC (LIST (first EXP) + (second EXP) + (third EXP)) + (SUBST VAL VAR (CDDDR EXP)))) + ((EQ VAR (CADDR EXP)) EXP) + (T (HIDELIMA EXP))) + 'LIMITSUB)) + (T (SETQ FUNC (GENSYM)) + (PUTPROP FUNC (HIDELIMA EXP) 'LIMITSUB))) + FUNC) + +(DEFUN HIDELIMA (E) + (COND ((AMONG VAR E) (NOUNLIMIT E VAR VAL)) (T E))) + +;;;Used by Defint also. +(DEFUN OSCIP (E) + (OR (INVOLVE E '(%SIN %COS %TAN)) + (AMONG '$%I (%EINVOLVE E)))) + +(DEFUN %EINVOLVE (E) (COND ((AMONG '$%E E) (%EINVOLVE01 E)))) + +(DEFUN %EINVOLVE01 (E) + (COND ((ATOM E) NIL) + ((MNUMP E) NIL) + ((AND (mexptp E) + (EQ (CADR E) '$%E) + (AMONG VAR (CADDR E))) + (CADDR E)) + (T (ORMAPC (FUNCTION %EINVOLVE) (CDR E))))) + + +(DECLARE (UNSPECIAL *INDICATOR NN* DN* EXP VAR VAL + ORIGVAL *LIMORDER TAYLORED + $TLIMSWITCH LOGCOMBED LHP? LHCOUNT $RATFAC)) \ No newline at end of file diff --git a/src/jim/tlimit.47 b/src/jim/tlimit.47 new file mode 100644 index 00000000..5f428926 --- /dev/null +++ b/src/jim/tlimit.47 @@ -0,0 +1,49 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module tlimit) +(load-macsyma-macros rzmac) + +;; TOP LEVEL FUNCTION(S): $TLIMIT $TLDEFINT + +(DECLARE (GENPREFIX TL) + (*LEXPR $LIMIT) + (SPECIAL $TLIMSWITCH TAYLORED EXP VAR VAL LL UL + SILENT-TAYLOR-FLAG)) + +(DEFMFUN $TLIMIT NARGS + ((LAMBDA ($TLIMSWITCH) (APPLY '$LIMIT (LISTIFY NARGS))) T)) + +(DEFMFUN $TLDEFINT (EXP VAR LL UL) + ((LAMBDA ($TLIMSWITCH) ($LDEFINT EXP VAR LL UL)) T)) + +(DEFUN TLIMP (EXP) ; TO BE EXPANDED TO BE SMARTER (MAYBE) + T) + +(DEFUN TAYLIM (E *I*) + (PROG (EX) + (SETQ EX (*CATCH 'TAYLOR-CATCH + (let ((SILENT-TAYLOR-FLAG t)) + ($TAYLOR E VAR (RIDOFAB VAL) 1.)))) + (OR EX (RETURN (COND ((EQ *I* T) (LIMIT1 E VAR VAL)) + ((EQ *I* 'THINK) (COND ((MEMQ (CAAR EXP) + '(MTIMES MEXPT)) + (LIMIT1 E VAR VAL)) + (T (SIMPLIMIT E VAR VAL)))) + (T (SIMPLIMIT E VAR VAL))))) + (RETURN + (let ((TAYLORED t)) + (LIMIT + (SIMPLIFY + ($logcontract ($RATDISREP ex))) + ;;(COND ((EQ (CADR EX) 'PS) + ;; (CONS (CAR EX) + ;; (LIST 'PS (THIRD EX) (FOURTH EX) + ;; (FIFTH EX)))) + ;; (t (EX))) + VAR + VAL + 'THINK))))) + +(DECLARE (UNSPECIAL TAYLORED EXP VAR VAL LL UL)) diff --git a/src/jm/risch.434 b/src/jm/risch.434 new file mode 100644 index 00000000..f0c94457 --- /dev/null +++ b/src/jm/risch.434 @@ -0,0 +1,1039 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module risch) + +(LOAD-MACSYMA-MACROS RZMAC RATMAC) + +(DECLARE (SPECIAL PROB ROOTFAC PARNUMER PARDENOM LOGPTDX WHOLEPART $RATALGDENOM + EXPEXPFLAG $LOGSIMP SWITCH1 DEGREE CARY $RATFAC $LOGEXPAND + RATFORM GENVAR *VAR VAR ROOTFACTOR EXPINT $KEEPFLOAT + TRIGINT OPERATOR $EXPONENTIALIZE $GCD $LOGARC CHANGEVP + KLTH R S BETA GAMMA B MAINVAR EXPFLAG EXPSTUFF LIFLAG + INTVAR SWITCH VARLIST NOGOOD GENVAR $ERFFLAG $LIFLAG + RISCHP $FACTORFLAG ALPHAR M SIMP GENPAIRS HYPERTRIGINT + *MOSESFLAG YYY *EXP Y $ALGEBRAIC IMPLICIT-REAL + ERRRJFFLAG $%E/_TO/_NUMLOG GENERATE-ATAN2 CONTEXT + BIGFLOATZERO RP-POLYLOGP) + (*EXPR $EXPONENTIALIZE SUBFUNSUBS SUBFUNNAME SRATSIMP PARTFRAC MQAPPLYP) + (*LEXPR CONTEXT POLYLOGP) + (GENPREFIX RISCH)) + +(DEFMVAR $LIFLAG T "Controls whether RISCH generates polylogs") + +(DEFMVAR $ERFFLAG T "Controls whether RISCH generates ERFS") + +(DEFVAR CHANGEVP T #-LISPM "When nil prevents changevar hack") + +(DEFMACRO PAIR (AL BL) `(MAPCAR (FUNCTION CONS) ,AL ,BL)) + +(DEFMACRO RISCHZERO () ''((0 . 1) 0)) + +(DEFUN RISCHNOUN (EXP1 &OPTIONAL (EXP2 EXP1 EXP2P)) + (UNLESS EXP2P (SETQ EXP1 (RZERO))) + `(,EXP1 ((%INTEGRATE) ,(DISREP EXP2) ,INTVAR))) + +(DEFUN GETRISCHVAR () + (DO ((VL VARLIST (CDR VL)) + (GL GENVAR (CDR GL))) + ((NULL (CDR VL)) (CAR GL)))) + +(DEFUN RISCH-PCONSTP (P) + (OR (PCOEFP P) (POINTERGP MAINVAR (CAR P)))) + +(DEFUN RISCH-CONSTP (R) + (SETQ R (RATFIX R)) + (AND (RISCH-PCONSTP (CAR R)) (RISCH-PCONSTP (CDR R)))) + +(DEFUN RISCHADD (X Y) + (LET (((A . B) X) ((C . D) Y)) + (CONS (R+ A C) (APPEND B D)))) + +(DEFMFUN $RISCH (EXP VAR) + ;; Get RATINT from SININT + (FIND-FUNCTION 'RATINT) + (WITH-NEW-CONTEXT (CONTEXT) + (RISCHINT EXP VAR))) + + +(DEFUN SPDERIVATIVE (P VAR) + (COND ((PCOEFP P) '(0 . 1)) + ((NULL (CDR P)) '(0 . 1)) + ((OR (NOT (ATOM (CAR P))) (NUMBERP (CAR P))) ;P IS A RATFORM + (LET ((DENPRIME (SPDERIVATIVE (CDR P) VAR))) + (COND ((RZEROP DENPRIME) + (RATQU (SPDERIVATIVE (CAR P) VAR) (CDR P))) + (T (RATQU (R- (R* (SPDERIVATIVE (CAR P) VAR) + (CDR P)) + (R* (CAR P) DENPRIME)) + (R* (CDR P) (CDR P))))))) + (T (R+ (SPDERIVATIVE1 (CAR P) + (CADR P) + (CADDR P) + VAR) + (SPDERIVATIVE (CONS (CAR P) (CDDDR P)) + VAR))))) + +(DEFUN SPDERIVATIVE1 (VAR1 DEG COEFF VAR) + (COND ((EQ VAR1 VAR) + (R* (RATEXPT (CONS (LIST VAR 1 1) 1) (SUB1 DEG)) + (PCTIMES DEG COEFF))) + ((POINTERGP VAR VAR1) '(0 . 1)) + ((EQUAL DEG 0) (SPDERIVATIVE COEFF VAR)) + (T (R+ (R* (RATEXPT (CONS (LIST VAR1 1 1) 1) DEG) + (SPDERIVATIVE COEFF VAR)) + (R* (COND ((EQUAL DEG 1) COEFF) + (T (R* DEG + COEFF + (RATEXPT (CONS (LIST VAR1 1 1) 1) + (SUB1 DEG))))) + (GET VAR1 'RISCHDIFF) ))))) + +(DEFUN POLYLOGP (EXP &OPTIONAL SUB) + (AND (MQAPPLYP EXP) (EQ (SUBFUNNAME EXP) '$LI) + (OR (NULL SUB) (EQUAL SUB (CAR (SUBFUNSUBS EXP)))))) + + +(DEFUN RISCHINT (EXP INTVAR &AUX ($LOGARC NIL) ($EXPONENTIALIZE NIL) + ($GCD '$ALGEBRAIC) ($ALGEBRAIC T) (IMPLICIT-REAL T)) + (PROG ($%E/_TO/_NUMLOG $LOGSIMP TRIGINT OPERATOR Y Z VAR RATFORM LIFLAG + MAINVAR VARLIST GENVAR HYPERTRIGINT $RATFAC $RATALGDENOM ) + (COND (($RATP EXP) (SETQ EXP (RATDISREP EXP)))) + (COND (($RATP INTVAR) (SETQ INTVAR (RATDISREP INTVAR)))) + (NONVARCHK INTVAR '$INTEGRATE T T) + (COND ((AND (ATOM INTVAR) (ISINOP EXP INTVAR)) (GO NOUN))) + (RISCHFORM EXP) + (COND (TRIGINT (RETURN (TRIGIN1 EXP INTVAR))) + (HYPERTRIGINT (RETURN (HYPERTRIGINT1 EXP INTVAR T))) + (OPERATOR (GO NOUN))) + (SETQ Y (INTSETUP EXP INTVAR)) + (COND (OPERATOR (GO NOUN))) + (SETQ RATFORM (CAR Y)) + (SETQ VARLIST (CADDR RATFORM)) + (SETQ MAINVAR (CAADR (RATF INTVAR))) + (SETQ GENVAR (CADDDR RATFORM)) + (UNLESS (ORMAPC (FUNCTION ALGPGET) VARLIST) + (SETQ $ALGEBRAIC NIL) + (SETQ $GCD (CAR *GCDL*))) + (SETQ VAR (GETRISCHVAR)) + (SETQ Z (TRYRISCH (CDR Y) MAINVAR)) + (SETF (CADDR RATFORM) VARLIST) + (SETF (CADDDR RATFORM) GENVAR) + (RETURN (COND ((ATOM (CDR Z)) (DISREP (CAR Z))) + (T (LET (($LOGSIMP T) ($%E/_TO/_NUMLOG T)) + (SIMPLIFY (LIST* '(MPLUS) + (DISREP (CAR Z)) + (CDR Z))))))) + NOUN (RETURN (LIST '(%INTEGRATE) EXP INTVAR)))) + +(DEFUN RISCHFORM (L) + (COND ((OR (ATOM L) (ALIKE1 INTVAR L) (FREEOF INTVAR L)) NIL) + ((POLYLOGP L) + (IF (AND (FIXP (CAR (SUBFUNSUBS L))) + (SIGNP G (CAR (SUBFUNSUBS L)))) + (RISCHFORM (CAR (SUBFUNARGS L))) + (SETQ OPERATOR T))) + ((ATOM (CAAR L)) + (CASEQ (CAAR L) + ((%SIN %COS %TAN %COT %SEC %CSC) + (SETQ TRIGINT T $EXPONENTIALIZE T) + (RISCHFORM (CADR L))) + ((%ASIN %ACOS %ATAN %ACOT %ASEC %ACSC) + (SETQ TRIGINT T $LOGARC T) + (RISCHFORM (CADR L))) + ((%SINH %COSH %TANH %COTH %SECH %CSCH) + (SETQ HYPERTRIGINT T $EXPONENTIALIZE T) + (RISCHFORM (CADR L))) + ((%ASINH %ACOSH %ATANH %ACOTH %ASECH %ACSCH) + (SETQ HYPERTRIGINT T $LOGARC T) + (RISCHFORM (CADR L))) + ((MTIMES MPLUS MEXPT RAT %ERF %LOG) + (MAPC #'RISCHFORM (CDR L))) + (T (SETQ OPERATOR (CAAR L))))) + (T (SETQ OPERATOR (CAAR L))))) + +(DEFUN HYPERTRIGINT1 (EXP VAR HYPERFUNC) + (IF HYPERFUNC (INTEGRATOR (RESIMPLIFY EXP) VAR) + (RISCHINT (RESIMPLIFY EXP) VAR))) + +(DEFUN TRIGIN1 (*EXP VAR) + (LET ((YYY (HYPERTRIGINT1 *EXP VAR NIL))) + (SETQ YYY (DIV ($EXPAND ($NUM YYY)) + ($EXPAND ($DENOM YYY)))) + (LET ((RISCHP VAR) (RP-POLYLOGP T) $LOGARC $EXPONENTIALIZE) + (SRATSIMP (IF (AND (FREEOF '$%I *EXP) (FREEOF '$LI YYY)) + ($REALPART YYY) + ($RECTFORM YYY)))))) + + +(DEFUN TRYRISCH (EXP MAINVAR) + (PROG (WHOLEPART ROOTFACTOR PARNUMER PARDENOM + SWITCH1 LOGPTDX EXPFLAG EXPSTUFF EXPINT Y) + (SETQ EXPSTUFF '(0 . 1)) + (COND ((EQ MAINVAR VAR) + (RETURN (RISCHFPROG EXP))) + ((EQ (GET VAR 'LEADOP) + 'MEXPT) + (SETQ EXPFLAG T))) + (SETQ Y (RISCHLOGDPROG EXP)) + (DOLIST (RAT LOGPTDX) + (SETQ Y (RISCHADD (RISCHLOGEPROG RAT) Y))) + (SETQ Y (RISCHADD (TRYRISCH1 EXPSTUFF MAINVAR) Y)) + (RETURN (IF EXPINT (RISCHADD (RISCHEXPPOLY EXPINT VAR) Y) + Y)))) + +(DEFUN TRYRISCH1 (EXP MAINVAR) + (LET* ((VARLIST (REVERSE (CDR (REVERSE VARLIST)))) + (VAR (GETRISCHVAR))) + (TRYRISCH EXP MAINVAR))) + +(DEFUN RISCHFPROG (RAT) + (LET (ROOTFACTOR PARDENOM PARNUMER LOGPTDX WHOLEPART SWITCH1) + (CONS (CDR (RATREP* (DPROG RAT))) + (LET ((VARLIST VARLIST) + (GENVAR (FIRSTN (LENGTH VARLIST) GENVAR))) + (MAPCAR 'EPROG LOGPTDX))))) + +(DEFUN RISCHLOGDPROG (RATARG) + (PROG (KLTH AROOTF DERIV THEBPG THETOP THEBOT PROD1 PROD2 ANS) + (SETQ ANS '(0 . 1)) + (COND ((OR (PCOEFP (CDR RATARG)) + (POINTERGP VAR (CADR RATARG))) + (RETURN (RISCHLOGPOLY RATARG)))) + (APROG (RATDENOMINATOR RATARG)) + (CPROG (RATNUMERATOR RATARG) (RATDENOMINATOR RATARG)) + (DO ((ROOTFACTOR (REVERSE ROOTFACTOR) (CDR ROOTFACTOR)) + (PARNUMER (REVERSE PARNUMER) (CDR PARNUMER)) + (KLTH (LENGTH ROOTFACTOR) (1- KLTH))) + ((= KLTH 1)) + (SETQ AROOTF (CAR ROOTFACTOR)) + (COND + ((PCOEFP AROOTF)) + ((AND (EQ (GET (CAR AROOTF) 'LEADOP) 'MEXPT) + (NULL (CDDDR AROOTF))) + (SETQ + EXPINT + (APPEND + (COND ((AND (NOT (ATOM (CAR PARNUMER))) + (NOT (ATOM (CAAR PARNUMER))) + (EQ (CAAAR PARNUMER) (CAR AROOTF))) + (GENNEGS AROOTF (CDAAR PARNUMER) (CDAR PARNUMER))) + (T (LIST + (LIST 'NEG (CAR PARNUMER) + (CAR AROOTF) KLTH (CADR AROOTF))))) + EXPINT))) + ((NOT (ZEROP (PDEGREE AROOTF VAR))) + (SETQ DERIV (SPDERIVATIVE AROOTF MAINVAR)) + (SETQ THEBPG (BPROG AROOTF (RATNUMERATOR DERIV))) + (SETQ THETOP (CAR PARNUMER)) + (DO KX (1- KLTH) (1- KX) (= KX 0) + (SETQ PROD1 (R* THETOP (CAR THEBPG))) + (SETQ PROD2 (R* THETOP (CDR THEBPG) (RATDENOMINATOR DERIV))) + (SETQ THEBOT (PEXPT AROOTF KX)) + (SETQ ANS (R+ ANS (RATQU (R- PROD2) (R* KX THEBOT)))) + (SETQ THETOP + (R+ PROD1 (RATQU (SPDERIVATIVE PROD2 MAINVAR) KX))) + (SETQ THETOP (CDR (RATDIVIDE THETOP THEBOT)))) + (PUSH (RATQU THETOP AROOTF) LOGPTDX)))) + (PUSH (RATQU (CAR PARNUMER) (CAR ROOTFACTOR)) LOGPTDX) + (COND ((OR (PZEROP ANS) (PZEROP (CAR ANS))) + (RETURN (RISCHLOGPOLY WHOLEPART)))) + (SETQ THETOP (CADR (PDIVIDE (RATNUMERATOR ANS) + (RATDENOMINATOR ANS)))) + (RETURN (RISCHADD (NCONS (RATQU THETOP (RATDENOMINATOR ANS))) + (RISCHLOGPOLY WHOLEPART))))) + +(DEFUN GENNEGS (DENOM NUM NUMDENOM) + (COND ((NULL NUM) NIL) + (T (CONS (LIST 'NEG (CADR NUM) + (CAR DENOM) + (DIFFERENCE KLTH (CAR NUM)) + (R* NUMDENOM (CADDR DENOM) )) + (GENNEGS DENOM (CDDR NUM) NUMDENOM))))) + +(DEFUN RISCHLOGEPROG (P) + (PROG (P1E P2E P2DERIV LOGCOEF NCC DCC ALLCC EXPCOEF) + (IF (OR (PZEROP P) (PZEROP (CAR P))) (RETURN (RISCHZERO))) + (SETQ P1E (RATNUMERATOR P)) + (DESETQ (DCC P2E) (OLDCONTENT (RATDENOMINATOR P))) + (COND ((AND (NOT SWITCH1) + (CDR (SETQ PARDENOM (INTFACTOR P2E)))) + (SETQ PARNUMER NIL) + (SETQ SWITCH1 T) + (DESETQ (NCC P1E) (OLDCONTENT P1E)) + (CPROG P1E P2E) + (SETQ ALLCC (RATQU NCC DCC)) + (RETURN (DO ((PNUM PARNUMER (CDR PNUM)) + (PDEN PARDENOM (CDR PDEN)) + (ANS (RISCHZERO))) + ((OR (NULL PNUM) (NULL PDEN)) + (SETQ SWITCH1 NIL) ANS) + (SETQ ANS (RISCHADD + (RISCHLOGEPROG + (R* ALLCC (RATQU (CAR PNUM) (CAR PDEN)))) + ANS)))))) + (WHEN (AND EXPFLAG (NULL (P-RED P2E))) + (PUSH (CONS 'NEG P) EXPINT) + (RETURN (RISCHZERO))) + (IF EXPFLAG (SETQ EXPCOEF (R* (P-LE P2E) (RATQU (GET VAR 'RISCHDIFF) + (MAKE-POLY VAR))))) + (SETQ P1E (RATQU P1E (PTIMES DCC (P-LC P2E))) + P2E (RATQU P2E (P-LC P2E))) ;MAKE DENOM MONIC + (SETQ P2DERIV (SPDERIVATIVE P2E MAINVAR)) + (SETQ LOGCOEF (RATQU P1E + (IF EXPFLAG (R- P2DERIV (R* P2E EXPCOEF)) + P2DERIV))) + (WHEN (RISCH-CONSTP LOGCOEF) + (IF EXPFLAG + (SETQ EXPSTUFF (R- EXPSTUFF (R* EXPCOEF LOGCOEF)))) + (RETURN + (LIST + '(0 . 1) + (LIST '(MTIMES) + (DISREP LOGCOEF) + (LOGMABS (DISREP P2E)))))) + (if (and expflag $liflag changevp) + (let* ((newvar (gensym)) + (new-int ($changevar + `((%integrate) ,(simplify (disrep p)) ,intvar) + (sub newvar (get var 'rischexpr)) + newvar intvar)) + (changevp nil)) ;prevents recursive changevar + (if (and (freeof intvar new-int) + (freeof '%integrate + (setq new-int (rischint (sdiff new-int newvar) + newvar)))) + (return + (list (rzero) + (substitute (get var 'rischexpr) newvar new-int)))))) + (RETURN (RISCHNOUN P)))) + + +(DEFUN FINDINT (EXP) (COND ((ATOM EXP) NIL) + ((ATOM (CAR EXP)) (FINDINT (CDR EXP))) + ((EQ (CAAAR EXP) '%INTEGRATE) T) + (T (FINDINT (CDR EXP))))) + +(DEFUN LOGEQUIV (FN1 FN2) + (FREEOF INTVAR ($RATSIMP (DIV* (REMABS (LEADARG FN1)) + (REMABS (LEADARG FN2)))))) + +(DEFUN REMABS (EXP) + (COND ((ATOM EXP) EXP) + ((EQ (CAAR EXP) 'MABS) (CADR EXP)) + (T EXP))) + +(DECLARE (SPECIAL VLIST LIANS DEGREE)) + +(DEFUN GETFNSPLIT (L &AUX COEF FN) + (MAPC #'(LAMBDA (X) (IF (FREE X INTVAR) (PUSH X COEF) (PUSH X FN))) L) + (CONS (MULN COEF NIL) (MULN FN NIL))) + +(DEFUN GETFNCOEFF (A FORM) + (COND ((NULL A) 0) + ((EQUAL (CAR A) 0) (GETFNCOEFF (CDR A) FORM)) + ((EQ (CAAAR A) 'MPLUS) (RATPL (GETFNCOEFF (CDAR A) FORM) + (GETFNCOEFF (CDR A) FORM))) + ((EQ (CAAAR A) 'MTIMES) + (LET (((COEF . NEWFN) (GETFNSPLIT (CDAR A)))) + (SETF (CDAR A) (LIST COEF NEWFN)) + (COND ((ZEROP1 COEF) (GETFNCOEFF (CDR A) FORM)) + ((AND (MATANP NEWFN) (MEMQ '$%I VARLIST)) + (LET (($LOGARC T) ($LOGEXPAND '$ALL)) + (RPLACA A ($EXPAND (RESIMPLIFY (CAR A))))) + (GETFNCOEFF A FORM)) + ((AND (ALIKE1 (LEADOP NEWFN) (LEADOP FORM)) + (OR (ALIKE1 (LEADARG NEWFN) (LEADARG FORM)) + (AND (MLOGP NEWFN) + (LOGEQUIV FORM NEWFN)))) + (RATPL (RFORM COEF) + (PROG2 (RPLACA A 0) + (GETFNCOEFF (CDR A) FORM)))) + ((DO VL VARLIST (CDR VL) (NULL VL) + (AND (NOT (ATOM (CAR VL))) + (ALIKE1 (LEADOP (CAR VL)) (LEADOP NEWFN)) + (IF (MLOGP NEWFN) + (LOGEQUIV (CAR VL) NEWFN) + (ALIKE1 (CAR VL) NEWFN)) + (RPLACA (CDDAR A) (CAR VL)) + (RETURN NIL)))) + ((LET (VLIST) (NEWVAR1 (CAR A)) (NULL VLIST)) + (SETQ CARY + (RATPL (CDR (RATREP* (CAR A))) + CARY)) + (RPLACA A 0) + (GETFNCOEFF (CDR A) FORM)) + ((AND LIFLAG + (MLOGP FORM) + (MLOGP NEWFN)) + (PUSH (DILOG (CONS (CAR A) FORM)) LIANS) + (RPLACA A 0) + (GETFNCOEFF (CDR A) FORM)) + ((AND LIFLAG + (POLYLOGP FORM) + (MLOGP NEWFN) + (LOGEQUIV FORM NEWFN)) + (PUSH (MUL* (CADAR A) (MAKE-LI (1+ (CAR (SUBFUNSUBS FORM))) + (LEADARG FORM))) + LIANS) + (RPLACA A 0) + (GETFNCOEFF (CDR A) FORM)) + (T (SETQ NOGOOD T) 0)))) + (T (RPLACA A (LIST '(MTIMES) 1 (CAR A))) + (GETFNCOEFF A FORM)))) + + +(DEFUN RISCHLOGPOLY (EXP) + (COND ((EQUAL EXP '(0 . 1)) (RISCHZERO)) + (EXPFLAG (PUSH (CONS 'POLY EXP) EXPINT) + (RISCHZERO)) + ((NOT (AMONG VAR EXP)) (TRYRISCH1 EXP MAINVAR)) + (T (DO ((DEGREE (PDEGREE (CAR EXP) VAR) (1- DEGREE)) + (P (CAR EXP)) + (DEN (CDR EXP)) + (LIANS ()) + (SUM (RZERO)) + (CARY (RZERO)) + (Y) (Z) (AK) (NOGOOD) (LBKPL1)) + ((MINUSP DEGREE) (CONS SUM (APPEND LIANS (CDR Y)))) + (SETQ AK (R- (RATQU (POLCOEF P DEGREE) DEN) + (R* (CONS (ADD1 DEGREE) 1) + CARY + (GET VAR 'RISCHDIFF)))) + (IF (NOT (PZEROP (POLCOEF P DEGREE))) + (SETQ P (IF (PCOEFP P) (PZERO) (PSIMP VAR (P-RED P))))) + (SETQ Y (TRYRISCH1 AK MAINVAR)) + (SETQ CARY (CAR Y)) + (AND (> DEGREE 0) (SETQ LIFLAG $LIFLAG)) + (SETQ Z (GETFNCOEFF (CDR Y) (GET VAR 'RISCHEXPR))) + (SETQ LIFLAG NIL) + (COND ((AND (GREATERP DEGREE 0) + (OR NOGOOD (FINDINT (CDR Y)))) + (RETURN (RISCHNOUN SUM (R+ (R* AK + (MAKE-POLY VAR DEGREE 1)) + (RATQU P DEN)))))) + (SETQ LBKPL1 (RATQU Z (CONS (1+ DEGREE) 1))) + (SETQ SUM (R+ (R* LBKPL1 (MAKE-POLY VAR (ADD1 DEGREE) 1)) + (R* CARY (IF (ZEROP DEGREE) 1 + (MAKE-POLY VAR DEGREE 1))) + SUM)))))) + +(DEFUN MAKE-LI (SUB ARG) + (SUBFUNMAKE '$LI (NCONS SUB) (NCONS ARG))) + +;integrates log(ro)^degree*log(rn)' in terms of polylogs +;finds constants c,d and integers j,k such that +;c*ro^j+d=rn^k If ro and rn are poly's then can assume either j=1 or k=1 +(DEFUN DILOG (L) + (LET* ((((nil COEF NLOG) . OLOG) L) + (NARG (REMABS (CADR NLOG))) + (VARLIST VARLIST) + (GENVAR GENVAR) + (RN (RFORM NARG)) + (RO (RFORM (CADR OLOG))) + (VAR (CAAR RO)) + ((J . K) (RATREDUCE (PDEGREE (CAR RN) VAR) (PDEGREE (CAR RO) VAR))) + (IDX (GENSYM)) + (RC) (RD)) + (COND ((AND (= J 1) (> K 1)) + (SETQ RN (RATEXPT RN K) + COEF (DIV COEF K) + NARG (RDIS RN))) + ((AND (= K 1) (> J 1)) + (SETQ RO (RATEXPT RO J) + COEF (DIV COEF (* J DEGREE)) + OLOG (MUL J OLOG)))) + (DESETQ (RC . RD) (RATDIVIDE RN RO)) + (COND ((AND (RISCH-CONSTP RC) + (RISCH-CONSTP RD)) + (SETQ NARG ($RATSIMP (SUB 1 (DIV NARG (RDIS RD))))) + (MUL* COEF (POWER -1 (1+ DEGREE)) + `((MFACTORIAL) ,DEGREE) + (DOSUM (MUL* (POWER -1 IDX) + (DIV* (POWER OLOG IDX) + `((MFACTORIAL) ,IDX)) + (MAKE-LI (ADD DEGREE (NEG IDX) 1) NARG)) + IDX 0 DEGREE T))) + (T (SETQ NOGOOD T) 0)))) + +(DEFUN EXPPOLYCONTROL (FLAG F A EXPG N) + (LET (Y L VAR (VARLIST VARLIST) (GENVAR GENVAR)) + (SETQ VARLIST (REVERSE (CDR (REVERSE VARLIST)))) + (SETQ VAR (GETRISCHVAR)) + (SETQ Y (GET VAR 'LEADOP)) + (COND ((AND (NOT (PZEROP (RATNUMERATOR F))) + (RISCH-CONSTP (SETQ L (RATQU A F)))) + (COND (FLAG + (LIST (R* L (CONS (LIST EXPG N 1) 1)) 0)) + (T L))) + ((EQ Y INTVAR) + (RISCHEXPVAR NIL FLAG (LIST F A EXPG N))) + (T (RISCHEXPLOG (EQ Y 'MEXPT) FLAG F A + (LIST EXPG N (GET VAR 'RISCHARG) + VAR (GET VAR 'RISCHDIFF))))))) + +(DEFUN RISCHEXPPOLY (EXPINT VAR) + (LET (Y W NUM DENOM TYPE (ANS (RISCHZERO)) + (EXPDIFF (RATQU (GET VAR 'RISCHDIFF) (LIST VAR 1 1)))) + (DO ((EXPINT EXPINT (CDR EXPINT))) + ((NULL EXPINT) ANS) + (DESETQ (TYPE . Y) (CAR EXPINT)) + (DESETQ (NUM . DENOM) (RATFIX Y)) + (COND ((EQ TYPE 'NEG) + (SETQ W (EXPPOLYCONTROL T + (R* (MINUS (CADR DENOM)) + EXPDIFF) + (RATQU NUM (CADDR DENOM)) + VAR + (MINUS (CADR DENOM))))) + ((OR (NUMBERP NUM) (NOT (EQ (CAR NUM) VAR))) + (SETQ W (TRYRISCH1 Y MAINVAR))) + (T (SETQ W (RISCHZERO)) + (DO NUM (CDR NUM) (CDDR NUM) (NULL NUM) + (COND ((EQUAL (CAR NUM) 0) + (SETQ W (RISCHADD + (TRYRISCH1 (RATQU (CADR NUM) DENOM) MAINVAR) + W))) + (T (SETQ W (RISCHADD (EXPPOLYCONTROL + T + (R* (CAR NUM) EXPDIFF) + (RATQU (CADR NUM) DENOM) + VAR + (CAR NUM)) + W))))))) + (SETQ ANS (RISCHADD W ANS))))) + +(DEFUN RISCHEXPVAR (EXPEXPFLAG FLAG L) + (PROG (LCM Y M P ALPHAR BETA GAMMA DELTA R S + TT DENOM K WL WV I YTEMP TTEMP YALPHA F A EXPG N YN YD) + (DESETQ (F A EXPG N) L) + (COND ((OR (PZEROP A) (PZEROP (CAR A))) + (RETURN (COND ((NULL FLAG) (RZERO)) + (T (RISCHZERO)))))) + (SETQ DENOM (RATDENOMINATOR F)) + (SETQ P (FINDPR (CDR (PARTFRAC A MAINVAR)) + (CDR (PARTFRAC F MAINVAR)))) + (SETQ LCM (PLCM (RATDENOMINATOR A) P)) + (SETQ Y (RATPL (SPDERIVATIVE (CONS 1 P) MAINVAR) + (RATQU F P))) + (SETQ LCM (PLCM LCM (RATDENOMINATOR Y))) + (SETQ R (CAR (RATQU LCM P))) + (SETQ S (CAR (R* LCM Y))) + (SETQ TT (CAR (R* A LCM))) + (SETQ BETA (PDEGREE R MAINVAR)) + (SETQ GAMMA (PDEGREE S MAINVAR)) + (SETQ DELTA (PDEGREE TT MAINVAR)) + (SETQ ALPHAR (MAX (DIFFERENCE (ADD1 DELTA) BETA) + (DIFFERENCE DELTA GAMMA))) + (SETQ M 0) + (COND ((EQUAL (SUB1 BETA) GAMMA) + (SETQ Y (R* -1 + (RATQU (POLCOEF S GAMMA) + (POLCOEF R BETA)))) + (AND (EQUAL (CDR Y) 1) + (NUMBERP (CAR Y)) + (SETQ M (CAR Y))))) + (SETQ ALPHAR (MAX ALPHAR M)) + (IF (MINUSP ALPHAR) + (RETURN (IF FLAG (CXERFARG (RZERO) EXPG N A) NIL))) + (COND ((NOT (AND (EQUAL ALPHAR M) (NOT (ZEROP M)))) + (GO DOWN2))) + (SETQ K (PLUS ALPHAR BETA -2)) + (SETQ WL NIL) + L2 (SETQ WV (LIST (CONS (POLCOEF TT K) 1))) + (SETQ I ALPHAR) + L1 (SETQ WV + (CONS (R+ (R* (CONS I 1) + (POLCOEF R (PLUS K 1 (MINUS I)))) + (CONS (POLCOEF S (PLUS K (MINUS I))) 1)) + WV)) + (SETQ I (SUB1 I)) + (COND ((GREATERP I -1) (GO L1))) + (SETQ WL (CONS WV WL)) + (SETQ K (SUB1 K)) + (COND ((GREATERP K -1) (GO L2))) + (SETQ Y (LSA WL)) + (IF (OR (EQ Y 'SINGULAR) (EQ Y 'INCONSISTENT)) + (COND ((NULL FLAG) (RETURN NIL)) + (T (RETURN (CXERFARG (RZERO) EXPG N A))))) + (SETQ K 0) + (SETQ LCM 0) + (SETQ Y (CDR Y)) + L3 (SETQ LCM + (R+ (R* (CAR Y) (PEXPT (LIST MAINVAR 1 1) K)) + LCM)) + (SETQ K (ADD1 K)) + (SETQ Y (CDR Y)) + (COND ((NULL Y) + (RETURN (COND ((NULL FLAG) (RATQU LCM P)) + (T (LIST (R* (RATQU LCM P) + (CONS (LIST EXPG N 1) 1)) + 0)))))) + (GO L3) + DOWN2(COND ((GREATERP (SUB1 BETA) GAMMA) + (SETQ K (PLUS ALPHAR (SUB1 BETA))) + (SETQ DENOM '(RATTI ALPHAR (POLCOEF R BETA) T))) + ((LESSP (SUB1 BETA) GAMMA) + (SETQ K (PLUS ALPHAR GAMMA)) + (SETQ DENOM '(POLCOEF S GAMMA))) + (T (SETQ K (PLUS ALPHAR GAMMA)) + (SETQ DENOM + '(RATPL (RATTI ALPHAR (POLCOEF R BETA) T) + (POLCOEF S GAMMA))))) + (SETQ Y 0) + LOOP (SETQ YN (POLCOEF (RATNUMERATOR TT) K) + YD (R* (RATDENOMINATOR TT) ;DENOM MAY BE 0 + (COND ((ZEROP ALPHAR) (POLCOEF S GAMMA)) + (T (EVAL DENOM))) )) + (COND ((RZEROP YD) + (COND ((PZEROP YN) (SETQ K (1- K) ALPHAR (1- ALPHAR)) + (GO LOOP)) ;need more constraints? + (T (COND + ((NULL FLAG) (RETURN NIL)) + (T (RETURN (CXERFARG (RZERO) EXPG N A))))))) + (T (SETQ YALPHA (RATQU YN YD)))) + (SETQ YTEMP (R+ Y (R* YALPHA + (CONS (LIST MAINVAR ALPHAR 1) 1) ))) + (SETQ TTEMP (R- TT (R* YALPHA + (R+ (R* S (CONS (LIST MAINVAR ALPHAR 1) 1)) + (R* R ALPHAR + (LIST MAINVAR (SUB1 ALPHAR) 1)))))) + (SETQ K (SUB1 K)) + (SETQ ALPHAR (SUB1 ALPHAR)) + (COND + ((LESSP ALPHAR 0) + (COND + ((RZEROP TTEMP) + (COND + ((NULL FLAG) (RETURN (RATQU YTEMP P))) + (T (RETURN (LIST (RATQU (R* YTEMP (CONS (LIST EXPG N 1) 1)) + P) + 0))))) + ((NULL FLAG) (RETURN NIL)) + ((AND (RISCH-CONSTP (SETQ TTEMP (RATQU TTEMP LCM))) + $ERFFLAG + (EQUAL (PDEGREE (CAR (GET EXPG 'RISCHARG)) MAINVAR) 2) + (EQUAL (PDEGREE (CDR (GET EXPG 'RISCHARG)) MAINVAR) 0)) + (RETURN (LIST (RATQU (R* YTEMP (CONS (LIST EXPG N 1) 1)) P) + (ERFARG2 (R* N (GET EXPG 'RISCHARG)) TTEMP)))) + (T (RETURN + (CXERFARG + (RATQU (R* Y (CONS (LIST EXPG N 1) 1)) P) + EXPG + N + (RATQU TT LCM))))))) + (SETQ Y YTEMP) + (SETQ TT TTEMP) + (GO LOOP))) + + +;; *JM should be declared as an array, although it is not created +;; by this file. -- cwh + +(DEFUN LSA (MM) + (PROG (D *MOSESFLAG M M2) + (SETQ D (LENGTH (CAR MM))) + ;; MTOA stands for MATRIX-TO-ARRAY. An array is created and + ;; associated functionally with the symbol *JM. The elements + ;; of the array are initialized from the matrix MM. + (MTOA '*JM (LENGTH MM) D MM) + (SETQ M (TFGELI '*JM (LENGTH MM) D)) + (COND ((OR (AND (NULL (CAR M)) (NULL (CADR M))) + (AND (CAR M) + (> (LENGTH (CAR M)) (- (LENGTH MM) (1- D))))) + (RETURN 'SINGULAR)) + ((CADR M) (RETURN 'INCONSISTENT))) + (SETQ *MOSESFLAG T) + (PTORAT '*JM (1- D) D) + (SETQ M2 (XRUTOUT '*JM (1- D) D NIL NIL)) + (SETQ M2 (LSAFIX (CDR M2) (CADDR M))) + (*REARRAY '*JM) + (RETURN M2))) + +(DEFUN LSAFIX (L N) + (DO ((N N (CDR N)) + (L L (CDR L))) + ((NULL L)) + (STORE (*JM 1 (CAR N)) (CAR L))) + (DO ((S (LENGTH L) (1- S)) + (ANS)) + ((= S 0) (CONS '(LIST) ANS)) + (SETQ ANS (CONS (*JM 1 S) ANS)))) + + +(DEFUN FINDPR (ALIST FLIST &AUX (P 1) ALPHAR FTERM) + (DO ALIST ALIST (CDR ALIST) (NULL ALIST) + (SETQ FTERM (FINDFLIST (CADAR ALIST) FLIST)) + (IF FTERM (SETQ FLIST (REMQ Y FLIST 1))) + (SETQ ALPHAR + (COND ((NULL FTERM) (CADDAR ALIST)) + ((EQUAL (CADDR FTERM) 1) + (FPR-DIF (CAR FLIST) (CADDAR ALIST))) + (T (MAX (- (CADDAR ALIST) (CADDR FTERM)) 0)))) + (IF (NOT (ZEROP ALPHAR)) + (SETQ P (PTIMES P (PEXPT (CADAR ALIST) ALPHAR))))) + (DO FLIST FLIST (CDR FLIST) (NULL FLIST) + (WHEN (EQUAL (CADDAR FLIST) 1) + (SETQ ALPHAR (FPR-DIF (CAR FLIST) 0)) + (SETQ P (PTIMES P (PEXPT (CADAR FLIST) ALPHAR))))) + P) + +(DEFUN FPR-DIF (FTERM ALPHA) + (LET* (((NUM DEN MULT) FTERM) + (M (SPDERIVATIVE DEN MAINVAR)) + (N)) + (COND ((RZEROP M) ALPHA) + (T (SETQ N (RATQU (CDR (RATDIVIDE NUM DEN)) + M)) + (IF (AND (EQUAL (CDR N) 1) (NUMBERP (CAR N))) + (MAX (CAR N) ALPHA) + ALPHA))))) + +(DEFUN FINDFLIST (A LIST) (COND ((NULL LIST) NIL) + ((EQUAL (CADAR LIST) A) (CAR LIST)) + (T (FINDFLIST A (CDR LIST))))) + + +(DEFUN RISCHEXPLOG (EXPEXPFLAG FLAG F A L) + (PROG (LCM Y YY M P ALPHAR BETA GAMMA DELTA + MU R S TT DENOM YMU RBETA EXPG N ETA LOGETA LOGDIFF + TEMP CARY NOGOOD VECTOR ARRAY RMU RRMU RARRAY) + (DESETQ (EXPG N ETA LOGETA LOGDIFF) L) + (COND ((OR (PZEROP A) (PZEROP (CAR A))) + (RETURN (COND ((NULL FLAG) (RZERO)) + (T (RISCHZERO)))))) + (SETQ P (FINDPR (CDR (PARTFRAC A VAR)) (CDR (PARTFRAC F VAR)))) + (SETQ LCM (PLCM (RATDENOMINATOR A) P)) + (SETQ Y (RATPL (SPDERIVATIVE (CONS 1 P) MAINVAR) + (RATQU F P))) + (SETQ LCM (PLCM LCM (RATDENOMINATOR Y))) + (SETQ R (CAR (RATQU LCM P))) + (SETQ S (CAR (R* LCM Y))) + (SETQ TT (CAR (R* A LCM))) + (SETQ BETA (PDEGREE R VAR)) + (SETQ GAMMA (PDEGREE S VAR)) + (SETQ DELTA (PDEGREE TT VAR)) + (COND (EXPEXPFLAG (SETQ MU (MAX (- DELTA BETA) + (- DELTA GAMMA))) + (GO EXPCASE))) + (SETQ MU (MAX (- (1+ DELTA) BETA) + (- (1+ DELTA) GAMMA))) + (COND ((< BETA GAMMA) (GO BACK)) + ((= (SUB1 BETA) GAMMA) (GO DOWN1))) + (SETQ Y (TRYRISCH1 (RATQU (R- (R* (POLCOEF R (1- BETA)) + (POLCOEF S GAMMA)) + (R* (POLCOEF R BETA) + (POLCOEF S (1- GAMMA)))) + (R* (POLCOEF R BETA) + (POLCOEF R BETA) )) + MAINVAR)) + (SETQ CARY (CAR Y)) + (SETQ YY (GETFNCOEFF (CDR Y) (GET VAR 'RISCHEXPR))) + (COND ((AND (NOT (FINDINT (CDR Y))) + (NOT NOGOOD) + (NOT (ATOM YY)) + (EQUAL (CDR YY) 1) + (NUMBERP (CAR YY)) + (GREATERP (CAR YY) MU)) + (SETQ MU (CAR YY)))) + (GO BACK) + EXPCASE + (COND ((NOT (EQUAL BETA GAMMA)) (GO BACK))) + (SETQ Y (TRYRISCH1 (RATQU (POLCOEF S GAMMA) (POLCOEF R BETA)) + MAINVAR)) + (COND ((FINDINT (CDR Y)) (GO BACK))) + (SETQ YY (RATQU (R* -1 (CAR Y)) ETA)) + (COND ((AND (EQUAL (CDR YY) 1) + (NUMBERP (CAR YY)) + (GREATERP (CAR YY) MU)) + (SETQ MU (CAR YY)))) + (GO BACK) + DOWN1(SETQ Y (TRYRISCH1 (RATQU (POLCOEF S GAMMA) (POLCOEF R BETA)) + MAINVAR)) + (SETQ CARY (CAR Y)) + (SETQ YY (GETFNCOEFF (CDR Y) (GET VAR 'RISCHEXPR))) + (COND ((AND (NOT (FINDINT (CDR Y))) + (NOT NOGOOD) + (EQUAL (CDR YY) 1) + (NUMBERP (CAR YY)) + (GREATERP (MINUS (CAR YY)) MU)) + (SETQ MU (MINUS (CAR YY))))) + BACK (IF (MINUSP MU) + (RETURN (IF FLAG (CXERFARG (RZERO) EXPG N A) NIL))) + (COND ((> BETA GAMMA)(GO LSACALL)) + ((= BETA GAMMA) + (GO RECURSE))) + (SETQ DENOM (POLCOEF S GAMMA)) + (SETQ Y '(0 . 1)) + LINEARLOOP + (SETQ YMU (RATQU (POLCOEF (RATNUMERATOR TT) (+ MU GAMMA)) + (R* (RATDENOMINATOR TT) DENOM))) + (SETQ Y (R+ Y (SETQ YMU (R* YMU (PEXPT (LIST LOGETA 1 1) MU) )))) + (SETQ TT (R- TT + (R* S YMU) + (R* R (SPDERIVATIVE YMU MAINVAR)))) + (SETQ MU (1- MU)) + (COND + ((NOT (< MU 0)) (GO LINEARLOOP)) + ((NOT FLAG) (RETURN (COND ((RZEROP TT) (RATQU Y P)) (T NIL)))) + ((RZEROP TT) + (RETURN (CONS (RATQU (R* Y (CONS (LIST EXPG N 1) 1)) P) '(0)))) + (T (RETURN (CXERFARG (RATQU (R* Y (CONS (LIST EXPG N 1) 1)) P) + EXPG + N + (RATQU TT LCM))))) + RECURSE + (SETQ RBETA (POLCOEF R BETA)) + (SETQ Y '(0 . 1)) + RECURSELOOP + (SETQ F (R+ (RATQU (POLCOEF S GAMMA) RBETA) + (COND (EXPEXPFLAG (R* MU (SPDERIVATIVE ETA MAINVAR))) + (T 0)))) + (SETQ YMU (EXPPOLYCONTROL NIL + F + (RATQU (POLCOEF (RATNUMERATOR TT) + (+ BETA MU)) + (R* (RATDENOMINATOR TT) RBETA)) + EXPG N)) + (COND + ((NULL YMU) + (RETURN + (COND + ((NULL FLAG) NIL) + (T (RETURN (CXERFARG (RATQU (R* Y (CONS (LIST EXPG N 1) 1)) P) + EXPG N (RATQU TT LCM)))))))) + (SETQ Y (R+ Y (SETQ YMU (R* YMU (PEXPT (LIST LOGETA 1 1) MU))))) + (SETQ TT (R- TT + (R* S YMU) + (R* R (SPDERIVATIVE YMU MAINVAR)))) + (SETQ MU (1- MU)) + (COND + ((NOT (< MU 0)) (GO RECURSELOOP)) + ((NOT FLAG) + (RETURN (COND ((RZEROP TT) (RATQU Y P)) (T NIL)))) + ((RZEROP TT) + (RETURN (CONS (RATQU (R* Y (CONS (LIST EXPG N 1) 1)) P) '(0)))) + (T (RETURN (CXERFARG (RATQU (R* Y (CONS (LIST EXPG N 1) 1)) P) + EXPG + N + (RATQU TT LCM))))) + LSACALL + (SETQ RRMU MU) + MULOOP + (SETQ TEMP (R* (RATEXPT (CONS (LIST LOGETA 1 1) 1) (1- MU)) + (R+ (R* S (CONS (LIST LOGETA 1 1) 1)) + (R* MU R LOGDIFF )))) + MU1 (SETQ VECTOR NIL) + (SETQ RMU (+ RRMU BETA)) + RMULOOP + (SETQ VECTOR (CONS (RATQU (POLCOEF (RATNUMERATOR TEMP) RMU) + (RATDENOMINATOR TEMP)) VECTOR)) + (SETQ RMU (1- RMU)) + (COND ((NOT (< RMU 0)) (GO RMULOOP))) + (SETQ MU (1- MU)) + (SETQ ARRAY (APPEND ARRAY (LIST (REVERSE VECTOR)))) + (COND ((NOT (< MU 0)) (GO MULOOP)) + ((EQUAL MU -2) (GO SKIPMU))) + (SETQ TEMP TT) + (GO MU1) + SKIPMU + (SETQ RARRAY NIL) + ARRAYLOOP + (SETQ VECTOR NIL) + (SETQ VECTOR (MAPCAR 'CAR ARRAY)) + (SETQ ARRAY (MAPCAR 'CDR ARRAY)) + (SETQ RARRAY (APPEND RARRAY (LIST VECTOR))) + (COND ((NOT (NULL (CAR ARRAY))) (GO ARRAYLOOP))) + (SETQ RMU (1+ RRMU)) + (SETQ VECTOR NIL) + ARRAY1LOOP + (SETQ VECTOR (CONS '(0 . 1) VECTOR)) + (SETQ RMU (1- RMU)) + (COND ((NOT (< RMU 0)) (GO ARRAY1LOOP))) + (SETQ ARRAY NIL) + ARRAY2LOOP + (COND ((EQUAL (CAR RARRAY) VECTOR) NIL) + (T (SETQ ARRAY (CONS (CAR RARRAY) ARRAY)))) + (SETQ RARRAY (CDR RARRAY)) + (COND (RARRAY (GO ARRAY2LOOP))) + (SETQ RARRAY (REVERSE ARRAY)) + (SETQ TEMP (LSA RARRAY)) + (COND ((OR (EQ TEMP 'SINGULAR) (EQ TEMP 'INCONSISTENT)) + (RETURN + (COND ((NULL FLAG) NIL) + (T (CXERFARG (RZERO) EXPG N A)))))) + (SETQ TEMP (CDR TEMP)) + (SETQ RMU 0) + (SETQ Y 0) + L3 (SETQ Y (R+ Y (R* (CAR TEMP) (PEXPT (LIST LOGETA 1 1) RMU)))) + (SETQ TEMP (CDR TEMP)) + (SETQ RMU (1+ RMU)) + (COND ((NOT (> RMU RRMU)) (GO L3))) + (RETURN (COND ((NULL FLAG) (RATQU Y P)) + (T (CONS (R* (LIST EXPG N 1) (RATQU Y P)) '(0))))))) + + +(DEFUN ERFARG (EXPARG COEF) + (PROG (NUM DENOM ERFARG) + (SETQ EXPARG (R- EXPARG)) + (UNLESS (AND (SETQ NUM (PNTHROOTP (RATNUMERATOR EXPARG) 2)) + (SETQ DENOM (PNTHROOTP (RATDENOMINATOR EXPARG) 2))) + (RETURN NIL)) + (SETQ ERFARG (CONS NUM DENOM)) + (IF (RISCH-CONSTP + (SETQ COEF (RATQU COEF (SPDERIVATIVE ERFARG MAINVAR)))) + (RETURN (SIMPLIFY `((MTIMES) ((RAT) 1 2) + ((MEXPT) $%PI ((RAT) 1 2)) + ,(DISREP COEF) + ((%ERF) ,(DISREP ERFARG)))))))) + +(DEFUN ERFARG2 (EXPARG COEFF &AUX (VAR MAINVAR) A B C D) + (WHEN (AND (= (PDEGREE (CAR EXPARG) VAR) 2) + (EQ (CAAR EXPARG) VAR) + (RISCH-PCONSTP (CDR EXPARG)) + (RISCH-CONSTP COEFF)) + (SETQ A (RATQU (R* -1 (CADDAR EXPARG)) + (CDR EXPARG))) + (SETQ B (DISREP (RATQU (R* -1 (POLCOEF (CAR EXPARG) 1)) + (CDR EXPARG)))) + (SETQ C (DISREP (RATQU (R* (POLCOEF (CAR EXPARG) 0)) + (CDR EXPARG)))) + (SETQ D (RATSQRT A)) + (SETQ A (DISREP A)) + (SIMPLIFY `((MTIMES) + ((MTIMES) + ((MEXPT) $%E ((MPLUS) ,C + ((MQUOTIENT) ((MEXPT) ,B 2) + ((MTIMES) 4 ,A)))) + ((RAT) 1 2) + ,(DISREP COEFF) + ((MEXPT) ,D -1) + ((MEXPT) $%PI ((RAT) 1 2))) + ((%ERF) ((MPLUS) + ((MTIMES) ,D ,INTVAR) + ((MTIMES) ,B ((RAT) 1 2) ((MEXPT) ,D -1)))))))) + + +(DEFUN CXERFARG (ANS EXPG N NUMDENOM &AUX (ARG (R* N (GET EXPG 'RISCHARG))) + (FAILS 0)) + (PROG (DENOM ERFANS NUM NERF) + (DESETQ (NUM . DENOM) NUMDENOM) + (UNLESS $ERFFLAG (SETQ FAILS NUM) (GO LOSE)) + (IF (SETQ ERFANS (ERFARG ARG NUMDENOM)) + (RETURN (LIST ANS ERFANS))) + AGAIN (WHEN (AND (NOT (PCOEFP DENOM)) + (NULL (P-RED DENOM)) + (EQ (GET (CAR DENOM) 'LEADOP) 'MEXPT)) + (SETQ ARG (R+ ARG (R* (- (P-LE DENOM)) + (GET (P-VAR DENOM) 'RISCHARG))) + DENOM (P-LC DENOM)) + (GO AGAIN)) + (LOOP FOR (COEF EXPARG EXPPOLY) IN (EXPLIST NUM ARG 1) + DO (SETQ COEF (RATQU COEF DENOM) + NERF (OR (ERFARG2 EXPARG COEF) (ERFARG EXPARG COEF))) + (IF NERF (PUSH NERF ERFANS) (SETQ FAILS + (PPLUS FAILS EXPPOLY)))) + LOSE (RETURN + (IF (PZEROP FAILS) (CONS ANS ERFANS) + (RISCHADD (CONS ANS ERFANS) + (RISCHNOUN (R* (RATEXPT (CONS (MAKE-POLY EXPG) 1) N) + (RATQU FAILS (CDR NUMDENOM))))))))) + +(DEFUN EXPLIST (P OARG EXPS) + (COND ((OR (PCOEFP P) (NOT (EQ 'MEXPT (GET (P-VAR P) 'LEADOP)))) + (LIST (LIST P OARG (PTIMES P EXPS)))) + (T (LOOP WITH NARG = (GET (P-VAR P) 'RISCHARG) + FOR (EXP COEF) ON (P-TERMS P) BY 'PT-RED + NCONC (EXPLIST COEF + (R+ OARG (R* EXP NARG)) + (PTIMES EXPS + (MAKE-POLY (P-VAR P) EXP 1))))))) + + +(DECLARE (SPECIAL *FNEWVARSW)) + +(DEFUN INTSETUP (EXP *VAR) + (PROG (VARLIST CLIST $FACTORFLAG DLIST GENPAIRS OLD Y Z $RATFAC $KEEPFLOAT + *FNEWVARSW) + Y (SETQ EXP (RADCAN1 EXP)) + (FNEWVAR EXP) + (SETQ *FNEWVARSW T) + A (SETQ CLIST NIL) + (SETQ DLIST NIL) + (SETQ Z VARLIST) + UP (POP Z Y) + (COND ((FREEOF *VAR Y) (PUSH Y CLIST)) + ((EQ Y *VAR) NIL) + ((AND (MEXPTP Y) + (NOT (EQ (CADR Y) '$%E))) + (COND ((NOT (FREEOF *VAR (CADDR Y))) + (SETQ DLIST `((MEXPT SIMP) + $%E + ,(MUL2* (CADDR Y) + `((%LOG) ,(CADR Y))))) + (SETQ EXP (SUBSTITUTE DLIST Y EXP)) + (SETQ VARLIST NIL) (GO Y)) + ((ATOM (CADDR Y)) + (COND ((NUMBERP (CADDR Y)) (PUSH Y DLIST)) + (T (SETQ OPERATOR T)(RETURN NIL)))) + (T (PUSH Y DLIST)))) + (T (PUSH Y DLIST))) + (IF Z (GO UP)) + (IF (MEMQ '$%I CLIST) (SETQ CLIST (CONS '$%I (DELETE '$%I CLIST)))) + (SETQ VARLIST (APPEND CLIST + (CONS *VAR + (NREVERSE (SORT (APPEND DLIST NIL) 'INTGREAT))))) + (ORDERPOINTER VARLIST) + (SETQ OLD VARLIST) + (MAPC (FUNCTION INTSET1) (CONS *VAR DLIST)) + (COND ((ALIKE OLD VARLIST) (RETURN (RATREP* EXP))) + (T (GO A))))) + + +(DEFUN LEADOP (EXP) + (COND ((ATOM EXP) EXP) + ((MQAPPLYP EXP) (CADR EXP)) + (T (CAAR EXP)))) + +(DEFUN LEADARG (EXP) + (COND ((ATOM EXP) 0) + ((AND (MEXPTP EXP) (EQ (CADR EXP) '$%E)) (CADDR EXP)) + ((MQAPPLYP EXP) (CAR (SUBFUNARGS EXP))) + (T (CADR EXP)))) + +(DEFUN INTSET1 (B) + (LET (E C D) + (FNEWVAR + (SETQ D (IF (MEXPTP B) ;needed for radicals + `((MTIMES SIMP) + ,B + ,(RADCAN1 (SDIFF (SIMPLIFY (CADDR B)) *VAR))) + (RADCAN1 (SDIFF (SIMPLIFY B) *VAR))))) + (SETQ D (RATREP* D)) + (SETQ C (RATREP* (LEADARG B))) + (SETQ E (CDR (ASSOC B (PAIR VARLIST GENVAR)))) + (PUTPROP E (LEADOP B) 'LEADOP) + (PUTPROP E B 'RISCHEXPR) + (PUTPROP E (CDR D) 'RISCHDIFF) + (PUTPROP E (CDR C) 'RISCHARG))) + +(DEFUN INTGREAT (A B) + (COND ((AND (NOT (ATOM A)) (NOT (ATOM B))) + (COND ((AND (NOT (FREEOF '%ERF A)) (FREEOF '%ERF B)) T) + ((AND (NOT (FREEOF '$LI A)) (FREEOF '$LI B)) T) + ((AND (FREEOF '$LI A) (NOT (FREEOF '$LI B))) NIL) + ((AND (FREEOF '%ERF A) (NOT (FREEOF '%ERF B))) NIL) + ((NOT (FREE B A)) NIL) + ((NOT (FREE A B)) T) + (T (GREAT (RESIMPLIFY (FIXINTGREAT A)) + (RESIMPLIFY (FIXINTGREAT B)))))) + (T (GREAT (RESIMPLIFY (FIXINTGREAT A)) + (RESIMPLIFY (FIXINTGREAT B)))))) + +(DEFUN FIXINTGREAT (A) (SUBST '/_101X *VAR A)) + +(DECLARE (UNSPECIAL B BETA CARY CONTEXT *EXP DEGREE GAMMA GENVAR + KLTH LIFLAG M NOGOOD OPERATOR PROB + R S SIMP SWITCH SWITCH1 *VAR VAR VARLIST Y YYY)) + diff --git a/src/jm/simp.834 b/src/jm/simp.834 new file mode 100644 index 00000000..bcf05e4f --- /dev/null +++ b/src/jm/simp.834 @@ -0,0 +1,2130 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module simp) + +(DECLARE (SPECIAL EXPTRLSW RULESW $%E/_TO/_NUMLOG *INV* SUBSTP + $%EMODE $RADEXPAND TIMESINP *CONST* LIMITP + PRODS NEGPRODS SUMS NEGSUMS EXPANDP $DOMAIN $LISTARITH + $LOGSIMP $LOGEXPAND $LOGNUMER $LOGNEGINT $M1PBRANCH + EXPANDFLAG $MAPERROR $SCALARMATRIXP NOUNL + DERIVFLAG $RATSIMPEXPONS $KEEPFLOAT $RATPRINT + $DEMOIVRE *ZEXPTSIMP? %E-VAL %PI-VAL FMAPLVL + BIGFLOATZERO BIGFLOATONE $ASSUMESCALAR $SUBNUMSIMP + OPERS-LIST *OPERS-LIST WFLAG $DONTFACTOR *N + *OUT *IN VARLIST GENVAR $FACTORFLAG RADCANP) + (*EXPR PSQUOREM1 PNTHROOTP) + (*LEXPR FMAPL1 $LIMIT OUTERMAP1 $RATSIMP $EXPAND) + (FIXNUM FMAPLVL L1 L2 XN NARGS I (SIGNUM1)) + (NOTYPE N) + (GENPREFIX SM) + (MUZZLED T)) + +;; General purpose simplification and conversion switches. + +(DEFMVAR $FLOAT NIL + "Causes non-integral rational numbers to be converted to + floating point." + EVFLAG + SEE-ALSO $NUMER) + +(DEFMVAR $NEGDISTRIB T + "Causes negations to be distributed over sums, e.g. -(A+B) is + simplified to -A-B.") + +(DEFMVAR $NUMER NIL + "Causes some mathematical functions (including exponentiation) + with numerical arguments to be evaluated in floating point. + It causes variables in an expression which have been given + NUMERVALs to be replaced by their values. It also turns + on the FLOAT switch." + SEE-ALSO ($NUMERVAL $FLOAT)) + +(DEFMVAR $SIMP T "Enables simplification.") + +(DEFMVAR $SUMEXPAND NIL + "If TRUE, products of sums and exponentiated sums go into nested + sums.") + +(DEFMVAR $NUMER_PBRANCH NIL) + +;; Switches dealing with matrices and non-commutative multiplication. + +(DEFMVAR $DOSCMXPLUS NIL + "Causes SCALAR + MATRIX to return a matrix answer. This switch + is not subsumed under DOALLMXOPS.") + +(DEFMVAR $DOMXEXPT T + "Causes SCALAR^MATRIX([1,2],[3,4]) to return + MATRIX([SCALAR,SCALAR^2],[SCALAR^3,SCALAR^4]). In general, this + transformation affects exponentiations where the base is a scalar + and the power is a matrix or list.") + +(DEFMVAR $DOMXPLUS NIL) + +(DEFMVAR $DOMXTIMES NIL) + +(DEFMVAR $MX0SIMP T) + +;; Switches dealing with expansion. + +(DEFMVAR $EXPOP 0 + "The largest positive exponent which will be automatically + expanded. (X+1)^3 will be automatically expanded if + EXPOP is greater than or equal to 3." + FIXNUM + SEE-ALSO ($EXPON $MAXPOSEX $EXPAND)) + +(DEFMVAR $EXPON 0 + "The largest negative exponent which will be automatically + expanded. (X+1)^(-3) will be automatically expanded if + EXPON is greater than or equal to 3." + FIXNUM + SEE-ALSO ($EXPOP $MAXNEGEX $EXPAND)) + +(DEFMVAR $MAXPOSEX 1000. + "The largest positive exponent which will be expanded by + the EXPAND command." + FIXNUM + SEE-ALSO ($MAXNEGEX $EXPOP $EXPAND)) + +(DEFMVAR $MAXNEGEX 1000. + "The largest negative exponent which will be expanded by + the EXPAND command." + FIXNUM + SEE-ALSO ($MAXPOSEX $EXPON $EXPAND)) + +;; Lisp level variables + +(DEFMVAR DOSIMP NIL + "Causes SIMP flags to be ignored. $EXPAND works by binding + $EXPOP to $MAXPOSEX, $EXPON to $MAXNEGEX, and DOSIMP to T.") + +(DEFMVAR ERRORSW NIL + "Causes a throw to the tag ERRORSW when certain errors occur + rather than the printing of a message. Kludgy substitute for + error signalling.") + +(DEFMVAR DERIVSIMP T "Hack in SIMPDERIV for RWG") + +;; The following SETQs should be replaced with DEFMVARS in the correct places. + +(SETQ $ROOTSEPSILON 1.0E-7 $/%RNUM 0 + $GRINDSWITCH NIL $ALGEPSILON 100000000. $ALGDELTA 1.0E-5) + +(PROG2 (SETQ $LISTARITH T WFLAG NIL $LOGNUMER NIL EXPANDP NIL $DOMAIN '$REAL + $M1PBRANCH NIL $%E/_TO/_NUMLOG NIL $%EMODE T TIMESINP NIL + $TRUE T $FALSE NIL $ON T $OFF NIL %E-VAL (MGET '$%E '$NUMER) + %PI-VAL (MGET '$%PI '$NUMER) $LOGABS NIL $LOGNEGINT NIL + DERIVFLAG NIL $RATSIMPEXPONS NIL EXPTRLSW NIL $LOGEXPAND T + EXPANDFLAG NIL $RADEXPAND T *ZEXPTSIMP? NIL $SUBNUMSIMP NIL + RISCHPF NIL $LIMITDOMAIN '$COMPLEX $LOGSIMP T +; $MATCHIDENT T $MATCHASSOC T $MATCHCOMM T $MATCHCRE NIL + RISCHP NIL RP-POLYLOGP NIL *CONST* 0) + (MAPC #'(LAMBDA (X) (MPUTPROP X T '$CONSTANT) (PUTPROP X T 'SYSCONST)) + '($%PI $%I $%E $%PHI $INF $MINF $INFINITY %I $%GAMMA))) + +(DEFPROP MNCTIMES T ASSOCIATIVE) +(DEFPROP LAMBDA T LISP-NO-SIMP) + +(DOLIST (X '(MPLUS MTIMES MNCTIMES MEXPT MNCEXPT %SUM)) + (PUTPROP X (CONS X '(SIMP)) 'MSIMPIND)) + +(PROG1 '(OPERATORS properties) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPERATORS)) + '((MPLUS SIMPLUS) (MTIMES SIMPTIMES) (MNCEXPT SIMPNCEXPT) + (MMINUS SIMPMIN) (%GAMMA SIMPGAMMA) (MFACTORIAL SIMPFACT) + (MNCTIMES SIMPNCT) (MQUOTIENT SIMPQUOT) (MEXPT SIMPEXPT) + (%LOG SIMPLN) (%SQRT SIMPSQRT) (%DERIVATIVE SIMPDERIV) + (MABS SIMPABS) (%SIGNUM SIMPSIGNUM) + (%INTEGRATE SIMPINTEG) (%LIMIT SIMP-LIMIT) ($EXP SIMPEXP) + (BIGFLOAT SIMPBIGFLOAT) (LAMBDA SIMPLAMBDA) (MDEFINE SIMPMDEF) + (MQAPPLY SIMPMQAPPLY) (%GAMMA SIMPGAMMA) (%ERF SIMPERF) + ($BETA SIMPBETA) (%SUM SIMPSUM) (%BINOMIAL SIMPBINOCOEF) + (%PLOG SIMPPLOG) (%PRODUCT SIMPPROD) (%GENFACT SIMPGFACT) + ($ATAN2 SIMPATAN2) ($MATRIX SIMPMATRIX) (%MATRIX SIMPMATRIX) + ($BERN SIMPBERN) ($EULER SIMPEULER)))) + +(DEFPROP $LI LISIMP SPECSIMP) +(DEFPROP $PSI PSISIMP SPECSIMP) + +(DEFPROP $EQUAL T BINARY) +(DEFPROP $NOTEQUAL T BINARY) + +;; The following definitions of ONEP and ONEP1 are bummed for speed, and should +;; be moved to a special place for implementation dependent code. +;; ONEP is the same as (EQUAL A 1), but does the check inline rather than +;; calling EQUAL (uses more instructions, so this isn't done by default). ONEP +;; seems to be used very rarely, so it seems hardly worth the effort. On the +;; Lisp Machine, this is probably more efficient as simply (EQUAL A 1). + +(DEFMFUN ONEP (A) (AND (EQ (TYPEP A) 'FIXNUM) (= A 1))) + +#-Franz +(DEFMFUN ONEP1 (A) (OR (EQUAL A 1) (EQUAL A 1.0) (EQUAL A BIGFLOATONE))) + +#+Franz +(DEFUN ONEP1 (A) + (LET ((TYPE (TYPEP A))) + (COND ((EQ TYPE 'FIXNUM) (EQUAL A 1)) + ((EQ TYPE 'FLONUM) (EQUAL A 1.0)) + ((EQ TYPE 'LISPT) (EQUAL A BIGFLOATONE))))) + +(DEFMFUN ZEROP1 (A) (IF (NUMBERP A) (ZEROP A) (ALIKE1 A BIGFLOATZERO))) + +(DEFMFUN $BFLOATP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'BIGFLOAT))) + +(DEFMFUN MNUMP (X) + (OR (NUMBERP X) (AND (NOT (ATOM X)) (MEMQ (CAAR X) '(RAT BIGFLOAT))))) + +;; EVEN works for any arbitrary lisp object since it does an integer +;; check first. In other cases, you may want the Lisp EVENP function +;; which only works for integers. + +(DEFMFUN EVEN (A) (AND (FIXP A) (NOT (ODDP A)))) + +(DEFMFUN RATNUMP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'RAT))) + +(DEFMFUN MPLUSP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MPLUS))) + +(DEFMFUN MTIMESP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MTIMES))) + +(DEFMFUN MEXPTP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MEXPT))) + +(DEFMFUN MNCTIMESP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MNCTIMES))) + +(DEFMFUN MNCEXPTP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MNCEXPT))) + +(DEFMFUN MLOGP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) '%LOG))) + +(DEFMFUN MMMINUSP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MMINUS))) + +(DEFMFUN MNEGP (X) (COND ((NUMBERP X) (MINUSP X)) + ((OR (RATNUMP X) ($BFLOATP X)) (MINUSP (CADR X))))) + +(DEFMFUN MQAPPLYP (E) (AND (NOT (ATOM E)) (EQ (CAAR E) 'MQAPPLY))) + +(DEFMFUN RATDISREP (E) (SIMPLIFYA ($RATDISREP E) NIL)) + +(DEFMFUN SRATSIMP (E) (SIMPLIFYA ($RATSIMP E) NIL)) + +(DEFMFUN SIMPCHECK (E FLAG) + (COND ((SPECREPP E) (SPECDISREP E)) (FLAG E) (T (SIMPLIFYA E NIL)))) + +(DEFMFUN MRATCHECK (E) (IF ($RATP E) (RATDISREP E) E)) + +(DEFMFUN $NUMBERP (E) (OR ($RATNUMP E) ($FLOATNUMP E) ($BFLOATP E))) + +(DEFMFUN $INTEGERP (X) + (OR (FIXP X) + (AND ($RATP X) (FIXP (CADR X)) (EQUAL (CDDR X) 1)))) + +;; The call to $INTEGERP in the following two functions checks for a CRE +;; rational number with an integral numerator and a unity denominator. + +(DEFMFUN $ODDP (X) + (COND ((FIXP X) (ODDP X)) + (($INTEGERP X) (ODDP (CADR X))))) + +(DEFMFUN $EVENP (X) + (COND ((FIXP X) (EVENP X)) + (($INTEGERP X) (NOT (ODDP (CADR X)))))) + +(DEFMFUN $FLOATNUMP (X) + (OR (FLOATP X) + (AND ($RATP X) (FLOATP (CADR X)) (ONEP1 (CDDR X))))) + +(DEFMFUN $RATNUMP (X) + (OR (FIXP X) + (RATNUMP X) + (AND ($RATP X) (FIXP (CADR X)) (FIXP (CDDR X))))) + +(DEFMFUN $RATP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MRAT))) + +(DEFMFUN SPECREPCHECK (E) (IF (SPECREPP E) (SPECDISREP E) E)) + +;; Note that the following two functions are carefully coupled. + +(DEFMFUN SPECREPP (E) (AND (NOT (ATOM E)) (MEMQ (CAAR E) '(MRAT MPOIS)))) + +(DEFMFUN SPECDISREP (E) + (COND ((EQ (CAAR E) 'MRAT) (RATDISREP E)) +; ((EQ (CAAR E) 'MPOIS) ($OUTOFPOIS E)) + (T ($OUTOFPOIS E)))) + +(DEFMFUN $POLYSIGN (X) (SETQ X (CADR (RATF X))) + (COND ((EQUAL X 0) 0) ((PMINUSP X) -1) (T 1))) + +;; These check for the correct number of operands within Macsyma expressions, +;; not arguments in a procedure call as the name may imply. + +(DEFMFUN ONEARGCHECK (L) + (IF (OR (NULL (CDR L)) (CDDR L)) (WNA-ERR (CAAR L)))) + +(DEFMFUN TWOARGCHECK (L) + (IF (OR (NULL (CDDR L)) (CDDDR L)) (WNA-ERR (CAAR L)))) + +(DEFMFUN WNA-ERR (OP) (MERROR "Wrong number of arguments to ~:@M" OP)) + +(DEFMFUN IMPROPER-ARG-ERR (EXP FN) + (MERROR "Improper argument to ~:M:~%~M" FN EXP)) + +(DEFMFUN SUBARGCHECK (FORM SUB/# ARG/# FUN) + (IF (OR (NOT (= (LENGTH (SUBFUNSUBS FORM)) SUB/#)) + (NOT (= (LENGTH (SUBFUNARGS FORM)) ARG/#))) + (MERROR "Wrong number of arguments or subscripts to ~:@M" FUN))) + +;; Constructor and extractor primitives for subscripted functions, e.g. +;; F[1,2](X,Y). SUBL is (1 2) and ARGL is (X Y). + +;; These will be flushed when NOPERS is finished. They will be macros in +;; NOPERS instead of functions, so we have to be careful that they aren't +;; mapped or applied anyplace. What we really want is open-codable routines. + +(DEFMFUN SUBFUNMAKES (FUN SUBL ARGL) + `((MQAPPLY SIMP) ((,FUN SIMP ARRAY) . ,SUBL) . ,ARGL)) + +(DEFMFUN SUBFUNMAKE (FUN SUBL ARGL) + `((MQAPPLY) ((,FUN SIMP ARRAY) . ,SUBL) . ,ARGL)) + +(DEFMFUN SUBFUNNAME (EXP) (CAAADR EXP)) + +(DEFMFUN SUBFUNSUBS (EXP) (CDADR EXP)) + +(DEFMFUN SUBFUNARGS (EXP) (CDDR EXP)) + +(DEFMFUN $NUMFACTOR (X) + (SETQ X (SPECREPCHECK X)) + (COND ((MNUMP X) X) + ((ATOM X) 1) + ((NOT (EQ (CAAR X) 'MTIMES)) 1) + ((MNUMP (CADR X)) (CADR X)) + (T 1))) + +(DEFUN SCALAR-OR-CONSTANT-P (X FLAG) + (IF FLAG (NOT ($NONSCALARP X)) ($SCALARP X))) + +(DEFMFUN $CONSTANTP (X) + (COND ((ATOM X) (OR ($NUMBERP X) (MGET X '$CONSTANT))) + ((MEMQ (CAAR X) '(RAT BIGFLOAT)) T) + ((SPECREPP X) ($CONSTANTP (SPECDISREP X))) + ((OR (MOPP (CAAR X)) (MGET (CAAR X) '$CONSTANT)) + (DO ((X (CDR X) (CDR X))) ((NULL X) T) + (IF (NOT ($CONSTANTP (CAR X))) (RETURN NIL)))))) + +(DEFUN CONSTANT (X) + (COND ((SYMBOLP X) (MGET X '$CONSTANT)) + (($SUBVARP X) + (AND (MGET (CAAR X) '$CONSTANT) + (DO ((X (CDR X) (CDR X))) ((NULL X) T) + (IF (NOT ($CONSTANTP (CAR X))) (RETURN NIL))))))) + +(DEFUN CONSTANTP (X) (OR (NUMBERP X) (MGET X '$CONSTANT))) + +(DEFUN CONSTTERMP (X) (AND ($CONSTANTP X) (NOT ($NONSCALARP X)))) + +(DEFMFUN $SCALARP (X) (OR (CONSTTERMP X) (EQ (SCALARCLASS X) '$SCALAR))) + +(DEFMFUN $NONSCALARP (X) (EQ (SCALARCLASS X) '$NONSCALAR)) + +(DEFUN SCALARCLASS (EXP); Returns $SCALAR, $NONSCALAR, or NIL (unknown). + (COND ((ATOM EXP) + (COND ((MGET EXP '$NONSCALAR) '$NONSCALAR) + ((MGET EXP '$SCALAR) '$SCALAR))) + ((SPECREPP EXP) (SCALARCLASS (SPECDISREP EXP))) +; If the function is declared scalar or nonscalar, then return. If it isn't +; explicitly declared, then try to be intelligent by looking at the arguments +; to the function. + ((SCALARCLASS (CAAR EXP))) +; + is SCALARP because that seems to be useful. This should +; probably only be true if is a member of the field of scalars. +; * is SCALARP since + is SCALARP. +; Also, this has to be done to make - SCALARP. + ((MEMQ (CAAR EXP) '(MPLUS MTIMES)) + (DO ((L (CDR EXP) (CDR L))) ((NULL L) '$SCALAR) + (IF (NOT (CONSTTERMP (CAR L))) + (RETURN (SCALARCLASS-LIST L))))) + ((AND (EQ (CAAR EXP) 'MQAPPLY) (SCALARCLASS (CADR EXP)))) + ((MXORLISTP EXP) '$NONSCALAR) +; If we can't find out anything about the operator, then look at the arguments +; to the operator. I think NIL should be returned at this point. -cwh + (T (DO ((EXP (CDR EXP) (CDR EXP)) (L)) + ((NULL EXP) (SCALARCLASS-LIST L)) + (IF (NOT (CONSTTERMP (CAR EXP))) + (SETQ L (CONS (CAR EXP) L))))))) + +; Could also do +|-|*|/ |^ , but this is not +; always correct and could screw somebody. + +; SCALARCLASS-LIST takes a list of expressions as its argument. If their +; scalarclasses all agree, then that scalarclass is returned. + +(DEFUN SCALARCLASS-LIST (LIST) + (COND ((NULL LIST) NIL) + ((NULL (CDR LIST)) (SCALARCLASS (CAR LIST))) + (T (LET ((SC-CAR (SCALARCLASS (CAR LIST))) + (SC-CDR (SCALARCLASS-LIST (CDR LIST)))) + (COND ((OR (EQ SC-CAR '$NONSCALAR) + (EQ SC-CDR '$NONSCALAR)) + '$NONSCALAR) + ((AND (EQ SC-CAR '$SCALAR) (EQ SC-CDR '$SCALAR)) + '$SCALAR)))))) + +(DEFMFUN MBAGP (X) (AND (NOT (ATOM X)) (MEMQ (CAAR X) '(MEQUAL MLIST $MATRIX)))) + +(DEFMFUN MEQUALP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MEQUAL))) + +(DEFMFUN MXORLISTP (X) (AND (NOT (ATOM X)) (MEMQ (CAAR X) '(MLIST $MATRIX)))) + +(DEFUN MXORLISTP1 (X) + (AND (NOT (ATOM X)) + (OR (EQ (CAAR X) '$MATRIX) + (AND (EQ (CAAR X) 'MLIST) $LISTARITH)))) + +(DEFMFUN CONSTFUN (X) + X ; Arg ignored. Function used for mapping down lists. + *CONST*) + +(DEFUN CONSTMX (*CONST* X) (SIMPLIFYA (FMAPL1 'CONSTFUN X) T)) + +(DEFMFUN ISINOP (EXP VAR) ; VAR is assumed to be an atom + (COND ((ATOM EXP) NIL) + ((AND (EQ (CAAR EXP) VAR) (NOT (MEMQ 'ARRAY (CDAR EXP))))) + (T (DO EXP (CDR EXP) (CDR EXP) (NULL EXP) + (COND ((ISINOP (CAR EXP) VAR) (RETURN T))))))) + +(DEFMFUN FREE (EXP VAR) + (COND ((ALIKE1 EXP VAR) NIL) + ((ATOM EXP) T) + (T (AND (FREE (CAAR EXP) VAR) (FREEL (CDR EXP) VAR))))) + +(DEFMFUN FREEL (L VAR) + (DO ((L L (CDR L))) ((NULL L) T) + (COND ((NOT (FREE (CAR L) VAR)) (RETURN NIL))))) + +(DEFMFUN FREEARGS (EXP VAR) + (COND ((ALIKE1 EXP VAR) NIL) + ((ATOM EXP) T) + (T (DO ((L (MARGS EXP) (CDR L))) ((NULL L) T) + (COND ((NOT (FREEARGS (CAR L) VAR)) (RETURN NIL))))))) + +(DEFMFUN SIMPLIFYA (X Y) + (COND ((ATOM X) (COND ((AND (EQ X '$%PI) $NUMER) %PI-VAL) (T X))) + ((NOT $SIMP) X) + ((ATOM (CAR X)) + (COND ((AND (CDR X) (ATOM (CDR X))) + (MERROR "~%~S is a cons with an atomic cdr - SIMPLIFYA" X)) + ((GET (CAR X) 'LISP-NO-SIMP) + ; this feature is to be used with care. it is meant to be + ; used to implement data objects with minimum of consing. + ; forms must not bash the DISPLA package. Only new forms + ; with carefully chosen names should use this feature. + X) + (T (CONS (CAR X) + (MAPCAR (FUNCTION (LAMBDA (X) (SIMPLIFYA X Y))) + (CDR X)))))) + ((EQ (CAAR X) 'RAT) (*RED1 X)) + ((AND (NOT DOSIMP) (MEMQ 'SIMP (CDAR X))) X) + ((EQ (CAAR X) 'MRAT) X) + ((AND (MEMQ (CAAR X) '(MPLUS MTIMES MEXPT)) + (MEMQ (GET (CAAR X) 'OPERATORS) '(SIMPLUS SIMPEXPT SIMPTIMES)) + (NOT (MEMQ 'ARRAY (CDAR X)))) + (COND ((EQ (CAAR X) 'MPLUS) (SIMPLUS X 1 Y)) + ((EQ (CAAR X) 'MTIMES) (SIMPTIMES X 1 Y)) + (T (SIMPEXPT X 1 Y)))) + ((NOT (ATOM (CAAR X))) + (COND ((OR (EQ (CAAAR X) 'LAMBDA) + (AND (NOT (ATOM (CAAAR X))) (EQ (CAAAAR X) 'LAMBDA))) + (MAPPLY (CAAR X) (CDR X) (CAAR X))) + (T (MERROR "Illegal form - SIMPLIFYA:~%~S" X)))) + ((GET (CAAR X) 'OPERS) + (LET ((OPERS-LIST *OPERS-LIST)) (OPER-APPLY X Y))) + ((AND (EQ (CAAR X) 'MQAPPLY) + (OR (ATOM (CADR X)) + (AND SUBSTP (OR (EQ (CAR (CADR X)) 'LAMBDA) + (EQ (CAAR (CADR X)) 'LAMBDA))))) + (COND ((OR (SYMBOLP (CADR X)) (NOT (ATOM (CADR X)))) + (SIMPLIFYA (CONS (CONS (CADR X) (CDAR X)) (CDDR X)) Y)) + ((OR (NOT (MEMQ 'ARRAY (CDAR X))) (NOT $SUBNUMSIMP)) + (MERROR "Improper value in functional position:~%~M" X)) + (T (CADR X)))) + (T (LET ((W (GET (CAAR X) 'OPERATORS))) + (COND ((AND W (OR (NOT (MEMQ 'ARRAY (CDAR X))) (RULECHK (CAAR X)))) + (FUNCALL W X 1 Y)) + (T (SIMPARGS X Y))))))) + + +(DEFMFUN EQTEST (X CHECK) + ((LAMBDA (Y) + (COND ((OR (ATOM X) (EQ (CAAR X) 'RAT) (EQ (CAAR X) 'MRAT) + (MEMQ 'SIMP (CDAR X))) + X) + ((AND (EQ (CAAR X) (CAAR CHECK)) (EQUAL (CDR X) (CDR CHECK))) + (COND ((AND (NULL (CDAR CHECK)) + (SETQ Y (GET (CAAR CHECK) 'MSIMPIND))) + (CONS Y (CDR CHECK))) + ((MEMQ 'SIMP (CDAR CHECK)) CHECK) + (T (CONS (CONS (CAAR CHECK) + (COND ((CDAR CHECK) (CONS 'SIMP (CDAR CHECK))) + (T '(SIMP)))) + (CDR CHECK))))) + ((SETQ Y (GET (CAAR X) 'MSIMPIND)) (RPLACA X Y)) + ((OR (MEMQ 'ARRAY (CDAR X)) + (AND (EQ (CAAR X) (CAAR CHECK)) + (MEMQ 'ARRAY (CDAR CHECK)))) + (RPLACA X (CONS (CAAR X) '(SIMP ARRAY)))) + (T (RPLACA X (CONS (CAAR X) '(SIMP)))))) + NIL)) + +(DEFUN RULECHK (X) (OR (MGET X 'OLDRULES) (GET X 'RULES))) + +(DEFMFUN RESIMPLIFY (X) (LET ((DOSIMP T)) (SIMPLIFYA X NIL))) + +(DEFMFUN SSIMPLIFYA (X) (LET ((DOSIMP T)) (SIMPLIFYA X NIL))) ; temporary + +(DEFMFUN SIMPARGS (X Y) + (IF (OR (EQ (GET (CAAR X) 'DIMENSION) 'DIMENSION-INFIX) + (GET (CAAR X) 'BINARY)) + (TWOARGCHECK X)) + (EQTEST + (COND (Y X) + (T (LET ((FLAG (MEMQ (CAAR X) '(MLIST MEQUAL)))) + (CONS (NCONS (CAAR X)) + (MAPCAR #'(LAMBDA (J) + (COND (FLAG (SIMPLIFYA J NIL)) + (T (SIMPCHECK J NIL)))) + (CDR X)))))) + X)) + +(DEFMFUN ADDK (X Y) ; X and Y are assumed to be already reduced + (COND ((EQUAL X 0) Y) + ((EQUAL Y 0) X) + ((AND (NUMBERP X) (NUMBERP Y)) (PLUS X Y)) + ((OR ($BFLOATP X) ($BFLOATP Y)) ($BFLOAT (LIST '(MPLUS) X Y))) + (T (PROG (G A B) + (COND ((NUMBERP X) + (COND ((FLOATP X) (RETURN (PLUS X (FPCOFRAT Y)))) + (T (SETQ X (LIST '(RAT) X 1))))) + ((NUMBERP Y) + (COND ((FLOATP Y) (RETURN (PLUS Y (FPCOFRAT X)))) + (T (SETQ Y (LIST '(RAT) Y 1)))))) + (SETQ G (GCD (CADDR X) (CADDR Y))) + (SETQ A (*QUO (CADDR X) G) B (*QUO (CADDR Y) G)) + (SETQ G (TIMESKL (LIST '(RAT) 1 G) + (LIST '(RAT) + (PLUS (TIMES (CADR X) B) + (TIMES (CADR Y) A)) + (TIMES A B)))) + (RETURN (COND ((NUMBERP G) G) + ((EQUAL (CADDR G) 1) (CADR G)) + ($FLOAT (FPCOFRAT G)) + (T G))))))) + +#-Franz +(DEFUN *RED1 (X) + (COND ((MEMQ 'SIMP (CDAR X)) (COND ($FLOAT (FPCOFRAT X)) (T X))) + (T (*RED (CADR X) (CADDR X))))) + +(DEFUN *RED (N D) + (COND ((ZEROP N) 0) + ((EQUAL D 1) N) + (T (LET ((U (GCD N D))) + (SETQ N (*QUO N U) D (*QUO D U)) + (IF (MINUSP D) (SETQ N (MINUS N) D (MINUS D))) + (COND ((EQUAL D 1) N) + ($FLOAT (FPCOFRAT1 N D)) + (T (LIST '(RAT SIMP) N D))))))) + +(DEFUN NUM1 (A) (IF (NUMBERP A) A (CADR A))) + +(DEFUN DENOM1 (A) (IF (NUMBERP A) 1 (CADDR A))) + +(DEFMFUN TIMESK (X Y) ; X and Y are assumed to be already reduced + (COND ((EQUAL X 1) Y) + ((EQUAL Y 1) X) + ((AND (NUMBERP X) (NUMBERP Y)) (TIMES X Y)) + ((OR ($BFLOATP X) ($BFLOATP Y)) ($BFLOAT (LIST '(MTIMES) X Y))) + ((FLOATP X) (TIMES X (FPCOFRAT Y))) + ((FLOATP Y) (TIMES Y (FPCOFRAT X))) + (T (TIMESKL X Y)))) + +(DEFUN TIMESKL (X Y) + (PROG (U V G) + (SETQ U (*RED (NUM1 X) (DENOM1 Y))) + (SETQ V (*RED (NUM1 Y) (DENOM1 X))) + (SETQ G (COND ((OR (EQUAL U 0) (EQUAL V 0)) 0) + ((EQUAL V 1) U) + ((AND (NUMBERP U) (NUMBERP V)) (TIMES U V)) + (T (LIST '(RAT SIMP) + (TIMES (NUM1 U) (NUM1 V)) + (TIMES (DENOM1 U) (DENOM1 V)))))) + (RETURN (COND ((NUMBERP G) G) + ((EQUAL (CADDR G) 1) (CADR G)) + ($FLOAT (FPCOFRAT G)) + (T G))))) + +(DEFMFUN FPCOFRAT (RATNO) (FPCOFRAT1 (CADR RATNO) (CADDR RATNO))) + +(DEFUN FPCOFRAT1 (NU D) + (IF (AND (BIGP NU) (BIGP D)) + (LET ((SIGN (IF (MINUSP NU) (PLUSP D) (MINUSP D))) + (LN (HAULONG NU)) (LD (HAULONG D))) + (IF (> LN LD) + (SETQ D (HAIPART D #-FRANZ 35. #+FRANZ 30.) + NU (HAIPART NU (- LN (- LD #-FRANZ 35. #+FRANZ 30.)))) + (SETQ NU (HAIPART NU #-FRANZ 35. #+FRANZ 30.) + D (HAIPART D (- LD (- LN #-FRANZ 35. #+FRANZ 30.))))) + (IF SIGN (SETQ NU (MINUS NU))))) + (*QUO (FLOAT NU) D)) + +; Definition of FPCOFRAT1 below semi-coloned out on 3/7/81 by JPG +; until it gives 0.0 for FLOAT(33^-33); rather than 8.9684807E+26 +;(DEFUN FPCOFRAT1 (NU D) +; (DECLARE (FIXNUM FP-PREC SCALE-FAC)) +; (IF (OR (BIGP NU) (BIGP D)) +; (LET* ((SIGN (IF (MINUSP NU) (PLUSP D) (MINUSP D))) +; (FP-PREC 35.) +; ;; upper bound on number of bits of mantissa supplied for f.p. numbers +; ;; 35. is big enough to be ok for mc,multics,lispm +; ;; RJF said he was going to use his own code for franz. +; ;; Does he want a #-Franz around this code? - BMT and JPG +; (SCALE-FAC (- (MAX FP-PREC (HAULONG NU)) +; (MAX FP-PREC (HAULONG D))))) +; (SETQ NU (HAIPART (ABS NU) FP-PREC) D (HAIPART (ABS D) FP-PREC)) +; (IF SIGN (SETQ NU (MINUS NU))) +; (FSC (*QUO (FLOAT NU) D) SCALE-FAC)) +; ;; Does the LISPM have FSC? +; (*QUO (FLOAT NU) D))) + +(DEFUN EXPTA (X Y) (COND ((EQUAL Y 1) X) + ((NUMBERP X) (EXPTB X (NUM1 Y))) + (($BFLOATP X) ($BFLOAT (LIST '(MEXPT) X Y))) + ((MINUSP (NUM1 Y)) + (*RED (EXPTB (CADDR X) (MINUS (NUM1 Y))) + (EXPTB (CADR X) (MINUS (NUM1 Y))))) + (T (*RED (EXPTB (CADR X) (NUM1 Y)) + (EXPTB (CADDR X) (NUM1 Y)))))) + +(DEFUN EXPTB (A B) + (COND ((EQUAL A %E-VAL) (EXP B)) + ((OR (FLOATP A) (NOT (MINUSP B))) (EXPT A B)) + (T (SETQ B (EXPT A (MINUS B))) (*RED 1 B)))) + +(DEFMFUN SIMPLUS (X W Z) ; W must be 1 + (PROG (RES CHECK EQNFLAG MATRIXFLAG SUMFLAG) + (IF (NULL (CDR X)) (RETURN 0)) + (SETQ CHECK X) + START(SETQ X (CDR X)) + (IF (NULL X) (GO END)) + (SETQ W (IF Z (CAR X) (SIMPLIFYA (CAR X) NIL))) + ST1 (COND + ((ATOM W) NIL) + ((EQ (CAAR W) 'MRAT) + (COND ((OR EQNFLAG MATRIXFLAG SUMFLAG (SPSIMPCASES (CDR X))) + (SETQ W (RATDISREP W)) (GO ST1)) + (T (RETURN (RATF (CONS '(MPLUS) + (NCONC (MAPCAR #'SIMPLIFY (CONS W (CDR X))) + (CDR RES)))))))) + ((EQ (CAAR W) 'MEQUAL) + (SETQ EQNFLAG + (IF (NOT EQNFLAG) + W + (LIST (CAR EQNFLAG) + (ADD2 (CADR EQNFLAG) (CADR W)) + (ADD2 (CADDR EQNFLAG) (CADDR W))))) + (GO START)) + ((MEMQ (CAAR W) '(MLIST $MATRIX)) + (SETQ MATRIXFLAG + (COND ((NOT MATRIXFLAG) W) + ((AND (OR $DOALLMXOPS $DOMXMXOPS $DOMXPLUS + (AND (EQ (CAAR W) 'MLIST) ($LISTP MATRIXFLAG))) + (OR (NOT (EQ (CAAR W) 'MLIST)) $LISTARITH)) + (ADDMX MATRIXFLAG W)) + (T (SETQ RES (PLS W RES)) MATRIXFLAG))) + (GO START)) + ((EQ (CAAR W) '%SUM) (SETQ SUMFLAG (SUMPLS SUMFLAG W)) (GO START))) + (SETQ RES (PLS W RES)) + (GO START) + END (IF SUMFLAG (SETQ RES (PLS (IF (NULL (CDR SUMFLAG)) + (CAR SUMFLAG) + (CONS '(MPLUS) SUMFLAG)) + RES))) + (SETQ RES (TESTP RES)) + (IF MATRIXFLAG + (SETQ RES (COND ((ZEROP1 RES) MATRIXFLAG) + ((AND (OR ($LISTP MATRIXFLAG) + $DOALLMXOPS $DOSCMXPLUS $DOSCMXOPS) + (OR (NOT ($LISTP MATRIXFLAG)) $LISTARITH)) + (MXPLUSC RES MATRIXFLAG)) + (T (TESTP (PLS MATRIXFLAG (PLS RES NIL))))))) + (RETURN + (IF EQNFLAG + (LIST (CAR EQNFLAG) + (ADD2 (CADR EQNFLAG) RES) + (ADD2 (CADDR EQNFLAG) RES)) + (EQTEST RES CHECK))))) + +(DEFUN MXPLUSC (SC MX) + (COND ((MPLUSP SC) + (SETQ SC (PARTITION-NS (CDR SC))) + (COND ((NULL (CAR SC)) (CONS '(MPLUS) (CONS MX (CADR SC)))) + ((NOT (NULL (CADR SC))) + (CONS '(MPLUS) + (CONS (SIMPLIFY + (OUTERMAP1 'MPLUS (CONS '(MPLUS) (CAR SC)) MX)) + (CADR SC)))) + (T (SIMPLIFY (OUTERMAP1 'MPLUS (CONS '(MPLUS) (CAR SC)) MX))))) + ((NOT (SCALAR-OR-CONSTANT-P SC $ASSUMESCALAR)) (LIST '(MPLUS) SC MX)) + (T (SIMPLIFY (OUTERMAP1 'MPLUS SC MX))))) + +(DEFUN PARTITION-NS (X) + ((LAMBDA (SP NSP) ; SP = scalar part, NSP = nonscalar part + (MAPC (FUNCTION + (LAMBDA (Z) (COND ((SCALAR-OR-CONSTANT-P Z $ASSUMESCALAR) + (SETQ SP (CONS Z SP))) + (T (SETQ NSP (CONS Z NSP)))))) + X) + (LIST (NREVERSE SP) (NREVERSE NSP))) + NIL NIL)) + +(DEFUN ADDMX (X1 X2) + (LET (($DOSCMXOPS T) ($DOMXMXOPS T) ($LISTARITH T)) + (SIMPLIFY (FMAPL1 'MPLUS X1 X2)))) + +(DEFUN PLUSIN (X FM) + (PROG (X1 FLAG CHECK W XNEW) + (SETQ W 1) + (COND ((MTIMESP X) + (SETQ CHECK X) + (COND ((MNUMP (CADR X)) (SETQ W (CADR X) X (CDDR X))) + (T (SETQ X (CDR X))))) + (T (SETQ X (LIST X)))) + (SETQ X1 (COND ((NULL (CDR X)) (CAR X)) (T (CONS '(MTIMES) X))) + XNEW (CONS '(MTIMES) (CONS W X))) + START(COND ((NULL (CDR FM)) (GO LESS)) + ((MTIMESP (CADR FM)) (GO TIMES)) + ((AND (ALIKE1 X1 (CADR FM)) (NULL (CDR X))) (GO EQU)) + ((GREAT X1 (CADR FM)) (GO GR))) + LESS (SETQ FLAG (EQTEST (TESTT XNEW) (OR CHECK '((FOO))))) + (RETURN (CDR (RPLACD FM (CONS FLAG (CDR FM))))) + GR (SETQ FM (CDR FM)) + (GO START) + EQU (RPLACA (CDR FM) (CONS '(MTIMES SIMP) (CONS (ADDK 1 W) X))) + DEL (COND ((ONEP1 (CADADR FM)) (RPLACD (CADR FM) (CDDADR FM)) (RETURN (CDR FM))) + ((NOT (ZEROP1 (CADADR FM))) (RETURN (CDR FM)))) + (RETURN (RPLACD FM (CDDR FM))) + TIMES(SETQ FLAG (CDADR FM)) + (COND ((OR (AND (MNUMP (CAR FLAG)) (ALIKE X (CDR FLAG))) (ALIKE1 X1 (CADR FM))) + (GO EQUT)) + ((OR (AND (MNUMP (CAR FLAG)) (GREAT XNEW (CADR FM))) (GREAT X1 (CADR FM))) + (GO GR))) + (GO LESS) + EQUT (SETQ X1 (CONS '(MTIMES SIMP) + (CONS (ADDK (COND ((MNUMP (CADADR FM)) (SETQ FLAG T) (CADADR FM)) + (T (SETQ FLAG NIL) 1)) + W) + X))) + (COND ((AND (ONEP1 (CADAR (RPLACA (CDR FM) X1))) + FLAG (NULL (CDDR (CDADR FM)))) + (RPLACA (CDR FM) (CADR (CDADR FM))) (RETURN (CDR FM)))) + (GO DEL))) + +(DEFMFUN SIMPLN (X Y Z) + (ONEARGCHECK X) + (COND ((ONEP1 (SETQ Y (SIMPCHECK (CADR X) Z))) (ADDK -1 Y)) + ((ZEROP1 Y) + (COND (RADCANP (LIST '(%LOG SIMP) 0)) + ((NOT ERRORSW) (MERROR "LOG(0) has been generated.")) + (T (*THROW 'ERRORSW T)))) + ((EQ Y '$%E) 1) + ((RATNUMP Y) + (COND ((EQUAL (CADR Y) 1) (SIMPLN1 (LIST NIL (CADDR Y) -1))) + ((EQ $LOGEXPAND '$SUPER) + (SIMPLIFYA (LIST '(MPLUS) (SIMPLIFYA (LIST '(%LOG) (CADR Y)) T) + (SIMPLN1 (LIST NIL (CADDR Y) -1))) T)) + (T (EQTEST (LIST '(%LOG) Y) X)))) + ((AND $LOGEXPAND (MEXPTP Y)) (SIMPLN1 Y)) + ((AND (MEMQ $LOGEXPAND '($ALL $SUPER)) (MTIMESP Y)) + (PROG (B) + (SETQ Y (CDR Y)) + LOOP (SETQ B (CONS (COND ((NOT (MEXPTP (CAR Y))) + (SIMPLIFYA (LIST '(%LOG) (CAR Y)) T)) + (T (SIMPLN1 (CAR Y)))) B)) + (COND ((NULL (SETQ Y (CDR Y))) + (RETURN (SIMPLIFYA (CONS '(MPLUS) B) T)))) + (GO LOOP))) + (($BFLOATP Y) ($BFLOAT (LIST '(%LOG) Y))) + ((OR (FLOATP Y) (AND $NUMER (FIXP Y))) + (COND ((PLUSP Y) (LOG Y)) + ($LOGNUMER (COND ((EQUAL Y -1) 0) (T (LOG (MINUS Y))))) + (T (ADD2 (LOG (MINUS Y)) (MUL2 '$%I %PI-VAL))))) + ((AND $LOGNEGINT (INTEGERP Y) (EQ ($SIGN Y) '$NEG)) + (ADD2 '((MTIMES SIMP) $%I $%PI) + (COND ((EQUAL Y -1) 0) (T (LIST '(%LOG SIMP) (NEG Y)))))) + (T (EQTEST (LIST '(%LOG) Y) X)))) + +(DEFUN SIMPLN1 (W) + (SIMPLIFYA (LIST '(MTIMES) (CADDR W) + (SIMPLIFYA (LIST '(%LOG) (CADR W)) T)) T)) + +(DEFMFUN SIMPSQRT (X VESTIGIAL Z) + VESTIGIAL ;Ignored. + (ONEARGCHECK X) + (SIMPLIFYA (LIST '(MEXPT) (CADR X) '((RAT SIMP) 1 2)) Z)) + +(DEFMFUN SIMPQUOT (X Y Z) + (TWOARGCHECK X) + (COND ((AND (FIXP (CADR X)) (FIXP (CADDR X)) (NOT (ZEROP (CADDR X)))) + (*RED (CADR X) (CADDR X))) + ((AND (NUMBERP (CADR X)) (NUMBERP (CADDR X)) (NOT (ZEROP (CADDR X)))) + (*QUO (CADR X) (CADDR X))) + (T (SETQ Y (SIMPLIFYA (CADR X) Z)) + (SETQ X (SIMPLIFYA (LIST '(MEXPT) (CADDR X) -1) Z)) + (IF (EQUAL Y 1) X (SIMPLIFYA (LIST '(MTIMES) Y X) T))))) + +;; Obsolete. Use DIV*. All references to this should now be flushed. +;; This definition will go away soon. + +;(DEFUN QSNT (X Y) (SIMPLIFY (LIST '(MTIMES) X (LIST '(MEXPT) Y -1)))) + +(DEFMFUN SIMPABS (X Y Z) + (ONEARGCHECK X) + (SETQ Y (SIMPCHECK (CADR X) Z)) + (COND ((NUMBERP Y) (ABS Y)) + ((OR (RATNUMP Y) ($BFLOATP Y)) (LIST (CAR Y) (ABS (CADR Y)) (CADDR Y))) + ((EQ (SETQ Z (CSIGN Y)) T) (CABS Y)) + ((MEMQ Z '($POS $PZ)) Y) + ((MEMQ Z '($NEG $NZ)) (NEG Y)) + ((EQ Z '$ZERO) 0) + ((AND (MEXPTP Y) (FIXP (CADDR Y))) + (LIST (CAR Y) (SIMPABS (LIST '(MABS) (CADR Y)) NIL T) (CADDR Y))) + ((MTIMESP Y) + (MULN (MAPCAR #'(LAMBDA (U) (SIMPABS (LIST '(MABS) U) NIL T)) (CDR Y)) T)) + ((MMINUSP Y) (LIST '(MABS SIMP) (NEG Y))) + ((MBAGP Y) + (CONS (CAR Y) + (MAPCAR #'(LAMBDA (U) (SIMPABS (LIST '(MABS) U) NIL T)) (CDR Y)))) + (T (EQTEST (LIST '(MABS) Y) X)))) + +(DEFUN PLS (X OUT) + (PROG (FM) + (COND ((MTIMESP X) (SETQ X (TESTTNEG X)))) + (COND ((NULL OUT) + (RETURN + (CONS '(MPLUS) + (COND ((MNUMP X) (NCONS X)) + ((NOT (MPLUSP X)) + (LIST 0 (COND ((ATOM X) X) (T (APPEND X NIL))))) + ((MNUMP (CADR X)) (APPEND (CDR X) NIL)) + (T (CONS 0 (APPEND (CDR X) NIL))))))) + ((MNUMP X) + (RETURN (CONS '(MPLUS) + (COND ((MNUMP (CADR OUT)) + (CONS (ADDK (CADR OUT) X) (CDDR OUT))) + (T (CONS X (CDR OUT))))))) + ((NOT (MPLUSP X)) (PLUSIN X (CDR OUT)) (RETURN OUT))) + (RPLACA (CDR OUT) + (ADDK (COND ((MNUMP (CADR OUT)) (CADR OUT)) (T 0)) + (COND ((MNUMP (CADR X)) (SETQ X (CDR X)) (CAR X)) (T 0)))) + (SETQ FM (CDR OUT)) + START(COND ((NULL (SETQ X (CDR X))) (RETURN OUT))) + (SETQ FM (PLUSIN (CAR X) FM)) + (GO START))) + +(DEFUN TESTT (X) + (COND ((MNUMP X) X) + ((NULL (CDDR X)) (CADR X)) + ((ONEP1 (CADR X)) + (COND ((NULL (CDDDR X)) (CADDR X)) (T (RPLACD X (CDDR X))))) + (T (TESTTNEG X)))) + +(DEFUN TESTTNEG (X) + (COND ((AND (EQUAL (CADR X) -1) (NULL (CDDDR X)) (MPLUSP (CADDR X)) $NEGDISTRIB) + (ADDN (MAPCAR (FUNCTION (LAMBDA (Z) (MUL2 -1 Z))) (CDADDR X)) T)) + (T X))) + +(DEFUN TESTP (X) (COND ((ATOM X) 0) + ((NULL (CDDR X)) (CADR X)) + ((ZEROP1 (CADR X)) + (COND ((NULL (CDDDR X)) (CADDR X)) (T (RPLACD X (CDDR X))))) + (T X))) + +(DEFUN SIMPMIN (X VESTIGIAL Z) + VESTIGIAL ;Ignored + (ONEARGCHECK X) + (COND ((NUMBERP (CADR X)) (MINUS (CADR X))) + ((ATOM (CADR X)) (LIST '(MTIMES SIMP) -1 (CADR X))) + (T (SIMPLIFYA (LIST '(MTIMES) -1 (SIMPLIFYA (CADR X) Z)) T)))) + +(DEFMFUN SIMPTIMES (X W Z) ; W must be 1 + (PROG (RES CHECK EQNFLAG MATRIXFLAG SUMFLAG) + (IF (NULL (CDR X)) (RETURN 1)) + (SETQ CHECK X) + START(SETQ X (CDR X)) + (COND ((ZEROP1 RES) + (COND ($MX0SIMP + (COND ((AND MATRIXFLAG (MXORLISTP1 MATRIXFLAG)) + (RETURN (CONSTMX RES MATRIXFLAG))) + (EQNFLAG (RETURN (LIST '(MEQUAL SIMP) + (MUL2 RES (CADR EQNFLAG)) + (MUL2 RES (CADDR EQNFLAG))))) + (T (DOLIST (U X) + (COND ((MXORLISTP1 U) + (RETURN + (SETQ RES (CONSTMX RES U)))) + ((AND (MEXPTP U) + (MXORLISTP1 (CADR U)) + ($NUMBERP (CADDR U))) + (RETURN + (SETQ RES (CONSTMX RES (CADR U))))) + ((MEQUALP U) + (RETURN + (SETQ RES (LIST '(MEQUAL SIMP) + (MUL2 RES (CADR U)) + (MUL2 RES (CADDR U)))))))))))) + (RETURN RES)) + ((NULL X) (GO END))) + (SETQ W (IF Z (CAR X) (SIMPLIFYA (CAR X) NIL))) + ST1 (COND + ((ATOM W) NIL) + ((EQ (CAAR W) 'MRAT) + (COND ((OR EQNFLAG MATRIXFLAG SUMFLAG (SPSIMPCASES (CDR X))) + (SETQ W (RATDISREP W)) (GO ST1)) + (T (RETURN (RATF (CONS '(MTIMES) + (NCONC (MAPCAR #'SIMPLIFY (CONS W (CDR X))) + (CDR RES)))))))) + ((EQ (CAAR W) 'MEQUAL) + (SETQ EQNFLAG + (IF (NOT EQNFLAG) + W + (LIST (CAR EQNFLAG) + (MUL2 (CADR EQNFLAG) (CADR W)) + (MUL2 (CADDR EQNFLAG) (CADDR W))))) + (GO START)) + ((MEMQ (CAAR W) '(MLIST $MATRIX)) + (SETQ MATRIXFLAG + (COND ((NOT MATRIXFLAG) W) + ((AND (OR $DOALLMXOPS $DOMXMXOPS $DOMXTIMES) + (OR (NOT (EQ (CAAR W) 'MLIST)) $LISTARITH) + (NOT (EQ *INV* '$DETOUT))) + (STIMEX MATRIXFLAG W)) + (T (SETQ RES (TMS W 1 RES)) MATRIXFLAG))) + (GO START)) + ((AND (EQ (CAAR W) '%SUM) $SUMEXPAND) + (SETQ SUMFLAG (SUMTIMES SUMFLAG W)) (GO START))) + (SETQ RES (TMS W 1 RES)) + (GO START) + END (COND ((MTIMESP RES) (SETQ RES (TESTT RES)))) + (COND (SUMFLAG (SETQ RES (COND ((OR (NULL RES) (EQUAL RES 1)) SUMFLAG) + ((NOT (MTIMESP RES)) + (LIST '(MTIMES) RES SUMFLAG)) + (T (NCONC RES (LIST SUMFLAG))))))) + (COND ((OR (ATOM RES) + (NOT (MEMQ (CAAR RES) '(MEXPT MTIMES))) + (AND (ZEROP $EXPOP) (ZEROP $EXPON)) + EXPANDFLAG)) + ((EQ (CAAR RES) 'MTIMES) (SETQ RES (EXPANDTIMES RES))) + ((AND (MPLUSP (CADR RES)) + (EQ (TYPEP (CADDR RES)) 'FIXNUM) + (NOT (OR (GREATERP (CADDR RES) $EXPOP) + (GREATERP (MINUS (CADDR RES)) $EXPON)))) + (SETQ RES (EXPANDEXPT (CADR RES) (CADDR RES))))) + (COND (MATRIXFLAG + (SETQ RES (COND ((NULL RES) MATRIXFLAG) + ((AND (OR ($LISTP MATRIXFLAG) $DOALLMXOPS + (AND $DOSCMXOPS (NOT (MEMBER RES '(-1 -1.0)))) + ;;; RES should only be -1 here (not = 1) + (AND $DOMXMXOPS (MEMBER RES '(-1 -1.0)))) + (OR (NOT ($LISTP MATRIXFLAG)) $LISTARITH)) + (MXTIMESC RES MATRIXFLAG)) + (T (TESTT (TMS MATRIXFLAG 1 (TMS RES 1 NIL)))))))) + (RETURN + (COND (EQNFLAG + (IF (NULL RES) (SETQ RES 1)) + (LIST (CAR EQNFLAG) + (MUL2 (CADR EQNFLAG) RES) + (MUL2 (CADDR EQNFLAG) RES))) + (T (EQTEST RES CHECK)))))) + +(DEFUN SPSIMPCASES (L) + (DO L L (CDR L) (NULL L) + (COND ((AND (NOT (ATOM (CAR L))) + (MEMQ (CAAAR L) '(MEQUAL MLIST $MATRIX %SUM))) + (RETURN T))))) + +(DEFUN MXTIMESC (SC MX) + (LET (SIGN OUT) + (AND (MTIMESP SC) (MEMBER (CADR SC) '(-1 -1.0)) + $DOSCMXOPS (NOT (OR $DOALLMXOPS $DOMXMXOPS $DOMXTIMES)) + (SETQ SIGN (CADR SC)) (RPLACA (CDR SC) NIL)) + (SETQ OUT ((LAMBDA (SCP*) + (COND ((NULL SCP*)(LIST '(MTIMES SIMP) SC MX)) + ((AND (NOT (ATOM SCP*)) (NULL (CAR SCP*))) + (APPEND '((MTIMES)) (CADR SCP*) (LIST MX))) + ((OR (ATOM SCP*) (AND (NULL (CDR SCP*)) + (NOT (NULL (CDR SC))) + (SETQ SCP* (CONS '(MTIMES) (CAR SCP*)))) + (NOT (MTIMESP SC))) + (SIMPLIFYA (OUTERMAP1 'MTIMES SCP* MX) NIL)) + (T (APPEND '((MTIMES)) + (LIST (SIMPLIFYA + (OUTERMAP1 'MTIMES + (CONS '(MTIMES) (CAR SCP*)) MX) T)) (CADR SCP*))))) + (COND ((MTIMESP SC) (PARTITION-NS (CDR SC))) + ((NOT (SCALAR-OR-CONSTANT-P SC $ASSUMESCALAR)) NIL) + (T SC)))) + (COND (SIGN (COND ((MTIMESP OUT) (RPLACD OUT (CONS SIGN (CDR OUT)))) + (T (LIST '(MTIMES) SIGN OUT)))) + ((MTIMESP OUT) (TESTT OUT)) + (T OUT)))) + +(DEFUN STIMEX (X Y) + (LET (($DOSCMXOPS T) ($DOMXMXOPS T) ($LISTARITH T)) + (SIMPLIFY (FMAPL1 'MTIMES X Y)))) + +; TMS takes a simplified expression FACTOR and a cumulative +; PRODUCT as arguments and modifies the cumulative product so +; that the expression is now one of its factors. The +; exception to this occurs when a tellsimp rule is triggered. +; The second argument is the POWER to which the expression is +; to be raised within the product. + +(DEFUN TMS (FACTOR POWER PRODUCT) + ((LAMBDA (RULESW Z) + (COND ((MPLUSP PRODUCT) (SETQ PRODUCT (LIST '(MTIMES SIMP) PRODUCT)))) + (COND ((ZEROP1 FACTOR) + (COND ((MNEGP POWER) + (COND (ERRORSW (*THROW 'ERRORSW T)) + (T (MERROR "Division by 0")))) + (T FACTOR))) + ((AND (NULL PRODUCT) + (OR (AND (MTIMESP FACTOR) (EQUAL POWER 1)) + (AND (SETQ PRODUCT (LIST '(MTIMES) 1)) NIL))) + (APPEND '((MTIMES)) (COND ((MNUMP (CADR FACTOR)) NIL) (T '(1))) + (CDR FACTOR) NIL)) + ((MNUMP FACTOR) + (RPLACA (CDR PRODUCT) (TIMESK (CADR PRODUCT) (EXPTA FACTOR POWER))) + PRODUCT) + ((MTIMESP FACTOR) + (COND ((MNUMP (CADR FACTOR)) + (SETQ FACTOR (CDR FACTOR)) + (RPLACA (CDR PRODUCT) + (TIMESK (CADR PRODUCT) (EXPTA (CAR FACTOR) POWER))))) + (DO ((FACTOR-LIST (CDR FACTOR) (CDR FACTOR-LIST))) + ((OR (NULL FACTOR-LIST) (ZEROP1 PRODUCT)) PRODUCT) + (SETQ Z (TIMESIN (CAR FACTOR-LIST) (CDR PRODUCT) POWER)) + (COND (RULESW (SETQ RULESW NIL) + (SETQ PRODUCT (TMS-FORMAT-PRODUCT Z)))))) + (T (SETQ Z (TIMESIN FACTOR (CDR PRODUCT) POWER)) + (COND (RULESW (TMS-FORMAT-PRODUCT Z)) (T PRODUCT))))) + NIL NIL)) + +(DEFUN TMS-FORMAT-PRODUCT (X) + (COND ((ZEROP1 X) X) + ((MNUMP X) (LIST '(MTIMES) X)) + ((NOT (MTIMESP X)) (LIST '(MTIMES) 1 X)) + ((NOT (MNUMP (CADR X))) (CONS '(MTIMES) (CONS 1 (CDR X)))) + (T X))) + +(DEFUN PLSK (X Y) (COND ($RATSIMPEXPONS (SRATSIMP (LIST '(MPLUS) X Y))) + ((AND (MNUMP X) (MNUMP Y)) (ADDK X Y)) + (T (ADD2 X Y)))) + +(DEFUN MULT (X Y) (COND ((AND (MNUMP X) (MNUMP Y)) (TIMESK X Y)) + (T (MUL2 X Y)))) + +(DEFMFUN SIMP-LIMIT (X VESTIGIAL Z) + VESTIGIAL ;Ignored. + ((LAMBDA (L1 Y) + (COND ((NOT (OR (= L1 2) (= L1 4) (= L1 5))) (WNA-ERR '%LIMIT))) + (SETQ Y (SIMPMAP (CDR X) Z)) + (COND ((AND (= L1 5) (NOT (MEMQ (CADDDR Y) '($PLUS $MINUS)))) + (MERROR "4th arg to LIMIT must be either PLUS or MINUS:~%~M" + (CADDDR Y))) + ((MNUMP (CADR Y)) + (MERROR "Wrong second arg to LIMIT:~%~M" (CADR Y))) + ((EQUAL (CAR Y) 1) 1) + (T (EQTEST (CONS '(%LIMIT) Y) X)))) + (LENGTH X) NIL)) + +(DEFMFUN SIMPINTEG (X VESTIGIAL Z) + VESTIGIAL ;Ignored. + ((LAMBDA (L1 Y) + (COND ((NOT (OR (= L1 3) (= L1 5))) + (MERROR "Wrong number of arguments to 'INTEGRATE"))) + (SETQ Y (SIMPMAP (CDR X) Z)) + (COND ((MNUMP (CADR Y)) + (MERROR "Attempt to integrate with respect to a number:~%~M" (CADR Y))) + ((AND (= L1 5) (ALIKE1 (CADDR Y) (CADDDR Y))) 0) + ((AND (= L1 5) (FREE (SETQ Z (SUB (CADDDR Y) (CADDR Y))) '$%I) + (EQ ($SIGN Z) '$NEG)) + (NEG (SIMPLIFYA (LIST '(%INTEGRATE) (CAR Y) (CADR Y) (CADDDR Y) (CADDR Y)) T))) + ((EQUAL (CAR Y) 1) + (COND ((= L1 3) (CADR Y)) + (T (COND ((OR (AMONG '$INF Z) (AMONG '$MINF Z)) (INFSIMP Z)) + (T Z))))) + (T (EQTEST (CONS '(%INTEGRATE) Y) X)))) + (LENGTH X) NIL)) + +(DEFMFUN SIMPBIGFLOAT (X VESTIGIAL SIMP-FLAG) + VESTIGIAL ;Ignored. + SIMP-FLAG ;No interesting subexpressions + (BIGFLOATM* X)) + +(DEFMFUN SIMPEXP (X VESTIGIAL Z) + VESTIGIAL ;Ignored. + (ONEARGCHECK X) (SIMPLIFYA (LIST '(MEXPT) '$%E (CADR X)) Z)) + +(DEFMFUN SIMPLAMBDA (X VESTIGIAL SIMP-FLAG) + VESTIGIAL ;Ignored. + SIMP-FLAG ;No interesting subexpressions + (CONS '(LAMBDA SIMP) (CDR X))) + +(DEFMFUN SIMPMDEF (X VESTIGIAL SIMP-FLAG) + VESTIGIAL ;Ignored. + SIMP-FLAG ;No interesting subexpressions + (TWOARGCHECK X) + (CONS '(MDEFINE SIMP) (CDR X))) + +(DEFUN SIMPMAP (E Z) (MAPCAR #'(LAMBDA (U) (SIMPCHECK U Z)) E)) + +(defmfun infsimp (e) + (let ((x ($expand e 1 1))) + (cond ((or (not (free x '$ind)) (not (free x '$und)) + (not (free x '$zeroa)) (not (free x '$zerob)) + (not (free x '$infinity)) + (mbagp x)) + (infsimp2 x e)) + ((and (free x '$inf) (free x '$minf)) x) + (t (infsimp1 x e))))) + +(defun infsimp1 (x e) + (let ((minf-coef (coeff x '$minf 1)) + (inf-coef (coeff x '$inf 1))) + (cond ((or (and (equal minf-coef 0) + (equal inf-coef 0)) + (and (not (free minf-coef '$inf)) + (not (free inf-coef '$minf))) + (let ((new-exp (sub (add2 (mul2 minf-coef '$minf) + (mul2 inf-coef '$inf)) + x))) + (and (not (free new-exp '$inf)) + (not (free new-exp '$minf))))) + (infsimp2 x e)) + (t (let ((sign-minf-coef ($asksign minf-coef)) + (sign-inf-coef ($asksign inf-coef))) + (cond ((or (and (eq sign-inf-coef '$zero) + (eq sign-minf-coef '$neg)) + (and (eq sign-inf-coef '$pos) + (eq sign-minf-coef '$zero)) + (and (eq sign-inf-coef '$pos) + (eq sign-minf-coef '$neg))) '$inf) + ((or (and (eq sign-inf-coef '$zero) + (eq sign-minf-coef '$pos)) + (and (eq sign-inf-coef '$neg) + (eq sign-minf-coef '$zero)) + (and (eq sign-inf-coef '$neg) + (eq sign-minf-coef '$pos))) '$minf) + ((or (and (eq sign-inf-coef '$pos) + (eq sign-minf-coef '$neg)) + (and (eq sign-inf-coef '$neg) + (eq sign-minf-coef '$neg))) '$und))))))) + +(defun infsimp2 (x e) + (setq x ($limit x)) + (if (isinop x '%limit) e x)) + +(DEFMFUN SIMPDERIV (X Y Z) + (PROG (FLAG W U) + (COND ((NOT (EVEN (LENGTH X))) + (COND ((AND (CDR X) (NULL (CDDDR X))) (NCONC X '(1))) + (T (WNA-ERR '%DERIVATIVE))))) + (SETQ W (CONS '(%DERIVATIVE) (SIMPMAP (CDR X) Z))) + (SETQ Y (CADR W)) + (DO U (CDDR W) (CDDR U) (NULL U) + (COND ((MNUMP (CAR U)) + (MERROR "Attempt to differentiate with respect to a number:~%~M" + (CAR U))))) + (COND ((OR (ZEROP1 Y) + (AND (OR (MNUMP Y) (AND (ATOM Y) (CONSTANT Y))) + (OR (NULL (CDDR W)) + (AND (NOT (ALIKE1 Y (CADDR W))) + (DO U (CDDR W) (CDDR U) (NULL U) + (COND ((AND (NUMBERP (CADR U)) (NOT (ZEROP (CADR U)))) + (RETURN T)))))))) + (RETURN 0)) + ((AND (NOT (ATOM Y)) (EQ (CAAR Y) '%DERIVATIVE) DERIVSIMP) + (RPLACD W (APPEND (CDR Y) (CDDR W))))) + (IF (NULL (CDDR W)) + (RETURN (IF (NULL DERIVFLAG) (LIST '(%DEL SIMP) Y) (DERIV (CDR W))))) + (SETQ U (CDR W)) + ZTEST(COND ((NULL U) (GO NEXT)) + ((ZEROP1 (CADDR U)) (RPLACD U (CDDDR U))) + (T (SETQ U (CDDR U)))) + (GO ZTEST) + NEXT (COND ((NULL (CDDR W)) (RETURN Y)) + ((AND (NULL (CDDDDR W)) (ONEP (CADDDR W)) + (ALIKE1 (CADR W) (CADDR W))) + (RETURN 1))) + AGAIN(SETQ Z (CDDR W)) + SORT (COND ((NULL (CDDR Z)) (GO LOOP)) + ((ALIKE1 (CAR Z) (CADDR Z)) + (RPLACA (CDDDR Z) (ADD2 (CADR Z) (CADDDR Z))) + (RPLACD Z (CDDDR Z))) + ((GREAT (CAR Z) (CADDR Z)) + (LET ((U1 (CAR Z)) (U2 (CADR Z)) (V1 (CADDR Z)) (V2 (CADDDR Z))) + (SETQ FLAG T) (RPLACA Z V1) + (RPLACD Z (CONS V2 (CONS U1 (CONS U2 (CDDDDR Z)))))))) + (COND ((SETQ Z (CDDR Z)) (GO SORT))) + LOOP (COND ((NULL FLAG) (RETURN (COND ((NULL DERIVFLAG) (EQTEST W X)) + (T (DERIV (CDR W))))))) + (SETQ FLAG NIL) + (GO AGAIN))) + +(DEFMFUN SIGNUM1 (X) + (COND ((MNUMP X) + (SETQ X (NUM1 X)) (COND ((PLUSP X) 1) ((MINUSP X) -1) (T 0))) + ((ATOM X) 1) + ((MPLUSP X) (IF EXPANDP 1 (SIGNUM1 (CAR (LAST X))))) + ((MTIMESP X) (IF (MPLUSP (CADR X)) 1 (SIGNUM1 (CADR X)))) + (T 1))) + +(DEFMFUN SIMPSIGNUM (X Y Z) + (ONEARGCHECK X) + (SETQ Y (SIMPCHECK (CADR X) Z)) + (COND ((MNUMP Y) + (SETQ Y (NUM1 Y)) (COND ((PLUSP Y) 1) ((MINUSP Y) -1) (T 0))) + ((EQ (SETQ Z (CSIGN Y)) T) (EQTEST (LIST '(%SIGNUM) Y) X)) + ((EQ Z '$POS) 1) + ((EQ Z '$NEG) -1) + ((EQ Z '$ZERO) 0) + ((MMINUSP Y) (MUL2 -1 (LIST '(%SIGNUM SIMP) (NEG Y)))) + (T (EQTEST (LIST '(%SIGNUM) Y) X)))) + +(DEFMFUN EXPTRL (R1 R2) + (COND ((EQUAL R2 1) R1) + ((EQUAL R2 1.0) (COND ((MNUMP R1) (ADDK 0.0 R1)) (T R1))) + ((EQUAL R2 BIGFLOATONE) (COND ((MNUMP R1) ($BFLOAT R1)) (T R1))) + ((ZEROP1 R1) + (COND ((OR (ZEROP1 R2) (MNEGP R2)) + (COND ((NOT ERRORSW) + (MERROR "~M has been generated" (LIST '(MEXPT) R1 R2))) + (T (*THROW 'ERRORSW T)))) + (T (ZERORES R1 R2)))) + ((OR (ZEROP1 R2) (ONEP1 R1)) + (COND ((OR ($BFLOATP R1) ($BFLOATP R2)) BIGFLOATONE) + ((OR (FLOATP R1) (FLOATP R2)) 1.0) + (T 1))) + ((OR ($BFLOATP R1) ($BFLOATP R2)) ($BFLOAT (LIST '(MEXPT) R1 R2))) + ((AND (NUMBERP R1) (FIXP R2)) (EXPTB R1 R2)) + ((AND (NUMBERP R1) (FLOATP R2) (EQUAL R2 (FLOAT (FIX R2)))) + (EXPTB (FLOAT R1) (FIX R2))) + ((OR $NUMER (AND (FLOATP R2) (OR (PLUSP (NUM1 R1)) $NUMER_PBRANCH))) + (LET (Y) + (COND ((MINUSP (SETQ R1 (ADDK 0.0 R1))) + (COND ((OR $NUMER_PBRANCH (EQ $DOMAIN '$COMPLEX)) + ;; for R1<0: R1^R2 = (-R1)^R2*cos(pi*R2) + i*(-R1)^R2*sin(pi*R2) + (SETQ R2 (ADDK 0.0 R2)) + (SETQ Y (EXPTRL (-$ R1) R2) R2 (TIMES %PI-VAL R2)) + (ADD2 (TIMES Y (COS R2)) + (LIST '(MTIMES SIMP) (TIMES Y (SIN R2)) '$%I))) + (T (SETQ Y (LET ($NUMER $FLOAT $KEEPFLOAT $RATPRINT) + (POWER -1 (RATF R2)))) + (SETQ Y (IF (AND (MEXPTP Y) (EQUAL (CADR Y) -1)) + (LIST '(MEXPT SIMP) -1 (FPCOFRAT (CADDR Y))) + (SSIMPLIFYA Y))) + (MUL2 Y (EXPTRL (-$ R1) R2))))) + ((EQUAL (SETQ R2 (ADDK 0.0 R2)) (FLOAT (FIX R2))) (EXPTB R1 (FIX R2))) + ((AND (EQUAL (SETQ Y (*$ 2.0 R2)) (FLOAT (FIX Y))) (NOT (EQUAL R1 %E-VAL))) + (EXPTB (SQRT R1) (FIX Y))) + (T (EXP (TIMES R2 (LOG R1))))))) + ((FLOATP R2) (LIST '(MEXPT SIMP) R1 R2)) + ((FIXP R2) + (COND ((MINUSP R2) + (EXPTRL (COND ((EQUAL (ABS (CADR R1)) 1) (TIMES (CADR R1) (CADDR R1))) + ((MINUSP (CADR R1)) + (LIST '(RAT) (MINUS (CADDR R1)) (MINUS (CADR R1)))) + (T (LIST '(RAT) (CADDR R1) (CADR R1)))) + (MINUS R2))) + (T (LIST '(RAT SIMP) (EXPTB (CADR R1) R2) (EXPTB (CADDR R1) R2))))) + ((AND (FLOATP R1) (ALIKE1 R2 '((RAT) 1 2))) + (COND ((MINUSP R1) (LIST '(MTIMES SIMP) (SQRT (MINUS R1)) '$%I)) (T (SQRT R1)))) + ((AND (FLOATP R1) (ALIKE1 R2 '((RAT) -1 2))) + (COND ((MINUSP R1) (LIST '(MTIMES SIMP) (//$ -1.0 (SQRT (MINUS R1))) '$%I)) + (T (//$ 1.0 (SQRT R1))))) + ((AND (FLOATP R1) (PLUSP R1)) (EXPTRL R1 (FPCOFRAT R2))) + (EXPTRLSW (LIST '(MEXPT SIMP) R1 R2)) + (T ((LAMBDA (EXPTRLSW) + (SIMPTIMES + (LIST '(MTIMES) + (EXPTRL R1 (*QUO (CADR R2) (CADDR R2))) + ((LAMBDA (Y Z) + (COND ((MEXPTP Y) (LIST (CAR Y) (CADR Y) (MUL2 (CADDR Y) Z))) + (T (POWER Y Z)))) + (LET ($KEEPFLOAT $RATPRINT) (SIMPNRT R1 (CADDR R2))) + (REMAINDER (CADR R2) (CADDR R2)))) + 1 T)) + T)))) + +(DEFMFUN SIMPEXPT (X Y Z) + (PROG (GR POT CHECK RES RULESW W MLPGR MLPPOT) + (SETQ CHECK X) + (COND (Z (SETQ GR (CADR X) POT (CADDR X)) (GO CONT))) + (TWOARGCHECK X) + (SETQ GR (SIMPLIFYA (CADR X) NIL)) + (SETQ POT (SIMPLIFYA (IF $RATSIMPEXPONS ($RATSIMP (CADDR X)) (CADDR X)) NIL)) + CONT (COND (($RATP POT) (SETQ POT (RATDISREP POT)) (GO CONT)) + (($RATP GR) + (COND ((MEMQ 'TRUNC (CAR GR)) (RETURN (SRF (LIST '(MEXPT) GR POT)))) + ((FIXP POT) + (LET ((VARLIST (CADDAR GR)) (GENVAR (CADDDR (CAR GR)))) + (RETURN (RATREP* (LIST '(MEXPT) GR POT))))) + (T (SETQ GR (RATDISREP GR)) (GO CONT)))) + ((OR (SETQ MLPGR (MXORLISTP GR)) (SETQ MLPPOT (MXORLISTP POT))) + (GO MATRIX)) + ((ONEP1 POT) (GO ATGR)) + ((OR (ZEROP1 POT) (ONEP1 GR)) (GO RETNO)) + ((ZEROP1 GR) + (COND ((OR (MNEGP POT) (AND *ZEXPTSIMP? (EQ ($ASKSIGN POT) '$NEG))) + (COND ((NOT ERRORSW) (MERROR "Division by 0")) + (T (*THROW 'ERRORSW T)))) + ((NOT (FREE POT '$%I)) + (COND ((NOT ERRORSW) + (MERROR "0 to a complex quantity has been generated.")) + (T (*THROW 'ERRORSW T)))) + (T (RETURN (ZERORES GR POT))))) + ((AND (MNUMP GR) (MNUMP POT) + (OR (NOT (RATNUMP GR)) (NOT (RATNUMP POT)))) + (RETURN (EQTEST (EXPTRL GR POT) CHECK))) + ((EQ GR '$%I) (RETURN (%ITOPOT POT))) + ((AND (NUMBERP GR) (MINUSP GR) (MEVENP POT)) (SETQ GR (MINUS GR)) (GO CONT)) + ((AND (NUMBERP GR) (MINUSP GR) (MODDP POT)) + (RETURN (MUL2 -1 (POWER (MINUS GR) POT)))) + ((AND (EQUAL GR -1) (INTEGERP POT) (MMINUSP POT)) + (SETQ POT (NEG POT)) (GO CONT)) + ((AND (EQUAL GR -1) (INTEGERP POT) (MTIMESP POT) + (= (LENGTH POT) 3) (EQ (TYPEP (CADR POT)) 'FIXNUM) + (ODDP (CADR POT)) (INTEGERP (CADDR POT))) + (SETQ POT (CADDR POT)) (GO CONT)) + ((ATOM GR) (GO ATGR)) + ((AND (EQ (CAAR GR) 'MABS) + (EVNUMP POT) + (OR (AND (EQ $DOMAIN '$REAL) (NOT (DECL-COMPLEXP (CADR GR)))) + (AND (EQ $DOMAIN '$COMPLEX) (DECL-REALP (CADR GR))))) + (RETURN (POWER (CADR GR) POT))) + ((EQ (CAAR GR) 'MEQUAL) + (RETURN (EQTEST (LIST (NCONS (CAAR GR)) + (POWER (CADR GR) POT) + (POWER (CADDR GR) POT)) + GR))) + ((EQ (TYPEP POT) 'SYMBOL) (GO OPP)) + ((EQ (CAAR GR) 'MEXPT) (GO E1)) + ((AND (EQ (CAAR GR) '%SUM) $SUMEXPAND (FIXP POT) + (SIGNP G POT) (LESSP POT $MAXPOSEX)) + (RETURN (DO ((I (1- POT) (1- I)) + (AN GR (SIMPTIMES (LIST '(MTIMES) AN GR) 1 T))) + ((SIGNP E I) AN)))) + ((EQUAL POT -1) (RETURN (EQTEST (TESTT (TMS GR POT NIL)) CHECK))) + ((EQ (TYPEP POT) 'FIXNUM) + (RETURN (EQTEST (COND ((AND (MPLUSP GR) + (NOT (OR (GREATERP POT $EXPOP) + (GREATERP (MINUS POT) $EXPON)))) + (EXPANDEXPT GR POT)) + (T (SIMPLIFYA (TMS GR POT NIL) T))) + CHECK)))) + OPP (COND ((EQ (CAAR GR) 'MEXPT) (GO E1)) + ((EQ (CAAR GR) 'RAT) + (RETURN (MUL2 (POWER (CADR GR) POT) (POWER (CADDR GR) (MUL2 -1 POT))))) + ((NOT (EQ (CAAR GR) 'MTIMES)) (GO UP)) + ((OR (EQ $RADEXPAND '$ALL) (AND $RADEXPAND (SIMPLEXPON POT))) + (SETQ RES (LIST 1)) (GO START)) + ((AND (OR (NOT (NUMBERP (CADR GR))) (EQUAL (CADR GR) -1)) + (SETQ W (MEMBER ($NUM GR) '(1 -1)))) + (SETQ POT (MULT -1 POT) GR (MUL2 (CAR W) ($DENOM GR))) (GO CONT)) + ((NOT $RADEXPAND) (GO UP))) + (RETURN (DO ((L (CDR GR) (CDR L)) (RES (NCONS 1)) (RAD)) + ((NULL L) + (COND ((EQUAL RES '(1)) + (EQTEST (LIST '(MEXPT) GR POT) CHECK)) + ((NULL RAD) (TESTT (CONS '(MTIMES SIMP) RES))) + (T (SETQ RAD (POWER* ; RADEXPAND=()? + (CONS '(MTIMES) (NREVERSE RAD)) POT)) + (COND ((NOT (ONEP1 RAD)) + (SETQ RAD (TESTT (TMS RAD 1 (CONS '(MTIMES) RES)))) + (COND (RULESW (SETQ RULESW NIL RES (CDR RAD)))))) + (EQTEST (TESTT (CONS '(MTIMES) RES)) CHECK)))) + (SETQ Z (COND ((NOT (FREE (CAR L) '$%I)) '$PNZ) + (T ($SIGN (CAR L))))) + (SETQ W (COND ((MEMQ Z '($NEG $NZ)) + (SETQ RAD (CONS -1 RAD)) (MULT -1 (CAR L))) + (T (CAR L)))) + (COND ((ONEP1 W)) + ((ALIKE1 W GR) (RETURN (LIST '(MEXPT SIMP) GR POT))) +;not needed? ((MEXPTP W) +; (SETQ Z (LIST '(MEXPT) (CAR L) POT)) +; (COND ((ALIKE1 Z (SETQ Z (SIMPLIFYA Z NIL))) +; (SETQ RAD (CONS W RAD))) +; (T (SETQ W (TIMESIN Z RES 1))))) + ((MEMQ Z '($PN $PNZ)) (SETQ RAD (CONS W RAD))) + (T (SETQ W (TESTT (TMS (SIMPLIFYA (LIST '(MEXPT) W POT) T) + 1 (CONS '(MTIMES) RES)))))) + (COND (RULESW (SETQ RULESW NIL RES (CDR W)))))) + START(COND ((AND (CDR RES) (ONEP1 (CAR RES)) (RATNUMP (CADR RES))) + (SETQ RES (CDR RES)))) + (COND ((NULL (SETQ GR (CDR GR))) + (RETURN (EQTEST (TESTT (CONS '(MTIMES) RES)) CHECK))) + ((MEXPTP (CAR GR)) + (SETQ Y (LIST (CAAR GR) (CADAR GR) (MULT (CADDAR GR) POT)))) + ((EQ (CAR GR) '$%I) (SETQ Y (%ITOPOT POT))) + ((MNUMP (CAR GR)) (SETQ Y (LIST '(MEXPT) (CAR GR) POT))) + (T (SETQ Y (LIST '(MEXPT SIMP) (CAR GR) POT)))) + (SETQ W (TESTT (TMS (SIMPLIFYA Y T) 1 (CONS '(MTIMES) RES)))) + (COND (RULESW (SETQ RULESW NIL RES (CDR W)))) + (GO START) + RETNO(RETURN (EXPTRL GR POT)) + ATGR (COND ((ZEROP1 POT) (GO RETNO)) + ((ONEP1 POT) + ((LAMBDA (Y) + (COND ((AND Y (FLOATP Y) (OR $NUMER (NOT (EQUAL POT 1)))) + (RETURN + (COND ((AND (EQ GR '$%E) (EQUAL POT BIGFLOATONE)) + ($BFLOAT '$%E)) + (T Y)))) + (T (GO RETNO)))) + (MGET GR '$NUMER))) + ((EQ GR '$%E) + (COND (($BFLOATP POT) (RETURN ($BFLOAT (LIST '(MEXPT) '$%E POT)))) + ((OR (FLOATP POT) (AND $NUMER (FIXP POT))) + (RETURN (EXP POT))) + ((AND $LOGSIMP (AMONG '%LOG POT)) (RETURN (%ETOLOG POT))) + ((AND $DEMOIVRE (SETQ Z (DEMOIVRE POT))) (RETURN Z)) + ((AND $%EMODE (SETQ Z (%ESPECIAL POT))) (RETURN Z)))) + (T ((LAMBDA (Y) (AND Y (FLOATP Y) + (OR (FLOATP POT) (AND $NUMER (FIXP POT))) + (RETURN (EXPTRL Y POT)))) (MGET GR '$NUMER)))) + UP (RETURN (EQTEST (LIST '(MEXPT) GR POT) CHECK)) + MATRIX + (COND ((ZEROP1 POT) + (COND ((MXORLISTP1 GR) (RETURN (CONSTMX (ADDK 1 POT) GR))) (T (GO RETNO)))) + ((ONEP1 POT) (RETURN GR)) + ((OR $DOALLMXOPS $DOSCMXOPS $DOMXEXPT) + (COND ((OR (AND MLPGR (OR (NOT ($LISTP GR)) $LISTARITH) + (SCALAR-OR-CONSTANT-P POT $ASSUMESCALAR)) + (AND $DOMXEXPT MLPPOT (OR (NOT ($LISTP POT)) $LISTARITH) + (SCALAR-OR-CONSTANT-P GR $ASSUMESCALAR))) + (RETURN (SIMPLIFYA (OUTERMAP1 'MEXPT GR POT) T))) + (T (GO UP)))) + ((AND $DOMXMXOPS (MEMBER POT '(-1 -1.0))) + (RETURN (SIMPLIFYA (OUTERMAP1 'MEXPT GR POT) T))) + (T (GO UP))) + E1 (COND ((OR (EQ $RADEXPAND '$ALL) (SIMPLEXPON POT) (NONEG (CADR GR)) + (EQUAL (CADDR GR) -1) + (AND (EQ $DOMAIN '$REAL) (ODNUMP (CADDR GR)))) + (SETQ POT (MULT POT (CADDR GR)) GR (CADR GR))) + ((AND (EQ $DOMAIN '$REAL) (FREE GR '$%I) $RADEXPAND + (EVNUMP (CADDR GR))) + (SETQ POT (MULT POT (CADDR GR)) GR (RADMABS (CADR GR)))) + ((MMINUSP (CADDR GR)) + (SETQ POT (NEG POT) + GR (LIST (CAR GR) (CADR GR) (NEG (CADDR GR))))) + (T (GO UP))) + (GO CONT))) + +(DEFUN TIMESIN (X Y W) ; Multiply X^W into Y + (PROG (FM TEMP Z CHECK U) + (IF (MEXPTP X) (SETQ CHECK X)) + TOP (COND ((EQUAL W 1) (SETQ TEMP X)) + (T (SETQ TEMP (CONS '(MEXPT) (IF CHECK (LIST (CADR X) (MULT (CADDR X) W)) + (LIST X W)))) + (IF (AND (NOT TIMESINP) (NOT (EQ X '$%I))) + (LET ((TIMESINP T)) (SETQ TEMP (SIMPLIFYA TEMP T)))))) + (SETQ X (IF (MEXPTP TEMP) (CDR TEMP) (LIST TEMP 1))) + (SETQ W (CADR X) FM Y) + START(COND ((NULL (CDR FM)) (GO LESS)) + ((MEXPTP (CADR FM)) + (COND ((ALIKE1 (CAR X) (CADADR FM)) + (COND ((ZEROP1 (SETQ W (PLSK (CADDR (CADR FM)) W))) (GO DEL)) + ((AND (MNUMP W) (OR (MNUMP (CAR X)) (EQ (CAR X) '$%I))) + (RPLACD FM (CDDR FM)) + (COND ((MNUMP (SETQ X (IF (MNUMP (CAR X)) + (EXPTRL (CAR X) W) + (POWER (CAR X) W)))) + (RETURN (RPLACA Y (TIMESK (CAR Y) X)))) + ((MTIMESP X) (GO TIMES)) + (T (SETQ TEMP X X (IF (MEXPTP X) (CDR X) (LIST X 1))) + (SETQ W (CADR X) FM Y) (GO START)))) + ((CONSTANTP (CAR X)) (GO CONST)) + ((ONEP1 W) (RETURN (RPLACA (CDR FM) (CAR X)))) + (T (GO SPCHECK)))) + ((OR (CONSTANTP (CAR X)) (CONSTANTP (CADADR FM))) + (IF (GREAT TEMP (CADR FM)) (GO GR))) + ((GREAT (CAR X) (CADADR FM)) (GO GR))) + (GO LESS)) + ((ALIKE1 (CAR X) (CADR FM)) (GO EQU)) + ((CONSTANTP (CAR X)) (IF (GREAT TEMP (CADR FM)) (GO GR))) + ((GREAT (CAR X) (CADR FM)) (GO GR))) + LESS (COND ((AND (EQ (CAR X) '$%I) (EQ (TYPEP W) 'FIXNUM)) (GO %I)) + ((AND (EQ (CAR X) '$%E) $NUMER (FIXP W)) + (RETURN (RPLACA Y (TIMESK (CAR Y) (EXP W))))) + ((AND (ONEP1 W) (NOT (CONSTANT (CAR X)))) (GO LESS1)) + ((AND (CONSTANTP (CAR X)) + (DO L (CDR FM) (CDR L) (NULL (CDR L)) + (WHEN (AND (MEXPTP (CADR L)) (ALIKE1 (CAR X) (CADADR L))) + (SETQ FM L) (RETURN T)))) + (GO START)) + ((OR (AND (MNUMP (CAR X)) (MNUMP W)) + (AND (EQ (CAR X) '$%E) $%EMODE (SETQ U (%ESPECIAL W)))) + (SETQ X (COND (U) + ((ALIKE (CDR CHECK) X) CHECK) + (T (EXPTRL (CAR X) W)))) + (COND ((MNUMP X) (RETURN (RPLACA Y (TIMESK (CAR Y) X)))) + ((MTIMESP X) (GO TIMES)) + ((MEXPTP X) (RETURN (CDR (RPLACD FM (CONS X (CDR FM)))))) + (T (SETQ TEMP X X (LIST X 1) W 1 FM Y) (GO START)))) + ((ONEP1 W) (GO LESS1)) + (T (SETQ TEMP (LIST '(MEXPT) (CAR X) W)) + (SETQ TEMP (EQTEST TEMP (OR CHECK '((FOO))))) + (RETURN (CDR (RPLACD FM (CONS TEMP (CDR FM))))))) + LESS1 (RETURN (CDR (RPLACD FM (CONS (CAR X) (CDR FM))))) + GR (SETQ FM (CDR FM)) (GO START) + EQU (COND ((AND (EQ (CAR X) '$%I) (EQUAL W 1)) + (RPLACD FM (CDDR FM)) (RETURN (RPLACA Y (TIMESK -1 (CAR Y))))) + ((ZEROP1 (SETQ W (PLSK 1 W))) (GO DEL)) + ((AND (MNUMP (CAR X)) (MNUMP W)) + (RETURN (RPLACA (CDR FM) (EXPTRL (CAR X) W)))) + ((CONSTANTP (CAR X)) (GO CONST))) + SPCHECK(SETQ Z (LIST '(MEXPT) (CAR X) W)) + (COND ((ALIKE1 (SETQ X (SIMPLIFYA Z T)) Z) (RETURN (RPLACA (CDR FM) X))) + (T (RPLACD FM (CDDR FM)) (SETQ RULESW T) (RETURN (MULN (CONS X Y) T)))) + CONST (RPLACD FM (CDDR FM)) + (SETQ X (CAR X) CHECK NIL) + (GO TOP) + TIMES (SETQ Z (TMS X 1 (SETQ TEMP (CONS '(MTIMES) Y)))) + (RETURN (COND ((EQ Z TEMP) (CDR Z)) (T (SETQ RULESW T) Z))) + DEL (RETURN (RPLACD FM (CDDR FM))) + %I (IF (MINUSP (SETQ W (REMAINDER W 4))) (SETQ W (+ 4 W))) + (RETURN (COND ((ZEROP W) FM) + ((= W 2) (RPLACA Y (TIMESK -1 (CAR Y)))) + ((= W 3) (RPLACA Y (TIMESK -1 (CAR Y))) + (RPLACD FM (CONS '$%I (CDR FM)))) + (T (RPLACD FM (CONS '$%I (CDR FM)))))))) + +(DEFMFUN SIMPMATRIX (X VESTIGIAL Z) + VESTIGIAL ;Ignored. + (IF (AND (NULL (CDDR X)) + $SCALARMATRIXP + (OR (EQ $SCALARMATRIXP '$ALL) (MEMQ 'MULT (CDAR X))) + ($LISTP (CADR X)) (CDADR X) (NULL (CDDADR X))) + (SIMPLIFYA (CADADR X) Z) + (LET ((BADP (DOLIST (ROW (CDR X)) (IF (NOT ($LISTP ROW)) (RETURN T)))) + (ARGS (SIMPMAP (CDR X) Z))) + (CONS (IF BADP '(%MATRIX SIMP) '($MATRIX SIMP)) ARGS)))) + +(DEFUN %ITOPOT (POT) + (IF (EQ (TYPEP POT) 'FIXNUM) + (LET ((I (BOOLE 1 POT 3))) + (COND ((= I 0) 1) + ((= I 1) '$%I) + ((= I 2) -1) + (T (LIST '(MTIMES SIMP) -1 '$%I)))) + (POWER -1 (MUL2 POT '((RAT SIMP) 1 2))))) + +(DEFUN MNLOGP (POT) + (COND ((EQ (CAAR POT) '%LOG) (SIMPLIFYA (CADR POT) NIL)) + ((AND (EQ (CAAR POT) 'MTIMES) + (OR (INTEGERP (CADR POT)) (AND $%E/_TO/_NUMLOG ($NUMBERP (CADR POT)))) + (NOT (ATOM (CADDR POT))) (EQ (CAAR (CADDR POT)) '%LOG) + (NULL (CDDDR POT))) + (POWER (CADR (CADDR POT)) (CADR POT))))) + +(DEFUN MNLOG (POT) + (PROG (A B C) + LOOP (COND ((NULL POT) + (COND (A (SETQ A (CONS '(MTIMES) A)))) + (COND (C (SETQ C (LIST '(MEXPT SIMP) '$%E (ADDN C NIL))))) + (RETURN (COND ((NULL C) (SIMPTIMES A 1 NIL)) + ((NULL A) C) + (T (SIMPTIMES (APPEND A (LIST C)) 1 NIL))))) + ((AND (AMONG '%LOG (CAR POT)) (SETQ B (MNLOGP (CAR POT)))) + (SETQ A (CONS B A))) + (T (SETQ C (CONS (CAR POT) C)))) + (SETQ POT (CDR POT)) + (GO LOOP))) + +(DEFUN %ETOLOG (POT) (COND ((MNLOGP POT)) + ((EQ (CAAR POT) 'MPLUS) (MNLOG (CDR POT))) + (T (LIST '(MEXPT SIMP) '$%E POT)))) + +(DEFUN ZERORES (R1 R2) + (COND ((OR ($BFLOATP R1) ($BFLOATP R2)) BIGFLOATZERO) + ((OR (FLOATP R1) (FLOATP R2)) 0.0) + (T 0))) + +(DEFMFUN $ORDERLESSP (A B) + (SETQ A (SPECREPCHECK A) B (SPECREPCHECK B)) + (AND (NOT (ALIKE1 A B)) (GREAT B A))) + +(DEFMFUN $ORDERGREATP (A B) + (SETQ A (SPECREPCHECK A) B (SPECREPCHECK B)) + (AND (NOT (ALIKE1 A B)) (GREAT A B))) + +(DEFUN EVNUMP (N) (OR (EVEN N) (AND (RATNUMP N) (EVEN (CADR N))))) +(DEFUN ODNUMP (N) (OR (AND (FIXP N) (ODDP N)) + (AND (RATNUMP N) (ODDP (CADR N))))) + +(DEFUN SIMPLEXPON (E) + (OR (INTEGERP E) + (AND (EQ $DOMAIN '$REAL) (RATNUMP E) (ODDP (CADDR E))))) + +(DEFUN NONEG (P) (AND (FREE P '$%I) (MEMQ ($SIGN P) '($POS $PZ $ZERO)))) + +(DEFUN RADMABS (E) + (IF (AND LIMITP (FREE E '$%I)) (ASKSIGN-P-OR-N E)) + (SIMPLIFYA (LIST '(MABS) E) T)) + +(DEFMFUN SIMPMQAPPLY (EXP Y Z) + (LET ((SIMPFUN (AND (NOT (ATOM (CADR EXP))) (GET (CAAADR EXP) 'SPECSIMP))) U) + (IF SIMPFUN + (FUNCALL SIMPFUN EXP Y Z) + (PROGN (SETQ U (SIMPARGS EXP Z)) + (IF (SYMBOLP (CADR U)) + (SIMPLIFYA (CONS (CONS (CADR U) (CDAR U)) (CDDR U)) Z) + U))))) + +(DEFMFUN DECL-COMPLEXP (E) + (AND (EQ (TYPEP E) 'SYMBOL) + (KINDP E '$COMPLEX) + (NOT (KINDP E '$REAL)))) + +(DEFMFUN DECL-REALP (E) + (AND (EQ (TYPEP E) 'SYMBOL) (KINDP E '$REAL))) + +(DEFMFUN GREAT (X Y) + (COND ((ATOM X) + (COND ((ATOM Y) + (COND ((NUMBERP X) + (COND ((NUMBERP Y) + (SETQ Y (*DIF X Y)) + (COND ((ZEROP Y) (FLOATP X)) (T (PLUSP Y)))))) + ((CONSTANT X) + (COND ((CONSTANT Y) (ALPHALESSP Y X)) (T (NUMBERP Y)))) + ((MGET X '$SCALAR) + (COND ((MGET Y '$SCALAR) (ALPHALESSP Y X)) (T (CONSTANTP Y)))) + ((MGET X '$MAINVAR) + (COND ((MGET Y '$MAINVAR) (ALPHALESSP Y X)) (T T))) + (T (OR (CONSTANTP Y) (MGET Y '$SCALAR) + (AND (NOT (MGET Y '$MAINVAR)) (ALPHALESSP Y X)))))) + (T (NOT (ORDFNA Y X))))) + ((ATOM Y) (ORDFNA X Y)) + ((EQ (CAAR X) 'RAT) + (COND ((EQ (CAAR Y) 'RAT) + (GREATERP (TIMES (CADDR Y) (CADR X)) (TIMES (CADDR X) (CADR Y)))))) + ((EQ (CAAR Y) 'RAT)) + ((MEMQ (CAAR X) '(MBOX MLABOX)) (GREAT (CADR X) Y)) + ((MEMQ (CAAR Y) '(MBOX MLABOX)) (GREAT X (CADR Y))) + ((OR (MEMQ (CAAR X) '(MTIMES MPLUS MEXPT %DEL)) + (MEMQ (CAAR Y) '(MTIMES MPLUS MEXPT %DEL))) + (ORDFN X Y)) + ((AND (EQ (CAAR X) 'BIGFLOAT) (EQ (CAAR Y) 'BIGFLOAT)) (MGRP X Y)) + (T (DO ((X1 (MARGS X) (CDR X1)) (Y1 (MARGS Y) (CDR Y1))) (()) + (COND ((NULL X1) + (RETURN (COND (Y1 NIL) + ((NOT (ALIKE1 (MOP X) (MOP Y))) + (GREAT (MOP X) (MOP Y))) + ((MEMQ 'ARRAY (CDAR X)) T)))) + ((NULL Y1) (RETURN T)) + ((NOT (ALIKE1 (CAR X1) (CAR Y1))) + (RETURN (GREAT (CAR X1) (CAR Y1))))))))) + +;; Trivial function used only in ALIKE1. Should be defined as an open-codable subr. + +(DEFMACRO MEMQARR (L) `(IF (MEMQ 'ARRAY ,L) T)) + +;; Compares two Macsyma expressions ignoring SIMP flags and all other +;; items in the header except for the ARRAY flag. + +(DEFMFUN ALIKE1 (X Y) + (COND ((EQ X Y)) + ((ATOM X) (EQUAL X Y)) + ((ATOM Y) NIL) + (T (AND (NOT (ATOM (CAR X))) + (NOT (ATOM (CAR Y))) + (EQ (CAAR X) (CAAR Y)) + (EQ (MEMQARR (CDAR X)) (MEMQARR (CDAR Y))) + (ALIKE (CDR X) (CDR Y)))))) + +;; Maps ALIKE1 down two lists. + +(DEFMFUN ALIKE (X Y) + (DO ((X X (CDR X)) (Y Y (CDR Y))) ((ATOM X) (EQUAL X Y)) + (COND ((OR (ATOM Y) (NOT (ALIKE1 (CAR X) (CAR Y)))) + (RETURN NIL))))) + +#+Franz +(DEFUN ALIKE1-PART2 (X Y) + (AND (NOT (ATOM (CAR X))) + (NOT (ATOM (CAR Y))) + (EQ (CAAR X) (CAAR Y)) + (EQ (MEMQARR (CDAR X)) (MEMQARR (CDAR Y))) + (ALIKE (CDR X) (CDR Y)))) + +(DEFUN ORDFNA (E A) ; A is an atom + (COND ((NUMBERP A) + (OR (NOT (EQ (CAAR E) 'RAT)) + (GREATERP (CADR E) (TIMES (CADDR E) A)))) + ((AND (CONSTANT A) (NOT (MEMQ (CAAR E) '(MPLUS MTIMES MEXPT)))) + (NOT (MEMQ (CAAR E) '(RAT BIGFLOAT)))) + ((NULL (MARGS E)) NIL) + ((EQ (CAAR E) 'MEXPT) + (COND ((AND (CONSTANTP (CADR E)) + (OR (NOT (CONSTANT A)) (NOT (CONSTANTP (CADDR E))))) + (OR (NOT (FREE (CADDR E) A)) (GREAT (CADDR E) A))) + ((EQ (CADR E) A) (GREAT (CADDR E) 1)) + (T (GREAT (CADR E) A)))) + ((MEMQ (CAAR E) '(MPLUS MTIMES)) + (LET ((U (CAR (LAST E)))) + (COND ((EQ U A) (NOT (ORDHACK E))) (T (GREAT U A))))) + ((EQ (CAAR E) '%DEL)) + ((PROG2 (SETQ E (CAR (MARGS E))) + (AND (NOT (ATOM E)) (MEMQ (CAAR E) '(MPLUS MTIMES)))) + (LET ((U (CAR (LAST E)))) (OR (EQ U A) (GREAT U A)))) + ((EQ E A)) + (T (GREAT E A)))) + +(DEFUN ORDLIST (A B CX CY) + (PROG (L1 L2 C D) + (SETQ L1 (LENGTH A) L2 (LENGTH B)) + LOOP (COND ((= L1 0) + (RETURN (COND ((= L2 0) (EQ CX 'MPLUS)) + ((AND (EQ CX CY) (= L2 1)) + (GREAT (COND ((EQ CX 'MPLUS) 0) (T 1)) (CAR B)))))) + ((= L2 0) (RETURN (NOT (ORDLIST B A CY CX))))) + (SETQ C (NTHELEM L1 A) D (NTHELEM L2 B)) + (COND ((NOT (ALIKE1 C D)) (RETURN (GREAT C D)))) + (SETQ L1 (1- L1) L2 (1- L2)) + (GO LOOP))) + +(DEFUN ORDFN (X Y) + (LET ((CX (CAAR X)) (CY (CAAR Y)) U) + (COND ((EQ CX '%DEL) (COND ((EQ CY '%DEL) (GREAT (CADR X) (CADR Y))) (T T))) + ((EQ CY '%DEL) NIL) + ((MEMQ CX '(MPLUS MTIMES)) + (COND ((MEMQ CY '(MPLUS MTIMES)) (ORDLIST (CDR X) (CDR Y) CX CY)) + ((ALIKE1 (SETQ U (CAR (LAST X))) Y) (NOT (ORDHACK X))) + (T (GREAT U Y)))) + ((MEMQ CY '(MPLUS MTIMES)) + (COND ((ALIKE1 X (SETQ U (CAR (LAST Y)))) (ORDHACK Y)) (T (GREAT X U)))) + ((EQ CX 'MEXPT) + (COND ((EQ CY 'MEXPT) + (COND ((ALIKE1 (CADR X) (CADR Y)) (GREAT (CADDR X) (CADDR Y))) + ((CONSTANTP (CADR X)) + (COND ((CONSTANTP (CADR Y)) + (COND ((OR (ALIKE1 (CADDR X) (CADDR Y)) + (AND (MNUMP (CADDR X)) (MNUMP (CADDR Y)))) + (GREAT (CADR X) (CADR Y))) + (T (GREAT (CADDR X) (CADDR Y))))) + (T (GREAT X (CADR Y))))) + ((CONSTANTP (CADR Y)) (GREAT (CADR X) Y)) + ((MNUMP (CADDR X)) + (GREAT (CADR X) (COND ((MNUMP (CADDR Y)) (CADR Y)) (T Y)))) + ((MNUMP (CADDR Y)) (GREAT X (CADR Y))) + (T (SETQ CX (SIMPLN1 X) CY (SIMPLN1 Y)) + (COND ((ALIKE1 CX CY) (GREAT (CADR X) (CADR Y))) + (T (GREAT CX CY)))))) + ((CONSTANTP (CADR X)) + (COND ((ALIKE1 (CADDR X) Y) T) (T (GREAT (CADDR X) Y)))) + ((ALIKE1 (CADR X) Y) (GREAT (CADDR X) 1)) + ((MNUMP (CADDR X)) (GREAT (CADR X) Y)) + (T (GREAT (SIMPLN1 X) (SIMPLN (LIST '(%LOG) Y) 1 T))))) + (T (NOT (ORDFN Y X)))))) ; (EQ CY 'MEXPT) + +(DEFUN ORDHACK (X) + (COND ((AND (CDDR X) (NULL (CDDDR X))) + (GREAT (COND ((EQ (CAAR X) 'MPLUS) 0) (T 1)) (CADR X))))) + +(DEFMFUN $MULTTHRU NARGS + (LET (ARG1 ARG2) + (COND ((= NARGS 2) + (SETQ ARG1 (SPECREPCHECK (ARG 1)) ARG2 (SPECREPCHECK (ARG 2))) + (COND ((OR (ATOM ARG2) (NOT (MEMQ (CAAR ARG2) '(MPLUS MEQUAL)))) + (MUL2 ARG1 ARG2)) + ((EQ (CAAR ARG2) 'MEQUAL) + (LIST (CAR ARG2) ($MULTTHRU ARG1 (CADR ARG2)) + ($MULTTHRU ARG1 (CADDR ARG2)))) + (T (EXPANDTERMS ARG1 (CDR ARG2))))) + ((= NARGS 1) + (PROG (P FLAG) + (SETQ ARG1 (SPECREPCHECK (ARG 1))) + (COND ((ATOM ARG1) (RETURN ARG1)) + ((EQ (CAAR ARG1) 'MNCTIMES) (SETQ FLAG T)) + ((NOT (EQ (CAAR ARG1) 'MTIMES)) (RETURN ARG1))) + (SETQ ARG1 (CDR ARG1)) + (COND ((NULL FLAG) (SETQ ARG1 (REVERSE ARG1)))) + LOOP (COND ((MPLUSP (CAR ARG1)) + (SETQ P (NRECONC P (CDR ARG1))) (GO OUT)) + (T (COND (FLAG (SETQ FLAG 'TT))) + (SETQ P (CONS (CAR ARG1) P)))) + (SETQ ARG1 (CDR ARG1)) + (COND ((NULL ARG1) (RETURN (ARG 1)))) + (GO LOOP) + OUT (SETQ P (COND (FLAG (CAR P)) (T (MULN P T)))) + (RETURN + (ADDN (MAPCAR #'(LAMBDA (Y) + (COND + (FLAG + (SIMPLIFYA (CONS '(MNCTIMES) + (COND ((EQ FLAG 'TT) + (LIST P Y)) + (T (LIST Y P)))) + T)) + (T (MUL2 P Y)))) + (CDAR ARG1)) + T)))) + (T (WNA-ERR '$MULTTHRU))))) + +; EXPANDEXPT computes the expansion of (x1 + x2 + ... + xm)^n +; taking a sum and integer power as arguments. +; Its theory is to recurse down the binomial expansion of +; (x1 + (x2 + x3 + ... + xm))^n using the Binomial Expansion +; Thus it does a sigma: +; +; n +; ------- +; \ / n \ k (n - k) +; > | | x1 (x2 + x3 + ... + xm) +; / \ k / +; ------- +; k=0 +; +; The function EXPONENTIATE-SUM does this and recurses through the second +; sum raised to a power. It takes a list of terms and a positive integer +; power as arguments. + + +(DEFUN EXPANDEXPT (SUM POWER) + (DECLARE (FIXNUM POWER)) + (LET ((EXPANSION (EXPONENTIATE-SUM (CDR SUM) (ABS POWER)))) + (COND ((PLUSP POWER) EXPANSION) + (T `((MEXPT SIMP) ,EXPANSION -1))))) + +(DEFUN EXPONENTIATE-SUM (TERMS RPOWER) + (DECLARE (FIXNUM RPOWER I)) + (COND ((= RPOWER 0) 1) + ((NULL (CDR TERMS)) (POWER (CAR TERMS) RPOWER)) + ((= RPOWER 1) (CONS '(MPLUS SIMP) TERMS)) + (T (DO ((I 0 (1+ I)) + (RESULT 0 (ADD2 RESULT + (MULN (LIST (COMBINATION RPOWER I) + (EXPONENTIATE-SUM (CDR TERMS) + (- RPOWER I)) + (POWER (CAR TERMS) I)) T)))) + ((> I RPOWER) RESULT))))) + +; Computes the combination of n elements taken m at a time by the formula +; +; (n * (n-1) * ... * (n - m + 1)) / m! = +; (n / 1) * ((n - 1) / 2) * ... * ((n - m + 1) / m) +; +; Checks for the case when m is greater than n/2 and translates +; to an equivalent expression. + +(DEFUN COMBINATION (N M) + (DECLARE (FIXNUM N M N1 M1)) + (COND ((> M (// N 2)) (COMBINATION N (- N M))) + (T (DO ((RESULT 1 (QUOTIENT (TIMES RESULT N1) M1)) + (N1 N (1- N1)) + (M1 1 (1+ M1))) + ((> M1 M) RESULT))))) + +(DEFUN EXPANDSUMS (A B) + (ADDN (PROG (C) + (SETQ A (FIXEXPAND A) B (CDR B)) + LOOP (COND ((NULL A) (RETURN C))) + (SETQ C (CONS (EXPANDTERMS (CAR A) B) C)) + (SETQ A (CDR A)) + (GO LOOP)) + T)) + +(DEFUN EXPANDTERMS (A B) + (ADDN (PROG (C) + LOOP (COND ((NULL B) (RETURN C))) + (SETQ C (CONS (MUL2 A (CAR B)) C)) + (SETQ B (CDR B)) + (GO LOOP)) + T)) + +(DEFUN GENEXPANDS (L) + (PROG NIL + LOOP (SETQ L (CDR L)) + (COND ((NULL L) + (SETQ PRODS (NREVERSE PRODS) NEGPRODS (NREVERSE NEGPRODS) + SUMS (NREVERSE SUMS) NEGSUMS (NREVERSE NEGSUMS)) + (RETURN NIL)) + ((ATOM (CAR L)) (SETQ PRODS (CONS (CAR L) PRODS))) + ((EQ (CAAAR L) 'RAT) + (COND ((NOT (EQUAL (CADAR L) 1)) (SETQ PRODS (CONS (CADAR L) PRODS)))) + (SETQ NEGPRODS (CONS (CADDAR L) NEGPRODS))) + ((EQ (CAAAR L) 'MPLUS) (SETQ SUMS (CONS (CAR L) SUMS))) + ((AND (EQ (CAAAR L) 'MEXPT) (EQUAL (CADDAR L) -1) (MPLUSP (CADAR L))) + (SETQ NEGSUMS (CONS (CADAR L) NEGSUMS))) + ((AND (EQ (CAAAR L) 'MEXPT) ((LAMBDA (EXPANDP) (MMINUSP (CADDAR L))) T)) + (SETQ NEGPRODS + (CONS (COND ((EQUAL (CADDAR L) -1) (CADAR L)) + (T (LIST (CAAR L) (CADAR L) (NEG (CADDAR L))))) + NEGPRODS))) + (T (SETQ PRODS (CONS (CAR L) PRODS)))) + (GO LOOP))) + +(DEFUN EXPANDTIMES (A) + (PROG (PRODS NEGPRODS SUMS NEGSUMS EXPSUMS EXPNEGSUMS) + (GENEXPANDS A) + (SETQ PRODS (COND ((NULL PRODS) 1) + ((NULL (CDR PRODS)) (CAR PRODS)) + (T (CONS '(MTIMES SIMP) PRODS)))) + (SETQ NEGPRODS (COND ((NULL NEGPRODS) 1) + ((NULL (CDR NEGPRODS)) (CAR NEGPRODS)) + (T (CONS '(MTIMES SIMP) NEGPRODS)))) + (COND ((NULL SUMS) (GO DOWN)) + (T (SETQ EXPSUMS (CAR SUMS)) + (MAPC (FUNCTION (LAMBDA (C) + (SETQ EXPSUMS (EXPANDSUMS EXPSUMS C)))) + (CDR SUMS)))) + (SETQ PRODS (COND ((EQUAL PRODS 1) EXPSUMS) + (T (EXPANDTERMS PRODS (FIXEXPAND EXPSUMS))))) + DOWN (COND + ((NULL NEGSUMS) + (COND + ((EQUAL 1 NEGPRODS) (RETURN PRODS)) + ((MPLUSP PRODS) (RETURN (EXPANDTERMS (POWER NEGPRODS -1) (CDR PRODS)))) + (T (RETURN ((LAMBDA (EXPANDFLAG) (MUL2 PRODS (POWER NEGPRODS -1))) T))))) + (T (SETQ EXPNEGSUMS (CAR NEGSUMS)) + (MAPC (FUNCTION (LAMBDA (C) + (SETQ EXPNEGSUMS (EXPANDSUMS EXPNEGSUMS C)))) + (CDR NEGSUMS)))) + (SETQ EXPNEGSUMS (EXPANDTERMS NEGPRODS (FIXEXPAND EXPNEGSUMS))) + (RETURN + (COND ((MPLUSP PRODS) + (EXPANDTERMS (LIST '(MEXPT SIMP) EXPNEGSUMS -1) (CDR PRODS))) + (T ((LAMBDA (EXPANDFLAG) + (MUL2 PRODS (LIST '(MEXPT SIMP) EXPNEGSUMS -1))) T)))))) + +(DEFMFUN EXPAND1 (EXP $EXPOP $EXPON) + (SSIMPLIFYA (SPECREPCHECK EXP))) + +;; When the arg-count checking code is implemented ... +;; (DEFMFUN $EXPAND (EXP &OPTIONAL ($EXPOP $MAXPOSEX) ($EXPON $MAXNEGEX)) +;; (SSIMPLIFYA (SPECREPCHECK EXP))) + +(DEFMFUN $EXPAND NARGS + (COND ((= NARGS 1) (EXPAND1 (ARG 1) $MAXPOSEX $MAXNEGEX)) + ((= NARGS 2) (EXPAND1 (ARG 1) (ARG 2) $MAXNEGEX)) + ((= NARGS 3) (EXPAND1 (ARG 1) (ARG 2) (ARG 3))) + (T (WNA-ERR '$EXPAND)))) + +(DEFUN FIXEXPAND (A) (COND ((NOT (MPLUSP A)) (NCONS A)) (T (CDR A)))) + + +(DEFMFUN SIMPNRT (X *N) ; computes X^(1/*N) + (PROG (*IN *OUT VARLIST GENVAR $FACTORFLAG $DONTFACTOR) + (SETQ $FACTORFLAG T) + (NEWVAR X) + (SETQ X (RATREP* X)) + (COND ((EQUAL (CADR X) 0) (RETURN 0))) + (SETQ X (RATFACT (CDR X) 'PSQFR)) + (SIMPNRT1 (MAPCAR #'PDIS X)) + (SETQ *OUT (COND (*OUT (MULN *OUT NIL)) (T 1))) + (SETQ *IN (COND (*IN (SETQ *IN (MULN *IN NIL)) + (NRTHK *IN *N)) + (T 1))) + (RETURN + ((LAMBDA ($%EMODE) + (SIMPLIFYA (LIST '(MTIMES) *IN *OUT) + (NOT (OR (ATOM *IN) + (ATOM (CADR *IN)) + (MEMQ (CAAADR *IN) '(MPLUS MTIMES RAT)))))) + T)))) + +(DEFUN SIMPNRT1 (X) + (DO ((X X (CDDR X)) (Y)) ((NULL X)) + (COND ((NOT (EQUAL 1 (SETQ Y (GCD (CADR X) *N)))) + (PUSH (SIMPNRT (LIST '(MEXPT) (CAR X) (QUOTIENT (CADR X) Y)) + (QUOTIENT *N Y)) + *OUT)) + ((AND (EQUAL (CADR X) 1) (FIXP (CAR X)) (PLUSP (CAR X)) + (SETQ Y (PNTHROOTP (CAR X) *N))) + (PUSH Y *OUT)) + (T (COND ((NOT (GREATERP *N (ABS (CADR X)))) + (PUSH (LIST '(MEXPT) (CAR X) (QUOTIENT (CADR X) *N)) *OUT))) + (PUSH (LIST '(MEXPT) (CAR X) (REMAINDER (CADR X) *N)) *IN))))) + +(DEFUN NRTHK (IN *N) + (COND ((EQUAL IN 1) 1) + ((EQUAL IN -1) + (COND ((EQUAL *N 2) '$%I) + ((EQ $DOMAIN '$REAL) + (COND ((EVEN *N) (NRTHK2 -1 *N)) + (T -1))) + ($M1PBRANCH + ((LAMBDA ($%EMODE) + (POWER* '$%E (LIST '(MTIMES) (LIST '(RAT) 1 *N) '$%PI '$%I))) + T)) + (T (NRTHK2 -1 *N)))) + ((OR (AND WFLAG (EQ ($ASKSIGN IN) '$NEG)) + (AND (MNUMP IN) (EQUAL ($SIGN IN) '$NEG))) + (NRTHK1 (MUL2* -1 IN) *N)) + (T (NRTHK2 IN *N)))) + +(DEFUN NRTHK1 (IN *N) ; computes (-IN)^(1/*N) + (COND ($RADEXPAND (MUL2 (NRTHK2 IN *N) (NRTHK -1 *N))) + (T (NRTHK2 (MUL2* -1 IN) *N)))) + +(DEFUN NRTHK2 (IN *N) (POWER* IN (LIST '(RAT) 1 *N))) ; computes IN^(1/*N) + +;; The following was formerly in SININT. This code was placed here because +;; SININT is now an out-of-core file on MC, and this code is needed in-core +;; because of the various calls to it. - BMT & JPG + +(DECLARE (SPECIAL VAR $RATFAC RATFORM CONTEXT) (FIXNUM NARGS) + (*LEXPR CONTEXT)) + +(DEFMFUN $INTEGRATE NARGS + (LET ($RATFAC) + (COND ((= NARGS 2) + (WITH-NEW-CONTEXT (CONTEXT) + (IF (MEMQ '%RISCH NOUNL) (RISCHINT (ARG 1) (ARG 2)) + (SININT (ARG 1) (ARG 2))))) + ((= NARGS 4) ($DEFINT (ARG 1) (ARG 2) (ARG 3) (ARG 4))) + (T (WNA-ERR '$INTEGRATE))))) + +(DEFUN RATP (A VAR) (COND ((ATOM A) T) + ((MEMQ (CAAR A) '(MPLUS MTIMES)) + (DO ((L (CDR A) (CDR L))) + ((NULL L) T) + (OR (RATP (CAR L) VAR) (RETURN NIL)))) + ((EQ (CAAR A) 'MEXPT) + (COND ((FREE (CADR A) VAR) (FREE (CADDR A) VAR)) + (T (AND (FIXP (CADDR A)) (RATP (CADR A) VAR))))) + (T (FREE A VAR)))) + +(DEFMFUN RATNUMERATOR (R) + (COND ((ATOM R) R) + ((ATOM (CDR R)) (CAR R)) + ((NUMBERP (CADR R)) R) + (T (CAR R)))) + +(DEFMFUN RATDENOMINATOR (R) + (COND ((ATOM R) 1) + ((ATOM (CDR R)) (CDR R)) + ((NUMBERP (CADR R)) 1) + (T (CDR R)))) + +(DECLARE (SPECIAL VAR)) + +(DEFMFUN BPROG (R S) + (PROG (P1B P2B COEF1R COEF2R COEF1S COEF2S F1 F2 A EGCD) + (SETQ R (RATFIX R)) + (SETQ S (RATFIX S)) + (SETQ COEF2R (SETQ COEF1S 0)) + (SETQ COEF2S (SETQ COEF1R 1)) + (SETQ A 1 EGCD 1) + (SETQ P1B (CAR R)) + (UNLESS (ZEROP (PDEGREE P1B VAR)) (SETQ EGCD (PGCDEXPON P1B))) + (SETQ P2B (CAR S)) + (UNLESS (OR (ZEROP (PDEGREE P2B VAR)) (= EGCD 1)) + (SETQ EGCD (GCD EGCD (PGCDEXPON P2B))) + (SETQ P1B (PEXPON*// P1B EGCD NIL) + P2B (PEXPON*// P2B EGCD NIL))) + B1 (COND ((LESSP (PDEGREE P1B VAR) (PDEGREE P2B VAR)) + (EXCH P1B P2B) + (EXCH COEF1R COEF2R) + (EXCH COEF1S COEF2S))) + (IF (ZEROP (PDEGREE P2B VAR)) + (RETURN (CONS (RATREDUCE (PTIMES (CDR R) (PEXPON*// COEF2R EGCD T)) + P2B) + (RATREDUCE (PTIMES (CDR S) (PEXPON*// COEF2S EGCD T)) + P2B)))) + (SETQ F1 (PSQUOREM1 (CDR P1B) (CDR P2B) T)) + (SETQ F2 (PSIMP VAR (CADR F1))) + (SETQ P1B (PQUOTIENTCHK (PSIMP VAR (CADDR F1)) A)) + (SETQ F1 (CAR F1)) + (SETQ COEF1R (PQUOTIENTCHK (PDIFFERENCE (PTIMES F1 COEF1R) + (PTIMES F2 COEF2R)) + A)) + (SETQ COEF1S (PQUOTIENTCHK (PDIFFERENCE (PTIMES F1 COEF1S) + (PTIMES F2 COEF2S)) + A)) + (SETQ A F1) + (GO B1))) + +(DEFUN RATDIFFERENCE (A B) (RATPLUS A (RATMINUS B))) + +(DEFUN RATPL (A B) (RATPLUS (RATFIX A) (RATFIX B))) + +(DEFUN RATTI (A B C) (RATTIMES (RATFIX A) (RATFIX B) C)) + +(DEFUN RATQU (A B) (RATQUOTIENT (RATFIX A) (RATFIX B))) + +(DEFUN RATFIX (A) (COND ((EQUAL A (RATNUMERATOR A)) (CONS A 1)) (T A))) + +(DEFUN RATDIVIDE (F G) + (LET* (((FNUM . FDEN) (RATFIX F)) + ((GNUM . GDEN) (RATFIX G)) + ((Q R) (PDIVIDE FNUM GNUM))) + (CONS (RATQU (RATTI Q GDEN T) FDEN) + (RATQU R FDEN)))) + +(DEFUN POLCOEF (L N) (COND ((OR (ATOM L) (POINTERGP VAR (CAR L))) + (COND ((EQUAL N 0) L) (T 0))) + (T (PTERM (CDR L) N)))) + +(DEFUN DISREP (L) (COND ((EQUAL (RATNUMERATOR L) L) + ($RATDISREP (CONS RATFORM (CONS L 1)))) + (T ($RATDISREP (CONS RATFORM L))))) + +(DECLARE (UNSPECIAL VAR)) + + +;; The following was formerly in MATRUN. This code was placed here because +;; MATRUN is now an out-of-core file on MC, and this code is needed in-core +;; so that MACSYMA SAVE files will work. - JPG + +(SETQ *AFTERFLAG NIL) + +(DEFMFUN MATCHERR NIL (*THROW 'MATCH NIL)) + +(DEFMFUN KAR (X) (IF (ATOM X) (MATCHERR) (CAR X))) + +(DEFMFUN KDR (X) (IF (ATOM X) (MATCHERR) (CDR X))) + +(DEFMFUN SIMPARGS1 (A VESTIGIAL C) + VESTIGIAL ;Ignored. + (SIMPARGS A C)) + +(DEFMFUN *KAR (X) (IF (NOT (ATOM X)) (CAR X))) + +;MATCOEF is obsolete, only needed for old SAVE files. - JPG 5/12/80 +#-NIL +(DEFUN MATCOEF FEXPR (L) + (RATDISREP (RATCOEF (MEVAL (CAR L)) (MEVAL (CADR L))))) +; NIL doesn't handle fexprs, and the compatibility mode isn't +; hacked for it yet. The lexical scoping in the evaluator will +; absolutely shoot to hell any chance of running the output of +; the matchcompiler anyway, without a good bit of hacking to MATCOM +; to make sure all the special declarations are generated. +; The same problem comes up if one tried to compile the output of +; the match compiler in just about any lisp of course. +; The easiest thing to do is probably to write a simple +; dynamic-binding evaluator for use in lusing situations like +; this! +#-NIL +(DEFUN RETLIST FEXPR (L) + (CONS '(MLIST SIMP) + (MAPCAR #'(LAMBDA (Z) (LIST '(MEQUAL SIMP) Z (MEVAL Z))) L))) + +(DEFMFUN NTHKDR (X C) (IF (ZEROP C) X (NTHKDR (KDR X) (SUB1 C)))) + + +; Undeclarations for the file: +(DECLARE (NOTYPE L1 L2 XN NARGS I)) + diff --git a/src/jm/sin.200 b/src/jm/sin.200 new file mode 100644 index 00000000..4a06d596 --- /dev/null +++ b/src/jm/sin.200 @@ -0,0 +1,1419 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module sin) + +(DECLARE (SPECIAL RATFORM EXPTSUM $RADEXPAND $%E/_TO/_NUMLOG + EXPTIND QUOTIND SPLIST L ANS SPLIST ARCPART COEF + AA DICT EXPTFLAG BASE* POWERLIST A B K STACK + RATROOT ROOTLIST SQUARE E W Y EXPRES ARG VAR + POWERL C D EXP CHEBYFORM RATROOTFORM TRIGARG + NOTSAME YY B1 YZ VARLIST GENVAR REPSWITCH $LIFLAG + NOPARTS TOP MAXPARTS NUMPARTS BLANK $OPSUBST) + (*EXPR POWERLIST RATROOT) + (*LEXPR $FACTOR $EXPAND) + (GENPREFIX SIN)) + +(DEFMVAR $INTEGRATION_CONSTANT_COUNTER 0) + +(DEFUN SASSQ1 (ARG LIST FN) + (COND ((NULL LIST) (FUNCALL FN)) + ((EQUAL (CAAR LIST) ARG) (CAR LIST)) + (T (SASSQ1 ARG (CDR LIST) FN)))) + + +(DEFUN OP MACRO (L) (LIST 'GET (CADR L) ''OPERATORS)) + +(DEFUN INTEGERP1 (X) (INTEGERP2 (MUL2* 2 X))) + +(DEFUN SUPEREXPT (EXP VAR BASE*) + (PROG (EXPTFLAG Y W) + (SETQ Y (ELEMXPT EXP)) + (COND (EXPTFLAG (RETURN NIL))) + (RETURN + (SUBSTINT + (LIST '(MEXPT) BASE* VAR) + VAR + (INTEGRATOR + (DIV Y (MUL2 VAR (SIMPLOG (LIST BASE*)))) + VAR))))) + +(DEFUN ELEMXPT (EXP) + (COND ((FREEVAR EXP) EXP) + ((ATOM EXP) (SETQ EXPTFLAG T)) + ((NOT (EQ (CAAR EXP) 'MEXPT)) + (CONS (CAR EXP) + (MAPCAR + (FUNCTION (LAMBDA (C) (ELEMXPT C))) + (CDR EXP)))) + ((NOT (FREEVAR (CADR EXP))) + (LIST '(MEXPT) + (ELEMXPT (CADR EXP)) + (ELEMXPT (CADDR EXP)))) + ((NOT (EQ (CADR EXP) BASE*)) + (ELEMXPT (LIST '(MEXPT) + BASE* + (SIMPLIFY (LIST '(MTIMES) + (LIST '(%LOG) + (CADR EXP)) + (CADDR EXP)))))) + ((NOT (SETQ W + (M2 (CADDR EXP) + '((MPLUS) + ((COEFFPT) (A FREEVAR) (VAR VARP)) + ((COEFFPT) (B FREEVAR))) + NIL))) + (LIST (CAR EXP) BASE* (ELEMXPT (CADDR EXP)))) + (T (SUBSTITUTE BASE* + 'BASE* + (SUBLISS W + '((MTIMES) + ((MEXPT) BASE* B) + ((MEXPT) VAR A))))))) + + +(DEFUN SUBST10 (EXP) + (COND ((ATOM EXP) EXP) + ((AND (EQ (CAAR EXP) 'MEXPT) + (EQ (CADR EXP) VAR)) + (LIST '(MEXPT) + VAR + (INTEGERP2 (QUOTIENT (CADDR EXP) D)))) + (T (CONS (NCONS (CAAR EXP)) + (MAPCAR (FUNCTION (LAMBDA (C) (SUBST10 C))) + (CDR EXP)))))) + +(DEFUN CHOICESIN (X1 X2) + (COND ((EQ X1 (CAR X2)) (CDR X2)) + (T (CONS (CAR X2) (CHOICESIN X1 (CDR X2)))))) + +(DEFUN RATIONALIZER (X) + ((LAMBDA (EXP1) (COND ((NOT (ALIKE1 EXP1 X)) EXP1))) + (SIMPLIFY ($FACTOR X)))) + +(DEFUN INTFORM (EXPRES) + (COND + ((FREEVAR EXPRES) NIL) + ((ATOM EXPRES) NIL) + ((MEMQ (CAAR EXPRES) '(MPLUS MTIMES)) + ((LAMBDA (L) (PROG (Y) + LOOP (COND ((SETQ Y (INTFORM (CAR L))) (RETURN Y)) + ((NOT (SETQ L (CDR L))) (RETURN NIL)) + (T (GO LOOP))))) + (CDR EXPRES))) + ((OR (EQ (CAAR EXPRES) '%LOG) (ARCP (CAAR EXPRES))) + (COND + ((SETQ ARG (M2 EXP +;;; (LIST '(MTIMES) (CONS (LIST (CAAR EXPRES)) '((B RAT8)))'((COEFFTT)(C RAT8PRIME))) + `((MTIMES) (( ,(CAAR EXPRES) ) (B RAT8)) ((COEFFTT) (C RAT8PRIME)) ) + NIL)) + (RATLOG EXP VAR (CONS (CONS 'A EXPRES) ARG))) + (T + (PROG (Y Z) + (COND + ((SETQ Y (INTFORM (CADR EXPRES))) (RETURN Y)) + ((AND (EQ (CAAR EXPRES) '%LOG) + (SETQ Z (M2 (CADR EXPRES) C NIL)) + (SETQ Y (M2 EXP + '((MTIMES) + ((COEFFTT) (C RAT8)) + ((COEFFTT) (D ELEM))) + NIL))) + (RETURN + ((LAMBDA (A B C D) + (SUBSTINT + EXPRES + VAR + (INTEGRATOR + (MULN + (LIST (SUBSTITUTE + `((MQUOTIENT) ((MPLUS) ((MEXPT) $%E ,VAR) + ((MTIMES) -1 ,A)) + ,B) + VAR + C) + `((MQUOTIENT) ((MEXPT) $%E ,VAR) ,B) + (SUBSTITUTE VAR EXPRES D)) + NIL) + VAR))) + (CDR (SASSQ 'A Z 'NILL)) + (CDR (SASSQ 'B Z 'NILL)) + (CDR (SASSQ 'C Y 'NILL)) + (CDR (SASSQ 'D Y 'NILL))))) + (T (RETURN NIL))))))) + ((OPTRIG (CAAR EXPRES)) + (COND ((NOT (SETQ W (M2 (CADR EXPRES) C NIL))) + (INTFORM (CADR EXPRES))) + (T (PROG2 (SETQ POWERL T) + (MONSTERTRIG EXP VAR (CADR EXPRES)))))) + ((AND (EQ (CAAR EXPRES) '%DERIVATIVE) + (EQ (CAAR EXP) (CAAR EXPRES)) + (OR (ATOM (CADR EXP)) (NOT (EQ (CAAADR EXP) 'MQAPPLY)) + (merror "Invalid arg to INTEGRATE:~%~M" EXP)) + (CHECKDERIV EXP))) + ((NOT (EQ (CAAR EXPRES) 'MEXPT)) NIL) + ((FIXP (CADDR EXPRES)) (INTFORM (CADR EXPRES))) + ((FREEVAR (CADR EXPRES)) + (COND ((M2 (CADDR EXPRES) C NIL) + (SUPEREXPT EXP VAR (CADR EXPRES))) + ((INTFORM (CADDR EXPRES))) + (T (LET* (($%E/_TO/_NUMLOG T) (NEXP (RESIMPLIFY EXP))) + (COND ((ALIKE1 EXP NEXP) NIL) + (T (INTFORM (SETQ EXP NEXP)))))))) + ((NOT (RAT8 (CADR EXPRES))) (INTFORM (CADR EXPRES))) + ((AND (SETQ W (M2 (CADR EXPRES) RATROOTFORM NIL)) ;e*(a*x+b) / (c*x+d) + (DENOMFIND (CADDR EXPRES))) ;expon is ratnum + (COND((SETQ W(PROG2 (SETQ POWERL T) (RATROOT EXP VAR (CADR EXPRES) W))) W) + (T(INTE EXP VAR)))) + ((NOT (INTEGERP1 (CADDR EXPRES))) ;2*exponent not integer + (COND ((M2 EXP CHEBYFORM NIL) (CHEBYF EXP VAR)) + (T (INTFORM (CADR EXPRES))))) + ((SETQ W (M2 (CADR EXPRES) D NIL)) ;sqrt(c*x^2+b*x+a) + (INTE EXP VAR)) + ((M2 EXP CHEBYFORM NIL) (CHEBYF EXP VAR)) + ((NOT (M2 (SETQ W ($EXPAND (CADR EXPRES))) (CADR EXPRES) NIL)) + (PROG2 (SETQ EXP (SUBSTITUTE W (CADR EXPRES) EXP)) + (INTFORM (SIMPLIFY (LIST '(MEXPT) W (CADDR EXPRES)))))) + ((SETQ W (RATIONALIZER (CADR EXPRES))) + (PROG2 (SETQ EXP (LET (($RADEXPAND '$ALL)) + (SUBSTITUTE W (CADR EXPRES) EXP))) + (INTFORM (LET (($RADEXPAND '$ALL)) + (SIMPLIFY (LIST '(MEXPT) W (CADDR EXPRES))))))))) + +(DEFUN SEPARC (EXP) + (COND ((ARCFUNCP EXP) + (SETQ ARCPART EXP + COEF 1)) + ((EQ (CAAR EXP) 'MTIMES) + (ARCLIST (CDR EXP)) + (SETQ COEF (COND ((NULL (CDR COEF)) (CAR COEF)) + (T (SETQ COEF (CONS (CAR EXP) COEF)))))))) +(DEFUN ARCLIST (LIST) + (COND ((NULL LIST) NIL) + ((AND (ARCFUNCP (CAR LIST)) + (NULL ARCPART)) + (SETQ ARCPART (CAR LIST)) + (ARCLIST (CDR LIST))) + (T (SETQ COEF (CONS (CAR LIST) COEF)) + (ARCLIST (CDR LIST))))) + +(DEFUN ARCFUNCP (EXP) + (AND (NOT (ATOM EXP)) + (OR (ARCP (CAAR EXP)) + (EQ (CAAR EXP) '%LOG) ;experimentally treat logs also + (AND (EQ (CAAR EXP) 'MEXPT) + (INTEGERP2 (CADDR EXP)) + (GREATERP (INTEGERP2 (CADDR EXP)) 0) + (ARCFUNCP (CADR EXP)))))) + +(DEFUN INTEGRATOR (EXP VAR) + (PROG (Y ARG POWERL CONST B W C D E RATROOTFORM + CHEBYFORM ARCPART COEF INTEGRAND) + (COND ((FREEVAR EXP) (RETURN (MUL2* EXP VAR)))) + (SETQ W (PARTITION EXP VAR 1)) + (SETQ CONST (CAR W)) + (SETQ EXP (CDR W)) + (COND ((MPLUSP EXP) (RETURN (MUL2* CONST (INTEGRATE1 (CDR EXP))))) + ((AND (NOT (ATOM EXP)) (EQ (CAAR EXP) '$ATAN2)) + (RETURN (MUL2* CONST (INTEGRATOR + (SIMPLIFYA (LIST '(%ATAN) (DIV (CADR EXP) (CADDR EXP))) T) + VAR)))) + ((AND (NOT (ATOM EXP)) (EQ (CAAR EXP) '%SUM)) + (RETURN (MUL2* CONST (INTSUM EXP VAR))))) + (COND ((SETQ Y (DIFFDIV EXP VAR)) (RETURN (MUL2* CONST Y)))) + (SETQ Y (COND ((EQ (CAAR EXP) 'MTIMES) (CDR EXP)) (T (LIST EXP)))) + (SETQ C '((MPLUS) + ((COEFFPT) (B FREEVAR) (X VARP)) + ((COEFFPT) (A FREEVAR)))) + (SETQ RATROOTFORM '((MTIMES) + ((COEFFTT) (E FREEVAR)) + ((MPLUS) + ((COEFFPT) (A FREEVAR) (VAR VARP)) + ((COEFFPT) (B FREEVAR))) + ((MEXPT) + ((MPLUS) + ((COEFFPT) (C FREEVAR) (VAR VARP)) + ((COEFFPT) (D FREEVAR))) + -1))) + (SETQ CHEBYFORM '((MTIMES) + ((MEXPT) (VAR VARP) (R1 NUMBERP)) + ((MEXPT) + ((MPLUS) + ((MTIMES) + ((COEFFTT) (C2 FREEVAR)) + ((MEXPT) (VAR VARP) (Q FREE1))) + ((COEFFPP) (C1 FREEVAR))) + (R2 NUMBERP)) + ((COEFFTT) (A FREEVAR)))) + (SETQ D '((MPLUS) + ((COEFFPT) (C FREEVAR) ((MEXPT) (X VARP) 2)) + ((COEFFPT) (B FREEVAR) (X VARP)) + ((COEFFPT) (A FREEVAR)))) + (SETQ E '((MTIMES) + ((MPLUS) + ((COEFFPT) (A FREEVAR) (VAR VARP)) + ((COEFFPT) (B FREEVAR))) + ((MPLUS) + ((COEFFPT) (C FREEVAR) (VAR VARP)) + ((COEFFPT) (D FREEVAR))))) + LOOP (COND ((RAT8 (CAR Y)) (GO SKIP)) + ((SETQ W (INTFORM (CAR Y))) (RETURN (MUL2* CONST W))) + (T (GO SPECIAL))) + SKIP (SETQ Y (CDR Y)) + (COND ((NULL Y) + (RETURN (MUL2* CONST (COND ((SETQ Y (POWERLIST EXP VAR)) Y) + (T (RATINT EXP VAR))))))) + (GO LOOP) + SPECIAL + (SEPARC EXP) ;SEPARC SETQS ARCPART AND COEF SUCH THAT + ;COEF*ARCEXP=EXP WHERE ARCEXP IS OF THE FORM + ;ARCFUNC^N AND COEF IS ITS ALGEBRAIC COEFFICIENT + + (COND ((AND (NOT (NULL ARCPART)) + (DO ((STACKLIST STACK (CDR STACKLIST))) + ((NULL STACKLIST) T) + (COND ((ALIKE1 (CAR STACKLIST) COEF) + (RETURN NIL)))) + (NOT (ISINOP (SETQ W ((LAMBDA (STACK) + (INTEGRATOR COEF VAR)) + (CONS COEF STACK))) + '%INTEGRATE)) + (SETQ INTEGRAND (MUL2 W (SDIFF ARCPART VAR))) + (DO ((STACKLIST STACK (CDR STACKLIST))) + ((NULL STACKLIST) T) + (COND ((ALIKE1 (CAR STACKLIST) INTEGRAND) + (RETURN NIL)))) + (NOT (ISINOP + (SETQ Y + ((LAMBDA (STACK INTEG) + (INTEGRATOR INTEG VAR)) + (CONS INTEGRAND STACK) + INTEGRAND)) + '%INTEGRATE))) + (RETURN (ADD2* (LIST '(MTIMES) CONST W ARCPART) + (LIST '(MTIMES) -1 CONST Y)))) + (T (RETURN + (MUL2 CONST + (COND ((SETQ Y (SCEP EXP VAR)) + (COND ((CDDR Y) + (INTEGRATOR ($TRIGREDUCE EXP) VAR)) + (T (SCE-INT (CAR Y) (CADR Y) VAR)))) + ((NOT (ALIKE1 EXP (SETQ Y ($EXPAND EXP)))) + (INTEGRATOR Y VAR)) + ((AND (NOT POWERL) + (SETQ Y (POWERLIST EXP VAR))) + Y) + ((SETQ Y (RISCHINT EXP VAR)) Y) + (T (LIST '(%INTEGRATE) EXP VAR))))))))) + +(DEFUN RAT8 (EXP) + (COND ((OR (ALIKE1 EXP VAR) (FREEVAR EXP)) T) + ((MEMQ (CAAR EXP) '(MPLUS MTIMES)) + (AND (RAT8 (CADR EXP)) + (COND ((CDDR EXP) (RAT8 (CONS (CAR EXP) (CDDR EXP)))) (T T)))) + ((NOT (EQ (CAAR EXP) 'MEXPT)) NIL) + ((FIXP (CADDR EXP)) (RAT8 (CADR EXP))))) + +(DEFUN OPTRIG (X) (MEMQ X '(%SIN %COS %SEC %TAN %CSC %COT))) + +;after finding a non-integrable summand usually better to pass rest to risch +(DEFUN INTEGRATE1 (EXP) + (DO ((TERMS EXP (CDR TERMS)) + (ANS)) + ((NULL TERMS) (ADDN ANS NIL)) + (LET ($LIFLAG) ;don't gen li's for + (PUSH (INTEGRATOR (CAR TERMS) VAR) ANS)) ;parts of integrand + (WHEN (AND (NOT (FREE (CAR ANS) '%INTEGRATE)) + (CDR TERMS)) + (RETURN (ADDN (CONS (RISCHINT (CONS '(MPLUS) TERMS) VAR) (CDR ANS)) + NIL))))) + +;(DEFUN ABSSUBST (EXP) +; (COND ((ATOM EXP) EXP) +; ((EQ (CAAR EXP) 'MABS) (CADR EXP)) +; (T (CONS (CAR EXP) (MAPCAR 'ABSSUBST (CDR EXP)))))) + +(DEFUN SCEP (EXPR VAR &AUX TRIGL EXP) ;PROD OF SIN, COS, EXP + (AND (MTIMESP EXPR) ;OF LINEAR ARGS + (LOOP FOR FAC IN (CDR EXPR) DO + (COND ((ATOM FAC) (RETURN NIL)) + ((TRIG1 (CAR FAC)) + (IF (LINEARP (CADR FAC) VAR) (PUSH FAC TRIGL) + (RETURN NIL))) + ((AND (MEXPTP FAC) + (EQ (CADR FAC) '$%E) + (LINEARP (CADDR FAC) VAR)) + ;should be only 1 exponential factor + (SETQ EXP FAC)) + (T (RETURN NIL))) + FINALLY (RETURN (CONS EXP TRIGL))))) + +;integrates exponential * sin or cos, all with linear args. +(DEFUN SCE-INT (EXP S-C VAR) ;EXP is non-trivial + (LET ((E-COEF (CAR (ISLINEAR (CADDR EXP) VAR))) + (SC-COEF (CAR (ISLINEAR (CADR S-C) VAR))) + (SC-ARG (CADR S-C))) + (MUL (DIV EXP (ADD (POWER E-COEF 2) (POWER SC-COEF 2))) + (ADD (MUL E-COEF S-C) + (IF (EQ (CAAR S-C) '%SIN) + (MUL* (NEG SC-COEF) `((%COS) ,SC-ARG)) + (MUL* SC-COEF `((%SIN) ,SC-ARG))))))) + +(defun checkderiv (expr) + (checkderiv1 (cadr expr) (cddr expr) () )) + +;; CHECKDERIV1 gets called on the expression being differentiated, +;; an alternating list of variables being differentiated with +;; respect to and powers thereof, and a reversed list of the latter +;; that have already been examined. It returns either the antiderivative +;; or (), saying this derivative isn't wrt the variable of integration. + +(defun checkderiv1 (expr wrt old-wrt) + (cond ((alike1 (car wrt) var) + (if (equal (cadr wrt) 1) ;Power = 1? + (if (null (cddr wrt)) ;single or partial + expr ;single + `((%derivative) ,expr ;Partial, return rest + ,.(nreverse old-wrt) + ,@(cddr wrt))) + `((%derivative) ,expr ;Higher order, reduce order + ,.(nreverse old-wrt) + ,(car wrt) ,(add2* (cadr wrt) -1) + ,@ (cddr wrt)))) + ((null (cddr wrt)) () ) ;Say it doesn't apply here + (t (checkderiv1 expr (cddr wrt) ;Else we check later terms + (list* (cadr wrt) (car wrt) old-wrt))))) + +(DEFUN ELEM (A) + (COND ((FREEVAR A) T) + ((ATOM A) NIL) + ((M2 A EXPRES NIL) T) + (T (EVAL (CONS 'AND (MAPCAR #'ELEM (CDR A))))))) + +(DEFUN FREEVAR (A) + (COND ((ATOM A) (NOT (EQ A VAR))) + ((ALIKE1 A VAR) NIL) + ((AND (NOT (ATOM (CAR A))) + (MEMQ 'ARRAY (CDAR A))) + (COND ((FREEVAR (CDR A)) T) + (T (MERROR "Variable of integration appeared in subscript")))) + (T (AND (FREEVAR (CAR A)) (FREEVAR (CDR A)))))) + +(DEFUN VARP (X) (ALIKE1 X VAR)) + +(DEFUN INTEGRALLOOKUPS (EXP) + (COND ((EQ (CAAR EXP) '%LOG) + (SUBSTITUTE (CADR EXP) + 'X + '((MPLUS) + ((MTIMES) X ((%LOG) X)) + ((MTIMES) -1 X)))) + ((EQ (CAAR EXP) 'MPLUS) + (MULN (LIST '((RAT SIMP) 1 2) EXP EXP) NIL)) + ((EQ (CAAR EXP) 'MEXPT) + (COND ((FREEVAR (CADR EXP)) + (SIMPLIFYA (SUBSTITUTE EXP + 'A + (SUBSTITUTE (CADR EXP) + 'B + '((MTIMES) + A + ((MEXPT) + ((%LOG) + B) + -1)))) + NIL)) + ((OR (EQUAL (CADDR EXP) -1) + (AND (NOT (MNUMP (CADDR EXP))) + (FREEOF '$%I (CADDR EXP)) + (EQ (ASKSIGN (POWER (ADD2 (CADDR EXP) 1) 2)) '$ZERO))) + (SUBSTITUTE (CADR EXP) 'X (LOGMABS 'X))) + (T (SUBSTITUTE (ADD2* (CADDR EXP) 1) + 'N + (SUBSTITUTE (CADR EXP) + 'X + '((MTIMES) + ((MEXPT) N -1) + ((MEXPT) X N))))))) + (T (SUBSTITUTE (CADR EXP) + 'X + (CDR (SASSQ (CAAR EXP) + '((%SIN (MTIMES) -1 ((%COS) X)) + (%COS (%SIN) X) + (%TAN (%LOG) + ((%SEC) X)) + (%SEC (%LOG) ((MPLUS) ((%SEC) X) ((%TAN) X))) + (%COT (%LOG) + ((%SIN) X)) + (%SINH (%COSH) X) + (%COSH (%SINH) X) + (%TANH (%LOG) + ((%COSH) X)) + (%COTH (%LOG) ((%SINH) X)) + (%SECH (%ATAN) + ((%SINH) X)) + (%CSCH (%LOG) ((%TANH) ((MTIMES) ((RAT SIMP) 1 2) X))) + (%CSC (MTIMES) + -1 + ((%LOG) + ((MPLUS) + ((%CSC) X) + ((%COT) + X))))) + 'NILL)))))) + + +(DEFUN TRUE (IGNORE) IGNORE T) + +(DEFUN RAT10 (EXP) + (COND ((FREEVAR EXP) T) + ((ALIKE1 EXP VAR) NIL) + ((EQ (CAAR EXP) 'MEXPT) + (COND ((ALIKE1 (CADR EXP) VAR) + (COND ((INTEGERP2 (CADDR EXP)) + (SETQ POWERLIST + (CONS (CADDR EXP) + POWERLIST))) + (T NIL))) + (T (AND (RAT10 (CADR EXP)) + (RAT10 (CADDR EXP)))))) + ((MEMQ (CAAR EXP) '(MPLUS MTIMES)) + (AND (RAT10 (CADR EXP)) + (OR (NULL (CDDR EXP)) + (RAT10 (CONS (CAR EXP) + (CDDR EXP)))))) + ((EQ (CAAR EXP) '%LOG) + (RAT10 (CADR EXP))) + (T (RAT10 (CADR EXP))))) + + +(DEFUN LISTGCD (POWERLIST) + (PROG (D) + (SETQ D (CAR POWERLIST)) + LOOP (SETQ POWERLIST (CDR POWERLIST)) + (COND ((equal D 1) (RETURN NIL))) + (COND ((NULL POWERLIST) (RETURN D))) + (SETQ D (GCD D (CAR POWERLIST))) + (GO LOOP))) + + +(DEFUN INTEGRATE5 (EXP VAR) + (IF (RAT8 EXP) (RATINT EXP VAR) (INTEGRATOR EXP VAR))) + +(DEFUN INTEGERP2 (X) + (LET (Y) (COND ((NOT (NUMBERP X)) NIL) + ((NOT (FLOATP X)) X) + ((PROG2 (SETQ Y (RATIONALIZE X)) (EQUAL (CDR Y) 1)) (CAR Y)) + (T NIL)))) + + +(DEFUN RAT3 (EXP IND) + (COND ((FREEVAR EXP) T) + ((ATOM EXP) IND) + ((MEMQ (CAAR EXP) '(MTIMES MPLUS)) + (AND (RAT3 (CADR EXP) IND) + (OR (NULL (CDDR EXP)) + (RAT3 (CONS (CAR EXP) (CDDR EXP)) + IND)))) + ((NOT (EQ (CAAR EXP) 'MEXPT)) + (RAT3 (CADR EXP) T)) + ((FREEVAR (CADR EXP)) (RAT3 (CADDR EXP) T)) + ((FIXP (CADDR EXP)) (RAT3 (CADR EXP) IND)) + ((AND (M2 (CADR EXP) RATROOT NIL) + (DENOMFIND (CADDR EXP))) + (SETQ ROOTLIST + (CONS (DENOMFIND (CADDR EXP)) + ROOTLIST))) + (T (RAT3 (CADR EXP) NIL)))) + + +(DEFUN SUBST4 (EXP) + (COND ((FREEVAR EXP) EXP) + ((ATOM EXP) A) + ((NOT (EQ (CAAR EXP) 'MEXPT)) + (MAPCAR (FUNCTION (LAMBDA (C) (SUBST4 C))) + EXP)) + ((M2 (CADR EXP) RATROOT NIL) + (LIST (CAR EXP) + B + (INTEGERP2 (TIMESK K (CADDR EXP))))) + (T (LIST (CAR EXP) + (SUBST4 (CADR EXP)) + (SUBST4 (CADDR EXP)))))) + + +(DEFUN FINDINGK (LIST) + (do ((k 1) (l list (cdr l))) + ((null l) k) + (setq k (lcm k (car l))))) + +(DEFUN DENOMFIND (X) + (COND ((RATNUMP X) (CADDR X)) + ((NOT (NUMBERP X)) NIL) + ((NOT (FLOATP X)) 1) + (T (CDR (RATIONALIZE X))))) + + + +(DEFUN RATROOT (EXP VAR RATROOT W) + (PROG (ROOTLIST K Y W1) + (COND ((SETQ Y (CHEBYF EXP VAR)) (RETURN Y))) + (COND ((NOT (RAT3 EXP T)) (RETURN NIL))) + (SETQ K (FINDINGK ROOTLIST)) + (SETQ W1 (CONS (CONS 'K K) W)) + (SETQ Y + (SUBST41 + EXP + (SIMPLIFY + (SUBLISS W1 + '((MQUOTIENT) + ((MPLUS) ((MTIMES) B E) + ((MTIMES) -1 D ((MEXPT) VAR K))) + ((MPLUS) ((MTIMES) C ((MEXPT) VAR K)) + ((MTIMES) -1 E A))))) + VAR)) + (SETQ Y + (INTEGRATOR + (SIMPLIFY + (LIST '(MTIMES) + Y + (SUBLISS + W1 '((MQUOTIENT) + ((MTIMES) + E ((MPLUS) + ((MTIMES) A D K + ((MEXPT) VAR ((MPLUS) -1 K))) + ((MTIMES) + -1 + ((MTIMES) B C K + ((MEXPT) VAR ((MPLUS) -1 K)))))) + ((MEXPT) ((MPLUS) + ((MTIMES) C ((MEXPT) VAR K)) + ((MTIMES) -1 A)) + 2))))) + VAR)) + (RETURN (SUBSTINT (SIMPLIFY (LIST '(MEXPT) + RATROOT + (LIST '(MEXPT) K -1))) + VAR + Y)))) + + +(DEFUN SUBST41 (EXP A B) (SUBST4 EXP)) + +(DEFUN CHEBYF (EXP VAR) + (PROG (R1 R2 D1 D2 N1 N2 W Q) + (COND ((NOT (SETQ W + (M2 EXP + '((MTIMES) + ((MEXPT) (VAR VARP) (R1 NUMBERP)) + ((MEXPT) + ((MPLUS) + ((MTIMES) + ((COEFFTT) (C2 FREEVAR)) + ((MEXPT) (VAR VARP) (Q FREE1))) + ((COEFFPP) (C1 FREEVAR))) + (R2 NUMBERP)) + ((COEFFTT) (A FREEVAR))) + NIL))) + (RETURN NIL))) + (SETQ Q (CDR (SASSQ 'Q W 'NILL))) + (SETQ + W + (LIST* + (CONS 'A (DIV* (CDR (SASSQ 'A W 'NILL)) Q)) + (CONS + 'R1 + (DIV* (ADDN (LIST 1 (NEG (SIMPLIFY Q)) (CDR (SASSQ 'R1 W 'NILL))) NIL) Q)) + W)) + (SETQ R1 (CDR (SASSQ 'R1 W 'NILL)) R2 (CDR (SASSQ 'R2 W 'NILL))) + (COND + ((NOT (AND (SETQ D1 (DENOMFIND R1)) + (SETQ D2 (DENOMFIND R2)) + (SETQ N1 (INTEGERP2 (TIMESK R1 D1))) + (SETQ N2 (INTEGERP2 (TIMESK R2 D2))) + (SETQ W (LIST* (CONS 'D1 D1) + (CONS 'D2 D2) + (CONS 'N1 N1) + (CONS 'N2 N2) + W)))) + (RETURN NIL)) + ((AND (INTEGERP2 R1) (GREATERP R1 0)) + (RETURN + (SUBSTINT + (SUBLISS W '((MPLUS) C1 ((MTIMES) C2 ((MEXPT) VAR Q)))) + VAR + (INTEGRATOR + (EXPANDS (LIST (SUBLISS W + '((MTIMES) + A + ((MEXPT) VAR R2) + ((MEXPT) + C2 + ((MTIMES) + -1 + ((MPLUS) R1 1)))))) + (CDR (EXPANDEXPT (SUBLISS W + '((MPLUS) + VAR + ((MTIMES) -1 C1))) + R1))) + VAR)))) + ((INTEGERP2 R2) + (RETURN + (SUBSTINT (SUBLISS W '((MEXPT) VAR ((MQUOTIENT) Q D1))) + VAR + (RATINT (SIMPLIFY (SUBLISS W + '((MTIMES) + D1 + A + ((MEXPT) + VAR + ((MPLUS) + N1 + D1 + -1)) + ((MEXPT) + ((MPLUS) + ((MTIMES) + C2 + ((MEXPT) + VAR + D1)) + C1) + R2)))) + VAR)))) + ((AND (INTEGERP2 R1) (LESSP R1 0)) + (RETURN + (SUBSTINT (SUBLISS W + '((MEXPT) + ((MPLUS) + C1 + ((MTIMES) C2 ((MEXPT) VAR Q))) + ((MQUOTIENT) 1 D2))) + VAR + (RATINT (SIMPLIFY (SUBLISS W + '((MTIMES) + A + D2 + ((MEXPT) + C2 + ((MTIMES) + -1 + ((MPLUS) + R1 + 1))) + ((MEXPT) + VAR + ((MPLUS) + N2 + D2 + -1)) + ((MEXPT) + ((MPLUS) + ((MEXPT) + VAR + D2) + ((MTIMES) + -1 + C1)) + R1)))) + VAR)))) + ((INTEGERP2 (ADD2* R1 R2)) + (RETURN + (SUBSTINT (SUBLISS W + '((MEXPT) + ((MQUOTIENT) + ((MPLUS) + C1 + ((MTIMES) C2 ((MEXPT) VAR Q))) + ((MEXPT) VAR Q)) + ((MQUOTIENT) 1 D1))) + VAR + (RATINT (SIMPLIFY (SUBLISS W + '((MTIMES) + -1 + A + D1 + ((MEXPT) + C1 + ((MPLUS) + R1 + R2 + 1)) + ((MEXPT) + VAR + ((MPLUS) + N2 + D1 + -1)) + ((MEXPT) + ((MPLUS) + ((MEXPT) + VAR + D1) + ((MTIMES) + -1 + C2)) + ((MTIMES) + -1 + ((MPLUS) + R1 + R2 + 2)))))) + VAR)))) + (T (RETURN (LIST '(%INTEGRATE) EXP VAR)))))) + +(DEFUN RAT6 (EXP) + (COND ((FREEVAR EXP) T) + ((ATOM EXP) T) + ((MEMQ (CAAR EXP) '(MPLUS MTIMES)) + (AND (RAT6 (CADR EXP)) + (OR (NULL (CDDR EXP)) + (RAT6 (CONS (CAR EXP) (CDDR EXP)))))) + ((NOT (EQ (CAAR EXP) 'MEXPT)) NIL) + ((FIXP (CADDR EXP)) (RAT6 (CADR EXP))) + ((NOT (INTEGERP2 (MUL2* 2 (CADDR EXP)))) + NIL) + (T (M2 (CADR EXP) SQUARE NIL)))) + + +(DEFUN SUBST6 (EXP A B) + (COND ((FREEVAR EXP) EXP) + ((ATOM EXP) A) + ((MEMQ (CAAR EXP) '(MPLUS MTIMES)) + (CONS (CAR EXP) + (MAPCAR + (FUNCTION (LAMBDA (C) (SUBST6 C A B))) + (CDR EXP)))) + ((NOT (EQ (CAAR EXP) 'MEXPT)) + (MERROR "SUBST6")) + ((FIXP (CADDR EXP)) + (LIST (CAR EXP) (SUBST6 (CADR EXP) A B) (CADDR EXP))) + (T (LIST (CAR EXP) + B + (INTEGERP2 (TIMESK 2 (CADDR EXP))))))) + + +(DEFUN GREATERRATP (X1 X2) + (COND ((AND (NUMBERP X1) (NUMBERP X2)) (GREATERP X1 X2)) + ((RATNUMP X1) + (GREATERRATP (QUOTIENT (FLOAT (CADR X1)) (CADDR X1)) X2)) + ((RATNUMP X2) + (GREATERRATP X1 (QUOTIENT (FLOAT (CADR X2)) (CADDR X2)))))) + +(DEFUN TRIG1 (X) (MEMQ (CAR X) '(%SIN %COS))) + +(DEFUN SUPERTRIG (EXP) + (COND ((FREEVAR EXP) T) + ((ATOM EXP) NIL) + ((MEMQ (CAAR EXP) '(MPLUS MTIMES)) + (AND (SUPERTRIG (CADR EXP)) + (OR (NULL (CDDR EXP)) + (SUPERTRIG (CONS (CAR EXP) + (CDDR EXP)))))) + ((EQ (CAAR EXP) 'MEXPT) + (AND (SUPERTRIG (CADR EXP)) + (SUPERTRIG (CADDR EXP)))) + ((EQ (CAAR EXP) '%LOG) + (SUPERTRIG (CADR EXP))) + ((MEMQ (CAAR EXP) + '(%SIN %COS %TAN %SEC %COT %CSC)) + (COND ((M2 (CADR EXP) TRIGARG NIL) T) + ((M2 (CADR EXP) + '((MPLUS) + ((COEFFPT) (B FREEVAR) (X VARP)) + ((COEFFPT) (A FREEVAR))) + NIL) + (AND (SETQ NOTSAME T) NIL)) + (T (SUPERTRIG (CADR EXP))))) + (T (SUPERTRIG (CADR EXP))))) + + +(DEFUN SUBST2S (EXP PAT) (COND ((NULL EXP) NIL) + ((M2 EXP PAT NIL) VAR) + ((ATOM EXP) EXP) + (T (CONS (SUBST2S (CAR EXP) PAT) + (SUBST2S (CDR EXP) PAT))))) + + +(DEFUN MONSTERTRIG (EXP VAR TRIGARG) + (PROG (NOTSAME W A B Y D) + (COND + ((SUPERTRIG EXP) (GO A)) + ((NULL NOTSAME) (RETURN NIL)) + ((NOT (SETQ Y (M2 EXP + '((MTIMES) + ((COEFFTT) (A FREEVAR)) + (((B TRIG1)) + ((MTIMES) + (X VARP) + ((COEFFTT) (M FREEVAR)))) + (((D TRIG1)) + ((MTIMES) + (X VARP) + ((COEFFTT) (N FREEVAR))))) + NIL))) + (GO B)) + ((NOT (AND (MEMQ (CAR (SETQ B + (CDR (SASSQ 'B + Y + 'NILL)))) + '(%SIN %COS)) + (MEMQ (CAR (SETQ D + (CDR (SASSQ 'D + Y + 'NILL)))) + '(%SIN %COS)))) + (RETURN NIL)) + ((AND (EQ (CAR B) '%SIN) (EQ (CAR D) '%SIN)) + (RETURN (SUBVAR (SUBLISS Y + '((MTIMES) + A + ((MPLUS) + ((MQUOTIENT) + ((%SIN) + ((MTIMES) + ((MPLUS) M ((MTIMES) -1 N)) + X)) + ((MTIMES) + 2 + ((MPLUS) M ((MTIMES) -1 N)))) + ((MTIMES) + -1 + ((MQUOTIENT) + ((%SIN) + ((MTIMES) ((MPLUS) M N) X)) + ((MTIMES) + 2 + ((MPLUS) M N)))))))))) + ((AND (EQ (CAR B) '%COS) (EQ (CAR D) '%COS)) + (RETURN (SUBVAR (SUBLISS Y + '((MTIMES) + A + ((MPLUS) + ((MQUOTIENT) + ((%SIN) + ((MTIMES) + ((MPLUS) M ((MTIMES) -1 N)) + X)) + ((MTIMES) + 2 + ((MPLUS) M ((MTIMES) -1 N)))) + ((MQUOTIENT) + ((%SIN) + ((MTIMES) ((MPLUS) M N) X)) + ((MTIMES) + 2 + ((MPLUS) M N))))))))) + ((OR (AND (EQ (CAR B) '%COS) + (SETQ W (CDR (SASSQ 'M Y 'NILL))) + (RPLACD (SASSQ 'M Y 'NILL) + (CDR (SASSQ 'N Y 'NILL))) + (RPLACD (SASSQ 'N Y 'NILL) W)) + T) + (RETURN (SUBVAR (SUBLISS Y + '((MTIMES) + -1 + A + ((MPLUS) + ((MQUOTIENT) + ((%COS) + ((MTIMES) + ((MPLUS) M ((MTIMES) -1 N)) + X)) + ((MTIMES) + 2 + ((MPLUS) M ((MTIMES) -1 N)))) + ((MQUOTIENT) + ((%COS) + ((MTIMES) ((MPLUS) M N) X)) + ((MTIMES) + 2 + ((MPLUS) M N)))))))))) + B (COND ((NOT (SETQ Y (PROG2 (SETQ TRIGARG VAR) + (M2 EXP + '((MTIMES) + ((COEFFTT) (A FREEVAR)) + (((B TRIG1)) + ((MTIMES) + (X VARP) + ((COEFFTT) (N INTEGERP2)))) + ((COEFFTT) (C SUPERTRIG))) + NIL)))) + (RETURN NIL))) + (RETURN + (INTEGRATOR + ($EXPAND + (LIST '(MTIMES) + (SCH-REPLACE Y 'A) + (SCH-REPLACE Y 'C) + (COND ((EQ (CAR (SETQ B (SCH-REPLACE Y 'B))) '%COS) + (SUBSTITUTE VAR + 'X + (SUPERCOSNX (SCH-REPLACE Y 'N)))) + (T (SUBSTITUTE VAR + 'X + (SUPERSINX (SCH-REPLACE Y 'N))))))) + VAR)) + A (SETQ W (SUBST2S EXP TRIGARG)) + (SETQ B (CDR (SASSQ 'B + (M2 TRIGARG + '((MPLUS) + ((COEFFPT) (B FREEVAR) (X VARP)) + ((COEFFPT) (A FREEVAR))) + NIL) + 'NILL))) + (SETQ A (SUBSTINT TRIGARG + VAR + (TRIGINT (DIV* W B) VAR))) +(COND((M2 A '((MTIMES)((COEFFTT)(D FREEVAR)) ((%INTEGRATE ) (B TRUE) (C TRUE)))NIL) + (RETURN(LIST '(%INTEGRATE) EXP VAR)))) +(RETURN A) )) + +(DEFUN TRIG2 (X) (MEMQ (CAR X) '(%SIN %COS %TAN %COT %SEC %CSC))) + +(DEFUN SUPERSINX (N) ((LAMBDA (I) + ($EXPAND (LIST '(MTIMES) + I + (SINNX (TIMESK I N))))) + (COND ((LESSP N 0) -1) (T 1)))) + + +(DEFUN SUPERCOSNX (N) ((LAMBDA (I) ($EXPAND (COSNX (TIMESK I N)))) + (COND ((LESSP N 0) -1) (T 1)))) + + +(DEFUN SINNX (N) (COND ((EQUAL N 1) '((%SIN) X)) + (T (LIST '(MPLUS) + (LIST '(MTIMES) + '((%SIN) X) + (COSNX (SUB1 N))) + (LIST '(MTIMES) + '((%COS) X) + (SINNX (SUB1 N))))))) + + +(DEFUN COSNX (N) (COND ((EQUAL N 1) '((%COS) X)) + (T (LIST '(MPLUS) + (LIST '(MTIMES) + '((%COS) X) + (COSNX (SUB1 N))) + (LIST '(MTIMES) + -1 + '((%SIN) X) + (SINNX (SUB1 N))))))) + + +(DEFUN POSEVEN (X) (AND (EVEN X) (GREATERP X -1))) + +(DEFUN TRIGFREE (X) + (COND ((ATOM X) (NOT (MEMQ X '(SIN* COS* SEC* TAN*)))) + (T (AND (TRIGFREE (CAR X)) (TRIGFREE (CDR X)))))) + +(DEFUN RAT1 (EXP) (PROG (B1 NOTSAME) + (COND ((AND (NUMBERP EXP) (ZEROP EXP)) + (RETURN NIL))) + (SETQ B1 (SUBST B 'B '((MEXPT) B (N EVEN)))) + (RETURN (PROG2 (SETQ YY (RATS EXP)) + (COND ((NOT NOTSAME) YY)))))) + +(DEFUN RATS (EXP) + (PROG (Y) + (RETURN + (COND ((EQ EXP A) 'X) + ((ATOM EXP) + (COND ((MEMQ EXP '(SIN* COS* SEC* TAN*)) + (SETQ NOTSAME T)) + (T EXP))) + ((SETQ Y (M2 EXP B1 NIL)) (F3 Y)) + (T (CONS (CAR EXP) + (MAPCAR + (FUNCTION (LAMBDA (G) (RATS G))) + (CDR EXP)))))))) + + +(DEFUN F3 (Y) + (SUBSTITUTE C + 'C + (SUBSTITUTE (QUOTIENT (CDR (SASSQ 'N Y NIL)) 2) + 'N + '((MEXPT) + ((MPLUS) + 1 + ((MTIMES) + C + ((MEXPT) X 2))) + N)))) + +(DEFUN ODD1 (N) + (COND ((NOT (NUMBERP N)) NIL) + ((NOT (EQUAL (REMAINDER N 2) 0)) + (SETQ YZ + (SUBSTITUTE C + 'C + (LIST '(MEXPT) + '((MPLUS) + 1 + ((MTIMES) + C + ((MEXPT) X 2))) + (QUOTIENT (SUB1 N) 2))))) + (T NIL))) + +(DEFUN SUBVAR (X) (SUBSTITUTE VAR 'X X)) + +(DEFUN SUBVARDLG (X) + (MAPCAR #'(LAMBDA (M) (CONS (SUBSTITUTE VAR 'X (CAR M)) + (CDR M))) + X)) + +(DEFUN TRIGINT (EXP VAR) + (PROG (Y REPL Y1 Y2 YY Z M N C YZ A B ) + (SETQ Y2 + (SUBLISS (SUBVARDLG '((((%SIN) X) . SIN*) + (((%COS) X) . COS*) + (((%TAN) X) . TAN*) + (((%COT) X) (MEXPT) TAN* -1) + (((%SEC) X) . SEC*) + (((%CSC) X) (MEXPT) SIN* -1))) + (SIMPLIFYA EXP NIL))) + (SETQ Y1 (SETQ Y (SIMPLIFY (SUBLISS '((TAN* (MTIMES) + SIN* + ((MEXPT) COS* -1)) + (SEC* (MEXPT) COS* -1)) + Y2)))) + (COND ((NULL (SETQ Z (M2 Y + '((MTIMES) + ((COEFFTT) (B TRIGFREE)) + ((MEXPT) SIN* (M POSEVEN)) + ((MEXPT) COS* (N POSEVEN))) + NIL))) + (GO L1))) + (SETQ M (CDR (SASSQ 'M Z 'NILL))) + (SETQ N (CDR (SASSQ 'N Z 'NILL))) + (SETQ A (INTEGERP2 (TIMES 0.5 + (COND ((LESSP M N) 1) (T -1)) + (PLUS N (TIMES -1 M))))) + (SETQ Z (CONS (CONS 'A A) Z)) + (RETURN + (SIMPLIFY + (LIST + '(MTIMES) + (CDR (SASSQ 'B Z 'NILL)) + '((RAT SIMP) 1 2) + (SUBSTINT + (LIST '(MTIMES) 2 VAR) + 'X + (INTEGRATOR (SIMPLIFY (COND ((LESSP M N) + (SUBLISS Z + '((MTIMES) + ((MEXPT) + ((MTIMES) + ((RAT SIMP) 1 2) + ((%SIN) X)) + M) + ((MEXPT) + ((MPLUS) + ((RAT SIMP) 1 2) + ((MTIMES) + ((RAT SIMP) 1 2) + ((%COS) X))) + A)))) + (T (SUBLISS Z + '((MTIMES) + ((MEXPT) + ((MTIMES) + ((RAT SIMP) 1 2) + ((%SIN) X)) + N) + ((MEXPT) + ((MPLUS) + ((RAT SIMP) 1 2) + ((MTIMES) + ((RAT SIMP) + -1 + 2) + ((%COS) X))) + A)))))) + 'X))))) + L1 (SETQ C -1) + (SETQ A 'SIN*) + (SETQ B 'COS*) + (COND ((AND (M2 Y + '((COEFFPT) (C RAT1) ((MEXPT) COS* (N ODD1))) + NIL) + (SETQ REPL (LIST '(%SIN) VAR))) + (GO GETOUT))) + (SETQ A B) + (SETQ B 'SIN*) + (COND ((AND (M2 Y + '((COEFFPT) (C RAT1) ((MEXPT) SIN* (N ODD1))) + NIL) + (SETQ REPL (LIST '(%COS) VAR))) + (GO GET3))) + (SETQ Y + (SIMPLIFY (SUBLISS '((SIN* (MTIMES) TAN* ((MEXPT) SEC* -1)) + (COS* (MEXPT) SEC* -1)) + Y2))) + (SETQ C 1) + (SETQ A 'TAN*) + (SETQ B 'SEC*) + (COND ((AND (RAT1 Y) (SETQ REPL (LIST '(%TAN) VAR))) + (GO GET1))) + (SETQ A B) + (SETQ B 'TAN*) + (COND ((AND (M2 Y + '((COEFFPT) (C RAT1) ((MEXPT) TAN* (N ODD1))) + NIL) + (SETQ REPL (LIST '(%SEC) VAR))) + (GO GETOUT))) +(COND((NOT (ALIKE1(SETQ REPL ($EXPAND EXP))EXP))(RETURN(INTEGRATOR REPL VAR)))) + (SETQ Y + (SIMPLIFY (SUBLISS '((SIN* (MTIMES) + 2 + X + ((MEXPT) + ((MPLUS) 1 ((MEXPT) X 2)) + -1)) + (COS* (MTIMES) + ((MPLUS) + 1 + ((MTIMES) -1 ((MEXPT) X 2))) + ((MEXPT) + ((MPLUS) 1 ((MEXPT) X 2)) + -1))) + Y1))) + (SETQ Y (LIST '(MTIMES) + Y + '((MTIMES) + 2 + ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1)))) + (SETQ REPL (SUBVAR '((MQUOTIENT) + ((%SIN) X) + ((MPLUS) 1 ((%COS) X))))) + (GO GET2) + GET3 (SETQ Y (LIST '(MTIMES) -1 YY YZ)) + (GO GET2) + GET1 (SETQ Y (LIST '(MTIMES) + '((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1) + YY)) + (GO GET2) + GETOUT + (SETQ Y (LIST '(MTIMES) YY YZ)) + GET2 (SETQ Y (SIMPLIFY Y)) + (RETURN (SUBSTINT REPL 'X (INTEGRATOR Y 'X))))) + +(DEFUN SININT (EXP VAR) + (FIND-FUNCTION 'RATINT) ; Make sure that RATINT is in core. + (COND ((NONVARCHK VAR '$INTEGRATE T T)) + (($RATP VAR) (SININT EXP (RATDISREP VAR))) + (($RATP EXP) (SININT (RATDISREP EXP) VAR)) + ((MXORLISTP EXP) + (CONS (CAR EXP) (MAPCAR #'(LAMBDA (Y) (SININT Y VAR)) (CDR EXP)))) + ((MEQUALP EXP) + (LIST (CAR EXP) (SININT (CADR EXP) VAR) + (ADD2 (SININT (CADDR EXP) VAR) + (CONCAT '$INTEGRATIONCONSTANT + (SETQ $INTEGRATION_CONSTANT_COUNTER + (1+ $INTEGRATION_CONSTANT_COUNTER)))))) + ((AND (ATOM VAR) (ISINOP EXP VAR)) (LIST '(%INTEGRATE) EXP VAR)) + ((LET + ((ANS (SIMPLIFY + (LET ($OPSUBST VARLIST GENVAR STACK) (INTEGRATOR EXP VAR))))) + (IF (SUM-OF-INTSP ANS) (LIST '(%INTEGRATE) EXP VAR) ANS))))) + +(DEFUN SUM-OF-INTSP (ANS) + (COND ((ATOM ANS) (NOT (EQ ANS VAR))) + ((MPLUSP ANS) (ANDMAPC #'SUM-OF-INTSP (CDR ANS))) + ((EQ (CAAR ANS) '%INTEGRATE) T) + ((MTIMESP ANS) + (DO ((FACS (CDR ANS) (CDR FACS)) + (INTS)) + ((NULL FACS) (< (LENGTH INTS) 2)) + (UNLESS (FREEOF VAR (CAR FACS)) + (IF (SUM-OF-INTSP (CAR FACS)) (PUSH (CAR FACS) INTS) + (RETURN NIL))))) + ((FREEOF VAR ANS) T) + (T NIL))) + +(DEFUN INTSUM (FORM VAR) + (PROG (EXP IDX LL UL PAIR VAL) + (SETQ EXP (CADR FORM) IDX (CADDR FORM) + LL (CADDDR FORM) UL (CAR (CDDDDR FORM))) + (IF (OR (NOT (ATOM VAR)) (NOT (FREE IDX VAR)) + (NOT (FREE LL VAR)) (NOT (FREE UL VAR))) + (RETURN (LIST '(%INTEGRATE) FORM VAR))) + (SETQ PAIR (PARTITION EXP VAR 1)) + (WHEN (AND (MEXPTP (CDR PAIR)) (EQ (CADDR PAIR) VAR)) + (SETQ VAL (SUBSTITUTE LL IDX (CADDDR PAIR))) + (COND ((EQUAL VAL -1) + (RETURN (ADD2 (INTEGRATOR (SUBSTITUTE LL IDX EXP) VAR) + (INTSUM1 EXP IDX (ADD2 1 LL) UL VAR)))) + ((MLSP VAL -1) + (RETURN (LIST '(%INTEGRATE) FORM VAR))))) + (RETURN (INTSUM1 EXP IDX LL UL VAR)))) + +(DEFUN INTSUM1 (EXP IDX LL UL VAR) + (ASSUME (LIST '(MGEQP) IDX LL)) + (IF (NOT (EQ UL '$INF)) (ASSUME (LIST '(MGEQP) UL IDX))) + (SIMPLIFYA (LIST '(%SUM) (INTEGRATOR EXP VAR) IDX LL UL) T)) + +(DEFUN RAT8PRIME (C) (AND (RAT8 C) (OR (NOT (MNUMP C)) (NOT (ZEROP1 C))))) + +(DEFUN FINDS (X) + (IF (ATOM X) (MEMQ X '(%LOG %INTEGRATE %ATAN)) + (OR (FINDS (CAR X)) (FINDS (CDR X))))) + +(DEFUN RATLOG (EXP VAR FORM) + (PROG (A B C D Y Z W) + (SETQ Y FORM) + (SETQ B (CDR (SASSQ 'B Y 'NILL))) + (SETQ C (CDR (SASSQ 'C Y 'NILL))) + (SETQ Y (INTEGRATOR C VAR)) + (COND ((FINDS Y) (RETURN NIL))) + (SETQ D (SDIFF (CDR (SASSQ 'A FORM 'NILL)) + VAR)) + + (SETQ Z (INTEGRATOR (MUL2* Y D) VAR)) + (SETQ D (CDR (SASSQ 'A FORM 'NILL))) + (RETURN (SIMPLIFY (LIST '(MPLUS) + (LIST '(MTIMES) Y D) + (LIST '(MTIMES) -1 Z)))))) + +(DEFUN FIND1 (Y A) + (COND ((EQ Y A) T) + ((ATOM Y) NIL) + (T (OR (FIND1 (CAR Y) A) (FIND1 (CDR Y) A))))) + (DEFUN MATCHSUM (ALIST BLIST) + (PROG (R S C D) + (SETQ S (M2 (CAR ALIST) + '((MTIMES) + ((COEFFTT) (A FREEVAR)) + ((COEFFTT) (C TRUE))) + NIL)) + (SETQ C (CDR (SASSQ 'C S 'NILL))) + (COND ((NOT (SETQ R + (M2 (CONS '(MPLUS) BLIST) + (LIST '(MPLUS) + (CONS '(MTIMES) + (CONS '((COEFFTT) (B FREE1)) + (COND ((MTIMESP C) + (CDR C)) + (T (LIST C))))) + '(D TRUE)) + NIL))) + (RETURN NIL))) + (SETQ D (SIMPLIFY (LIST '(MTIMES) + (SUBLISS S 'A) + (LIST '(MEXPT) + (SUBLISS R 'B) + -1)))) + (COND ((M2 (CONS '(MPLUS) ALIST) + (TIMESLOOP D BLIST) + NIL) + (RETURN D)) + (T (RETURN NIL))))) + +(DEFUN TIMESLOOP (A B) + (CONS '(MPLUS) (MAPCAR (FUNCTION (LAMBDA (C) (MUL2* A C))) B))) + +(DEFUN SIMPLOG (A) (SIMPLIFYA (CONS '(%LOG) A) NIL)) + +(DEFUN EXPANDS (AA B) + (ADDN (MAPCAR (FUNCTION (LAMBDA (C) (TIMESLOOP C AA))) B) NIL)) + +(DEFUN POWERLIST (EXP VAR) + (PROG (Y Z C D POWERLIST B) + (SETQ Y (M2 EXP + '((MTIMES) + ((MEXPT) (VAR VARP) (C INTEGERP2)) + ((COEFFTT) (A FREEVAR)) + ((COEFFTT) (B TRUE))) + NIL)) + (SETQ B (CDR (SASSQ 'B Y 'NILL))) + (SETQ C (CDR (SASSQ 'C Y 'NILL))) + (COND ((NOT (SETQ Z (RAT10 B))) (RETURN NIL))) + (SETQ D (LISTGCD (CONS (ADD1 C) POWERLIST))) + (COND ((OR (NULL D) (ZEROP D)) (RETURN NIL))) + (RETURN + (SUBSTINT + (LIST '(MEXPT) VAR D) + VAR + (INTEGRATE5 (SIMPLIFY (LIST '(MTIMES) + (POWER* D -1) + (CDR (SASSQ 'A + Y + 'NILL)) + (LIST '(MEXPT) + VAR + (SUB1 (QUOTIENT (ADD1 C) D))) + (SUBST10 B))) + VAR))))) + +(DEFUN DIFFDIV (EXP VAR) + (PROG (Y A X V D Z W R) + (COND + ((AND (MEXPTP EXP) + (MPLUSP (CADR EXP)) + (INTEGERP2 (CADDR EXP)) + (LESSP (CADDR EXP) 6) + (GREATERP (CADDR EXP) 0)) + (RETURN (INTEGRATOR (EXPANDEXPT (CADR EXP) (CADDR EXP)) VAR)))) + (SETQ EXP (COND ((MTIMESP EXP) EXP) (T (LIST '(MTIMES) EXP)))) + (SETQ Z (CDR EXP)) + A (SETQ Y (CAR Z)) + (SETQ R (LIST '(MPLUS) + (CONS '(COEFFPT) + (CONS '(C FREE1) + (CHOICESIN Y (CDR EXP)))))) + (COND + ((SETQ W (M2 (SDIFF Y VAR) R NIL)) + (RETURN (MULN (LIST Y Y (POWER* (MUL2* 2 (CDR (SASSQ 'C W 'NILL))) -1)) NIL)))) + (SETQ W (COND ((OR (ATOM Y) (MEMQ (CAAR Y) '(MPLUS MTIMES))) Y) + ((EQ (CAAR Y) 'MEXPT) + (COND ((FREEVAR (CADR Y)) (CADDR Y)) + ((FREEVAR (CADDR Y)) (CADR Y)) + (T 0))) + (T (CADR Y)))) + (COND + ((SETQ W (COND ((AND (SETQ X (SDIFF W VAR)) + (MPLUSP X) + (SETQ D (CHOICESIN Y (CDR EXP))) + (SETQ V (CAR D)) + (MPLUSP V) + (NOT (CDR D))) + (COND ((SETQ D (MATCHSUM (CDR X) (CDR V))) + (LIST (CONS 'C D))) + (T NIL))) + (T (M2 X R NIL)))) + (RETURN (COND ((NULL (SETQ X (INTEGRALLOOKUPS Y))) NIL) + ((EQ W T) X) + (T (MUL2* X (POWER* (CDR (SASSQ 'C W 'NILL)) -1))))))) + (SETQ Z (CDR Z)) + (COND ((NULL Z) (RETURN NIL))) + (GO A))) + +(DEFUN SUBLISS (A B) + (PROG (X Y Z) + (SETQ X B) + (SETQ Z A) + LOOP (COND ((NULL Z) (RETURN X))) + (SETQ Y (CAR Z)) + (SETQ X (SUBSTITUTE (CDR Y) (CAR Y) X)) + (SETQ Z (CDR Z)) + (GO LOOP))) + +(DEFUN SUBSTINT (X Y EXPRES) + (COND ((AND (NOT (ATOM EXPRES)) (EQ (CAAR EXPRES) '%INTEGRATE)) + (LIST (CAR EXPRES) EXP VAR)) + (T (SUBSTINT1 (SUBSTITUTE X Y EXPRES))))) + +(DEFUN SUBSTINT1 (EXP) + (COND ((ATOM EXP) EXP) + ((AND (EQ (CAAR EXP) '%INTEGRATE) (NULL (CDDDR EXP)) + (NOT (SYMBOLP (CADDR EXP))) (NOT (FREE (CADDR EXP) VAR))) + (SIMPLIFY (LIST '(%INTEGRATE) (MUL2 (CADR EXP) (SDIFF (CADDR EXP) VAR)) + VAR))) + (T (RECUR-APPLY #'SUBSTINT1 EXP)))) diff --git a/src/jm/sinint.140 b/src/jm/sinint.140 new file mode 100644 index 00000000..3d2d989b --- /dev/null +++ b/src/jm/sinint.140 @@ -0,0 +1,374 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module sinint) +(load-macsyma-macros ratmac) + +(DECLARE (GENPREFIX I) + (SPECIAL RISCHPF GENVAR $SAVEFACTORS CHECKFACTORS + EXP VAR $FACTORFLAG $RATFAC $LOGABS $EXPOP $EXPON + $KEEPFLOAT RATFORM ROOTFACTOR PARDENOM $ALGEBRAIC + WHOLEPART PARNUMER VARLIST LOGPTDX SWITCH1) + (FIXNUM NARGS I N KLTH KX)) + + +(DEFUN ROOTFAC (Q) + (PROG (NTHDQ NTHDQ1 SIMPROOTS ANS) + (SETQ NTHDQ (PGCD Q (PDERIVATIVE Q VAR))) + (SETQ SIMPROOTS (PQUOTIENT Q NTHDQ)) + (SETQ ANS (LIST (PQUOTIENT SIMPROOTS (PGCD NTHDQ SIMPROOTS)))) + AMEN (IF (OR (PCOEFP NTHDQ) (POINTERGP VAR (CAR NTHDQ))) + (RETURN (REVERSE ANS))) + (SETQ NTHDQ1 (PGCD (PDERIVATIVE NTHDQ VAR) NTHDQ)) + (SETQ ANS (CONS (PQUOTIENT (PGCD NTHDQ SIMPROOTS) (PGCD NTHDQ1 SIMPROOTS)) + ANS)) + (SETQ NTHDQ NTHDQ1) + (GO AMEN))) + +(DEFUN APROG (Q) + (SETQ Q (OLDCONTENT Q)) + (SETQ ROOTFACTOR (ROOTFAC (CADR Q))) + (SETQ ROOTFACTOR + (CONS (PTIMES (CAR Q) (CAR ROOTFACTOR)) (CDR ROOTFACTOR))) + (DO ((PD (LIST (CAR ROOTFACTOR))) + (RF (CDR ROOTFACTOR) (CDR RF)) + (N 2 (1+ N))) + ((NULL RF) (SETQ PARDENOM (REVERSE PD))) + (PUSH (PEXPT (CAR RF) N) PD)) + ROOTFACTOR) + +(DEFUN CPROG (TOP BOTTOM) + (PROG (FRPART PARDENOMC PPDENOM THEBPG) + (SETQ FRPART (PDIVIDE TOP BOTTOM)) + (SETQ WHOLEPART (CAR FRPART)) + (SETQ FRPART (CADR FRPART)) + (IF (= (LENGTH PARDENOM) 1) + (RETURN (SETQ PARNUMER (LIST FRPART)))) + (SETQ PARDENOMC (CDR PARDENOM)) + (SETQ PPDENOM (LIST (CAR PARDENOM))) + DSEQ (IF (= (LENGTH PARDENOMC) 1) (GO OK)) + (SETQ PPDENOM (CONS (PTIMES (CAR PPDENOM) (CAR PARDENOMC)) PPDENOM)) + (SETQ PARDENOMC (CDR PARDENOMC)) + (GO DSEQ) + OK (SETQ PARDENOMC (REVERSE PARDENOM)) + NUMC (SETQ THEBPG (BPROG (CAR PARDENOMC) (CAR PPDENOM))) + (SETQ PARNUMER + (CONS (CDR (RATDIVIDE (RATTI FRPART (CDR THEBPG) T) + (CAR PARDENOMC))) + PARNUMER)) + (SETQ FRPART + (CDR (RATDIVIDE (RATTI FRPART (CAR THEBPG) T) + (CAR PPDENOM)))) + (SETQ PARDENOMC (CDR PARDENOMC)) + (SETQ PPDENOM (CDR PPDENOM)) + (IF (NULL PPDENOM) + (RETURN (SETQ PARNUMER (CONS FRPART PARNUMER)))) + (GO NUMC))) + +(DEFUN POLYINT (P) (RATQU (POLYINT1 (RATNUMERATOR P)) (RATDENOMINATOR P))) + +(DEFUN POLYINT1 (P) + (COND ((OR (NULL P) (EQUAL P 0)) (CONS 0 1)) + ((ATOM P) (LIST VAR 1 P)) + ((NOT (NUMBERP (CAR P))) + (IF (POINTERGP VAR (CAR P)) (LIST VAR 1 P) (POLYINT1 (CDR P)))) + (T (RATPLUS (POLYINT2 P) (POLYINT1 (CDDR P)))))) + +(DEFUN POLYINT2 (P) (CONS (LIST VAR (ADD1 (CAR P)) (CADR P)) (ADD1 (CAR P)))) + +(DEFUN DPROG (RATARG) + (PROG (KLTH KX AROOTF DERIV THEBPG THETOP THEBOT PROD1 PROD2 ANS) + (SETQ ANS (CONS 0 1)) + (IF (OR (PCOEFP (CDR RATARG)) (POINTERGP VAR (CADR RATARG))) + (RETURN (DISREP (POLYINT RATARG)))) + (APROG (RATDENOMINATOR RATARG)) + (CPROG (RATNUMERATOR RATARG) (RATDENOMINATOR RATARG)) + (SETQ ROOTFACTOR (REVERSE ROOTFACTOR)) + (SETQ PARNUMER (REVERSE PARNUMER)) + (SETQ KLTH (LENGTH ROOTFACTOR)) + INTG (IF (= KLTH 1) (GO SIMP)) + (SETQ AROOTF (CAR ROOTFACTOR)) + (IF (ZEROP (PDEGREE AROOTF VAR)) (GO RESET)) + (SETQ DERIV (PDERIVATIVE AROOTF VAR)) + (SETQ THEBPG (BPROG AROOTF DERIV)) + (SETQ KX (1- KLTH)) + (SETQ THETOP (CAR PARNUMER)) + ITER (SETQ PROD1 (RATTI THETOP (CAR THEBPG) T)) + (SETQ PROD2 (RATTI THETOP (CDR THEBPG) T)) + (SETQ THEBOT (PEXPT AROOTF KX)) + (SETQ ANS + (RATPLUS ANS (RATQU (RATMINUS PROD2) (RATTI KX THEBOT T)))) + (SETQ THETOP + (RATPLUS PROD1 + (RATQU (RATREDUCE (PDERIVATIVE (CAR PROD2) VAR) + (CDR PROD2)) + KX))) + (SETQ THETOP (CDR (RATDIVIDE THETOP THEBOT))) + (COND ((= KX 1) (SETQ LOGPTDX (CONS (RATQU THETOP AROOTF) LOGPTDX)) + (GO RESET))) + (SETQ KX (1- KX)) + (GO ITER) + RESET(SETQ ROOTFACTOR (CDR ROOTFACTOR)) + (SETQ PARNUMER (CDR PARNUMER)) + (SETQ KLTH (1- KLTH)) + (GO INTG) + SIMP (SETQ LOGPTDX + (CONS (RATQU (CAR PARNUMER) (CAR ROOTFACTOR)) LOGPTDX)) + (IF (EQUAL ANS 0) (RETURN (DISREP (POLYINT WHOLEPART)))) + (SETQ THETOP + (CADR (PDIVIDE (RATNUMERATOR ANS) (RATDENOMINATOR ANS)))) + (RETURN (LIST '(MPLUS) + (DISREP (POLYINT WHOLEPART)) + (DISREP (RATQU THETOP (RATDENOMINATOR ANS))))))) + +(DEFUN LOGMABS (X) + (LIST '(%LOG) (IF $LOGABS (SIMPLIFY (LIST '(MABS) X)) X))) + +(DEFUN NPASK (EXP) + (COND ((FREEOF '$%I EXP) + (LEARN `((MNOTEQUAL) ,EXP 0) T) (ASKSIGN EXP)) + (T '$POSITIVE))) + +(DEFUN EPROG (P) + (PROG (P1E P2E A1E A2E A3E DISCRIM REPART SIGN NCC DCC ALLCC XX DEG) + (IF (OR (EQUAL P 0) (EQUAL (CAR P) 0)) (RETURN 0)) + (SETQ P1E (RATNUMERATOR P) P2E (RATDENOMINATOR P)) + (COND ((OR SWITCH1 + (AND (NOT (ATOM P2E)) + (EQ (CAR (SETQ XX (CADR (OLDCONTENT P2E)))) VAR) + (MEMBER (SETQ DEG (PDEGREE XX VAR)) '(5 6)) + (ZEROCOEFL XX DEG) + (OR (EQUAL DEG 5) (NOT (PMINUSP (CAR (LAST XX))))))) + (GO EFAC))) + (SETQ A1E (INTFACTOR P2E)) + (IF (> (LENGTH A1E) 1) (GO E40)) + EFAC (SETQ NCC (OLDCONTENT P1E)) + (SETQ P1E (CADR NCC)) + (SETQ DCC (OLDCONTENT P2E)) + (SETQ P2E (CADR DCC)) + (SETQ ALLCC (RATQU (CAR NCC) (CAR DCC))) + (SETQ DEG (PDEGREE P2E VAR)) + (SETQ A1E (PDERIVATIVE P2E VAR)) + (SETQ A2E (RATQU (POLCOEF P1E (PDEGREE P1E VAR)) + (POLCOEF A1E (PDEGREE A1E VAR)))) + (COND ((EQUAL (RATTI A2E A1E T) (CONS P1E 1)) + (RETURN (LIST '(MTIMES) + (DISREP (RATTI ALLCC A2E T)) + (LOGMABS (DISREP P2E)))))) + (COND ((EQUAL DEG 1) (GO E10)) + ((EQUAL DEG 2) (GO E20)) + ((AND (EQUAL DEG 3) (EQUAL (POLCOEF P2E 2) 0) + (EQUAL (POLCOEF P2E 1) 0)) + (RETURN (E3PROG P1E P2E ALLCC))) + ((AND (MEMBER DEG '(4 5 6)) (ZEROCOEFL P2E DEG)) + (RETURN (ENPROG P1E P2E ALLCC DEG)))) + (RETURN (LIST '(MTIMES) + (DISREP ALLCC) + (LIST '(%INTEGRATE) + (LIST '(MQUOTIENT) (DISREP P1E) (DISREP P2E)) + (CAR (LAST VARLIST))))) + E10 (RETURN (LIST '(MTIMES) + (DISREP (RATTI ALLCC + (RATQU (POLCOEF P1E (PDEGREE P1E VAR)) + (POLCOEF P2E 1)) + T)) + (LOGMABS (DISREP P2E)))) + E20 (SETQ DISCRIM + (RATDIFFERENCE (CONS (PEXPT (POLCOEF P2E 1) 2) 1) + (RATTI 4 (RATTI (POLCOEF P2E 2) (POLCOEF P2E 0) T) T))) + (SETQ A2E (RATTI (POLCOEF P2E (PDEGREE P2E VAR)) 2 T)) + (IF (NOT (FREE (SETQ XX (SIMPLIFY (DISREP DISCRIM))) '$%I)) (GO POS)) + (SETQ SIGN (NPASK XX)) + (COND ((EQ SIGN '$NEGATIVE) (GO E30)) + ((EQ SIGN '$ZERO) (GO ZIP))) + POS (SETQ A1E (RATSQRT DISCRIM)) + (SETQ A3E (LOGMABS + (LIST '(MQUOTIENT) + (LIST '(MPLUS) + (LIST '(MTIMES) + (DISREP A2E) (DISREP (LIST VAR 1 1))) + (DISREP (POLCOEF P2E 1)) + (LIST '(MMINUS) A1E)) + (LIST '(MPLUS) + (LIST '(MTIMES) + (DISREP A2E) (DISREP (LIST VAR 1 1))) + (DISREP (POLCOEF P2E 1)) + A1E)))) + (COND ((ZEROP (PDEGREE P1E VAR)) + (RETURN (LIST '(MTIMES) + (DISREP ALLCC) + (LIST '(MQUOTIENT) (DISREP (POLCOEF P1E 0)) A1E) + A3E)))) + (RETURN + (LIST + '(MPLUS) + (LIST '(MTIMES) + (DISREP (RATTI ALLCC (RATQU (POLCOEF P1E (PDEGREE P1E VAR)) A2E) T)) + (LOGMABS (DISREP P2E))) + (LIST + '(MTIMES) + (LIST + '(MQUOTIENT) + (DISREP (RATTI ALLCC (RATQU (EPROGRATD A2E P1E P2E) A2E) T)) + A1E) + A3E))) + E30 (SETQ A1E (RATSQRT (RATMINUS DISCRIM))) + (SETQ + REPART + (RATQU (COND ((ZEROP (PDEGREE P1E VAR)) (RATTI A2E (POLCOEF P1E 0) T)) + (T (EPROGRATD A2E P1E P2E))) + (POLCOEF P2E (PDEGREE P2E VAR)))) + (SETQ A3E (COND ((EQUAL 0 (CAR REPART)) 0) + (T `((MTIMES) ((MQUOTIENT) + ,(DISREP (RATTI ALLCC REPART T)) + ,A1E) + ((%ATAN) + ((MQUOTIENT) + ,(DISREP (PDERIVATIVE P2E VAR)) + ,A1E)))))) + (IF (ZEROP (PDEGREE P1E VAR)) (RETURN A3E)) + (RETURN (LIST '(MPLUS) + (LIST '(MTIMES) + (DISREP (RATTI ALLCC + (RATQU (POLCOEF P1E (PDEGREE P1E VAR)) A2E) + T)) + (LOGMABS (DISREP P2E))) + A3E)) + ZIP (SETQ + P2E + (RATQU + (PSIMP + (P-VAR P2E) + (PCOEFADD 2 + (PEXPT (PTIMES 2 (POLCOEF P2E 2)) 2) + (PCOEFADD 1 (PTIMES 4 (PTIMES (POLCOEF P2E 2) + (POLCOEF P2E 1))) + (PCOEFADD 0 (PEXPT (POLCOEF P2E 1) 2) ())))) + (PTIMES 4 (POLCOEF P2E 2)))) + (RETURN (FPROG (RATTI ALLCC (RATQU P1E P2E) T))) + E40 (SETQ PARNUMER NIL PARDENOM A1E SWITCH1 T) + (CPROG P1E P2E) + (SETQ A2E + (MAPCAR #'(LAMBDA (J K) (EPROG (RATQU J K))) PARNUMER PARDENOM)) + (SETQ SWITCH1 NIL) + (RETURN (CONS '(MPLUS) A2E)))) + +(DEFUN E3PROG (NUM DENOM CONT) + (PROG (A B C D E R RATR VAR* X) + (SETQ A (POLCOEF NUM 2) B (POLCOEF NUM 1) C (POLCOEF NUM 0) + D (POLCOEF DENOM 3) E (POLCOEF DENOM 0)) + (SETQ R (COND ((EQ (NPASK (SIMPLIFY (DISREP (RATQU E D)))) '$NEGATIVE) + (SIMPNRT (DISREP (RATQU (RATTI -1 E T) D)) 3)) + (T (NEG (SIMPNRT (DISREP (RATQU E D)) 3))))) + (SETQ VAR* (LIST VAR 1 1)) + (NEWVAR R) + (ORDERPOINTER VARLIST) + (SETQ X (RATF R)) + (SETQ RATFORM (CAR X) RATR (CDR X)) + (RETURN + (SIMPLIFY + (LIST '(MPLUS) + (LIST '(MTIMES) + (DISREP (RATQU (R* CONT (R+ (R* A RATR RATR) (R* B RATR) C)) + (R* RATR RATR 3 D))) + (LOGMABS (DISREP (RATPL (RATTI -1 RATR T) VAR*)))) + (EPROG (R* CONT (RATQU (R+ (R* (R+ (R* 2 A RATR RATR) + (R* -1 B RATR) + (R* -1 C)) + VAR*) + (R+ (RATQU (R* -1 A E) D) + (R* B RATR RATR) + (R* -1 2 C RATR))) + (R* 3 D RATR RATR + (R+ (RATTI VAR* VAR* T) + (RATTI RATR VAR* T) + (RATTI RATR RATR T)))))) + ))))) + +(DEFUN EPROGRATD (A2E P1E P2E) + (RATDIFFERENCE (RATTI A2E (POLCOEF P1E (SUB1 (PDEGREE P1E VAR))) T) + (RATTI (POLCOEF P2E (SUB1 (PDEGREE P2E VAR))) + (POLCOEF P1E (PDEGREE P1E VAR)) + T))) + +(DEFUN ENPROG (NUM DENOM CONT DEG) + ; Denominator is (A*VAR^4+B) = + ; (SQRT(A)*VAR^2 - SQRT(2)*A^(1/4)*B^(1/4)*VAR + SQRT(B)) * + ; (SQRT(A)*VAR^2 + SQRT(2)*A^(1/4)*B^(1/4)*VAR + SQRT(B)) + ; or (A*VAR^5+B) = + ; (1/4) * (A^(1/5)*VAR + B^(1/5)) * + ; (2*A^(2/5)*VAR^2 + (-SQRT(5)-1)*A^(1/5)*B^(1/5)*VAR + 2*B^(2/5)) * + ; (2*A^(2/5)*VAR^2 + (+SQRT(5)-1)*A^(1/5)*B^(1/5)*VAR + 2*B^(2/5)) + ; or (A*VAR^6+B) = + ; (A^(1/3)*VAR^2 + B^(1/3)) * + ; (A^(1/3)*VAR^2 - SQRT(3)*A^(1/6)*B^(1/6)*VAR + B^(1/3)) * + ; (A^(1/3)*VAR^2 + SQRT(3)*A^(1/6)*B^(1/6)*VAR + B^(1/3)) + (PROG ($EXPOP $EXPON A B TERM DISVAR $ALGEBRAIC) + (SETQ $EXPOP 0 $EXPON 0) + (SETQ A (SIMPLIFY (DISREP (POLCOEF DENOM DEG))) + B (SIMPLIFY (DISREP (POLCOEF DENOM 0))) + DISVAR (SIMPLIFY (GET VAR 'DISREP)) + NUM (SIMPLIFY (DISREP NUM)) + CONT (SIMPLIFY (DISREP CONT))) + (COND ((= DEG 4) + (SETQ DENOM (ADD2 (MUL2 (POWER A '((RAT SIMP) 1 2)) (POWER DISVAR 2)) + (POWER B '((RAT SIMP) 1 2))) + TERM (MULN (LIST (POWER 2 '((RAT SIMP) 1 2)) + (POWER A '((RAT SIMP) 1 4)) + (POWER B '((RAT SIMP) 1 4)) + DISVAR) + T)) + (SETQ DENOM (MUL2 (ADD2 DENOM TERM) (SUB DENOM TERM)))) + ((= DEG 5) + (SETQ TERM (MUL3 (POWER A '((RAT SIMP) 1 5)) + (POWER B '((RAT SIMP) 1 5)) + DISVAR)) + (SETQ DENOM (ADD2 (MUL3 2 (POWER A '((RAT SIMP) 2 5)) + (POWER DISVAR 2)) + (SUB (MUL2 2 (POWER B '((RAT SIMP) 2 5))) TERM))) + (SETQ TERM (MUL2 (POWER 5 '((RAT SIMP) 1 2)) TERM)) + (SETQ DENOM (MULN (LIST '((RAT SIMP) 1 4) + (ADD2 (MUL2 (POWER A '((RAT SIMP) 1 5)) DISVAR) + (POWER B '((RAT SIMP) 1 5))) + (ADD2 DENOM TERM) (SUB DENOM TERM)) + T))) + (T (SETQ DENOM (ADD2 (MUL2 (POWER A '((RAT SIMP) 1 3)) (POWER DISVAR 2)) + (POWER B '((RAT SIMP) 1 3))) + TERM (MULN (LIST (POWER 3 '((RAT SIMP) 1 2)) + (POWER A '((RAT SIMP) 1 6)) + (POWER B '((RAT SIMP) 1 6)) + DISVAR) + T)) + (SETQ DENOM (MUL3 DENOM (ADD2 DENOM TERM) (SUB DENOM TERM))))) + ;;Needs $ALGEBRAIC NIL so next call to RATF will preserve factorization. + (RETURN (MUL2 CONT (RATINT (DIV NUM DENOM) DISVAR))))) + +(DEFUN ZEROCOEFL (E N) + (DO ((I 1 (1+ I))) ((= I N) T) + (IF (NOT (EQUAL (POLCOEF E I) 0)) (RETURN NIL)))) + +(DEFUN RATSQRT (A) (LET (VARLIST) (SIMPNRT (DISREP A) 2))) + +(DEFUN FPROG (RAT*) + (PROG (ROOTFACTOR PARDENOM PARNUMER LOGPTDX WHOLEPART SWITCH1) + (RETURN (ADDN (CONS (DPROG RAT*) (MAPCAR #'EPROG LOGPTDX)) NIL)))) + +(DEFMFUN RATINT (EXP VAR) + (PROG (GENVAR CHECKFACTORS VARLIST RATARG RATFORM $KEEPFLOAT) + (SETQ VARLIST (LIST VAR)) + (SETQ RATARG (RATF EXP)) + (SETQ RATFORM (CAR RATARG)) + (SETQ VAR (CAADR (RATF VAR))) + (RETURN (FPROG (CDR RATARG))))) + +(DEFUN INTFACTOR (L) + (PROG ($FACTORFLAG A B) + (SETQ A (OLDCONTENT L) B (EVERYSECOND (PFACTOR (CADR A)))) + (RETURN (IF (EQUAL (CAR A) 1) B (CONS (CAR A) B))))) + +(DEFUN EVERYSECOND (A) + (IF A (CONS (IF (NUMBERP (CAR A)) + (PEXPT (CAR A) (CADR A)) + (CAR A)) + (EVERYSECOND (CDDR A))))) diff --git a/src/jm/zero.23 b/src/jm/zero.23 new file mode 100644 index 00000000..3d729e76 --- /dev/null +++ b/src/jm/zero.23 @@ -0,0 +1,63 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module zero) + +(DECLARE (SPECIAL S VAR EXP V1 V R1 R2 $NUMER $LISTCONSTVARS VARLIST GENVAR) + (*LEXPR $RAT)) + +(DEFMFUN $ZEROEQUIV (EXP VAR) + (PROG (R S V VARLIST GENVAR) + (SETQ EXP (SPECREPCHECK EXP)) + (SETQ R (LET ($LISTCONSTVARS) ($LISTOFVARS EXP))) + (IF (AND (CDR R) (OR (CDDR R) (NOT (ALIKE1 (CADR R) VAR)))) + (RETURN '$DONTKNOW)) + (SETQ EXP ($EXPONENTIALIZE EXP)) + (SETQ R (SDIFF EXP VAR)) + (IF (ISINOP R '%DERIVATIVE) (RETURN '$DONTKNOW)) + ($RAT R) + (SETQ R ($RAT EXP)) + (SETQ S (CAR R)) + (SETQ V (RATNUMERATOR (CDR R))) + (RETURN (ZEROEQUIV1 V)))) + +(DEFUN ZEROEQUIV1 (V) + (PROG (V1 V2 COEFF DEG) + (IF (ATOM V) (RETURN (EQUAL V 0))) + COEFFLOOP (IF (NULL (CDR V)) (RETURN T)) + (SETQ DEG (CADR V)) + (IF (EQUAL DEG 0) (RETURN (ZEROEQUIV1 (CADDR V)))) + (SETQ COEFF (CADDR V)) + (WHEN (ZEROEQUIV1 COEFF) + (SETQ V (CONS (CAR V) (CDDDR V))) + (GO COEFFLOOP)) + (SETQ V1 ($RAT (SDIFF (RATDISREP (CONS S (CONS V (CADDR V)))) + VAR))) + (SETQ V2 (CADR ($RAT (RATDISREP V1)))) + (IF (EQUAL (PDEGREE V2 (CAR V)) (CADR V)) + (RETURN (ZEROEQUIV2 V))) + (IF (LESSP (PDEGREE V2 (CAR V)) (CADR V)) + (RETURN (IF (ZEROEQUIV1 V2) (ZEROEQUIV2 V)))) + (RETURN '$DONTKNOW))) + +(DEFUN ZEROEQUIV2 (V) + (PROG (R R1 R2) + (SETQ R (SIN (TIMES 0.001 (RANDOM 1000.)))) + (SETQ V (SUBSTITUTE R VAR (RATDISREP (CONS S (CONS V 1))))) + (SETQ V (MEVAL '(($EV) V $NUMER))) + (COND ((AND (NUMBERP V) (LESSP (ABS V) (TIMES R 0.01))) + (RETURN T)) + ((NUMBERP V) (RETURN NIL))) + (IF (AND (FREE V '$%I) (NOT (ISINOP V '%LOG))) + (RETURN '$DONTKNOW)) + (SETQ R1 ($REALPART V)) + (SETQ R1 (MEVAL '(($EV) R1 $NUMER))) + (IF (NOT (NUMBERP R1)) (RETURN '$DONTKNOW)) + (SETQ R2 ($IMAGPART V)) + (SETQ R2 (MEVAL '(($EV) R2 $NUMER))) + (IF (NOT (NUMBERP R2)) (RETURN '$DONTKNOW)) + (COND ((AND (LESSP (ABS R1) (TIMES R 0.01)) + (LESSP (ABS R2) (TIMES R 0.01))) + (RETURN T)) + (T (RETURN NIL))))) diff --git a/src/jpg/comm.395 b/src/jpg/comm.395 new file mode 100644 index 00000000..66aeb8f3 --- /dev/null +++ b/src/jpg/comm.395 @@ -0,0 +1,917 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1982 Massachusetts Institute of Technology ** + +(macsyma-module comm) + +(DECLARE (GENPREFIX C) + (SPECIAL $EXPTSUBST $LINECHAR $NOLABELS $INFLAG $PIECE $DISPFLAG + $GRADEFS $PROPS $DEPENDENCIES DERIVFLAG DERIVLIST + $LINENUM $PARTSWITCH LINELABLE NN* DN* ISLINP + $POWERDISP ATVARS ATP $ERREXP $DERIVSUBST $DOTDISTRIB + $OPSUBST $SUBNUMSIMP $TRANSRUN IN-P SUBSTP $SQRTDISPFLAG + $PFEFORMAT) + (*LEXPR FACTOR) + (FIXNUM I N LARGL LVRS COUNT TIM (SIGNUM1))) + +(PROG1 '(OP properties) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP) + (PUTPROP (CADR X) (CAR X) 'OPR)) + '((MPLUS &+) (MMINUS &-) (MTIMES &*) (MEXPT &**) (MEXPT &^) + (MNCTIMES &/.) (RAT &//) (MQUOTIENT &//) (MNCEXPT &^^) + (MEQUAL &=) (MGREATERP &>) (MLESSP &<) (MLEQP &<=) (MGEQP &>=) + (MNOTEQUAL &/#) (MAND &AND) (MOR &OR) (MNOT &NOT) (MSETQ &/:) + (MDEFINE &/:=) (MDEFMACRO &/:/:=) (MQUOTE &/') (MLIST &[) + (MSET &/:/:) (MFACTORIAL &!) (MARROW &->) (MPROGN &/() + (MCOND &IF))) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP)) + '((MQAPPLY $SUBVAR) (BIGFLOAT $BFLOAT)))) + +(SETQ $EXPTSUBST NIL $PARTSWITCH NIL $INFLAG NIL $GRADEFS '((MLIST SIMP)) + $DEPENDENCIES '((MLIST SIMP)) ATVARS '(&@1 &@2 &@3 &@4) ATP NIL + ISLINP NIL LNORECURSE NIL &** '&^ $DERIVSUBST NIL TIMESP NIL + $OPSUBST T IN-P NIL SUBSTP NIL) + +(DEFMVAR $VECT_CROSS NIL + "If TRUE allows DIFF(X~Y,T) to work where ~ is defined in + SHARE;VECT where VECT_CROSS is set to TRUE.") + +(DEFMFUN $SUBSTITUTE N + (COND ((= N 2) + (LET ((L (ARG 1)) (Z (ARG 2))) + (COND ((AND ($LISTP L) ($LISTP (CADR L)) (NULL (CDDR L))) + ($SUBSTITUTE (CADR L) Z)) + ((NOTLOREQ L) (IMPROPER-ARG-ERR L '$SUBSTITUTE)) + ((EQ (CAAR L) 'MEQUAL) (SUBSTITUTE (CADDR L) (CADR L) Z)) + (T (DO ((L (CDR L) (CDR L))) ((NULL L) Z) + (SETQ Z ($SUBSTITUTE (CAR L) Z))))))) + ((= N 3) (SUBSTITUTE (ARG 1) (ARG 2) (ARG 3))) + (T (WNA-ERR '$SUBSTITUTE)))) + +(DECLARE (SPECIAL X Y OPRX OPRY NEGXPTY TIMESP)) + +(DEFMFUN SUBSTITUTE (X Y Z) ; The args to SUBSTITUTE are assumed to be simplified. + (LET ((IN-P T) (SUBSTP T)) + (IF (AND (MNUMP Y) (= (SIGNUM1 Y) 1)) + (LET ($SQRTDISPFLAG ($PFEFORMAT T)) (SETQ Z (NFORMAT-ALL Z)))) + (SIMPLIFYA + (IF (ATOM Y) + (COND ((EQUAL Y -1) + (SETQ Y '((MMINUS) 1)) (SUBST2 (NFORMAT-ALL Z))) + (T (LET ((OPRX (GETOPR X)) (OPRY (GETOPR Y))) + (SUBST1 Z)))) + (LET ((NEGXPTY (IF (AND (EQ (CAAR Y) 'MEXPT) + (= (SIGNUM1 (CADDR Y)) 1)) + (MUL2 -1 (CADDR Y)))) + (TIMESP (IF (EQ (CAAR Y) 'MTIMES) (SETQ Y (NFORMAT Y))))) + (SUBST2 Z))) + NIL))) + +(DEFUN SUBST1 (Z) ; Y is an atom + (COND ((ATOM Z) (IF (EQUAL Y Z) X Z)) + ((SPECREPP Z) (SUBST1 (SPECDISREP Z))) + ((EQ (CAAR Z) 'BIGFLOAT) Z) + ((AND (EQ (CAAR Z) 'RAT) (OR (EQUAL Y (CADR Z)) (EQUAL Y (CADDR Z)))) + (DIV (SUBST1 (CADR Z)) (SUBST1 (CADDR Z)))) + ((AND ATP (MEMQ (CAAR Z) '(%DERIVATIVE %LAPLACE))) Z) + ((AND (EQ Y T) (EQ (CAAR Z) 'MCOND)) + (LIST (NCONS (CAAR Z)) (SUBST1 (CADR Z)) (SUBST1 (CADDR Z)) + (CADDDR Z) (SUBST1 (CAR (CDDDDR Z))))) + (T (LET ((MARGS (MAPCAR #'SUBST1 (CDR Z)))) + (SUBST0 + (IF (AND $OPSUBST + (OR (EQ OPRY (CAAR Z)) + (AND (EQ (CAAR Z) 'RAT) (EQ OPRY 'MQUOTIENT)))) + (IF (OR (NUMBERP X) + (MEMQ X '(T NIL $%E $%PI $%I)) + (AND (NOT (ATOM X)) + (NOT (OR (EQ (CAR X) 'LAMBDA) + (EQ (CAAR X) 'LAMBDA))))) + (IF (OR (AND (MEMQ 'ARRAY (CDAR Z)) + (OR (AND (MNUMP X) $SUBNUMSIMP) + (AND (NOT (MNUMP X)) (NOT (ATOM X))))) + ($SUBVARP X)) + (LIST* '(MQAPPLY) X MARGS) + (MERROR + "Attempt to substitute ~M for ~M in ~M~ + ~%Illegal substitution for operator of expression" + X Y Z)) + (CONS (NCONS OPRX) MARGS)) + (CONS (NCONS (CAAR Z)) MARGS)) + Z))))) + +(DEFUN SUBST2 (Z) + (LET (NEWEXPT) + (COND ((ATOM Z) Z) + ((SPECREPP Z) (SUBST2 (SPECDISREP Z))) + ((AND ATP (MEMQ (CAAR Z) '(%DERIVATIVE %LAPLACE))) Z) + ((ALIKE1 Y Z) X) + ((AND TIMESP (EQ (CAAR Z) 'MTIMES) (ALIKE1 Y (SETQ Z (NFORMAT Z)))) X) + ((AND (EQ (CAAR Y) 'MEXPT) (EQ (CAAR Z) 'MEXPT) (ALIKE1 (CADR Y) (CADR Z)) + (SETQ NEWEXPT (COND ((ALIKE1 NEGXPTY (CADDR Z)) -1) + ($EXPTSUBST (EXPTHACK (CADDR Y) (CADDR Z)))))) + (LIST '(MEXPT) X NEWEXPT)) + ((AND $DERIVSUBST (EQ (CAAR Y) '%DERIVATIVE) (EQ (CAAR Z) '%DERIVATIVE) + (ALIKE1 (CADR Y) (CADR Z))) + (LET ((TAIL (SUBST-DIFF-MATCH (CDDR Y) (CDR Z)))) + (COND ((NULL TAIL) Z) + (T (CONS (NCONS (CAAR Z)) (CONS X (CDR TAIL))))))) + (T (RECUR-APPLY #'SUBST2 Z))))) + +(DECLARE (UNSPECIAL X Y OPRX OPRY NEGXPTY TIMESP)) + +(DEFMFUN SUBST0 (NEW OLD) + (COND ((ALIKE (CDR NEW) (CDR OLD)) + (COND ((EQ (CAAR NEW) (CAAR OLD)) OLD) + (T (SIMPLIFYA (CONS (CONS (CAAR NEW) (MEMQ 'ARRAY (CDAR OLD))) (CDR OLD)) + NIL)))) + ((MEMQ 'ARRAY (CDAR OLD)) + (SIMPLIFYA (CONS (CONS (CAAR NEW) '(ARRAY)) (CDR NEW)) NIL)) + (T (SIMPLIFYA NEW NIL)))) + +(DEFUN EXPTHACK (Y Z) + (PROG (NN* DN* YN YD ZN ZD QD) + (COND ((AND (MNUMP Y) (MNUMP Z)) + (RETURN (IF (NUMBERP (SETQ Y (DIV* Z Y))) Y))) + ((ATOM Z) (IF (NOT (MNUMP Y)) (RETURN NIL))) + ((OR (RATNUMP Z) (EQ (CAAR Z) 'MPLUS)) (RETURN NIL))) + (NUMDEN Y) ; (CSIMP) sets NN* and DN* + (SETQ YN NN* YD DN*) + (NUMDEN Z) + (SETQ ZN NN* ZD DN*) + (SETQ QD (COND ((AND (EQUAL ZD 1) (EQUAL YD 1)) 1) + ((PROG2 (NUMDEN (DIV* ZD YD)) + (AND (EQUAL DN* 1) (EQUAL NN* 1))) + 1) + ((EQUAL NN* 1) (DIV* 1 DN*)) + ((EQUAL DN* 1) NN*) + (T (RETURN NIL)))) + (NUMDEN (DIV* ZN YN)) + (IF (EQUAL DN* 1) (RETURN (DIV* NN* QD))))) + +(DEFUN SUBST-DIFF-MATCH (L1 L2) + (DO ((L L1 (CDDR L)) (L2 (APPEND L2 NIL)) (FAILED NIL NIL)) + ((NULL L) L2) + (DO ((L2 L2 (CDDR L2))) + ((NULL (CDR L2)) (SETQ FAILED T)) + (IF (ALIKE1 (CAR L) (CADR L2)) + (IF (AND (EQ (TYPEP (CADR L)) 'FIXNUM) + (EQ (TYPEP (CADDR L2)) 'FIXNUM)) + (COND ((< (CADR L) (CADDR L2)) + (RETURN (RPLACD (CDR L2) + (CONS (- (CADDR L2) (CADR L)) + (CDDDR L2))))) + ((= (CADR L) (CADDR L2)) + (RETURN (RPLACD L2 (CDDDR L2)))) + (T (RETURN (SETQ FAILED T)))) + (RETURN (SETQ FAILED T))))) + (IF FAILED (RETURN NIL)))) + +(DEFMFUN RECUR-APPLY (FUN E) + (COND ((EQ (CAAR E) 'BIGFLOAT) E) + ((SPECREPP E) (FUNCALL FUN (SPECDISREP E))) + (T (LET ((NEWARGS (MAPCAR FUN (CDR E)))) + (IF (ALIKE NEWARGS (CDR E)) + E + (SIMPLIFYA (CONS (CONS (CAAR E) (MEMQ 'ARRAY (CDAR E))) NEWARGS) + NIL)))))) + +(DEFMFUN $DEPENDS N + (IF (ODDP N) (MERROR "DEPENDS takes an even number of arguments.")) + (DO ((I 1 (+ I 2)) (L)) + ((> I N) (I-$DEPENDENCIES (NREVERSE L))) + (COND (($LISTP (ARG I)) + (DO L1 (CDR (ARG I)) (CDR L1) (NULL L1) + (SETQ L (CONS (DEPENDS1 (CAR L1) (ARG (1+ I))) L)))) + (T (SETQ L (CONS (DEPENDS1 (ARG I) (ARG (1+ I))) L)))))) + +(DEFUN DEPENDS1 (X Y) + (NONSYMCHK X '$DEPENDS) + (CONS (NCONS X) (IF ($LISTP Y) (CDR Y) (NCONS Y)))) + +(DEFMSPEC $DEPENDENCIES (FORM) (I-$DEPENDENCIES (CDR FORM))) + +(DEFMFUN I-$DEPENDENCIES (L) + (DOLIST (Z L) + (COND ((ATOM Z) (MERROR "Wrong format. Try F(X).")) + ((OR (EQ (CAAR Z) 'MQAPPLY) (MEMQ 'ARRAY (CDAR Z))) + (MERROR "Improper form for DEPENDS:~%~M" Z)) + (T (LET ((Y (MGET (CAAR Z) 'DEPENDS))) + (MPUTPROP (CAAR Z) + (SETQ Y (UNION* (REVERSE (CDR Z)) Y)) + 'DEPENDS) + (ADD2LNC (CONS (NCONS (CAAR Z)) Y) $DEPENDENCIES))))) + (CONS '(MLIST SIMP) L)) + +(DEFMSPEC $GRADEF (L) (SETQ L (CDR L)) + (LET ((Z (CAR L)) (N 0)) + (COND ((ATOM Z) + (IF (NOT (= (LENGTH L) 3)) (MERROR "Wrong arguments to GRADEF")) + (MPUTPROP Z + (CONS (CONS (CADR L) (MEVAL (CADDR L))) + (MGET Z '$ATOMGRAD)) + '$ATOMGRAD) + (I-$DEPENDENCIES (NCONS (LIST (NCONS Z) (CADR L)))) + (ADD2LNC Z $PROPS) + Z) + ((OR (MOPP1 (CAAR Z)) (MEMQ 'ARRAY (CDAR Z))) + (MERROR "Wrong arguments to GRADEF:~%~M" Z)) + ((PROG2 (SETQ N (- (LENGTH Z) (LENGTH L))) (MINUSP N)) + (WNA-ERR '$GRADEF)) + (T (DO ZL (CDR Z) (CDR ZL) (NULL ZL) + (IF (NOT (SYMBOLP (CAR ZL))) + (MERROR "Parameters to GRADEF must be names:~%~M" + (CAR ZL)))) + (SETQ L (NCONC (MAPCAR #'(LAMBDA (X) (REMSIMP (MEVAL X))) + (CDR L)) + (MAPCAR #'(LAMBDA (X) (LIST '(%DERIVATIVE) Z X 1)) + (NTHCDR (- (LENGTH Z) N) Z)))) + (PUTPROP (CAAR Z) + (SUBLIS (MAPCAR #'CONS (CDR Z) (MAPCAR #'STRIPDOLLAR (CDR Z))) + (CONS (CDR Z) L)) + 'GRAD) + (ADD2LNC (CONS (NCONS (CAAR Z)) (CDR Z)) $GRADEFS) + Z)))) + +(DEFMFUN $DIFF N (LET (DERIVLIST) (DERIV (LISTIFY N)))) + +(DEFMFUN $DEL (E) (STOTALDIFF E)) + +(DEFUN DERIV (E) + (PROG (EXP Z COUNT) + (COND ((NULL E) (WNA-ERR '$DIFF)) + ((NULL (CDR E)) (RETURN (STOTALDIFF (CAR E)))) + ((NULL (CDDR E)) (NCONC E '(1)))) + (SETQ EXP (CAR E) Z (SETQ E (APPEND E NIL))) + LOOP (IF (OR (NULL DERIVLIST) (MEMBER (CADR Z) DERIVLIST)) (GO DOIT)) + ; DERIVLIST is set by $EV + (SETQ Z (CDR Z)) + LOOP2(COND ((CDR Z) (GO LOOP)) ((NULL (CDR E)) (RETURN EXP)) (T (GO NOUN))) + DOIT (COND ((NONVARCHK (CADR Z) '$DIFF NIL T)) + ((NULL (CDDR Z)) (WNA-ERR '$DIFF)) + ((NOT (FIXP (CADDR Z))) (GO NOUN)) + ((MINUSP (SETQ COUNT (CADDR Z))) + (MERROR "Improper count to DIFF:~%~M" COUNT))) + LOOP1(COND ((ZEROP COUNT) (RPLACD Z (CDDDR Z)) (GO LOOP2)) + ((EQUAL (SETQ EXP (SDIFF EXP (CADR Z))) 0) (RETURN 0))) + (SETQ COUNT (1- COUNT)) + (GO LOOP1) + NOUN (RETURN (DIFF%DERIV (CONS EXP (CDR E)))))) + +(DEFUN CHAINRULE (E X) + (LET (W) + (COND (ISLINP (IF (AND (NOT (ATOM E)) + (EQ (CAAR E) '%DERIVATIVE) + (NOT (FREEL (CDR E) X))) + (DIFF%DERIV (LIST E X 1)) + 0)) + ((ATOMGRAD E X)) + ((NOT (SETQ W (MGET (COND ((ATOM E) E) + ((MEMQ 'ARRAY (CDAR E)) (CAAR E)) + ((ATOM (CADR E)) (CADR E)) + (T (CAAADR E))) + 'DEPENDS))) + 0) + (T (LET (DERIVFLAG) + (ADDN (MAPCAR + #'(LAMBDA (U) + (LET ((Y (SDIFF U X))) + (IF (EQUAL Y 0) + 0 + (LIST '(MTIMES) + (OR (ATOMGRAD E U) + (LIST '(%DERIVATIVE) E U 1)) + Y)))) + W) + NIL)))))) + +(DEFUN ATOMGRAD (E X) + (LET (Y) (AND (ATOM E) (SETQ Y (MGET E '$ATOMGRAD)) (ASSOLIKE X Y)))) + +(DEFUN DEPENDS (E X) + (COND ((ALIKE1 E X) T) + ((MNUMP E) NIL) + ((ATOM E) (MGET E 'DEPENDS)) + (T (OR (DEPENDS (CAAR E) X) (DEPENDSL (CDR E) X))))) + +(DEFUN DEPENDSL (L X) + (DO ((L L (CDR L))) ((NULL L) NIL) + (IF (DEPENDS (CAR L) X) (RETURN T)))) + +(DEFMFUN SDIFF (E X) ; The args to SDIFF are assumed to be simplified. + (COND ((ALIKE1 E X) 1) + ((MNUMP E) 0) + ((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) (CHAINRULE E X)) + ((EQ (CAAR E) 'MRAT) (RATDX E X)) + ((EQ (CAAR E) 'MPLUS) (ADDN (SDIFFMAP (CDR E) X) T)) + ((MBAGP E) (CONS (CAR E) (SDIFFMAP (CDR E) X))) + ((EQ (CAAR E) '%SUM) (DIFFSUM E X)) + ((NOT (DEPENDS E X)) 0) + ((EQ (CAAR E) 'MTIMES) (ADDN (SDIFFTIMES (CDR E) X) T)) + ((EQ (CAAR E) 'MEXPT) (DIFFEXPT E X)) + ((EQ (CAAR E) 'MNCTIMES) + (LET (($DOTDISTRIB T)) + (ADD2 (NCMULN (CONS (SDIFF (CADR E) X) (CDDR E)) T) + (NCMUL2 (CADR E) (SDIFF (CONS '(MNCTIMES) (CDDR E)) X))))) + ((AND $VECT_CROSS (EQ (CAAR E) '|$~|)) + (ADD2* `((|$~|) ,(CADR E) ,(SDIFF (CADDR E) X)) + `((|$~|) ,(SDIFF (CADR E) X) ,(CADDR E)))) + ((EQ (CAAR E) 'MNCEXPT) (DIFFNCEXPT E X)) + ((MEMQ (CAAR E) '(%LOG %PLOG)) + (SDIFFGRAD (COND ((AND (NOT (ATOM (CADR E))) (EQ (CAAADR E) 'MABS)) + (CONS (CAR E) (CDADR E))) + (T E)) + X)) + ((EQ (CAAR E) '%DERIVATIVE) + (COND ((OR (ATOM (CADR E)) (MEMQ 'ARRAY (CDAADR E))) (CHAINRULE E X)) + ((FREEL (CDDR E) X) (DIFF%DERIV (CONS (SDIFF (CADR E) X) (CDDR E)))) + (T (DIFF%DERIV (LIST E X 1))))) + ((MEMQ (CAAR E) '(%BINOMIAL $BETA)) + (LET ((EFACT ($MAKEFACT E))) (MUL2 (FACTOR (SDIFF EFACT X)) (DIV E EFACT)))) + ((EQ (CAAR E) '%INTEGRATE) (DIFFINT E X)) + ((EQ (CAAR E) '%LAPLACE) (DIFFLAPLACE E X)) + ((MEMQ (CAAR E) '(%REALPART %IMAGPART)) + (LIST (NCONS (CAAR E)) (SDIFF (CADR E) X))) + (T (SDIFFGRAD E X)))) + +(DEFUN SDIFFGRAD (E X) + (LET ((FUN (CAAR E)) GRAD ARGS) + (COND ((AND (EQ FUN 'MQAPPLY) (GET (CAAADR E) 'GRAD)) + (SDIFFGRAD (CONS (NCONS (CAAADR E)) (APPEND (CDADR E) (CDDR E))) + X)) + ((OR (EQ FUN 'MQAPPLY) (NULL (SETQ GRAD (GET FUN 'GRAD)))) + (IF (NOT (DEPENDS E X)) 0 (DIFF%DERIV (LIST E X 1)))) + ((NOT (= (LENGTH (CDR E)) (LENGTH (CAR GRAD)))) + (MERROR "Wrong number of arguments for ~:M" FUN)) + (T (SETQ ARGS (SDIFFMAP (CDR E) X)) + (ADDN (MAPCAR + #'MUL2 + (CDR (SUBSTITUTEL + (CDR E) (CAR GRAD) + (DO ((L1 (CDR GRAD) (CDR L1)) + (ARGS ARGS (CDR ARGS)) (L2)) + ((NULL L1) (CONS '(MLIST) (NREVERSE L2))) + (SETQ L2 (CONS (COND ((EQUAL (CAR ARGS) 0) 0) + (T (CAR L1))) + L2))))) + ARGS) + T))))) + +(DEFUN SDIFFMAP (E X) (MAPCAR #'(LAMBDA (TERM) (SDIFF TERM X)) E)) + +(DEFUN SDIFFTIMES (L X) + (PROG (TERM LEFT OUT) + LOOP (SETQ TERM (CAR L) L (CDR L)) + (SETQ OUT (CONS (MULN (CONS (SDIFF TERM X) (APPEND LEFT L)) T) OUT)) + (IF (NULL L) (RETURN OUT)) + (SETQ LEFT (CONS TERM LEFT)) + (GO LOOP))) + +(DEFUN DIFFEXPT (E X) + (IF (MNUMP (CADDR E)) + (MUL3 (CADDR E) (POWER (CADR E) (ADDK (CADDR E) -1)) (SDIFF (CADR E) X)) + (MUL2 E (ADD2 (MUL3 (POWER (CADR E) -1) (CADDR E) (SDIFF (CADR E) X)) + (MUL2 (SIMPLIFYA (LIST '(%LOG) (CADR E)) T) + (SDIFF (CADDR E) X)))))) + +(DEFUN DIFF%DERIV (E) (LET (DERIVFLAG) (SIMPLIFYA (CONS '(%DERIVATIVE) E) T))) + +(PROG1 '(GRAD properties) + (LET ((HEADER (PURCOPY '(X)))) + (MAPC #'(LAMBDA (Z) (PUTPROP (CAR Z) (CONS HEADER (CDR Z)) 'GRAD)) + ; All these GRAD templates have been simplified and then the SIMP flags + ; (which are unnecessary) have been removed to save core space. + '((%LOG ((MEXPT) X -1)) (%PLOG ((MEXPT) X -1)) + (%GAMMA ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) X) ((%GAMMA) X))) + (MFACTORIAL ((MTIMES) ((MQAPPLY) (($PSI ARRAY) 0) ((MPLUS) 1 X)) + ((MFACTORIAL) X))) + (%SIN ((%COS) X)) + (%COS ((MTIMES) -1 ((%SIN) X))) + (%TAN ((MEXPT) ((%SEC) X) 2)) + (%COT ((MTIMES) -1 ((MEXPT) ((%CSC) X) 2))) + (%SEC ((MTIMES) ((%SEC) X) ((%TAN) X))) + (%CSC ((MTIMES) -1 ((%COT) X) ((%CSC) X))) + (%ASIN ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2))) + (%ACOS ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) + ((RAT) -1 2)))) + (%ATAN ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1)) + (%ACOT ((MTIMES) -1 ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) -1))) + (%ACSC ((MTIMES) -1 ((MEXPT) X -1) + ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2)))) + (%ASEC ((MTIMES) ((MEXPT) X -1) ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2)))) + (%SINH ((%COSH) X)) + (%COSH ((%SINH) X)) + (%TANH ((MEXPT) ((%SECH) X) 2)) + (%COTH ((MTIMES) -1 ((MEXPT) ((%CSCH) X) 2))) + (%SECH ((MTIMES) -1 ((%SECH) X) ((%TANH) X))) + (%CSCH ((MTIMES) -1 ((%COTH) X) ((%CSCH) X))) + (%ASINH ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2))) + (%ACOSH ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) ((RAT) -1 2))) + (%ATANH ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) -1)) + (%ACOTH ((MTIMES) -1 ((MEXPT) ((MPLUS) -1 ((MEXPT) X 2)) -1))) + (%ASECH ((MTIMES) -1 ((MEXPT) X -1) + ((MEXPT) ((MPLUS) 1 ((MTIMES) -1 ((MEXPT) X 2))) ((RAT) -1 2)))) + (%ACSCH ((MTIMES) -1 ((MEXPT) X -1) + ((MEXPT) ((MPLUS) 1 ((MEXPT) X 2)) ((RAT) -1 2)))) + (MABS ((MTIMES) X ((MEXPT) ((MABS) X) -1))) + (%ERF ((MTIMES) 2 ((MEXPT) $%PI ((RAT) -1 2)) + ((MEXPT) $%E ((MTIMES) -1 ((MEXPT) X 2))))) +; ($LI2 ((MTIMES) -1 ((%LOG) ((MPLUS) 1 ((MTIMES) -1 X))) ((MEXPT) X -1))) + ($EI ((MTIMES) ((MEXPT) X -1) ((MEXPT) $%E X)))))) + + (DEFPROP $ATAN2 ((X Y) ((MTIMES) Y ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1)) + ((MTIMES) -1 X ((MEXPT) ((MPLUS) ((MEXPT) X 2) ((MEXPT) Y 2)) -1))) + GRAD) + + (DEFPROP $%J ((N X) ((%DERIVATIVE) ((MQAPPLY) (($%J ARRAY) N) X) N 1) + ((MPLUS) ((MQAPPLY) (($%J ARRAY) ((MPLUS) -1 N)) X) + ((MTIMES) -1 N ((MQAPPLY) (($%J ARRAY) N) X) ((MEXPT) X -1)))) + GRAD) + + (DEFPROP $LI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($LI ARRAY) N) X) N 1) + ((MTIMES) ((MQAPPLY) (($LI ARRAY) ((MPLUS) -1 N)) X) ((MEXPT) X -1))) + GRAD) + + (DEFPROP $PSI ((N X) ((%DERIVATIVE) ((MQAPPLY) (($PSI ARRAY) N) X) N 1) + ((MQAPPLY) (($PSI ARRAY) ((MPLUS) 1 N)) X)) + GRAD)) + +(DEFMFUN ATVARSCHK (ARGL) + (DO ((LARGL (LENGTH ARGL) (1- LARGL)) (LATVRS (LENGTH ATVARS)) (L)) + ((NOT (< LATVRS LARGL)) (NCONC ATVARS L)) + (SETQ L (CONS (IMPLODE (CONS '& (CONS '@ (MEXPLODEN LARGL)))) L)))) + +(DEFMFUN NOTLOREQ (X) + (OR (ATOM X) + (NOT (MEMQ (CAAR X) '(MLIST MEQUAL))) + (AND (EQ (CAAR X) 'MLIST) + (DOLIST (U (CDR X)) (IF (NOT (MEQUALP U)) (RETURN T)))))) + +(DEFMFUN SUBSTITUTEL (L1 L2 E) + (DO ((L1 L1 (CDR L1)) (L2 L2 (CDR L2))) ((NULL L1) E) + (SETQ E (SUBSTITUTE (CAR L1) (CAR L2) E)))) + +(DEFMFUN UNION* (A B) + (DO ((A A (CDR A)) (X B)) ((NULL A) X) + (IF (NOT (MEMALIKE (CAR A) B)) (SETQ X (CONS (CAR A) X))))) + +(DEFMFUN NTHELEM (N E) (CAR (NTHCDR (1- N) E))) + +(DEFMFUN DELSIMP (E) (DELQ 'SIMP (APPEND E NIL) 1)) + +(DEFMFUN REMSIMP (E) + (IF (ATOM E) E (CONS (DELSIMP (CAR E)) (MAPCAR #'REMSIMP (CDR E))))) + +(DEFMFUN $TRUNC (E) + (COND ((ATOM E) E) + ((EQ (CAAR E) 'MPLUS) (CONS (APPEND (CAR E) '(TRUNC)) (CDR E))) + ((MBAGP E) (CONS (CAR E) (MAPCAR #'$TRUNC (CDR E)))) + ((SPECREPP E) ($TRUNC (SPECDISREP E))) + (T E))) + +(DEFMSPEC $LDISPLAY (FORM) (DISP1 (CDR FORM) T T)) + +(DEFMFUN $LDISP N (DISP1 (LISTIFY N) T NIL)) + +(DEFMSPEC $DISPLAY (FORM) (DISP1 (CDR FORM) NIL T)) + +(DEFMFUN $DISP N (DISP1 (LISTIFY N) NIL NIL)) + +(DEFUN DISP1 (LL LABLIST EQNSP) + (IF LABLIST (SETQ LABLIST (NCONS '(MLIST SIMP)))) + (DO ((LL LL (CDR LL)) (L) (ANS) ($DISPFLAG T) (TIM 0)) + ((NULL LL) (OR LABLIST '$DONE)) + (SETQ L (CAR LL) ANS (IF EQNSP (MEVAL L) L)) + (IF (AND EQNSP (NOT (MEQUALP ANS))) + (SETQ ANS (LIST '(MEQUAL SIMP) (DISP2 L) ANS))) + (IF LABLIST (NCONC LABLIST (NCONS (ELABEL ANS)))) + (SETQ TIM (RUNTIME)) + (DISPLA (LIST '(MLABLE) (IF LABLIST LINELABLE) ANS)) + (MTERPRI) + (TIMEORG TIM))) + +(DEFUN DISP2 (E) + (COND ((ATOM E) E) + ((EQ (CAAR E) 'MQAPPLY) + (CONS '(MQAPPLY) (CONS (CONS (CAADR E) (MAPCAR #'MEVAL (CDADR E))) + (MAPCAR #'MEVAL (CDDR E))))) + ((EQ (CAAR E) 'MSETQ) (DISP2 (CADR E))) + ((EQ (CAAR E) 'MSET) (DISP2 (MEVAL (CADR E)))) + ((EQ (CAAR E) 'MLIST) (CONS (CAR E) (MAPCAR #'DISP2 (CDR E)))) + ((MSPECFUNP (CAAR E)) E) + (T (CONS (CAR E) (MAPCAR #'MEVAL (CDR E)))))) + +(DEFMFUN ELABEL (E) + (IF (NOT (CHECKLABEL $LINECHAR)) (SETQ $LINENUM (1+ $LINENUM))) + (MAKELABEL $LINECHAR) + (IF (NOT $NOLABELS) (SET LINELABLE E)) + LINELABLE) + +(DEFMFUN $DISPTERMS (E) + (COND ((OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT)) (DISPLA E)) + ((SPECREPP E) ($DISPTERMS (SPECDISREP E))) + (T (LET (($DISPFLAG T)) + (MTERPRI) + (DISPLA (GETOP (MOP E))) + (DO E (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP)) + (REVERSE (CDR E)) + (MARGS E)) + (CDR E) (NULL E) (MTERPRI) (DISPLA (CAR E)) (MTERPRI))) + (MTERPRI))) + '$DONE) + +(DEFMFUN $DISPFORM N + (IF (NOT (OR (= N 1) (AND (= N 2) (EQ (ARG 2) '$ALL)))) + (MERROR "Incorrect arguments to DISPFORM")) + (LET ((E (ARG 1))) + (IF (OR (ATOM E) + (ATOM (SETQ E (IF (= N 1) (NFORMAT E) (NFORMAT-ALL E)))) + (MEMQ 'SIMP (CDAR E))) + E + (CONS (CONS (CAAR E) (CONS 'SIMP (CDAR E))) + (IF (AND (EQ (CAAR E) 'MPLUS) (NOT $POWERDISP)) + (REVERSE (CDR E)) + (CDR E)))))) + +(DEFMFUN $PART N (MPART (LISTIFY N) NIL NIL $INFLAG '$PART)) + +(DEFMFUN $INPART N (MPART (LISTIFY N) NIL NIL T '$INPART)) + +(DEFMSPEC $SUBSTPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL $INFLAG '$SUBSTPART))) + +(DEFMSPEC $SUBSTINPART (L) (LET ((SUBSTP T)) (MPART (CDR L) T NIL T '$SUBSTINPART))) + +(DEFMFUN PART1 (ARGLIST SUBSTFLAG DISPFLAG INFLAG) ; called only by TRANSLATE + (LET ((SUBSTP T)) (MPART ARGLIST SUBSTFLAG DISPFLAG INFLAG '$SUBSTPART))) + +(DEFMFUN MPART (ARGLIST SUBSTFLAG DISPFLAG INFLAG FN) + (PROG (SUBSTITEM ARG ARG1 EXP EXP1 EXP* SEVLIST COUNT PREVCOUNT N SPECP + LASTELEM LASTCOUNT) + (DECLARE (FIXNUM PREVCOUNT LASTELEM LASTCOUNT)) + (SETQ SPECP (OR SUBSTFLAG DISPFLAG)) + (IF SUBSTFLAG (SETQ SUBSTITEM (CAR ARGLIST) ARGLIST (CDR ARGLIST))) + (IF (NULL ARGLIST) (WNA-ERR '$PART)) + (SETQ EXP (IF SUBSTFLAG (MEVAL (CAR ARGLIST)) (CAR ARGLIST))) + (WHEN (NULL (SETQ ARGLIST (CDR ARGLIST))) + (SETQ $PIECE EXP) + (RETURN (COND (SUBSTFLAG (MEVAL SUBSTITEM)) + (DISPFLAG (BOX EXP DISPFLAG)) + (T EXP)))) + (COND ((NOT INFLAG) + (COND ((OR (AND ($LISTP EXP) (NULL (CDR ARGLIST))) + (AND ($MATRIXP EXP) + (OR (NULL (CDR ARGLIST)) (NULL (CDDR ARGLIST))))) + (SETQ INFLAG T)) + ((NOT SPECP) (SETQ EXP (NFORMAT EXP))) + (T (SETQ EXP (NFORMAT-ALL EXP))))) + ((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP)))) + (IF (AND (ATOM EXP) (NULL $PARTSWITCH)) + (MERROR "~:M called on atom: ~:M" FN EXP)) + (IF (AND INFLAG SPECP) (SETQ EXP (SUBST NIL NIL EXP))) + (SETQ EXP* EXP) + START(COND ((OR (ATOM EXP) (EQ (CAAR EXP) 'BIGFLOAT)) (GO ERR)) + ((EQUAL (SETQ ARG (COND (SUBSTFLAG (MEVAL (CAR ARGLIST))) + (T (CAR ARGLIST)))) + 0) + (SETQ ARGLIST (CDR ARGLIST)) + (COND ((MNUMP SUBSTITEM) + (MERROR "~M is an invalid operator in ~:M" + SUBSTITEM FN)) + ((AND SPECP ARGLIST) + (IF (EQ (CAAR EXP) 'MQAPPLY) + (PROG2 (SETQ EXP (CADR EXP)) (GO START)) + (MERROR "Invalid operator in ~:M" FN))) + (T (SETQ $PIECE (GETOP (MOP EXP))) + (RETURN + (COND (SUBSTFLAG + (SETQ SUBSTITEM (GETOPR (MEVAL SUBSTITEM))) + (COND ((MNUMP SUBSTITEM) + (MERROR "Invalid operator in ~:M:~%~M" + FN SUBSTITEM)) + ((NOT (ATOM SUBSTITEM)) + (IF (NOT (EQ (CAAR EXP) 'MQAPPLY)) + (RPLACA (RPLACD EXP (CONS (CAR EXP) + (CDR EXP))) + '(MQAPPLY))) + (RPLACA (CDR EXP) SUBSTITEM) + (RETURN (RESIMPLIFY EXP*))) + ((EQ (CAAR EXP) 'MQAPPLY) + (RPLACD EXP (CDDR EXP)))) + (RPLACA EXP (CONS SUBSTITEM + (IF (AND (MEMQ 'ARRAY (CDAR EXP)) + (NOT (MOPP SUBSTITEM))) + '(ARRAY)))) + (RESIMPLIFY EXP*)) + (DISPFLAG + (RPLACD EXP (CDR (BOX (SUBST NIL NIL EXP) DISPFLAG))) + (RPLACA EXP (IF (EQ DISPFLAG T) + '(MBOX) + '(MLABOX))) + (RESIMPLIFY EXP*)) + (T (WHEN ARGLIST (SETQ EXP $PIECE) (GO A)) + $PIECE)))))) + ((NOT (ATOM ARG)) (GO SEVERAL)) + ((NOT (EQ (TYPEP ARG) 'FIXNUM)) + (MERROR "Non-integer argument to ~:M:~%~M" FN ARG)) + ((< ARG 0) (GO BAD))) + (IF (EQ (CAAR EXP) 'MQAPPLY) (SETQ EXP (CDR EXP))) + LOOP (COND ((NOT (ZEROP ARG)) (SETQ ARG (1- ARG) EXP (CDR EXP)) + (IF (NULL EXP) (GO ERR)) (GO LOOP)) + ((NULL (SETQ ARGLIST (CDR ARGLIST))) + (RETURN (COND (SUBSTFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP))) + (RPLACA EXP (MEVAL SUBSTITEM)) + (RESIMPLIFY EXP*)) + (DISPFLAG (SETQ $PIECE (RESIMPLIFY (CAR EXP))) + (RPLACA EXP (BOX (CAR EXP) DISPFLAG)) + (RESIMPLIFY EXP*)) + (INFLAG (SETQ $PIECE (CAR EXP))) + (T (SETQ $PIECE (SIMPLIFY (CAR EXP)))))))) + (SETQ EXP (CAR EXP)) + A (COND ((AND (NOT INFLAG) (NOT SPECP)) (SETQ EXP (NFORMAT EXP))) + ((SPECREPP EXP) (SETQ EXP (SPECDISREP EXP)))) + (GO START) + ERR (COND ((EQ $PARTSWITCH 'MAPPLY) + (MERROR "Improper index to list or matrix")) + ($PARTSWITCH (RETURN (SETQ $PIECE '$END))) + (T (MERROR "~:M fell off end." FN))) + BAD (IMPROPER-ARG-ERR ARG FN) + SEVERAL + (IF (OR (NOT (MEMQ (CAAR ARG) '(MLIST $ALLBUT))) (CDR ARGLIST)) + (GO BAD)) + (SETQ EXP1 (CONS (CAAR EXP) (IF (MEMQ 'ARRAY (CDAR EXP)) '(ARRAY)))) + (IF (EQ (CAAR EXP) 'MQAPPLY) + (SETQ SEVLIST (LIST (CADR EXP) EXP1) EXP (CDDR EXP)) + (SETQ SEVLIST (NCONS EXP1) EXP (CDR EXP))) + (SETQ ARG1 (CDR ARG) PREVCOUNT 0 EXP1 EXP) + (DOLIST (ARG* ARG1) + (IF (NOT (EQ (TYPEP ARG*) 'FIXNUM)) + (MERROR "Non-integer argument to ~:M:~%~M" FN ARG*))) + (WHEN (AND SPECP (EQ (CAAR ARG) 'MLIST)) + (IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1)))) + (SETQ ARG1 (SORT (APPEND ARG1 NIL) #'<))) + (WHEN (EQ (CAAR ARG) '$ALLBUT) + (SETQ N (LENGTH EXP)) + (DOLIST (I ARG1) + (IF (OR (< I 1) (> I N)) + (MERROR "Invalid argument to ~:M:~%~M" FN I))) + (DO ((I N (1- I)) (ARG2)) + ((= I 0) (SETQ ARG1 ARG2)) + (IF (NOT (MEMBER I ARG1)) (SETQ ARG2 (CONS I ARG2)))) + (IF SUBSTFLAG (SETQ LASTELEM (CAR (LAST ARG1))))) + (IF (NULL ARG1) (IF SPECP (GO BAD) (GO END))) + (IF SUBSTFLAG (SETQ LASTCOUNT LASTELEM)) + SEVLOOP + (IF SPECP + (SETQ COUNT (- (CAR ARG1) PREVCOUNT) PREVCOUNT (CAR ARG1)) + (SETQ COUNT (CAR ARG1))) + (IF (< COUNT 1) (GO BAD)) + (IF (AND SUBSTFLAG (< (CAR ARG1) LASTELEM)) + (SETQ LASTCOUNT (1- LASTCOUNT))) + COUNT(COND ((NULL EXP) (GO ERR)) + ((NOT (= COUNT 1)) (SETQ COUNT (1- COUNT) EXP (CDR EXP)) (GO COUNT))) + (SETQ SEVLIST (CONS (CAR EXP) SEVLIST)) + (SETQ ARG1 (CDR ARG1)) + END (COND ((NULL ARG1) + (SETQ SEVLIST (NREVERSE SEVLIST)) + (SETQ $PIECE (IF (OR INFLAG (NOT SPECP)) + (SIMPLIFY SEVLIST) + (RESIMPLIFY SEVLIST))) + (RETURN (COND (SUBSTFLAG (RPLACA (NTHCDR (1- LASTCOUNT) EXP1) + (MEVAL SUBSTITEM)) + (RESIMPLIFY EXP*)) + (DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG)) + (RESIMPLIFY EXP*)) + (T $PIECE)))) + (SUBSTFLAG (IF (NULL (CDR EXP)) (GO ERR)) + (RPLACA EXP (CADR EXP)) (RPLACD EXP (CDDR EXP))) + (DISPFLAG (RPLACA EXP (BOX (CAR EXP) DISPFLAG)) + (SETQ EXP (CDR EXP))) + (T (SETQ EXP EXP1))) + (GO SEVLOOP))) + +(DEFMFUN GETOP (X) (OR (AND (SYMBOLP X) (GET X 'OP)) X)) + +(DEFMFUN GETOPR (X) (OR (AND (SYMBOLP X) (GET X 'OPR)) X)) + +; List manipulation commands + +(DEFMFUN LISTERCHK (L FUN 2NDP) + (WHEN (NOT ($LISTP L)) + (MERROR "~Margument to ~:M not a list: ~M" + (IF 2NDP '|2nd | '||) + FUN + L))) + +(DEFMFUN $LISTP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MLIST))) + +(DEFMFUN $CONS (X L) (LISTERCHK L '$CONS T) (CONS (CAR L) (CONS X (CDR L)))) + +(DEFMFUN $APPEND N + `((MLIST SIMP) + ,@(APPLY #'APPEND + (MAPCAR #'(LAMBDA (X) + (LISTERCHK X '$APPEND NIL) + (CDR X)) + (LISTIFY N))))) + +(DEFMFUN $ENDCONS (X L) (LISTERCHK L '$ENDCONS T) (APPEND L (NCONS X))) + +(DEFMFUN $MEMBER (X L) + (LISTERCHK (SETQ L ($TOTALDISREP L)) '$MEMBER T) + (IF (MEMALIKE ($TOTALDISREP X) (CDR L)) T)) + +; General manipulation commands + +(DEFMFUN ATOMCHK (E FUN 2NDP) + (WHEN (OR (ATOM E) (EQ (CAAR E) 'BIGFLOAT)) + (MERROR "~Margument to ~:M was atomic: ~M" + (IF 2NDP '|2nd | '||) FUN E))) + +(DEFMFUN FORMAT1 (E) + (COND (($LISTP E) E) ($INFLAG (SPECREPCHECK E)) (T (NFORMAT E)))) + +(DEFMFUN $FIRST (E) + (ATOMCHK (SETQ E (FORMAT1 E)) '$FIRST NIL) + (IF (NULL (CDR E)) (MERROR "Argument to FIRST is empty.")) + (CAR (MARGS E))) + +(DEFMFUN $REST N + (PROG (M FUN FUN1 REVP) + (IF (AND (= N 2) (EQUAL (ARG 2) 0)) (RETURN (ARG 1))) + (ATOMCHK (SETQ M (FORMAT1 (ARG 1))) '$REST NIL) + (COND ((= N 1)) + ((NOT (= N 2)) (WNA-ERR '$REST)) + ((NOT (EQ (TYPEP (ARG 2)) 'FIXNUM)) + (MERROR "2nd argument to REST must be an integer:~%~M" + (ARG 2))) + ((MINUSP (SETQ N (ARG 2))) (SETQ N (- N) REVP T))) + (IF (< (LENGTH (MARGS M)) N) + (IF $PARTSWITCH (RETURN '$END) (MERROR "REST fell off end."))) + (SETQ FUN (CAR M)) + (IF (EQ (CAR FUN) 'MQAPPLY) (SETQ FUN1 (CADR M) M (CDR M))) + (SETQ M (CDR M)) + (IF REVP (SETQ M (REVERSE M))) + (DO N N (1- N) (ZEROP N) (SETQ M (CDR M))) + (SETQ M (CONS (IF (EQ (CAR FUN) 'MLIST) FUN (DELSIMP FUN)) + (IF REVP (NREVERSE M) M))) + (IF (EQ (CAR FUN) 'MQAPPLY) + (RETURN (CONS (CAR M) (CONS FUN1 (CDR M))))) + (RETURN M))) + +(DEFMFUN $LAST (E) (ATOMCHK (SETQ E (FORMAT1 E)) '$LAST NIL) + (IF (NULL (CDR E)) E (CAR (LAST E)))) + +(DEFMFUN $ARGS (E) (ATOMCHK (SETQ E (FORMAT1 E)) '$ARGS NIL) + (CONS '(MLIST) (MARGS E))) + +(DEFMFUN $REVERSE (E) + (ATOMCHK (SETQ E (FORMAT1 E)) '$REVERSE NIL) + (IF (EQ (CAAR E) 'MQAPPLY) + (LIST* (DELSIMP (CAR E)) (CADR E) (REVERSE (CDDR E))) + (CONS (IF (EQ (CAAR E) 'MLIST) (CAR E) (DELSIMP (CAR E))) + (REVERSE (CDR E))))) + +(DEFMFUN $DELETE N + (COND ((= N 2) (SETQ N -1)) + ((NOT (= N 3)) (WNA-ERR '$DELETE)) + ((OR (NOT (EQ (TYPEP (ARG 3)) 'FIXNUM)) (MINUSP (SETQ N (ARG 3)))) + (MERROR "Improper 3rd argument to DELETE:~%~M" (ARG 3)))) + (LET ((X (ARG 1)) (L (ARG 2))) + (ATOMCHK (SETQ L (SPECREPCHECK L)) '$DELETE T) + (SETQ X (SPECREPCHECK X) L (CONS (DELSIMP (CAR L)) (APPEND (CDR L) NIL))) + (PROG (L1) + (SETQ L1 (IF (EQ (CAAR L) 'MQAPPLY) (CDR L) L)) + LOOP (COND ((OR (NULL (CDR L1)) (ZEROP N)) (RETURN L)) + ((ALIKE1 X (SPECREPCHECK (CADR L1))) + (SETQ N (1- N)) (RPLACD L1 (CDDR L1))) + (T (SETQ L1 (CDR L1)))) + (GO LOOP)))) + +(DEFMFUN $LENGTH (E) + (SETQ E (COND (($LISTP E) E) + ((OR $INFLAG (NOT ($RATP E))) (SPECREPCHECK E)) + (T ($RATDISREP E)))) + (COND ((SYMBOLP E) (MERROR "LENGTH called on atomic symbol ~:M" E)) + ((OR (NUMBERP E) (EQ (CAAR E) 'BIGFLOAT)) + (IF (AND (NOT $INFLAG) (MNEGP E)) + 1 + (MERROR "LENGTH called on number ~:M" E))) + ((OR $INFLAG (NOT (MEMQ (CAAR E) '(MTIMES MEXPT)))) (LENGTH (MARGS E))) + ((EQ (CAAR E) 'MEXPT) + (IF (AND (ALIKE1 (CADDR E) '((RAT SIMP) 1 2)) $SQRTDISPFLAG) 1 2)) + (T (LENGTH (CDR (NFORMAT E)))))) + +(DEFMFUN $ATOM (X) + (SETQ X (SPECREPCHECK X)) (OR (ATOM X) (EQ (CAAR X) 'BIGFLOAT))) + +(DEFMFUN $SYMBOLP (X) (SETQ X (SPECREPCHECK X)) (SYMBOLP X)) + +(DEFMFUN $NUM (E) + (LET (X) + (COND ((ATOM E) E) + ((EQ (CAAR E) 'MRAT) ($RATNUMER E)) + ((EQ (CAAR E) 'RAT) (CADR E)) + ((EQ (CAAR (SETQ X (NFORMAT E))) 'MQUOTIENT) (SIMPLIFY (CADR X))) + ((AND (EQ (CAAR X) 'MMINUS) (NOT (ATOM (SETQ X (CADR X)))) + (EQ (CAAR X) 'MQUOTIENT)) + (SIMPLIFY (LIST '(MTIMES) -1 (CADR X)))) + (T E)))) + +(DEFMFUN $DENOM (E) + (COND ((ATOM E) 1) + ((EQ (CAAR E) 'MRAT) ($RATDENOM E)) + ((EQ (CAAR E) 'RAT) (CADDR E)) + ((OR (EQ (CAAR (SETQ E (NFORMAT E))) 'MQUOTIENT) + (AND (EQ (CAAR E) 'MMINUS) (NOT (ATOM (SETQ E (CADR E)))) + (EQ (CAAR E) 'MQUOTIENT))) + (SIMPLIFY (CADDR E))) + (T 1))) + + +(DEFMFUN $FIX (E) ($ENTIER E)) + +(DEFMFUN $ENTIER (E) + (LET ((E1 (SPECREPCHECK E))) + (COND ((NUMBERP E1) (FIX E1)) + ((RATNUMP E1) (SETQ E (QUOTIENT (CADR E1) (CADDR E1))) + (IF (MINUSP (CADR E1)) (SUB1 E) E)) + (($BFLOATP E1) + (SETQ E (FPENTIER E1)) + (IF (AND (MINUSP (CADR E1)) (NOT (ZEROP1 (SUB E E1)))) + (SUB1 E) + E)) + (T (LIST '($ENTIER) E))))) + +(DEFMFUN $FLOAT (E) + (COND ((NUMBERP E) (FLOAT E)) + ((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) E) + ((EQ (CAAR E) 'RAT) (FPCOFRAT E)) + ((EQ (CAAR E) 'BIGFLOAT) (FP2FLO E)) + ((MEMQ (CAAR E) '(MEXPT MNCEXPT)) + (LIST (NCONS (CAAR E)) ($FLOAT (CADR E)) (CADDR E))) + (T (RECUR-APPLY #'$FLOAT E)))) + +(DEFMFUN $COEFF N + (COND ((= N 3) (IF (EQUAL (ARG 3) 0) + (COEFF (ARG 1) (ARG 2) (ARG 3)) + (COEFF (ARG 1) (POWER (ARG 2) (ARG 3)) 1))) + ((= N 2) (COEFF (ARG 1) (ARG 2) 1)) + (T (WNA-ERR '$COEFF)))) + +(DEFMFUN COEFF (E VAR POW) + (SIMPLIFY + (COND ((ALIKE1 E VAR) (IF (EQUAL POW 1) 1 0)) + ((ATOM E) (IF (EQUAL POW 0) E 0)) + ((EQ (CAAR E) 'MEXPT) + (COND ((ALIKE1 (CADR E) VAR) + (IF (OR (EQUAL POW 0) (NOT (ALIKE1 (CADDR E) POW))) 0 1)) + ((EQUAL POW 0) E) + (T 0))) + ((OR (EQ (CAAR E) 'MPLUS) (MBAGP E)) + (CONS (IF (EQ (CAAR E) 'MPLUS) '(MPLUS) (CAR E)) + (MAPCAR #'(LAMBDA (E) (COEFF E VAR POW)) (CDR E)))) + ((EQ (CAAR E) 'MRAT) (RATCOEFF E VAR POW)) + ((EQUAL POW 0) (IF (FREE E VAR) E 0)) + ((EQ (CAAR E) 'MTIMES) + (LET ((TERM (IF (EQUAL POW 1) VAR (POWER VAR POW)))) + (IF (MEMALIKE TERM (CDR E)) ($DELETE TERM E 1) 0))) + (T 0)))) + +(DECLARE (SPECIAL POWERS VAR HIFLG NUM FLAG)) + +(DEFMFUN $HIPOW (E VAR) (FINDPOWERS E T)) + ; These work best on expanded "simple" expressions. + +(DEFMFUN $LOPOW (E VAR) (FINDPOWERS E NIL)) + +(DEFUN FINDPOWERS (E HIFLG) + (LET (POWERS NUM FLAG) + (FINDPOWERS1 E) + (COND ((NULL POWERS) (IF (NULL NUM) 0 NUM)) + (T (IF NUM (SETQ POWERS (CONS NUM POWERS))) + (MAXIMIN POWERS (IF HIFLG '$MAX '$MIN)))))) + +(DEFUN FINDPOWERS1 (E) + (COND ((ALIKE1 E VAR) (CHECKPOW 1)) + ((ATOM E)) + ((EQ (CAAR E) 'MPLUS) + (COND ((NOT (FREEL (CDR E) VAR)) + (DO E (CDR E) (CDR E) (NULL E) + (SETQ FLAG NIL) (FINDPOWERS1 (CAR E)) + (IF (NULL FLAG) (CHECKPOW 0)))))) + ((AND (EQ (CAAR E) 'MEXPT) (ALIKE1 (CADR E) VAR)) (CHECKPOW (CADDR E))) + ((SPECREPP E) (FINDPOWERS1 (SPECDISREP E))) + (T (MAPC #'FINDPOWERS1 (CDR E))))) + +(DEFUN CHECKPOW (POW) + (SETQ FLAG T) + (COND ((NOT (NUMBERP POW)) (SETQ POWERS (CONS POW POWERS))) + ((NULL NUM) (SETQ NUM POW)) + (HIFLG (IF (GREATERP POW NUM) (SETQ NUM POW))) + ((LESSP POW NUM) (SETQ NUM POW)))) + +(DECLARE (UNSPECIAL POWERS VAR HIFLG NUM FLAG)) + + +; Undeclarations for the file: +(DECLARE (NOTYPE I N LARGL LVRS COUNT TIM)) diff --git a/src/jpg/comm2.56 b/src/jpg/comm2.56 new file mode 100644 index 00000000..df218209 --- /dev/null +++ b/src/jpg/comm2.56 @@ -0,0 +1,771 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1982 Massachusetts Institute of Technology ** + +(macsyma-module comm2) + +(DECLARE (GENPREFIX CC) (SPECIAL $PROPS) (FIXNUM N I J)) + +(DECLARE (SPLITFILE DIFF2) (SPECIAL $DOTDISTRIB)) + +(DEFMFUN DIFFINT (E X) + ((LAMBDA (A) + (COND ((NULL (CDDDR E)) + (COND ((ALIKE1 X (CADDR E)) (CADR E)) + ((AND (NOT (ATOM (CADDR E))) (ATOM X) (NOT (FREE (CADDR E) X))) + (MUL2 (CADR E) (SDIFF (CADDR E) X))) + ((OR ($CONSTANTP (SETQ A (SDIFF (CADR E) X))) + (AND (ATOM (CADDR E)) (FREE A (CADDR E)))) + (MUL2 A (CADDR E))) + (T (SIMPLIFYA (LIST '(%INTEGRATE) A (CADDR E)) T)))) + ((ALIKE1 X (CADDR E)) (ADDN (DIFFINT1 (CDR E) X X) T)) + (T (ADDN (CONS (COND ((EQUAL (SETQ A (SDIFF (CADR E) X)) 0) 0) + (T (SIMPLIFYA (LIST '(%INTEGRATE) A (CADDR E) + (CADDDR E) (CAR (CDDDDR E))) T))) + (DIFFINT1 (CDR E) X (CADDR E))) T)))) + NIL)) + +(DEFUN DIFFINT1 (E X Y) + (LET ((U (SDIFF (CADDDR E) X)) (V (SDIFF (CADDR E) X))) + (LIST (IF (ZEROP U) 0 (MUL2 U (SUBSTITUTE (CADDDR E) Y (CAR E)))) + (IF (ZEROP V) 0 (MUL3 V (SUBSTITUTE (CADDR E) Y (CAR E)) -1))))) + +(DEFMFUN DIFFSUM (E X) + (COND ((OR (NOT (ATOM X)) (NOT (FREE (CADDDR E) X)) (NOT (FREE (CAR (CDDDDR E)) X))) + (DIFF%DERIV (LIST E X 1))) + ((EQ (CADDR E) X) 0) + (T (SIMPLIFYA (LIST '(%SUM) (SDIFF (CADR E) X) (CADDR E) (CADDDR E) (CAR (CDDDDR E))) + T)))) + +(DEFMFUN DIFFLAPLACE (E X) + (COND ((OR (NOT (ATOM X)) (EQ (CADDDR E) X)) (DIFF%DERIV (LIST E X 1))) + ((EQ (CADDR E) X) 0) + (T ($LAPLACE (SDIFF (CADR E) X) (CADDR E) (CADDDR E))))) + +(DEFMFUN DIFFNCEXPT (E X) + ((LAMBDA (BASE* POW) + (COND ((AND (MNUMP POW) (OR (NOT (EQ (TYPEP POW) 'FIXNUM)) (< POW 0))) ; POW cannot be 0 + (DIFF%DERIV (LIST E X 1))) + ((AND (ATOM BASE*) (EQ BASE* X) (FREE POW BASE*)) + (MUL2* POW (LIST '(MNCEXPT) BASE* (ADD2 POW -1)))) + ((EQ (TYPEP POW) 'FIXNUM) + ((LAMBDA (DERIV ANS) + (DO I 0 (1+ I) (= I POW) + (SETQ ANS (CONS (LIST '(MNCTIMES) (LIST '(MNCEXPT) BASE* I) + (LIST '(MNCTIMES) DERIV + (LIST '(MNCEXPT) BASE* (- POW 1 I)))) + ANS))) + (ADDN ANS NIL)) + (SDIFF BASE* X) NIL)) + ((AND (NOT (DEPENDS POW X)) (OR (ATOM POW) (AND (ATOM BASE*) (FREE POW BASE*)))) + ((LAMBDA (DERIV INDEX) + (SIMPLIFYA + (LIST '(%SUM) + (LIST '(MNCTIMES) (LIST '(MNCEXPT) BASE* INDEX) + (LIST '(MNCTIMES) DERIV + (LIST '(MNCEXPT) BASE* + (LIST '(MPLUS) POW -1 (LIST '(MTIMES) -1 INDEX))))) + INDEX 0 (LIST '(MPLUS) POW -1)) NIL)) + (SDIFF BASE* X) (GENSUMINDEX))) + (T (DIFF%DERIV (LIST E X 1))))) + (CADR E) (CADDR E))) + +(DEFMFUN STOTALDIFF (E) + (COND ((OR (MNUMP E) (CONSTANT E)) 0) + ((OR (ATOM E) (MEMQ 'ARRAY (CDAR E))) + (LET ((W (MGET (IF (ATOM E) E (CAAR E)) 'DEPENDS))) + (IF W (CONS '(MPLUS) + (MAPCAR #'(LAMBDA (X) + (LIST '(MTIMES) (CHAINRULE E X) (LIST '(%DEL) X))) + W)) + (LIST '(%DEL) E)))) + ((SPECREPP E) (STOTALDIFF (SPECDISREP E))) + ((EQ (CAAR E) 'MNCTIMES) + (LET (($DOTDISTRIB T)) + (ADD2 (NCMULN (CONS (STOTALDIFF (CADR E)) (CDDR E)) T) + (NCMUL2 (CADR E) (STOTALDIFF (NCMULN (CDDR E) T)))))) + ((EQ (CAAR E) 'MNCEXPT) + (IF (AND (EQ (TYPEP (CADDR E)) 'FIXNUM) (> (CADDR E) 0)) + (STOTALDIFF (LIST '(MNCTIMES) (CADR E) + (NCPOWER (CADR E) (1- (CADDR E))))) + (LIST '(%DERIVATIVE) E))) + (T (ADDN (CONS 0 (MAPCAR #'(LAMBDA (X) + (MUL2 (SDIFF E X) (LIST '(%DEL SIMP) X))) + (EXTRACTVARS (MARGS E)))) + T)))) + +(DEFUN EXTRACTVARS (E) + (COND ((NULL E) NIL) + ((ATOM (CAR E)) + (IF (NOT (CONSTANTP (CAR E))) + (UNION* (NCONS (CAR E)) (EXTRACTVARS (CDR E))) + (EXTRACTVARS (CDR E)))) + ((MEMQ 'ARRAY (CDAAR E)) (UNION* (NCONS (CAR E)) (EXTRACTVARS (CDR E)))) + (T (UNION* (EXTRACTVARS (CDAR E)) (EXTRACTVARS (CDR E)))))) + +(DECLARE (SPLITFILE AT) + (SPECIAL ATVARS ATEQS ATP MUNBOUND) (*LEXPR $SUBSTITUTE)) + +(DEFMFUN $ATVALUE (EXP EQS VAL) + (LET (DL VL FUN) + (COND ((NOTLOREQ EQS) (IMPROPER-ARG-ERR EQS '$ATVALUE)) + ((OR (ATOM EXP) (AND (EQ (CAAR EXP) '%DERIVATIVE) (ATOM (CADR EXP)))) + (IMPROPER-ARG-ERR EXP '$ATVALUE))) + (COND ((NOT (EQ (CAAR EXP) '%DERIVATIVE)) + (SETQ FUN (CAAR EXP) VL (CDR EXP) DL (LISTOF0S VL))) + (T (SETQ FUN (CAAADR EXP) VL (CDADR EXP)) + (DOLIST (V VL) + (SETQ DL (NCONC DL (NCONS (OR (GET (CDR EXP) V) 0))))))) + (IF (OR (MOPP FUN) (EQ FUN 'MQAPPLY)) (IMPROPER-ARG-ERR EXP '$ATVALUE)) + (ATVARSCHK VL) + (DO ((VL1 VL (CDR VL1)) (L ATVARS (CDR L))) ((NULL VL1)) + (IF (AND (SYMBOLP (CAR VL1)) (NOT (MGET (CAR VL1) '$CONSTANT))) + (SETQ VAL (SUBSTITUTE (CAR L) (CAR VL1) VAL)) + (IMPROPER-ARG-ERR (CONS '(MLIST) VL) '$ATVALUE))) + (SETQ EQS (IF (EQ (CAAR EQS) 'MEQUAL) (LIST EQS) (CDR EQS))) + (SETQ EQS (DO ((EQS EQS (CDR EQS)) (L)) ((NULL EQS) L) + (IF (NOT (MEMQ (CADAR EQS) VL)) + (IMPROPER-ARG-ERR (CAR EQS) '$ATVALUE)) + (SETQ L (NCONC L (NCONS (CONS (CADAR EQS) (CADDAR EQS))))))) + (SETQ VL (DO ((VL VL (CDR VL)) (L)) ((NULL VL) L) + (SETQ L (NCONC L (NCONS (CDR (OR (ASSQ (CAR VL) EQS) + (CONS NIL MUNBOUND)))))))) + (DO ((ATVALUES (MGET FUN 'ATVALUES) (CDR ATVALUES))) + ((NULL ATVALUES) + (MPUTPROP FUN (CONS (LIST DL VL VAL) (MGET FUN 'ATVALUES)) 'ATVALUES)) + (WHEN (AND (EQUAL (CAAR ATVALUES) DL) (EQUAL (CADAR ATVALUES) VL)) + (RPLACA (CDDAR ATVALUES) VAL) (RETURN NIL))) + (ADD2LNC FUN $PROPS) + VAL)) + +(DEFMFUN $AT (EXP ATEQS) + (IF (NOTLOREQ ATEQS) (IMPROPER-ARG-ERR ATEQS '$AT)) + (ATSCAN (LET ((ATP T)) ($SUBSTITUTE ATEQS EXP)))) + +(DEFUN ATSCAN (EXP) + (COND ((OR (ATOM EXP) (MEMQ (CAAR EXP) '(%AT MRAT))) EXP) + ((EQ (CAAR EXP) '%DERIVATIVE) + (OR (AND (NOT (ATOM (CADR EXP))) + (LET ((VL (CDADR EXP)) DL) + (DOLIST (V VL) + (SETQ DL (NCONC DL (NCONS (OR (GET (CDR EXP) V) + 0))))) + (ATFIND (CAAADR EXP) + (CDR ($SUBSTITUTE ATEQS (CONS '(MLIST) VL))) + DL))) + (LIST '(%AT) EXP ATEQS))) + ((EQ (CAAR EXP) '%LAPLACE) (LIST '(%AT) EXP ATEQS)) + ((AT1 EXP)) + (T (RECUR-APPLY #'ATSCAN EXP)))) + +(DEFUN AT1 (EXP) (ATFIND (CAAR EXP) (CDR EXP) (LISTOF0S (CDR EXP)))) + +(DEFUN ATFIND (FUN VL DL) + (DO ATVALUES (MGET FUN 'ATVALUES) (CDR ATVALUES) (NULL ATVALUES) + (AND (EQUAL (CAAR ATVALUES) DL) + (DO ((L (CADAR ATVALUES) (CDR L)) (VL VL (CDR VL))) + ((NULL L) T) + (IF (AND (NOT (EQUAL (CAR L) (CAR VL))) + (NOT (EQ (CAR L) MUNBOUND))) + (RETURN NIL))) + (RETURN (PROG2 (ATVARSCHK VL) + (SUBSTITUTEL VL ATVARS (CADDAR ATVALUES))))))) + +(DEFUN LISTOF0S (LIST) + (DO ((LIST LIST (CDR LIST)) (L NIL (CONS 0 L))) ((NULL LIST) L))) + +(DECLARE (SPLITFILE LOGCON) (SPECIAL $RATFAC GENVAR VARLIST $KEEPFLOAT *E*)) + +(DEFMVAR $LOGCONCOEFFP NIL) +(DEFMVAR $SUPERLOGCON T) + +(DEFMFUN $LOGCONTRACT (E) (LGCCHECK (LOGCON E))) ; E is assumed to be simplified. + +(DEFUN LOGCON (E) + (COND ((ATOM E) E) + ((MEMQ (CAAR E) '(MPLUS MTIMES)) + (IF (AND $SUPERLOGCON (NOT (LGCSIMPLEP E))) (SETQ E (LGCSORT E))) + (COND ((MPLUSP E) (LGCPLUS E)) ((MTIMESP E) (LGCTIMES E)) (T (LOGCON E)))) + (T (RECUR-APPLY #'LOGCON E)))) + +(DEFUN LGCPLUS (E) + (DO ((X (CDR E) (CDR X)) (LOG) (NOTLOGS) (Y)) + ((NULL X) + (COND ((NULL LOG) (SUBST0 (CONS '(MPLUS) (NREVERSE NOTLOGS)) E)) + (T (SETQ LOG (SRATSIMP (MULN LOG T))) + (ADDN (CONS (LGCSIMP LOG) NOTLOGS) T)))) + (COND ((ATOM (CAR X)) (SETQ NOTLOGS (CONS (CAR X) NOTLOGS))) + ((EQ (CAAAR X) '%LOG) (SETQ LOG (CONS (LOGCON (CADAR X)) LOG))) + ((EQ (CAAAR X) 'MTIMES) + (SETQ Y (LGCTIMES (CAR X))) + (COND ((OR (ATOM Y) (NOT (EQ (CAAR Y) '%LOG))) + (SETQ NOTLOGS (CONS Y NOTLOGS))) + (T (SETQ LOG (CONS (CADR Y) LOG))))) + (T (SETQ NOTLOGS (CONS (LOGCON (CAR X)) NOTLOGS)))))) + +(DEFUN LGCTIMES (E) + (SETQ E (SUBST0 (CONS '(MTIMES) (MAPCAR 'LOGCON (CDR E))) E)) + (COND ((NOT (MTIMESP E)) E) + (T (DO ((X (CDR E) (CDR X)) (LOG) (NOTLOGS) (DECINTS)) + ((NULL X) + (COND ((OR (NULL LOG) (NULL DECINTS)) E) + (T (MULN (CONS (LGCSIMP (POWER LOG (MULN DECINTS T))) + NOTLOGS) + T)))) + (COND ((AND (NULL LOG) (NOT (ATOM (CAR X))) + (EQ (CAAAR X) '%LOG) (NOT (EQUAL (CADAR X) -1))) + (SETQ LOG (CADAR X))) + ((LOGCONCOEFFP (CAR X)) (SETQ DECINTS (CONS (CAR X) DECINTS))) + (T (SETQ NOTLOGS (CONS (CAR X) NOTLOGS)))))))) + +(DEFUN LGCSIMP (E) + (COND ((ATOM E) (SIMPLN (LIST '(%LOG) E) 1 T)) (T (LIST '(%LOG SIMP) E)))) + +(DEFUN LGCSIMPLEP (E) + (AND (EQ (CAAR E) 'MPLUS) + (NOT (DO L (CDR E) (CDR L) (NULL L) + (COND ((NOT (OR (ATOM (CAR L)) + (NOT (ISINOP (CAR L) '%LOG)) + (EQ (CAAAR L) '%LOG) + (AND (EQ (CAAAR L) 'MTIMES) + (NULL (CDDDAR L)) + (MNUMP (CADAR L)) + (NOT (ATOM (CADDAR L))) + (EQ (CAAR (CADDAR L)) '%LOG)))) + (RETURN T))))))) + +(DEFUN LGCSORT (E) + (LET (GENVAR VARLIST ($KEEPFLOAT T) VL E1) + (NEWVAR E) + (SETQ VL (DO ((VL VARLIST (CDR VL)) (LOGS) (NOTLOGS) (DECINTS)) + ((NULL VL) + (SETQ LOGS (SORT LOGS 'GREAT)) + (NRECONC DECINTS (NCONC LOGS (NREVERSE NOTLOGS)))) + (COND ((AND (NOT (ATOM (CAR VL))) (EQ (CAAAR VL) '%LOG)) + (SETQ LOGS (CONS (CAR VL) LOGS))) + ((LOGCONCOEFFP (CAR VL)) + (SETQ DECINTS (CONS (CAR VL) DECINTS))) + (T (SETQ NOTLOGS (CONS (CAR VL) NOTLOGS)))))) + (SETQ E1 (RATDISREP (RATREP E VL))) + (IF (ALIKE1 E E1) E E1))) + +(DEFUN LGCCHECK (E) + (LET (NUM DENOM) + (COND ((ATOM E) E) + ((AND (EQ (CAAR E) '%LOG) + (SETQ NUM (MEMBER ($NUM (CADR E)) '(1 -1))) + (NOT (EQUAL (SETQ DENOM ($DENOM (CADR E))) 1))) + (LIST '(MTIMES SIMP) -1 + (LIST '(%LOG SIMP) (IF (= (CAR NUM) 1) DENOM (NEG DENOM))))) + (T (RECUR-APPLY #'LGCCHECK E))))) + +(DEFUN LOGCONCOEFFP (E) + (IF $LOGCONCOEFFP (LET ((*E* E)) (IS '(($LOGCONCOEFFP) *E*))) (INTEGERP E))) + +(DECLARE (SPLITFILE RTCON) (SPECIAL $RADEXPAND $DOMAIN RADPE)) + +(DEFMVAR $ROOTSCONMODE T) + +(DEFUN $ROOTSCONTRACT (E) ; E is assumed to be simplified + ((LAMBDA (RADPE $RADEXPAND) (RTCON E)) + (AND $RADEXPAND (NOT (EQ $RADEXPAND '$ALL)) (EQ $DOMAIN '$REAL)) NIL)) + +(DEFUN RTCON (E) + (COND ((ATOM E) E) + ((EQ (CAAR E) 'MTIMES) + (IF (AND (NOT (FREE E '$%I)) + (LET ((NUM ($NUM E))) + (AND (NOT (ALIKE1 E NUM)) + (OR (EQ NUM '$%I) + (AND (NOT (ATOM NUM)) (MEMQ '$%I NUM) + (MEMQ '$%I (RTCON NUM))))))) + (SETQ E (LIST* (CAR E) -1 '((MEXPT) -1 ((RAT SIMP) -1 2)) + (DELQ '$%I (APPEND (CDR E) NIL) 1)))) + (DO ((X (CDR E) (CDR X)) (ROOTS) (NOTROOTS) (Y)) + ((NULL X) + (COND ((NULL ROOTS) (SUBST0 (CONS '(MTIMES) (NREVERSE NOTROOTS)) E)) + (T (IF $ROOTSCONMODE + (LET (((MIN GCD LCM) (RTC-GETINFO ROOTS))) + (COND ((AND (= MIN GCD) (NOT (= GCD 1)) + (NOT (= MIN LCM)) + (NOT (EQ $ROOTSCONMODE '$ALL))) + (SETQ ROOTS + (RT-SEPAR + (LIST GCD + (RTCON + (RTC-FIXITUP + (RTC-DIVIDE-BY-GCD ROOTS GCD) + NIL)) + 1) + NIL))) + ((EQ $ROOTSCONMODE '$ALL) + (SETQ ROOTS + (RT-SEPAR (SIMP-ROOTS LCM ROOTS) + NIL)))))) + (RTC-FIXITUP ROOTS NOTROOTS)))) + (COND ((ATOM (CAR X)) + (COND ((EQ (CAR X) '$%I) (SETQ ROOTS (RT-SEPAR (LIST 2 -1) ROOTS))) + (T (SETQ NOTROOTS (CONS (CAR X) NOTROOTS))))) + ((AND (EQ (CAAAR X) 'MEXPT) (RATNUMP (SETQ Y (CADDAR X)))) + (SETQ ROOTS (RT-SEPAR (LIST (CADDR Y) + (LIST '(MEXPT) + (RTCON (CADAR X)) (CADR Y))) + ROOTS))) + + ((AND RADPE (EQ (CAAAR X) 'MABS)) + (SETQ ROOTS (RT-SEPAR (LIST 2 `((MEXPT) ,(RTCON (CADAR X)) 2) 1) + ROOTS))) + (T (SETQ NOTROOTS (CONS (RTCON (CAR X)) NOTROOTS)))))) + ((AND RADPE (EQ (CAAR E) 'MABS)) + (POWER (POWER (RTCON (CADR E)) 2) '((RAT SIMP) 1 2))) + (T (RECUR-APPLY #'RTCON E)))) + +; RT-SEPAR separates like roots into their appropriate "buckets", +; where a bucket looks like: +; (( ( ) +; ( )) etc) + +(DEFUN RT-SEPAR (A ROOTS) + (LET ((U (ASSOC (CAR A) ROOTS))) + (COND (U (NCONC U (CDR A))) (T (SETQ ROOTS (CONS A ROOTS))))) + ROOTS) + +(DEFUN SIMP-ROOTS (LCM ROOT-LIST) + (LET (ROOT1) + (DO ((X ROOT-LIST (CDR X))) + ((NULL X) (PUSH LCM ROOT1)) + (PUSH (LIST '(MEXPT) (MULN (CDAR X) NIL) (QUOTIENT LCM (CAAR X))) + ROOT1)))) + +(DEFUN RTC-GETINFO (LIST) + (LET ((M (CAAR LIST)) (G (CAAR LIST)) (L (CAAR LIST))) + (DO ((X (CDR LIST) (CDR X))) + ((NULL X) (LIST M G L)) + (SETQ M (MIN M (CAAR X)) G (GCD G (CAAR X)) L (LCM L (CAAR X)))))) + +(DEFUN RTC-FIXITUP (ROOTS NOTROOTS) + (MAPCAR #'(LAMBDA (X) (RPLACD X (LIST (SRATSIMP (MULN (CDR X) (NOT $ROOTSCONMODE)))))) + ROOTS) + (MULN (NCONC (MAPCAR #'(LAMBDA (X) (POWER* (CADR X) `((RAT) 1 ,(CAR X)))) + ROOTS) + NOTROOTS) + (NOT $ROOTSCONMODE))) + +(DEFUN RTC-DIVIDE-BY-GCD (LIST GCD) + (MAPCAR #'(LAMBDA (X) (RPLACA X (QUOTIENT (CAR X) GCD))) LIST) + LIST) + +(DECLARE (SPLITFILE NTERMS)) + +(DEFMFUN $NTERMS (E) + (COND ((ZEROP1 E) 0) + ((ATOM E) 1) + ((EQ (CAAR E) 'MTIMES) + (IF (EQUAL -1 (CADR E)) (SETQ E (CDR E))) + (DO ((L (CDR E) (CDR L)) (C 1 (TIMES C ($NTERMS (CAR L))))) + ((NULL L) C))) + ((EQ (CAAR E) 'MPLUS) + (DO ((L (CDR E) (CDR L)) (C 0 (PLUS C ($NTERMS (CAR L))))) + ((NULL L) C))) + ((AND (EQ (CAAR E) 'MEXPT) (FIXP (CADDR E)) (PLUSP (CADDR E))) + ($BINOMIAL (PLUS (CADDR E) ($NTERMS (CADR E)) -1) (CADDR E))) + ((SPECREPP E) ($NTERMS (SPECDISREP E))) + (T 1))) + +(DECLARE (SPLITFILE ATAN2) + (SPECIAL $NUMER $%PIARGS $LOGARC $TRIGSIGN HALF%PI FOURTH%PI)) + +(DEFUN SIMPATAN2 (E VESTIGIAL Z) ; atan2(y,x) ~ atan(y/x) + VESTIGIAL ;ignored + (TWOARGCHECK E) + (LET (Y X SIGN) + (SETQ Y (SIMPCHECK (CADR E) Z) X (SIMPCHECK (CADDR E) Z)) + (COND ((AND (ZEROP1 Y) (ZEROP1 X)) + (MERROR "ATAN2(0,0) has been generated.")) + ((OR (AND (FLOATP Y) (FLOATP X)) + (AND $NUMER (NUMBERP Y) (NUMBERP X))) + (ATAN2 Y X)) + ((AND ($BFLOATP Y) ($BFLOATP X)) + (IF (MMINUSP* Y) (NEG (*FPATAN (NEG Y) (LIST X))) + (*FPATAN Y (LIST X)))) + ((AND $%PIARGS (FREE X '$%I) (FREE Y '$%I) + (COND ((ZEROP1 Y) (IF (ATAN2NEGP X) (SIMPLIFY '$%PI) 0)) + ((ZEROP1 X) + (IF (ATAN2NEGP Y) (MUL2* -1 HALF%PI) (SIMPLIFY HALF%PI))) + ((ALIKE1 Y X) + (IF (ATAN2NEGP X) (MUL2* -3 FOURTH%PI) (SIMPLIFY FOURTH%PI))) + ((ALIKE1 Y (MUL2 -1 X)) + (IF (ATAN2NEGP X) (MUL2* 3 FOURTH%PI) (MUL2* -1 FOURTH%PI))) + ((AND (EQUAL Y 1) (ALIKE1 X '((MEXPT SIMP) 3 ((RAT SIMP) 1 2)))) + (MUL2* '((RAT SIMP) 1 6) '$%PI))))) + ($LOGARC (LOGARC '%ATAN (DIV Y X))) + ((AND $TRIGSIGN (MMINUSP* Y)) + (NEG (SIMPLIFYA (LIST '($ATAN2) (NEG Y) X) T))) + ; atan2(y,x) = atan(y/x) + pi sign(y) (1-sign(x))/2 + ((AND (FREE X '$%I) (EQ (SETQ SIGN ($SIGN X)) '$POS)) + (SIMPLIFYA (LIST '(%ATAN) (DIV Y X)) T)) + ((AND (EQ SIGN '$NEG) (FREE Y '$%I) + (MEMQ (SETQ SIGN ($SIGN Y)) '($POS $NEG))) + (ADD2 (SIMPLIFYA (LIST '(%ATAN) (DIV Y X)) T) + (PORM (EQ SIGN '$POS) (SIMPLIFY '$%PI)))) + (T (EQTEST (LIST '($ATAN2) Y X) E))))) + +(DEFUN ATAN2NEGP (E) (EQ (ASKSIGN-P-OR-N E) '$NEG)) + +(DECLARE (SPLITFILE ARITHF) (SPECIAL LNORECURSE)) + +(DEFMFUN $FIBTOPHI (E) + (COND ((ATOM E) E) + ((EQ (CAAR E) '$FIB) + (SETQ E (COND (LNORECURSE (CADR E)) (T ($FIBTOPHI (CADR E))))) + (LET ((PHI (MEVAL '$%PHI))) + (DIV (ADD2 (POWER PHI E) (NEG (POWER (ADD2 1 (NEG PHI)) E))) + (ADD2 -1 (MUL2 2 PHI))))) + (T (RECUR-APPLY #'$FIBTOPHI E)))) + +(DEFMSPEC $NUMERVAL (L) (SETQ L (CDR L)) + (DO ((L L (CDDR L)) (X (NCONS '(MLIST SIMP)))) ((NULL L) X) + (COND ((NULL (CDR L)) (MERROR "NUMERVAL takes an even number of args")) + ((NOT (SYMBOLP (CAR L))) + (MERROR "~M must be atomic - NUMERVAL" (CAR L))) + ((BOUNDP (CAR L)) + (MERROR "~M is bound - NUMERVAL" (CAR L)))) + (MPUTPROP (CAR L) (CADR L) '$NUMER) + (ADD2LNC (CAR L) $PROPS) + (NCONC X (NCONS (CAR L))))) + + +(DECLARE (SPLITFILE DERIVD) (SPECIAL POWERS VAR DEPVAR)) + +(DEFMFUN $DERIVDEGREE (E DEPVAR VAR) + (LET (POWERS) (DERIVDEG1 E) (IF (NULL POWERS) 0 (MAXIMIN POWERS '$MAX)))) + +(DEFUN DERIVDEG1 (E) + (COND ((OR (ATOM E) (SPECREPP E))) + ((EQ (CAAR E) '%DERIVATIVE) + (COND ((ALIKE1 (CADR E) DEPVAR) + (DO L (CDDR E) (CDDR L) (NULL L) + (COND ((ALIKE1 (CAR L) VAR) + (RETURN (SETQ POWERS (CONS (CADR L) POWERS))))))))) + (T (MAPC 'DERIVDEG1 (CDR E))))) + +(DECLARE (UNSPECIAL POWERS VAR DEPVAR)) + +(DECLARE (SPLITFILE BOX)) + +(DEFMFUN $DPART N (MPART (LISTIFY N) NIL T NIL '$DPART)) + +(DEFMFUN $LPART N (MPART (CDR (LISTIFY N)) NIL (LIST (ARG 1)) NIL '$LPART)) + +(DEFMFUN $BOX N + (COND ((= N 1) (LIST '(MBOX) (ARG 1))) + ((= N 2) (LIST '(MLABOX) (ARG 1) (BOX-LABEL (ARG 2)))) + (T (WNA-ERR '$BOX)))) + +(DEFMFUN BOX (E LABEL) (IF (EQ LABEL T) (LIST '(MBOX) E) ($BOX E (CAR LABEL)))) + +(DEFUN BOX-LABEL (X) (IF (ATOM X) X (IMPLODE (CONS #/& (MSTRING X))))) + +(DECLARE (SPECIAL LABEL)) + +(DEFMFUN $REMBOX N + (LET ((LABEL (COND ((= N 1) '(NIL)) + ((= N 2) (BOX-LABEL (ARG 2))) + (T (WNA-ERR '$REMBOX))))) + (REMBOX1 (ARG 1)))) + +(DEFUN REMBOX1 (E) + (COND ((ATOM E) E) + ((OR (AND (EQ (CAAR E) 'MBOX) + (OR (EQUAL LABEL '(NIL)) (MEMQ LABEL '($UNLABELLED $UNLABELED)))) + (AND (EQ (CAAR E) 'MLABOX) + (OR (EQUAL LABEL '(NIL)) (EQUAL LABEL (CADDR E))))) + (REMBOX1 (CADR E))) + (T (RECUR-APPLY #'REMBOX1 E)))) + +(DECLARE (UNSPECIAL LABEL)) + +(DECLARE (SPLITFILE MAPF) (SPECIAL SCANMAPP) (*LEXPR SCANMAP1)) + +(DEFUN MMAPEV1 (L) ; very temporary + (IF (NULL (CDDR L)) + (MERROR "~:M called with fewer than two arguments." (CAAR L))) + (LET ((OP (GETOPR (MEVAL (CADR L))))) + (BADFUNCHK (CADR L) OP NIL) + (CONS OP (MAPCAR #'MEVAL (CDDR L))))) + +(DEFMSPEC $SCANMAP (L) + (LET ((SCANMAPP T)) (RESIMPLIFY (APPLY #'SCANMAP1 (MMAPEV1 L))))) + +(DEFUN SCANMAP1 N + (LET ((FUNC (ARG 1)) (ARG2 (SPECREPCHECK (ARG 2))) NEWARG2) + (COND ((EQ FUNC '$RAT) (MERROR "SCANMAP results must be in general representation.")) + ((> N 2) + (COND ((EQ (ARG 3) '$BOTTOMUP) + (COND ((MAPATOM ARG2) (FUNCER FUNC (NCONS ARG2))) + (T (SUBST0 (FUNCER FUNC + (NCONS (MCONS-OP-ARGS + (MOP ARG2) + (MAPCAR #'(LAMBDA (U) + (SCANMAP1 + FUNC U '$BOTTOMUP)) + (MARGS ARG2))))) + ARG2)))) + ((> N 3) (WNA-ERR '$SCANMAP)) + (T (MERROR "Only BOTTOMUP is an acceptable 3rd arg to SCANMAP.")))) + ((MAPATOM ARG2) (FUNCER FUNC (NCONS ARG2))) + (T (SETQ NEWARG2 (SPECREPCHECK (FUNCER FUNC (NCONS ARG2)))) + (COND ((MAPATOM NEWARG2) NEWARG2) + ((AND (ALIKE1 (CADR NEWARG2) ARG2) (NULL (CDDR NEWARG2))) + (SUBST0 (CONS (NCONS (CAAR NEWARG2)) + (NCONS (SUBST0 + (MCONS-OP-ARGS + (MOP ARG2) + (MAPCAR #'(LAMBDA (U) (SCANMAP1 FUNC U)) + (MARGS ARG2))) + ARG2))) + NEWARG2)) + (T (SUBST0 (MCONS-OP-ARGS + (MOP NEWARG2) + (MAPCAR #'(LAMBDA (U) (SCANMAP1 FUNC U)) + (MARGS NEWARG2))) + NEWARG2))))))) + +(DEFUN SUBGEN (FORM) ; This function does mapping of subscripts. + (DO ((DS (IF (EQ (CAAR FORM) 'MQAPPLY) (LIST (CAR FORM) (CADR FORM)) + (NCONS (CAR FORM))) + (OUTERMAP1 #'DSFUNC1 (SIMPLIFY (CAR SUB)) DS)) + (SUB (REVERSE (OR (AND (EQ 'MQAPPLY (CAAR FORM)) (CDDR FORM)) + (CDR FORM))) + (CDR SUB))) + ((NULL SUB) DS))) + +(DEFUN DSFUNC1 (DSN DSO) + (COND ((OR (ATOM DSO) (ATOM (CAR DSO))) DSO) + ((MEMQ 'ARRAY (CAR DSO)) + (COND ((EQ 'MQAPPLY (CAAR DSO)) + (NCONC (LIST (CAR DSO) (CADR DSO) DSN) (CDDR DSO))) + (T (NCONC (LIST (CAR DSO) DSN) (CDR DSO))))) + (T (MAPCAR #'(LAMBDA (D) (DSFUNC1 DSN D)) DSO)))) + +(DECLARE (SPLITFILE GENMAT) (FIXNUM DIM1 DIM2)) + +(DEFMFUN $GENMATRIX N + (LET ((ARGS (LISTIFY N))) + (IF (OR (< N 2) (> N 5)) (WNA-ERR '$GENMATRIX)) + (IF (NOT (OR (SYMBOLP (CAR ARGS)) + (AND (NOT (ATOM (CAR ARGS))) + (EQ (CAAAR ARGS) 'LAMBDA)))) + (IMPROPER-ARG-ERR (CAR ARGS) '$GENMATRIX)) + (IF (MEMQ NIL (MAPCAR #'(LAMBDA (U) (EQ (TYPEP U) 'FIXNUM)) + (CDR ARGS))) + (MERROR "Invalid arguments to GENMATRIX:~%~M" + (CONS '(MLIST) (CDR ARGS)))) + (LET* ((HEADER (LIST (CAR ARGS) 'ARRAY)) + (DIM1 (CADR ARGS)) + (DIM2 (IF (= N 2) (CADR ARGS) (CADDR ARGS))) + (I (IF (> N 3) (ARG 4) 1)) + (J (IF (= N 5) (ARG 5) I)) + (L (NCONS '($MATRIX)))) + (COND ((AND (OR (= DIM1 0) (= DIM2 0)) (= I 1) (= J 1))) + ((OR (> I DIM1) (> J DIM2)) + (MERROR "Invalid arguments to GENMATRIX:~%~M" + (CONS '(MLIST) ARGS)))) + (DO I I (1+ I) (> I DIM1) (NCONC L (NCONS (NCONS '(MLIST))))) + (DO ((I I (1+ I)) (L (CDR L) (CDR L))) ((> I DIM1)) + (DO J J (1+ J) (> J DIM2) + (NCONC (CAR L) (NCONS (MEVAL (LIST HEADER I J)))))) + L))) + +(DEFMFUN $COPYMATRIX (X) + (IF (NOT ($MATRIXP X)) (MERROR "Argument not a matrix - COPYMATRIX:~%~M" X)) + (CONS (CAR X) (MAPCAR #'(LAMBDA (X) (APPEND X NIL)) (CDR X)))) + +(DEFMFUN $COPYLIST (X) + (IF (NOT ($LISTP X)) (MERROR "Argument not a list - COPYLIST:~%~M" X)) + (CONS (CAR X) (APPEND (CDR X) NIL))) + + +(DECLARE (SPLITFILE ADDROW)) + +(DEFMFUN $ADDROW N + (COND ((= N 0) (WNA-ERR '$ADDROW)) + ((NOT ($MATRIXP (ARG 1))) (MERROR "First argument to ADDROW must be a matrix")) + ((= N 1) (ARG 1)) + (T (DO ((I 2 (1+ I)) (M (ARG 1))) ((> I N) M) + (SETQ M (ADDROW M (ARG I))))))) + +(DEFMFUN $ADDCOL N + (COND ((= N 0) (WNA-ERR '$ADDCOL)) + ((NOT ($MATRIXP (ARG 1))) (MERROR "First argument to ADDCOL must be a matrix")) + ((= N 1) (ARG 1)) + (T (DO ((I 2 (1+ I)) (M ($TRANSPOSE (ARG 1)))) ((> I N) ($TRANSPOSE M)) + (SETQ M (ADDROW M ($TRANSPOSE (ARG I)))))))) + +(DEFUN ADDROW (M R) + (COND ((NOT (MXORLISTP R)) (MERROR "Illegal argument to ADDROW or ADDCOL")) + ((AND (CDR M) + (OR (AND (EQ (CAAR R) 'MLIST) (NOT (= (LENGTH (CADR M)) (LENGTH R)))) + (AND (EQ (CAAR R) '$MATRIX) + (NOT (= (LENGTH (CADR M)) (LENGTH (CADR R)))) + (PROG2 (SETQ R ($TRANSPOSE R)) + (NOT (= (LENGTH (CADR M)) (LENGTH (CADR R)))))))) + (MERROR "Incompatible structure - ADDROW//ADDCOL"))) + (APPEND M (IF (EQ (CAAR R) '$MATRIX) (CDR R) (NCONS R)))) + +(DECLARE (SPLITFILE ARRAYF)) + +(DEFMFUN $ARRAYMAKE (ARY SUBS) + (COND ((OR (NOT ($LISTP SUBS)) (NULL (CDR SUBS))) + (MERROR "Wrong type argument to ARRAYMAKE:~%~M" SUBS)) + ((EQ (TYPEP ARY) 'SYMBOL) + (CONS (CONS (GETOPR ARY) '(ARRAY)) (CDR SUBS))) + (T (CONS '(MQAPPLY ARRAY) (CONS ARY (CDR SUBS)))))) + +(DEFMSPEC $ARRAYINFO (ARY) (SETQ ARY (CDR ARY)) + (LET ((GEN (MGETL (SETQ ARY (CAR ARY)) '(HASHAR ARRAY))) ARY1) + (COND ((NULL GEN) (MERROR "Not an array - ARRAYINFO:~%~M" ARY)) + ((MFILEP (CADR GEN)) + (I-$UNSTORE (NCONS ARY)) + (SETQ GEN (MGETL ARY '(HASHAR ARRAY))))) + (SETQ ARY1 (CADR GEN)) + (COND ((EQ (CAR GEN) 'HASHAR) + (APPEND '((MLIST SIMP) $HASHED) + (CONS (FUNCALL ARY1 2) + (DO ((I 3 (1+ I)) (L) (N (CADR (ARRAYDIMS ARY1)))) + ((= I N) (SORT L '(LAMBDA (X Y) (GREAT Y X)))) + (DO L1 (FUNCALL ARY1 I) (CDR L1) (NULL L1) + (SETQ L (CONS (CONS '(MLIST SIMP) (CAAR L1)) + L))))))) + (T (SETQ ARY1 (ARRAYDIMS ARY1)) + (LIST '(MLIST SIMP) + (COND ((GET ARY 'ARRAY) + (CDR (ASSQ (CAR ARY1) + '((T . $COMPLETE) (FIXNUM . $INTEGER) + (FLONUM . $FLOAT))))) + (T '$DECLARED)) + (LENGTH (CDR ARY1)) + (CONS '(MLIST SIMP) (MAPCAR #'1- (CDR ARY1)))))))) + +(DECLARE (SPLITFILE ALIAS) + (SPECIAL ALIASLIST ALIASCNTR GREATORDER LESSORDER) + (FIXNUM ALIASCNTR)) + +(DEFMSPEC $MAKEATOMIC (L) (SETQ L (CDR L)) + (DO ((L L (CDR L)) (BAS) (X)) ((NULL L) '$DONE) + (IF (OR (ATOM (CAR L)) + (NOT (OR (SETQ X (MEMQ (CAAAR L) '(MEXPT MNCEXPT))) + (MEMQ 'ARRAY (CDAAR L))))) + (IMPROPER-ARG-ERR (CAR L) '$MAKEATOMIC)) + (IF X (SETQ BAS (CADAR L) X (AND (ATOM (CADDAR L)) (CADDAR L))) + (SETQ BAS (CAAAR L) X (AND (ATOM (CADAR L)) (CADAR L)))) + (IF (NOT (ATOM BAS)) (IMPROPER-ARG-ERR (CAR L) '$MAKEATOMIC)) + (SETQ ALIASLIST + (CONS (CONS (CAR L) + (IMPLODE + (NCONC (EXPLODEN BAS) + (OR (AND X (EXPLODEN X)) (NCONS '/ )) + (CONS '$ (MEXPLODEN (SETQ ALIASCNTR (1+ ALIASCNTR))))))) + ALIASLIST)))) + +(DEFMSPEC $ORDERGREAT (L) + (IF GREATORDER (MERROR "Reordering is not allowed.")) + (MAKORDER (SETQ GREATORDER (REVERSE (CDR L))) '_)) + +(DEFMSPEC $ORDERLESS (L) + (IF LESSORDER (MERROR "Reordering is not allowed.")) + (MAKORDER (SETQ LESSORDER (CDR L)) '/#)) + +(DEFUN MAKORDER (L CHAR) + (DO ((L L (CDR L)) (N 101 (1+ N))) ((NULL L) '$DONE) + (ALIAS (CAR L) + (IMPLODE (NCONC (NCONS CHAR) (MEXPLODEN N) + (EXPLODEN (STRIPDOLLAR (CAR L)))))))) + +(DEFMFUN $UNORDER NIL + (LET ((L (DELQ NIL + (CONS '(MLIST SIMP) + (NCONC (MAPCAR #'REMALIAS (MAPCAR #'GETALIAS LESSORDER)) + (MAPCAR #'REMALIAS (MAPCAR #'GETALIAS GREATORDER))))))) + (SETQ LESSORDER NIL GREATORDER NIL) L)) + +(DECLARE (SPLITFILE CONCAT) (NOTYPE (ASCII-NUMBERP FIXNUM))) + +(DEFMFUN $CONCAT N + (LET ((L (LISTIFY N))) + (IF (NULL L) (MERROR "CONCAT needs at least one argument.")) + (IMPLODE + (CONS (COND ((NOT (ATOM (CAR L)))) + ((OR (NUMBERP (CAR L)) (= (GETCHARN (CAR L) 1) #/&)) #/&) + (T #/$)) + (APPLY #'NCONC + (MAPCAR + #'(LAMBDA (X) + (IF (NOT (ATOM X)) + (MERROR "Argument to CONCAT not an atom: ~M" X)) + (STRING* X)) + L)))))) + +(DEFMFUN $GETCHAR (X Y) + (LET ((N 0)) + (COND ((NOT (EQ (TYPEP X) 'SYMBOL)) + (MERROR "1st argument to GETCHAR not a symbol: ~M" X)) + ((OR (NOT (EQ (TYPEP Y) 'FIXNUM)) (NOT (> Y 0))) + (MERROR "Incorrect 2nd argument to GETCHAR: ~M" Y)) + ((= (SETQ N (GETCHARN (FULLSTRIP1 X) Y)) 0) NIL) + ((= (GETCHARN X 1) '#/&) (IMPLODE (LIST #/& N))) + ((ASCII-NUMBERP N) (- N #/0)) + (T (IMPLODE (LIST #/$ N)))))) + +#+ITS +(DECLARE (SPLITFILE TTYINI) + (SPECIAL $PAGEPAUSE LINEL $LINEL SCROLLP TTYHEIGHT $PLOTHEIGHT + SMART-TTY RUBOUT-TTY 12-BIT-TTY CURSORPOS PLASMA-TTY + DISPLAY-FILE)) + +#+ITS +(DEFMFUN $TTY_INIT NIL + (SETQ $PAGEPAUSE (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_25.))) + ; bit 3.8 (%TSMOR) of TTYSTS + (SETQ $LINEL (SETQ LINEL (LINEL T))) + (SETQ SCROLLP (NOT (= 0 (BOOLE 1 (CADDR (STATUS TTY)) 1_30.)))) + (SETQ TTYHEIGHT (CAR (STATUS TTYSIZE)) + $PLOTHEIGHT (IF (< TTYHEIGHT 200.) (- TTYHEIGHT 2) 24.)) + (LET ((TTYOPT (CAR (CDDDDR (SYSCALL 6 'CNSGET TYO))))) + ; %TOFCI (bit 3.4) = terminal has a 12 bit keyboard. + (SETQ 12-BIT-TTY (NOT (= (BOOLE 1 8_18. TTYOPT) 0))) + ; %TOMVU (bit 3.9) = terminal can do vertical cursor movement. + ; However, we must also make sure that the screen size + ; is within the ITS addressing limits. + (SETQ SMART-TTY (AND (NOT (= (BOOLE 1 256._18. TTYOPT) 0)) + (< TTYHEIGHT 200.) + (< LINEL 128.))) + ; %TOERS (bit 4.6) = terminal can selectively erase. + ; %TOMVB (bit 4.4) = terminal can backspace. + ; %TOOVR (bit 4.1) = terminal can overstrike (i.e. printing one + ; character on top of another causes both + ; to appear.) + (SETQ RUBOUT-TTY + (OR (NOT (= (BOOLE 1 32._27. TTYOPT) 0)) ;%TOERS + (AND (NOT (= (BOOLE 1 8._27. TTYOPT) 0)) ;%TOMVB + (= (BOOLE 1 1_27. TTYOPT) 0)))) ;%TOOVR + ; %TOCID (bit 3.1) = terminal can insert and delete characters. + ; If the console has a 12-bit keyboard, an 85 by 50 screen, and + ; can't ins/del characters, then it must be a Plasma console. + (SETQ PLASMA-TTY + (AND 12-BIT-TTY (= LINEL 84.) (= TTYHEIGHT 50.) + (= 0 (BOOLE 1 1_18. TTYOPT))))) + (SETQ CURSORPOS SMART-TTY) + (IF SMART-TTY (SETQ DISPLAY-FILE (OPEN '|TTY:| '(TTY OUT IMAGE BLOCK)))) + (COND (PLASMA-TTY (LOAD '((DSK MACSYM) ARDS))) + ((OR (= TTY 13.) (JOB-EXISTS 'H19) (JOB-EXISTS 'H19WHO)) + (LOAD '((DSK MACSYM) H19))) + ((JOB-EXISTS 'VT100) (LOAD '((DSK MACSYM) VT100)))) + '$DONE) + +#+ITS +(DEFUN JOB-EXISTS (JNAME) (PROBEF (LIST '(USR *) (STATUS UNAME) JNAME))) + + +; Undeclarations for the file: +(DECLARE (NOTYPE N I J)) diff --git a/src/jpg/dskfn.169 b/src/jpg/dskfn.169 new file mode 100644 index 00000000..ffc2c913 --- /dev/null +++ b/src/jpg/dskfn.169 @@ -0,0 +1,492 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1982 Massachusetts Institute of Technology ** + +(macsyma-module dskfn) + +(DECLARE (GENPREFIX DK) + (SPECIAL $FILENAME $DEVICE $DIREC $STORENUM $FILENUM $DSKALL + $FILESIZE FILELIST FILELIST1 *NOPOINT OPERS $PACKAGEFILE + FASDUMPFL FASDEQLIST FASDNONEQLIST SAVENOHACK + DSKSAVEP AAAAA ERRSET LESSORDER GREATORDER INDLIST + $LABELS $ALIASES VARLIST MOPL $PROPS DEFAULTF + $INFOLISTS $FEATURES FEATUREL SAVEFILE $GRADEFS + $VALUES $FUNCTIONS $ARRAYS PRINLENGTH PRINLEVEL + $CONTEXTS CONTEXT $ACTIVECONTEXTS) + (FIXNUM N $FILESIZE $STORENUM $FILENUM) + (*LEXPR $FACTS)) + +(SETQ FILELIST NIL FILELIST1 NIL $PACKAGEFILE NIL + INDLIST (PURCOPY '(EVFUN EVFLAG BINDTEST NONARRAY SP2 OPERS SPECIAL + AUTOLOAD ASSIGN MODE))) + +(DEFMSPEC $UNSTORE (FORM) (I-$UNSTORE (CDR FORM))) + +(DEFMFUN I-$UNSTORE (X) + (DO ((X X (CDR X)) (LIST (NCONS '(MLIST SIMP))) (PROP) (FL NIL NIL)) + ((NULL X) LIST) + (SETQ X (INFOLSTCHK X)) + (WHEN (AND (BOUNDP (CAR X)) (MFILEP (SETQ PROP (SYMEVAL (CAR X))))) + (SETQ FL T) + (SET (CAR X) (EVAL (DSKGET (CADR PROP) (CADDR PROP) 'VALUE NIL)))) + (DO PROPS (CDR (OR (GET (CAR X) 'MPROPS) '(NIL))) (CDDR PROPS) (NULL PROPS) + (COND ((MFILEP (CADR PROPS)) + (SETQ FL T) + (COND ((MEMQ (CAR PROPS) '(HASHAR ARRAY)) + (LET ((AAAAA (GENSYM))) + (SETQ PROP (DSKGET (CADADR PROPS) + (CADDR (CADR PROPS)) + (CAR PROPS) + T)) + (MPUTPROP (CAR X) + (IF (EQ PROP 'AAAAA) AAAAA (CAR X)) + (CAR PROPS)))) + (T (SETQ PROP (DSKGET (CADADR PROPS) (CADDR (CADR PROPS)) + (CAR PROPS) NIL)) + (MPUTPROP (CAR X) PROP (CAR PROPS))))))) + (AND FL (NCONC LIST (NCONS (CAR X)))))) + +(DEFUN INFOLSTCHK (X) + ((LAMBDA (ITEML) + (IF (EQ ITEML T) X (APPEND (OR ITEML '(NIL)) (CDR X)))) + (COND ((NOT (AND X (OR (MEMQ (CAR X) '($ALL $CONTEXTS)) + (MEMQ (CAR X) (CDR $INFOLISTS))))) + T) + ((EQ (CAR X) '$ALL) + (INFOLSTCHK (APPEND (CDR $INFOLISTS) + '($LINENUM $RATVARS $WEIGHTLEVELS *RATWEIGHTS + TELLRATLIST $DONTFACTOR $FEATURES $CONTEXTS)))) + ((EQ (CAR X) '$LABELS) (REVERSE (CDR $LABELS))) + ((MEMQ (CAR X) '($FUNCTIONS $MACROS $GRADEFS $DEPENDENCIES)) + (MAPCAR #'CAAR (CDR (SYMEVAL (CAR X))))) + ((EQ (CAR X) '$CONTEXTS) (DELQ '$GLOBAL (REVERSE (CDR $CONTEXTS)) 1)) + (T (CDR (SYMEVAL (CAR X))))))) + +#-Franz +(DEFUN FILELENGTH (FILE) + (PROG2 (SETQ FILE (OPEN FILE '(IN FIXNUM))) + (LET ((N (FIX (+$ (//$ (FLOAT (LENGTHF FILE)) 1024.0) 0.999999)))) + (LIST '(MTIMES SIMP) N (IF (= N 1) '$BLOCK '$BLOCKS))) + (CLOSE FILE))) + +(DEFMSPEC $SAVE (FORM) (DSKSETUP (CDR FORM) NIL NIL '$SAVE)) + +(DEFMSPEC $STORE (FORM) (I-$STORE (CDR FORM))) +(DEFMFUN I-$STORE (X) (DSKSETUP X T NIL '$STORE)) + +(DEFMSPEC $FASSAVE (FORM) (DSKSETUP (CDR FORM) NIL T '$FASSAVE)) + +#-LISPM +(DEFUN DSKSETUP (X STOREFL FASDUMPFL FN) + (LET ((*NOPOINT T) PRINLENGTH PRINLEVEL OFILE FILE + LIST FASDEQLIST FASDNONEQLIST ERROR #+PDP10 LENGTH #+PDP10 OINT) + #-Franz + (SETQ FILE (COND (($LISTP (CAR X)) (PROG1 (FILESTRIP (CDAR X)) (SETQ X (CDR X)))) + (T ;;Set OFILE to the last thing we wrote to. + #-LISPM (SETQ OFILE (DEFAULTF ())) + #+LISPM (SETQ OFILE (FILE-EXPAND-PATHNAME "")) + ;;Cons up a new filename if none specified in + ;;SAVE or STORE command. + #+Multics + (merror "First argument to ~:M must be a list.~ + ~%~:M([/"myfile/"],all); is acceptable." + FN FN) + #-Multics + (FULLSTRIP (LIST $FILENAME + (IF DSKSAVEP + (SETQ $STORENUM (1+ $STORENUM)) + (SETQ $FILENUM (1+ $FILENUM))) + $DEVICE $DIREC))))) + #+Franz (setq file (filestrip x) x (cdr x)) + ;;Lisp Machine FILESTRIP returns a string. Fix later. + #+LISPM (IF (STRINGP FILE) (SETQ FILE (UNEXPAND-PATHNAME FILE))) + (DOLIST (U X) + (COND ((ATOM U) (IF (NOT (SYMBOLP U)) (IMPROPER-ARG-ERR U FN))) + ((LISTARGP U)) + ((OR (NOT (EQ (CAAR U) 'MEQUAL)) (NOT (SYMBOLP (CADR U)))) + (IMPROPER-ARG-ERR U FN)))) + #-Franz + (IF (AND STOREFL (EQ (CADR FILE) '>)) + (MERROR "> as second filename has not been implemented for STORE.")) + #+PDP10 (IF STOREFL (SETQ OINT (NOINTERRUPT 'TTY))) + (COND (DSKSAVEP (SETQ FILELIST (CONS FILE FILELIST))) + (OFILE (SETQ FILELIST1 (CONS FILE FILELIST1)))) + ;;Create a stream to the file. On ITS, use a hack to avoid repeated + ;;creation of file arrays. + #-Franz + (LET ((TEMP-FILE #-Multics`(,(CARFILE (CDDR FILE)) |!SAVE!| OUTPUT) + #+Multics "macsyma.saved.output")) + #+PDP10 (OPEN (CNAMEF SAVEFILE TEMP-FILE) + (IF FASDUMPFL '(OUT FIXNUM BLOCK) '(OUT ASCII))) + #+LISPM (SETQ SAVEFILE (OPEN TEMP-FILE '(:OUT :ASCII))) + #-(OR LISPM PDP10) (SETQ SAVEFILE (OPEN TEMP-FILE '(OUT ASCII)))) + #+Franz (setq savefile (outfile file)) + (SETQ *NOPOINT NIL) + (WHEN (NULL FASDUMPFL) + (PRINC ";;; -*- Mode: LISP; Package: Macsyma; -*- Saved by " SAVEFILE) + (PRINC (sys-user-id) SAVEFILE)) + #-(or Franz LISPM Multics) (FASPRINT T `(SETQ SAVENO ,SAVENOHACK)) + (SETQ LIST (NCONS (IF (SYMBOLP FILE) FILE (MFILE-OUT FILE))) + X (CONS '$ALIASES X)) + (IF (NULL (ERRSET (DSKSTORE X STOREFL FILE LIST))) (SETQ ERROR T)) + (SETQ *NOPOINT T) + (COND ((NULL (CDR LIST)) + (DELETEF SAVEFILE) + (IF (NOT DSKSAVEP) + (MTELL "~M~%Nothing has been ~:Md. ~:M attempt aborted." + (CAR LIST) FN FN)) + (SETQ LIST '$ABORTED)) + #-Franz + (FASDUMPFL (*FASDUMP SAVEFILE (NREVERSE FASDNONEQLIST) (NREVERSE FASDEQLIST) NIL) + (RENAMEF SAVEFILE FILE)) + (T (TERPRI SAVEFILE) #-Franz (RENAMEF SAVEFILE FILE))) + #+PDP10 (IF STOREFL (NOINTERRUPT OINT)) + #-(or Franz LISPM Multics) (DEFAULTF (IF DSKSAVEP OFILE FILE)) + #+PDP10 + (WHEN (NOT (ATOM LIST)) + (RPLACA LIST (MTRUENAME SAVEFILE)) + (SETQ LENGTH (FILELENGTH SAVEFILE)) + (WHEN (> (CADR LENGTH) 30.) + (MTELL "~:M is ~A blocks big!" (CAR LIST) (CADR LENGTH)) + (COND ((> (CADR LENGTH) 60.) + (MTELL "You probably want to delete it.")) + ((> (CADR LENGTH) 50.) + (MTELL "Do you really want such a large file?"))))) + (IF ERROR (LET ((ERRSET 'ERRBREAK1)) (MERROR "Error in ~:M attempt" FN))) + ;;The CLOSE happens inside of RENAMEF on ITS. + #-PDP10 (CLOSE SAVEFILE) + (IF (ATOM LIST) LIST + `((MLIST SIMP) ,(CAR LIST) #+PDP10 ,LENGTH . ,(CDR LIST))))) + +#+LISPM +(DEFUN DSKSETUP (X STOREFL FASDUMPFL FN) + (LET ((*NOPOINT T) PRINLENGTH PRINLEVEL OFILE FILE + LIST FASDEQLIST FASDNONEQLIST ERROR #+PDP10 LENGTH #+PDP10 OINT) + (SETQ SAVEFILE (OPEN (NSUBSTRING (STRING (CAR X)) 1) '(:OUT :ASCII))) + (SETQ FILE (LIST (CAR X))) + (WHEN (NULL FASDUMPFL) + (PRINC ";;; -*- Mode: LISP; Package: Macsyma; -*- Saved by " SAVEFILE) + (PRINC (sys-user-id) SAVEFILE)) + (DOLIST (U X) + (COND ((ATOM U) (IF (NOT (SYMBOLP U)) (IMPROPER-ARG-ERR U FN))) + ((LISTARGP U)) + ((OR (NOT (EQ (CAAR U) 'MEQUAL)) (NOT (SYMBOLP (CADR U)))) + (IMPROPER-ARG-ERR U FN)))) + (COND (DSKSAVEP (SETQ FILELIST (CONS FILE FILELIST))) + (OFILE (SETQ FILELIST1 (CONS FILE FILELIST1)))) + (SETQ LIST (NCONS (CAR X)) X (CDR X)) + (IF (NULL (ERRSET (DSKSTORE X STOREFL FILE LIST))) (SETQ ERROR T)) + (CLOSE SAVEFILE) + '$DONE)) + +(DEFUN DSKSTORE (X STOREFL FILE LIST) + (DO ((X X (CDR X)) (VAL) (RENAME) (ITEM) + (ALRDYSTRD) (STFL STOREFL STOREFL) (NITEMFL NIL NIL)) + ((NULL X)) + (COND ((SETQ VAL (LISTARGP (CAR X))) + (SETQ X (NCONC (GETLABELS (CAR VAL) (CDR VAL) NIL) (CDR X)))) + ((SETQ VAL (ASSQ (CAR X) '(($CLABELS . $INCHAR) ($DLABELS . $OUTCHAR) + ($ELABELS . $LINECHAR)))) + (SETQ X (NCONC (GETLABELS* (EVAL (CDR VAL)) NIL) (CDR X))))) + (IF (NOT (ATOM (CAR X))) + (SETQ RENAME (CADAR X) ITEM (GETOPR (CADDAR X))) + (SETQ X (INFOLSTCHK X) ITEM (SETQ RENAME (AND X (GETOPR (CAR X)))))) + (COND ((NOT (SYMBOLP ITEM)) + (SETQ NITEMFL ITEM) + (SETQ ITEM (LET ((NITEM (GENSYM))) (SET NITEM (MEVAL ITEM)) NITEM))) + ((EQ ITEM '$RATWEIGHTS) (SETQ ITEM '*RATWEIGHTS)) + ((EQ ITEM '$TELLRATS) (SETQ ITEM 'TELLRATLIST))) + (COND + ((NULL X) (RETURN NIL)) + ((NULL (CAR X))) + ((AND (SETQ VAL (ASSQ ITEM ALRDYSTRD)) (EQ RENAME (CDR VAL)))) + ((NULL (SETQ ALRDYSTRD (CONS (CONS ITEM RENAME) ALRDYSTRD)))) + ((AND (OR (NOT (BOUNDP ITEM)) + (AND (EQ ITEM '$RATVARS) (NULL VARLIST)) + (PROG2 (SETQ VAL (SYMEVAL ITEM)) + (OR (AND (MEMQ ITEM '($WEIGHTLEVELS $DONTFACTOR)) + (NULL (CDR VAL))) + (AND (MEMQ ITEM '(TELLRATLIST *RATWEIGHTS)) (NULL VAL)) + (AND (EQ ITEM '$FEATURES) (ALIKE (CDR VAL) FEATUREL)) + (AND (EQ ITEM '$DEFAULT_LET_RULE_PACKAGE) + (EQ ITEM VAL)))) + (AND (MFILEP VAL) + (OR DSKSAVEP (NOT (UNSTOREP ITEM)) (NULL (SETQ STFL T))))) + (OR (NULL (SETQ VAL (GET ITEM 'MPROPS))) (EQUAL VAL '(NIL)) + (IF (NOT DSKSAVEP) (NOT (UNSTOREP ITEM)))) + (NOT (GETL ITEM '(OPERATORS REVERSEALIAS GRAD NOUN VERB EXPR OP DATA))) + (NOT (MEMQ ITEM (CDR $PROPS))) + (OR (NOT (MEMQ ITEM (CDR $CONTEXTS))) + (NOT (EQ ITEM '$INITIAL)) + (LET ((CONTEXT '$INITIAL)) (NULL (CDR ($FACTS '$INITIAL))))))) + (T (WHEN (AND (BOUNDP ITEM) (NOT (MFILEP (SETQ VAL (SYMEVAL ITEM))))) + (IF (EQ ITEM '$CONTEXT) (SETQ X (LIST* NIL VAL (CDR X)))) + (DSKATOM ITEM RENAME VAL) + (IF (NOT (OPTIONP RENAME)) (INFOSTORE ITEM FILE 'VALUE STFL RENAME))) + (WHEN (SETQ VAL (AND (MEMQ ITEM (CDR $ALIASES)) (GET ITEM 'REVERSEALIAS))) + (DSKDEFPROP RENAME VAL 'REVERSEALIAS) + (PRADD2LNC RENAME '$ALIASES) + (DSKDEFPROP (MAKEALIAS VAL) RENAME 'ALIAS) + (AND GREATORDER (NOT (ASSQ 'GREATORDER ALRDYSTRD)) + (SETQ X (LIST* NIL 'GREATORDER (CDR X)))) + (AND LESSORDER (NOT (ASSQ 'LESSORDER ALRDYSTRD)) + (SETQ X (LIST* NIL 'LESSORDER (CDR X)))) + (SETQ X (LIST* NIL (MAKEALIAS VAL) (CDR X)))) + (COND ((SETQ VAL (GET ITEM 'NOUN)) + (SETQ X (LIST* NIL VAL (CDR X))) + (DSKDEFPROP RENAME VAL 'NOUN)) + ((SETQ VAL (GET ITEM 'VERB)) + (SETQ X (LIST* NIL VAL (CDR X))) + (DSKDEFPROP RENAME VAL 'VERB))) + (WHEN (MGET ITEM '$RULE) + (IF (SETQ VAL (RULEOF ITEM)) + (SETQ X (LIST* NIL VAL (CDR X)))) + (PRADD2LNC (GETOP RENAME) '$RULES)) + (WHEN (AND (SETQ VAL (CADR (GETL-FUN ITEM '(EXPR)))) + (OR (MGET ITEM '$RULE) (GET ITEM 'TRANSLATED))) + #-Franz + (IF (MGET ITEM 'TRACE) + (LET (VAL1 #+PDP10 (OINT (NOINTERRUPT 'TTY))) + (REMPROP ITEM 'EXPR) + (IF (SETQ VAL1 (GET ITEM 'EXPR)) + (DSKDEFPROP RENAME VAL1 'EXPR)) + (SETPLIST ITEM (LIST* 'EXPR VAL (PLIST ITEM))) + #+PDP10 (NOINTERRUPT OINT)) + (DSKDEFPROP RENAME VAL 'EXPR)) + #+Franz (fasprin `(def ,rename ,(getd item))) + (IF (SETQ VAL (ARGS ITEM)) + (FASPRIN `(ARGS (QUOTE ,RENAME) (QUOTE ,VAL)))) + (PROPSCHK ITEM RENAME 'TRANSLATED)) + (WHEN (AND (SETQ VAL (GETL ITEM '(A-EXPR FEXPR TRANSLATED-MMACRO))) + (GET ITEM 'TRANSLATED)) + (DSKDEFPROP RENAME (CADR VAL) (CAR VAL)) + (PROPSCHK ITEM RENAME 'TRANSLATED)) + (WHEN (SETQ VAL (GET ITEM 'OPERATORS)) + (DSKDEFPROP RENAME VAL 'OPERATORS) + (WHEN (SETQ VAL (GET ITEM 'RULES)) + (DSKDEFPROP RENAME VAL 'RULES) + (SETQ X (CONS NIL (APPEND VAL (CDR X))))) + (IF (MEMQ ITEM (CDR $PROPS)) (PRADD2LNC RENAME '$PROPS)) + (SETQ VAL (MGET ITEM 'OLDRULES)) + (AND VAL (SETQ X (CONS NIL (NCONC (CDR (REVERSE VAL)) (CDR X)))))) + (IF (MEMQ ITEM (CDR $FEATURES)) (PRADD2LNC RENAME '$FEATURES)) + (WHEN (MEMQ (GETOP ITEM) (CDR $PROPS)) + (DOLIST (IND INDLIST) (PROPSCHK ITEM RENAME IND)) + (WHEN (GET (SETQ VAL (STRIPDOLLAR ITEM)) 'ALPHABET) + (DSKDEFPROP VAL T 'ALPHABET) + (PRADD2LNC (GETCHARN VAL 1) 'ALPHABET) + (PRADD2LNC ITEM '$PROPS)) + (DOLIST (OPER OPERS) (PROPSCHK ITEM RENAME OPER))) + (WHEN (AND (SETQ VAL (GET ITEM 'OP)) (MEMQ VAL (CDR $PROPS))) + (DSKDEFPROP ITEM VAL 'OP) + (DSKDEFPROP VAL ITEM 'OPR) + (PRADD2LNC VAL '$PROPS) + (IF (SETQ VAL (EXTOPCHK ITEM VAL)) + (SETQ X (LIST* NIL VAL (CDR X))))) + (WHEN (AND (SETQ VAL (GET ITEM 'GRAD)) (ASSOC (NCONS ITEM) $GRADEFS)) + (DSKDEFPROP RENAME VAL 'GRAD) + (PRADD2LNC (CONS (NCONS RENAME) (CAR VAL)) '$GRADEFS)) + (WHEN (AND (GET ITEM 'DATA) + (NOT (MEMQ ITEM (CDR $CONTEXTS))) + (SETQ VAL (CDR ($FACTS ITEM)))) + (FASPRIN `(RESTORE-FACTS (QUOTE ,VAL))) + (IF (MEMQ ITEM (CDR $PROPS)) (PRADD2LNC ITEM '$PROPS))) + (WHEN (AND (MEMQ ITEM (CDR $CONTEXTS)) + (LET ((CONTEXT ITEM)) (SETQ VAL (CDR ($FACTS ITEM))))) + (FASPRINT T `(DSKSETQ $CONTEXT (QUOTE ,ITEM))) + (IF (MEMQ ITEM (CDR $ACTIVECONTEXTS)) + (FASPRINT T `($ACTIVATE (QUOTE ,ITEM)))) + (FASPRINT T `(RESTORE-FACTS (QUOTE ,VAL)))) + (MPROPSCHK ITEM RENAME FILE STFL) + (IF (NOT (GET ITEM 'VERB)) + (NCONC LIST (NCONS (OR NITEMFL (GETOP ITEM))))))))) + +(DEFUN DSKATOM (ITEM RENAME VAL) + (COND ((EQ ITEM '$RATVARS) + (FASPRINT T `(SETQ VARLIST (APPEND VARLIST (QUOTE ,VARLIST)))) + (FASPRINT T '(SETQ $RATVARS (CONS '(MLIST SIMP) VARLIST))) + (PRADD2LNC '$RATVARS '$MYOPTIONS)) + ((MEMQ ITEM '($WEIGHTLEVELS $DONTFACTOR)) + (FASPRIN `(SETQ ,ITEM (NCONC (QUOTE ,VAL) (CDR ,ITEM)))) + (PRADD2LNC ITEM '$MYOPTIONS)) + ((EQ ITEM 'TELLRATLIST) + (FASPRIN `(SETQ TELLRATLIST (NCONC (QUOTE ,VAL) TELLRATLIST))) + (PRADD2LNC 'TELLRATLIST '$MYOPTIONS)) + ((EQ ITEM '*RATWEIGHTS) + (FASPRIN `(APPLY (FUNCTION $RATWEIGHT) (QUOTE ,(DOT2L VAL))))) + ((EQ ITEM '$FEATURES) + (DOLIST (VAR (CDR $FEATURES)) + (IF (NOT (MEMQ VAR FEATUREL)) (PRADD2LNC VAR '$FEATURES)))) + ((AND (EQ ITEM '$LINENUM) (EQ ITEM RENAME)) + (FASPRINT T `(SETQ $LINENUM ,VAL))) + ((NOT ($RATP VAL)) + (FASPRINT T (LIST 'DSKSETQ RENAME + (IF (OR (NUMBERP VAL) (MEMQ VAL '(NIL T))) + VAL + (LIST 'QUOTE VAL))))) + (T (FASPRINT T `(DSKSETQ ,RENAME (DSKRAT (QUOTE ,VAL))))))) + +(DEFUN MPROPSCHK (ITEM RENAME FILE STFL) + (DO ((PROPS (CDR (OR (GET ITEM 'MPROPS) '(NIL))) (CDDR PROPS)) (VAL)) + ((NULL PROPS)) + (COND ((OR (MEMQ (CAR PROPS) '(TRACE TRACE-TYPE TRACE-LEVEL)) + (MFILEP (SETQ VAL (CADR PROPS))) + (AND (EQ (CAR PROPS) 'T-MFEXPR) (NOT (GET ITEM 'TRANSLATED))))) + ((NOT (MEMQ (CAR PROPS) '(HASHAR ARRAY))) + (FASPRIN (LIST 'MDEFPROP RENAME VAL (CAR PROPS))) + (IF (NOT (MEMQ (CAR PROPS) '(MLEXPRP MFEXPRP T-MFEXPR))) + (INFOSTORE ITEM FILE (CAR PROPS) STFL + (COND ((MEMQ (CAR PROPS) '(MEXPR MMACRO)) + (LET ((VAL1 (ARGS ITEM))) + (IF VAL1 (FASPRIN `(ARGS (QUOTE ,RENAME) + (QUOTE ,VAL1))))) + (LET ((VAL1 (GET ITEM 'FUNCTION-MODE))) + (IF VAL1 (DSKDEFPROP RENAME + VAL1 + 'FUNCTION-MODE))) + (CONS (NCONS RENAME) (CDADR VAL))) + ((EQ (CAR PROPS) 'DEPENDS) + (CONS (NCONS RENAME) VAL)) + (T RENAME))))) + (T (DSKARY ITEM (LIST 'QUOTE RENAME) VAL (CAR PROPS)) + (INFOSTORE ITEM FILE (CAR PROPS) STFL RENAME))))) + +(DEFUN DSKARY (ITEM RENAME VAL IND) + ; Some small forms ordinarily non-EQ for fasdump must be output + ; in proper sequence with the big mungeables. + ; For this reason only they are output as EQ-forms. + (LET ((ARY (COND ((AND (EQ IND 'ARRAY) (GET ITEM 'ARRAY)) RENAME) + ; This code handles "COMPLETE" arrays. + (T (FASPRINT T '(SETQ AAAAA (GENSYM))) 'AAAAA))) + (DIMS (ARRAYDIMS VAL)) + VAL1) + (IF (EQ IND 'HASHAR) (FASPRINT T `(REMCOMPARY ,RENAME))) + (FASPRINT T `(MREMPROP ,RENAME (QUOTE ,(IF (EQ IND 'ARRAY) 'HASHAR 'ARRAY)))) + (FASPRINT T `(MPUTPROP ,RENAME ,ARY (QUOTE ,IND))) + (FASPRINT T `(*ARRAY ,ARY (QUOTE ,(CAR DIMS)) ,.(CDR DIMS))) + (FASPRINT T `(FILLARRAY ,ARY (QUOTE ,(LISTARRAY VAL)))) + (IF (SETQ VAL1 (GET ITEM 'ARRAY-MODE)) + (FASPRINT T `(DEFPROP ,(CADR RENAME) ,VAL1 ARRAY-MODE))))) + +(DEFUN EXTOPCHK (ITEM VAL) + (LET ((VAL1 (IMPLODE (CONS #/$ (CDR (EXPLODEN VAL)))))) + (WHEN (OR (GET VAL1 'NUD) (GET VAL1 'LED) (GET VAL1 'LBP)) + (FASPRIN `(DEFINE-SYMBOL (QUOTE ,VAL))) + (IF (MEMQ VAL MOPL) + (FASPRIN `(SETQ MOPL (CONS (QUOTE ,VAL) MOPL)))) + (WHEN (SETQ VAL (GET VAL1 'DIMENSION)) + (DSKDEFPROP VAL1 VAL 'DIMENSION) + (DSKDEFPROP VAL1 (GET VAL1 'DISSYM) 'DISSYM) + (DSKDEFPROP VAL1 (GET VAL1 'GRIND) 'GRIND)) + (IF (SETQ VAL (GET VAL1 'LBP)) (DSKDEFPROP VAL1 VAL 'LBP)) + (IF (SETQ VAL (GET VAL1 'RBP)) (DSKDEFPROP VAL1 VAL 'RBP)) + (IF (SETQ VAL (GET VAL1 'NUD)) (DSKDEFPROP VAL1 VAL 'NUD)) + (IF (SETQ VAL (GET VAL1 'LED)) (DSKDEFPROP VAL1 VAL 'LED)) + (WHEN (SETQ VAL (GET VAL1 'VERB)) + (DSKDEFPROP VAL (GET VAL 'DIMENSION) 'DIMENSION) + (DSKDEFPROP VAL (GET VAL 'DISSYM) 'DISSYM)) + (WHEN (SETQ VAL (GET ITEM 'MATCH)) + (DSKDEFPROP ITEM VAL 'MATCH) VAL)))) + +(DEFUN PROPSCHK (ITEM RENAME IND) + (LET ((VAL (GET ITEM IND))) + (WHEN VAL (DSKDEFPROP RENAME VAL IND) + (PRADD2LNC (GETOP RENAME) '$PROPS)))) + +(DEFUN FASPRIN (FORM) (FASPRINT NIL FORM)) + +(DEFUN FASPRINT (EQFL FORM) + (COND ((NULL FASDUMPFL) #-Franz (PRINT FORM SAVEFILE) + #+Franz (pp-form form savefile)) + (EQFL (SETQ FASDEQLIST (CONS FORM FASDEQLIST))) + (T (SETQ FASDNONEQLIST (CONS FORM FASDNONEQLIST))))) + +(DEFUN UNSTOREP (ITEM) (I-$UNSTORE (NCONS ITEM))) + +(DEFUN INFOSTORE (ITEM FILE FLAG STOREFL RENAME) + (LET ((PROP (COND ((EQ FLAG 'VALUE) + (IF (MEMQ RENAME (CDR $LABELS)) '$LABELS '$VALUES)) + ((EQ FLAG 'MEXPR) '$FUNCTIONS) + ((EQ FLAG 'MMACRO) '$MACROS) + ((MEMQ FLAG '(ARRAY HASHAR)) '$ARRAYS) + ((EQ FLAG 'DEPENDS) (SETQ STOREFL NIL) '$DEPENDENCIES) + (T (SETQ STOREFL NIL) '$PROPS)))) + (COND ((EQ PROP '$LABELS) + (FASPRIN `(ADDLABEL (QUOTE ,RENAME))) + (IF (GET ITEM 'NODISP) (DSKDEFPROP RENAME T 'NODISP))) + (T (PRADD2LNC RENAME PROP))) + (COND (STOREFL + (COND ((MEMQ FLAG '(MEXPR MMACRO)) (SETQ RENAME (CAAR RENAME))) + ((EQ FLAG 'ARRAY) (REMCOMPARY ITEM))) + (SETQ PROP (LIST '(MFILE) FILE RENAME)) + (COND ((EQ FLAG 'VALUE) (SET ITEM PROP)) + ((MEMQ FLAG '(MEXPR MMACRO AEXPR ARRAY HASHAR)) + (MPUTPROP ITEM PROP FLAG))))))) + +(DEFUN PRADD2LNC (ITEM PROP) + (IF (OR (NULL $PACKAGEFILE) (NOT (MEMQ PROP (CDR $INFOLISTS))) + (AND (EQ PROP '$PROPS) (GET ITEM 'OPR))) + (FASPRIN `(ADD2LNC (QUOTE ,ITEM) ,PROP)))) + +(DEFUN DSKDEFPROP (NAME VAL IND) + (FASPRIN (IF (AND (MEMQ IND '(EXPR FEXPR MACRO)) (EQ (CAR VAL) 'LAMBDA)) + (LIST* 'DEFUN NAME + (IF (EQ IND 'EXPR) (CDR VAL) (CONS IND (CDR VAL)))) + (LIST 'DEFPROP NAME VAL IND)))) + +(DEFUN DSKGET (FILE NAME FLAG UNSTOREP) + (LET ((DEFAULTF DEFAULTF) (EOF (LIST NIL)) ITEM (*NOPOINT T)) + (SETQ FILE (OPEN FILE '(IN ASCII))) + (SETQ ITEM (DO ((ITEM (READ FILE EOF) (READ FILE EOF))) + ((EQ ITEM EOF) (MERROR "~%~:M not found" NAME)) + (IF (OR (AND (NOT (ATOM ITEM)) (EQ (CAR ITEM) 'DSKSETQ) + (EQ FLAG 'VALUE) (EQ (CADR ITEM) NAME)) + (AND (NOT (ATOM ITEM)) (= (LENGTH ITEM) 4) + (OR (EQ (CADDDR ITEM) FLAG) + (AND (EQ (CAR (CADDDR ITEM)) 'QUOTE) + (EQ (CADR (CADDDR ITEM)) FLAG))) + (OR (EQ (CADR ITEM) NAME) + (AND (EQ (CAADR ITEM) 'QUOTE) + (EQ (CADADR ITEM) NAME))))) + (RETURN ITEM)))) + (WHEN UNSTOREP (EVAL (READ FILE)) (EVAL (READ FILE))) + (CLOSE FILE) + (CADDR ITEM))) + +(DEFUN DSKSAVE NIL + (LET ((DSKSAVEP T)) + (IF $DSKALL (I-$STORE '($LABELS $VALUES $FUNCTIONS $MACROS $ARRAYS)) + (I-$STORE '($LABELS))))) + +(DEFMSPEC $REMFILE (L) (SETQ L (CDR L)) + (IF (AND L (OR (CDR L) (NOT (MEMQ (CAR L) '($ALL $TRUE T))))) + (IMPROPER-ARG-ERR L '$REMFILE)) + (DOLIST (FILE (IF L (APPEND FILELIST1 FILELIST) FILELIST)) + (ERRSET (DELETEF FILE) NIL) + (SETQ FILELIST (DELETE FILE FILELIST 1)) + (SETQ FILELIST1 (DELETE FILE FILELIST1 1))) + '$DONE) + +(DEFMSPEC $RESTORE (FILE) (SETQ FILE (CDR FILE)) + (LET ((EOF (NCONS NIL)) (IN (OPEN (FILESTRIP FILE) '(IN ASCII)))) + (SETQ FILE (TRUENAME IN)) + (SETQ FILE (IF (ATOM FILE) FILE (APPEND (CDR FILE) (CAR FILE)))) + (DO ITEM (READ IN EOF) (READ IN EOF) (EQ ITEM EOF) + (COND ((AND (EQ (CAR ITEM) 'DSKSETQ) (NOT (OPTIONP (CADR ITEM)))) + (SET (CADR ITEM) (LIST '(MFILE) FILE (CADR ITEM)))) + ((AND (EQ (CAR ITEM) 'MDEFPROP) + (MEMQ (CADDDR ITEM) '(MEXPR MMACRO AEXPR))) + (MPUTPROP (CADR ITEM) + (LIST '(MFILE) FILE (CADR ITEM)) + (CADDDR ITEM))) + ((AND (EQ (CAR ITEM) 'MPUTPROP) + (MEMQ (CADR (CADDDR ITEM)) '(ARRAY HASHAR))) + (MPUTPROP (CADADR ITEM) + (LIST '(MFILE) FILE (CADADR ITEM)) + (CADR (CADDDR ITEM))) + (DO ITEM (READ IN) (READ IN) NIL + (IF (EQ (CAR ITEM) 'ADD2LNC) (RETURN (EVAL ITEM))))) + (T (EVAL ITEM)))) + (CLOSE IN) + (IF $CHANGE_FILEDEFAULTS (DEFAULTF FILE)) + (IF (ATOM FILE) FILE (MFILE-OUT FILE)))) diff --git a/src/jpg/medit.85 b/src/jpg/medit.85 new file mode 100644 index 00000000..965f1459 --- /dev/null +++ b/src/jpg/medit.85 @@ -0,0 +1,382 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ** + +(macsyma-module medit) + +(DECLARE (GENPREFIX ED) + (SPECIAL ST COMMAND WINDOW ^W ^S BEFORE AFTER AVANT APRES + GSTRING ^R $CURSOR REPRINT POS ERRSET ERRBREAK2 OLDST + ^HMSG EDITMSG STATE-PDL BACKRUB READING) + (*EXPR REPRINT) + (FIXNUM WINDOW AVANT APRES COUNT SCOUNT LENGTH CNT N I OTHER + (UPCASIFY FIXNUM)) + (NOTYPE (PRIN NOTYPE FIXNUM) (CHARACTER FIXNUM) (REV* FIXNUM) + (ASCII-NUMBERP FIXNUM))) + +#.(SETQ NALT #-MULTICS #\ALT #+MULTICS #/&) + +(SETQ EDITMSG #-Multics '(|In editor: (Type just to exit.)/ +| . |In editor:/ +|) + #+Multics '(|In editor: (Type just && to exit.)/ +| . |In editor:/ +|) $CURSOR '&$ WINDOW -1 *NOPOINT (SETQ IBASE (SETQ BASE (+ 5 5)))) + +(DEFUN EDIT* (AFTER) + (LET ((STATE-PDL (CONS 'EDIT STATE-PDL))) + (PROG (COMMAND STRING N BEFORE AVANT APRES SSTRING ISTRING + GSTRING COUNT FLAG ^R REPRINT POS RSSTRING RISTRING + LENGTH CLEARP GRINDP MFRP QUIETP) + (IF ^S (SETQ ^W NIL ^S NIL)) + (SETQ AVANT 0 APRES (LENGTH AFTER)) + (TERPRI) + (COND ((CAR EDITMSG) + (PRINC (CAR EDITMSG)) + (SETQ EDITMSG (CONS NIL (CDR EDITMSG)))) + (T (PRINC (CDR EDITMSG)))) + (PRINC (STRIPDOLLAR $CURSOR)) + (PRAFTER) + A (SETQ POS (CURSORPOS)) + RDLOOP + (SETQ N (LET ((READING T)) (TYI))) + (COND ((AND (NULL COMMAND) (MEMBER N '(#\SP #\NEWLINE #\TAB #/; #/$))) + (GO RDLOOP)) + ((= N #.NALT) + ;;; The EQUAL clause remains here because (CAR COMMAND) + ;;; may be NIL (and NIL is non-numeric). + (COND ((AND (EQUAL (CAR COMMAND) #.NALT) (NULL (CDR COMMAND))) + (GO EXIT)) + ((AND (EQUAL (CAR COMMAND) #.NALT) + (OR (NOT (EQUAL (CADR COMMAND) #/\)) + (AND (CDDR COMMAND) (= (CADDR COMMAND) #/\)))) + (SETQ COMMAND (NREVERSE COMMAND)) + (SETQ REPRINT NIL) (GO LOOP)))) + ((= N #\VT) (GO VT)) + ((= N #\BS) + (COND (BACKRUB (POP COMMAND) (GO RDLOOP)) + (T (PRINC ^HMSG) (GO VT)))) + ((= N #\FF) (FORMFEED) (PRTEXT) (GO VT)) + ((= N #/?) + (COND ((AND (EQUAL (CAR COMMAND) #/?) + (OR (NOT (AND (CDR COMMAND) (= (CADR COMMAND) #/\))) + (AND (CDDR COMMAND) (= (CADDR COMMAND) #/\)))) + (SETQ COMMAND NIL) (TERPRI) (GO RDLOOP)))) + ((OR (= N #\NEWLINE) (= N #\TAB))) + ((< N 32.) (SETQ REPRINT T) (GO RDLOOP)) ; Test for control chars. + ((AND (= N #/\) (PUSH N COMMAND) (PROG2 (SETQ N (TYI)) NIL))) + ((= N #\RUBOUT) (RUBOUT* COMMAND) (POP COMMAND) (GO RDLOOP))) + (PUSH N COMMAND) + (GO RDLOOP) + VT (REPRINT COMMAND (= N #\FF)) (GO RDLOOP) + LOOP (COND ((NULL COMMAND) (PRTEXT) (GO A)) + ((OR (= (SETQ N (READ1UCCH)) #.NALT) (= N #\SP) + (= N #\NEWLINE) (= N #\TAB)) + (GO LOOP))) + (SETQ COUNT 0 STRING NIL FLAG NIL CLEARP NIL GRINDP NIL MFRP NIL) + (COND ((= N #/-) (GO MINUS)) + ((ASCII-NUMBERP N) (SETQ FLAG T)) + (T (SETQ COUNT 1) (GO X))) + NUM (PUSH N STRING) + (IF (ASCII-NUMBERP (SETQ N (READ1UCCH))) (GO NUM)) + (SETQ COUNT (READLIST (NREVERSE STRING)) STRING NIL) + X1 (COND ((OR (= N #\SP) (= N #\NEWLINE) (= N #\TAB)) + (SETQ N (READ1UCCH)) (GO X1)) + ((MEMBER N '(#/B #/G #/I #/J #/P #/T #/V #/( #/) + #/[ #/] #/M #/Y #/Q #/Z)) + (TERPRI) (IF (NULL FLAG) (PRINC '-)) (GO NOGO1)) + ((AND (NULL FLAG) (PLUSP COUNT)) (GO MX)) + ((OR (PLUSP COUNT) (= N #/W))) + ((MEMBER N '(#/L #/K)) (GO MX)) + (T (GO NOGO))) + X (CASEQ N + ((#/J #/T) (GO T)) + (#/C (GO C)) + (#/R (GO R)) + (#/I (GO SI)) + (#/G (COND ((MEMBER (SETQ N (READ1UCCH)) '(#/V #/F)) + (SETQ GRINDP T) (GO Y)) + ((= N #/R) (INSERT (APPEND GSTRING NIL)) + (GO LOOP)) + (T (SETQ FLAG 'G) (GO NOGO)))) + (#/B (GO B)) + (#/P (GO LOOP)) + (#/Q (COND ((OR (NULL (CDR COMMAND)) + (AND (NULL (CDDR COMMAND)) + (MEMBER (CAR COMMAND) '(#\SP #\NEWLINE)))) + (SETQ QUIETP T) (GO EXIT)) + (T (GO NOGO)))) + (#/V (SETQ WINDOW -1) (GO LOOP)) + (#/W (SETQ WINDOW COUNT) (GO LOOP)) + ((#/D #/S #/K #/L) + (IF (= APRES 0) (GO WHAT)) + (CASEQ N + (#/D (DELETE* T (MIN COUNT APRES))) + (#/S (SETQ FLAG T) (GO SI)) + (#/K (KILL* COUNT)) + (T (LINE* COUNT))) + (GO LOOP)) + (#/Y (COND ((MEMBER (SETQ N (READ1UCCH)) '(#/V #/F)) + (GO Y)) + (T (SETQ FLAG (IF GRINDP 'G 'Y)) + (GO NOGO)))) + ((#/( #/[) (COND ((= AVANT 0) (GO WHAT)) + ((NULL (MOVE N NIL NIL)) (GO ERR))) + (GO LOOP)) + ((#/) #/]) (COND ((= APRES 0) (GO WHAT)) + ((NULL (MOVE N T NIL)) (GO ERR))) + (GO LOOP)) + (#/M (SETQ FLAG 'M) + (IF (= (SETQ N (READ1UCCH)) #/Y) + (PROG2 (SETQ CLEARP T) (GO X))) + (CASEQ N + (#/G (SETQ N #/Y GRINDP T CLEARP T) + (GO X)) + (#/F (SETQ MFRP T) (GO X)) + ((#/) #/]) (COND ((= APRES 0) (GO WHAT)) + ((NULL (MOVE N T T)) (GO ERR))) + (GO LOOP)) + ((#/( #/[) (COND ((= AVANT 0) (GO WHAT)) + ((NULL (MOVE N NIL T)) (GO ERR))) + (GO LOOP)) + (T (GO NOGO)))) + (#/Z (COND ((= (SETQ N (READ1UCCH)) #/J) (GO B)) + (T (SETQ FLAG 'Z) (GO NOGO)))) + (#/F (SETQ FLAG 'F) (IF (= (SETQ N (READ1UCCH)) #/R) + (GO FR) + (GO NOGO))) + (T (GO NOGO))) + MINUS(COND ((ASCII-NUMBERP (SETQ N (READ1UCCH))) (SETQ FLAG NIL) (GO NUM))) + (SETQ COUNT 1) + MX (CASEQ N + (#/C (GO R)) + (#/R (GO C)) + ((#/D #/S #/K #/L) + (IF (= AVANT 0) + (IF (NOT (= COUNT 0)) + (PROG2 (PRINC " +-") (GO WHAT1)))) + (CASEQ N + (#/D (DELETE* NIL (MIN COUNT AVANT))) + (#/S (SETQ FLAG NIL) (GO SI)) + (#/K (MKILL* COUNT)) + (T (MLINE COUNT))) + (GO LOOP)) + (T (PRINC " +-") (GO NOGO1))) + SI (COND ((AND (NULL (SETQ STRING (READSTRING))) + (NULL (SETQ STRING (IF (= N #/S) SSTRING ISTRING))))) + ((= N #/S) + (IF (NULL (SEARCH (SETQ SSTRING STRING) FLAG COUNT NIL)) + (GO ERR))) + (T (INSERT (REVERSE (SETQ ISTRING STRING))))) + (GO LOOP) + FR (COND ((= APRES 0) (GO WHAT)) + ((NULL (SETQ STRING (READSTRING))) + (IF (NULL RSSTRING) (GO LOOP))) + (T (SETQ RSSTRING STRING RISTRING (AND COMMAND (READSTRING))))) + (SETQ LENGTH (LENGTH RSSTRING)) + FR1 (COND ((NULL (SEARCH RSSTRING T 1 MFRP)) (IF MFRP (GO LOOP)) (GO ERR))) + (DELETE* NIL LENGTH) + (IF RISTRING (INSERT (REVERSE RISTRING))) + (IF (AND (NOT MFRP) (= (SETQ COUNT (1- COUNT)) 0)) (GO LOOP)) + (GO FR1) + C (COND ((NOT (< APRES COUNT)) (CHARACTER COUNT) (GO LOOP))) + B (IF (PLUSP APRES) (CHARACTER APRES)) + (GO LOOP) + R (COND ((NOT (< AVANT COUNT)) (REV* COUNT) (GO LOOP))) + T (IF (PLUSP AVANT) (REV* AVANT)) + (GO LOOP) + Y (COND ((NULL (YANK N CLEARP GRINDP)) (GO ERR)) (CLEARP (GO T))) + (GO LOOP) + WHAT (TERPRI) + WHAT1(IF (NOT (= COUNT 1)) (PRINC COUNT)) + (IF (MEMQ FLAG '(F M)) (PRINC FLAG)) + (TYO N) (PRINC " impossible") (GO ERR) + NOGO (TERPRI) + NOGO1(IF (NOT (= COUNT 1)) (PRINC COUNT)) + (IF CLEARP (PRINC 'M)) + (IF (MEMQ FLAG '(F Y G M Z)) (PRINC FLAG)) + (TYO N) (PRINC " incorrect command") + ERR (SETQ COMMAND NIL) (PRTEXT) (GO A) + EXIT (IF (PLUSP APRES) (CHARACTER APRES)) + (SETQ ST BEFORE) (RETURN QUIETP)))) + +;;; Read1ch returns the first character on the command-list, (the +;;; previous character, in other words). + +(DEFUN READ1CH NIL (POP COMMAND)) + +(DEFUN READ1UCCH NIL (UPCASIFY (POP COMMAND))) ; Read one upper case character + +(DEFUN PRTEXT NIL (PRBEFORE) (PRINC (STRIPDOLLAR $CURSOR)) (PRAFTER)) + +(DEFUN PRBEFORE NIL + (TERPRI) + (IF (OR (MINUSP WINDOW) (< AVANT WINDOW)) + (PRIN (REVERSE BEFORE) AVANT) + (DO ((I WINDOW (1- I)) (X1 BEFORE) (X2)) + ((= I 0) (PRIN X2 WINDOW)) + (SETQ X2 (CONS (CAR X1) X2) X1 (CDR X1))))) + +(DEFUN PRAFTER NIL + (PRIN AFTER (IF (OR (MINUSP WINDOW) (< APRES WINDOW)) APRES WINDOW)) + (TERPRI)) + +(DEFUN PRIN (X1 I) (DO I I (1- I) (= I 0) (TYO (POP X1)))) + +(DEFUN READSTRING NIL + (PROG (CHAR STRING) + LOOP (COND ((= (SETQ CHAR (READ1CH)) #/\) + (PUSH #/\ STRING) (SETQ CHAR (READ1CH))) + ((= CHAR #.NALT) (RETURN STRING)) + ((AND (MEMBER CHAR '(#/; #/$)) (NOT (EQUAL (CAR STRING) #/\))) + (PUSH #/\ STRING))) + (PUSH CHAR STRING) + (GO LOOP))) + +(DEFUN DELETE* (FLAG COUNT) + (PROG (SAVE) + (SETQ SAVE (COND (FLAG (SETQ APRES (- APRES COUNT)) AFTER) + (T (SETQ AVANT (- AVANT COUNT)) BEFORE)) + GSTRING NIL) + LOOP (SETQ GSTRING (CONS (CAR SAVE) GSTRING) SAVE (CDR SAVE)) + (COND ((PLUSP (SETQ COUNT (1- COUNT))) (GO LOOP)) + (FLAG (SETQ AFTER SAVE GSTRING (NREVERSE GSTRING))) + (T (SETQ BEFORE SAVE))) + (RETURN NIL))) + +(DEFUN YANK (N CLEARP GRINDP) + (PROG (ST ITEM) + (COND ((NULL (SETQ ST (READSTRING))) (RETURN T)) + ((AND (= N #/V) (EQUAL ST '(#/^))) + (SETQ ITEM (REVERSE OLDST)) (GO END)) + ((NULL (SETQ ITEM (PARSE2))) (RETURN NIL))) + (SETQ ITEM (CAR ITEM)) + (LET ((ERRSET 'ERRBREAK2)) + (COND ((NULL + (SETQ ITEM (ERRSET + (PROG2 (SETQ ITEM (IF (= N #/F) + (CONSFUNDEF + ITEM NIL NIL) + (STRMEVAL ITEM))) + (IF GRINDP (STRGRIND ITEM) + (MSTRING ITEM)))))) + (RETURN NIL)))) + (SETQ ITEM (CAR ITEM)) + END (IF CLEARP (SETQ BEFORE NIL AFTER NIL AVANT 0 APRES 0)) + (INSERT ITEM) + (RETURN T))) + +(DEFUN SEARCH (STRING FLAG COUNT MFRP) + (SETQ STRING (MAPCAR #'UPCASIFY STRING)) + (PROG (PROV SAVE SCOUNT LENGTH) + (SETQ LENGTH (LENGTH STRING) SCOUNT 0) + (IF FLAG (SETQ STRING (REVERSE STRING))) + START(SETQ PROV STRING SAVE (IF FLAG AFTER BEFORE)) + LOOP (COND ((NULL PROV) (IF FLAG (CHARACTER LENGTH) (REV* LENGTH)) + (IF (= (SETQ COUNT (1- COUNT)) 0) (RETURN T)) + (SETQ SCOUNT 0) (GO START)) + ((NULL SAVE) + (IF (NOT (= SCOUNT 0)) + (IF FLAG (REV* SCOUNT) (CHARACTER SCOUNT))) + (IF (NOT MFRP) (PRINC " +Search failed")) (RETURN NIL)) + ((NOT (= (CAR PROV) (UPCASIFY (CAR SAVE)))) + (IF FLAG (CHARACTER 1) (REV* 1)) + (SETQ SCOUNT (1+ SCOUNT)) (GO START))) + (SETQ PROV (CDR PROV) SAVE (CDR SAVE)) + (GO LOOP))) + +(DEFUN UPCASIFY (N) + (IF (AND (>= N #/a) (<= N #/z)) (- N #.(- #/a #/A)) N)) + +(DEFUN MOVE (N FLAG DELP) + (PROG (I SCOUNT SAVE OTHER) + (SETQ I 0 SCOUNT 1 SAVE (IF FLAG AFTER BEFORE) + OTHER (CDR (ASSOC N '((#/( . #/)) (#/[ . #/]) + (#/) . #/() (#/] . #/[))))) + LOOP (COND ((NULL SAVE) + (COND ((= I 0) (PRINC " +No ") (TYO OTHER) (PRINC "s encountered")) + (T (TERPRI) (PRINC I) + (PRINC " too few ") (TYO N) (PRINC "s"))) + (RETURN NIL)) + ((= (CAR SAVE) OTHER) (SETQ I (1+ I))) + ((= (CAR SAVE) N) + (COND ((= I 0) (TERPRI) (TYO N) + (PRINC " seen before ") + (TYO OTHER) + (RETURN NIL)) + ((= (SETQ I (1- I)) 0) + (COND (DELP (DELETE* FLAG SCOUNT)) + (FLAG (CHARACTER SCOUNT)) + (T (REV* SCOUNT))) + (RETURN T)))) + ((= (CAR SAVE) #/\) (SETQ SCOUNT (1+ SCOUNT) SAVE (CDR SAVE)))) + (SETQ SCOUNT (1+ SCOUNT) SAVE (CDR SAVE)) + (GO LOOP))) + +(DEFUN INSERT (STRING) + (PROG (SAVE) + (SETQ AVANT (+ AVANT (LENGTH STRING))) + LOOP (IF (NULL STRING) (RETURN NIL)) + (SETQ STRING (CDR (SETQ SAVE STRING)) BEFORE (RPLACD SAVE BEFORE)) + (GO LOOP))) + +(DEFUN CHARACTER (COUNT) + (PROG (SAVE) + (SETQ APRES (- APRES COUNT) AVANT (+ AVANT COUNT)) + LOOP (SETQ AFTER (CDR (SETQ SAVE AFTER)) BEFORE (RPLACD SAVE BEFORE)) + (IF (PLUSP (SETQ COUNT (1- COUNT))) (GO LOOP)) + (RETURN NIL))) + +(DEFUN REV* (COUNT) + (PROG (SAVE) + (SETQ AVANT (- AVANT COUNT) APRES (+ APRES COUNT)) + LOOP (SETQ BEFORE (CDR (SETQ SAVE BEFORE)) AFTER (RPLACD SAVE AFTER)) + (IF (PLUSP (SETQ COUNT (1- COUNT))) (GO LOOP)) + (RETURN NIL))) + +(DEFUN LINE* (COUNT) + (PROG NIL + LOOP (CHARACTER 1) + (COND ((= APRES 0)) + ((OR (NOT (= (CAR BEFORE) #\NEWLINE)) + (PLUSP (SETQ COUNT (1- COUNT)))) + (GO LOOP))) + (RETURN NIL))) + +(DEFUN KILL* (COUNT) + (PROG (N) + (SETQ GSTRING NIL) + LOOP (SETQ GSTRING (NCONC GSTRING (NCONS (SETQ N (CAR AFTER)))) + AFTER (CDR AFTER)) + (COND ((= (SETQ APRES (1- APRES)) 0)) + ((OR (NOT (= N #\NEWLINE)) (PLUSP (SETQ COUNT (1- COUNT)))) + (GO LOOP))) + (RETURN NIL))) + +(DEFUN MLINE (COUNT) + (PROG NIL + LOOP (IF (OR (= AVANT 0) + (AND (= (CAR BEFORE) #\NEWLINE) + (MINUSP (SETQ COUNT (1- COUNT))))) + (RETURN NIL)) + (REV* 1) + (GO LOOP))) + +(DEFUN MKILL* (COUNT) + (PROG NIL + (SETQ GSTRING NIL COUNT (1+ COUNT)) + LOOP (COND ((= AVANT 0)) + ((OR (NOT (= (CAR BEFORE) #\NEWLINE)) + (PLUSP (SETQ COUNT (1- COUNT)))) + (SETQ GSTRING (CONS (CAR BEFORE) GSTRING) + BEFORE (CDR BEFORE)) + (SETQ AVANT (1- AVANT)) (GO LOOP))) + (RETURN NIL))) + +; Undeclarations for the file: +(DECLARE (NOTYPE COUNT SCOUNT LENGTH CNT N I OTHER)) + \ No newline at end of file diff --git a/src/jpg/mlisp.613 b/src/jpg/mlisp.613 new file mode 100644 index 00000000..562eea61 --- /dev/null +++ b/src/jpg/mlisp.613 @@ -0,0 +1,1959 @@ +;;; -*- Mode:LISP; Package:MACSYMA; Ibase:10 -*- + +; ** (c) Copyright 1982 Massachusetts Institute of Technology ** + +(macsyma-module mlisp) + +(EVAL-WHEN (EVAL COMPILE) (SETQ OLD-IBASE IBASE IBASE 10.)) + +(DECLARE (SPECIAL MSPECLIST MPROPLIST BINDLIST LOCLIST BVARS NOUNSFLAG + NOITEMS DERIVFLAG DERIVLIST MPROGP MDOP EVP AEXPRP MLOCP $LABELS + $VALUES $FUNCTIONS $ARRAYS $RULES $GRADEFS $DEPENDENCIES $ALIASES + $MYOPTIONS $PROPS GENVAR $MAXPOSEX $MAXNEGEX $EXPOP $EXPON + $FLOAT $NUMER ARYP MSUMP STATE-PDL EVARRP $SETVAL NOUNL + $SETCHECKBREAK $REFCHECK DEBUG REFCHKL BAKTRCL MAPLP + $NOREPEAT $DETOUT $DOALLMXOPS $DOSCMXOPS OPERS FACTLIST OPEXPRP + $TRANSLATE $TRANSRUN $MAPERROR OUTARGS1 OUTARGS2 FMAPLVL MOPL + $POWERDISP $SUBSCRMAP $DISPFLAG $OPTIONSET DSKSETP FEXPRERRP + $FEATURES ALPHABET $%ENUMER $INFEVAL $SAVEDEF $%% %E-VAL + $MAPPRINT FEATUREL OUTFILES FUNDEFSIMP MFEXPRP TRANSP + SFINDEX MSPECLIST2 ENVLIST $MACROS LINEL $RATFAC $RATWTLVL + $OPERATORS NOEVALARGS $PIECE $PARTSWITCH *GCDL*) + (UNSPECIAL ARGS) + (GENPREFIX %LS) + (*EXPR RATF $FLOAT) + (*LEXPR MAP1 MMAPCAR FMAPL1 OUTERMAP1 $INPART LINEL $DIFF $INTEGRATE + $LDISP $RATVARS $RATWEIGHT) + (FIXNUM N I J NNEED NGIVEN NCELLS NITEMS LISPSUB INDX FMAPLVL EVFLG + LINEL SFINDEX (HASHER))) +; NNEED to be flushed + +(SETQ MSPECLIST NIL BINDLIST NIL LOCLIST NIL MPROPLIST NIL $%ENUMER NIL + $FLOAT NIL NOUNL NIL $REFCHECK NIL SCANMAPP NIL MAPLP NIL + MPROGP NIL EVP NIL MDOP NIL MLOCP NIL PUTL NIL + $SUBSCRMAP NIL $TRANSLATE NIL $TRANSRUN T $SAVEDEF T AEXPRP NIL + $MAPERROR T FMAPLVL 0 $OPTIONSET NIL + $SETCHECKBREAK NIL DSKSETP NIL ARYP NIL MSUMP NIL EVARRP NIL + $INFEVAL NIL FACTLIST NIL $MAPPRINT T FUNDEFSIMP NIL + MFEXPRP T NOUNSFLAG NIL OPEXPRP NIL ;$OPERATORS NIL + SFINDEX 1 MSPECLIST2 NIL ENVLIST NIL TRANSP NIL NOEVALARGS NIL + $PIECE '$PIECE $SETVAL '$SETVAL FEXPRERRP NIL + FEATUREL (PURCOPY '($INTEGER $NONINTEGER $EVEN $ODD + $RATIONAL $IRRATIONAL $REAL $IMAGINARY + $COMPLEX $ANALYTIC $INCREASING $DECREASING + $ODDFUN $EVENFUN $POSFUN $COMMUTATIVE $LASSOCIATIVE + $RASSOCIATIVE $SYMMETRIC $ANTISYMMETRIC)) + $FEATURES (CONS '(MLIST SIMP) (APPEND FEATUREL NIL))) + +;; These three variables are what get stuck in array slots as magic +;; unbound objects. They are for T, FIXNUM, and FLONUM type arrays +;; respectively. + +(DEFVAR MUNBOUND '|#####|) + +;; The most negative fixnum. Sign bit is on and all other bits are zero. +;; Assumes two's complement arithmetic. +(DEFVAR FIXUNBOUND (ROT 1 -1)) + +;; The PDP10 floating point representation is: +;; 1 bit sign, 8 bit exponent, 27 bit mantissa +;; If positive, exponent is excess 128. If negative, exponent is one's +;; complement of excess 128. +;; If positive normalized, mantissa is between 2^26 and 2^27-1. If negative, +;; two's complement. See RAT;FLOAT for more details. + +;; I think this is supposed to be the most negative flonum. It's close, +;; but not quite. The smallest is (FSC (ROT 3 -1) 0). + +#+PDP10 +(DEFVAR FLOUNBOUND (FSC (- 2 (LSH -1 -1)) 0)) + +;; H6180 floating point representation is: +;; 8 bit exponent, 1 bit sign, 27 bit mantissa +;; The 8 bit exponent is viewed as two's complement, between 2^7-1 and -2^7. +;; The 28 bit mantissa is viewed as two's complement, between -1 and 1-2^-27. +;; The most negative flonum is given below. The most positive flonum +;; is its logical complement. + +#+H6180 +(DEFVAR FLOUNBOUND (FSC (LOGIOR (LSH 1 35.) (LSH 1 27.)) 0)) + +;; Too bad there's no general way of getting the most negative flonum in +;; a relatively machine-independent manner. + +#+(OR LISPM NIL) +(DEFVAR FLOUNBOUND '*FLOUNBOUND-DOESNT-MATTER-ANYWAY*) + +(DEFMVAR MUNBINDP NIL + "Used for safely MUNBINDing incorrectly-bound variables." + NO-RESET) +(DEFMVAR $SETCHECK NIL) + +(MAPC #'(LAMBDA (X) (SET X (NCONS '(MLIST SIMP)))) + '($VALUES $FUNCTIONS $MACROS $ARRAYS $MYOPTIONS $RULES $PROPS)) + +(DEFMFUN MAPPLY (FN ARGS FNNAME) + (COND ;((AND $OPERATORS (MNUMP FN)) (MUL2 FN (CAR ARGS))) + ((ATOM FN) (SETQ FN (GETOPR FN)) (BADFUNCHK FNNAME FN NIL) + (LET ((NOEVALARGS T)) (MEVAL (CONS (NCONS FN) ARGS)))) + ((EQ (CAR FN) 'LAMBDA) (APPLY FN ARGS)) + ((AND (EQ (CAAR FN) 'MFILE) + (SETQ FN (EVAL (DSKGET (CADR FN) (CADDR FN) 'VALUE NIL))) + NIL)) + ((EQ (CAAR FN) 'LAMBDA) (MLAMBDA FN ARGS FNNAME T)) + ((EQ (CAAR FN) 'MQUOTE) (CONS (CDR FN) ARGS)) + ((AND ARYP (MEMQ (CAAR FN) '(MLIST $MATRIX))) + (IF (NOT (OR (= (LENGTH ARGS) 1) + (AND (EQ (CAAR FN) '$MATRIX) (= (LENGTH ARGS) 2)))) + (MERROR "Wrong number of indices:~%~M" (CONS '(MLIST) ARGS))) + (DO ((ARGS1 ARGS (CDR ARGS1))) + ((NULL ARGS1) (LET (($PIECE $PIECE) ($PARTSWITCH 'MAPPLY)) + (APPLY #'$INPART (CONS FN ARGS)))) + (UNLESS (EQ (TYPEP (CAR ARGS1)) 'FIXNUM) + (IF EVARRP (RETURN 'NOTEXIST)) + (MERROR "Subscript must be an integer:~%~M" (CAR ARGS1))))) + (ARYP (CONS '(MQAPPLY ARRAY) (CONS FN ARGS))) + ((MEMQ 'ARRAY (CDAR FN)) (CONS '(MQAPPLY) (CONS FN ARGS))) + (T (BADFUNCHK FNNAME FN T)))) +;( ((OR (NOT $OPERATORS) (NULL ARGS) (CDR ARGS)) (BADFUNCHK FNNAME FN T)) +; ((EQ (CAAR FN) '%DIFFOP) (APPLY #'$DIFF (CONS (CAR ARGS) (CDR FN)))) +; ((EQ (CAAR FN) '%INTEGOP) (APPLY #'$INTEGRATE (CONS (CAR ARGS) (CDR FN)))) +; ((EQ (CAAR FN) 'MNCTIMES) +; (DO L (REVERSE (CDR FN)) (CDR L) (NULL L) +; (SETQ ARGS (NCONS (MAPPLY (CAR L) ARGS FNNAME)))) +; (CAR ARGS)) +; ((AND (EQ (CAAR FN) 'MNCEXPT) (EQ (TYPEP (CADDR FN)) 'FIXNUM) (> (CADDR FN) 0)) +; (DO N (CADDR FN) (1- N) (= N 0) +; (SETQ ARGS (NCONS (MAPPLY (CADR FN) ARGS FNNAME)))) +; (CAR ARGS)) +; ((EQ (CAAR FN) 'MTIMES) +; (MULN (MAPCAR #'(LAMBDA (L) (MAPPLY L ARGS FNNAME)) (CDR FN)) NIL)) +; ((EQ (CAAR FN) 'MPLUS) +; (ADDN (MAPCAR #'(LAMBDA (L) (MAPPLY L ARGS FNNAME)) (CDR FN)) NIL)) +; (T `((MQAPPLY) ,FN . ,ARGS)) ) + +(DEFMFUN MCALL N (MAPPLY (ARG 1) (LISTIFY (- 1 N)) (ARG 1))) + +(DECLARE (MAPEX T)) ; To avoid the overuse of pdls in this highly recursive + ; part of the evaluator. + +(DEFUN MEVALARGS (ARGS) + (COND (NOEVALARGS (SETQ NOEVALARGS NIL) ARGS) (T (MAPCAR #'MEVAL ARGS)))) + +(DECLARE (MAPEX NIL)) + +(DEFUN MLAMBDA (FN ARGS FNNAME NOEVAL) + (COND ((NOT ($LISTP (CADR FN))) + (MERROR "First argument to LAMBDA must be a list:~%~M" (CADR FN)))) + (SETQ NOEVALARGS NIL) + ((LAMBDA (PARAMS MLOCP) + (SETQ LOCLIST (CONS NIL LOCLIST)) + (DO ((A) (P)) + ((OR (NULL PARAMS) (AND (NULL ARGS) (NOT (MDEFLISTP PARAMS)))) + (SETQ ARGS (NRECONC A ARGS) PARAMS (NRECONC P PARAMS))) + (COND ((MDEFLISTP PARAMS) + (SETQ PARAMS (CDAR PARAMS) ARGS (NCONS (CONS '(MLIST) ARGS))))) + (COND ((AND MFEXPRP (MQUOTEP (CAR PARAMS))) + (SETQ A (CONS (CAR ARGS) A) P (CONS (CADAR PARAMS) P))) + ((ATOM (CAR PARAMS)) + (SETQ P (CONS (CAR PARAMS) P) + A (CONS (COND (NOEVAL (CAR ARGS)) + (T (MEVAL (CAR ARGS)))) A))) + (T (MERROR "Illegal LAMBDA parameter:~%~M" (CAR PARAMS)))) + (SETQ ARGS (CDR ARGS) PARAMS (CDR PARAMS))) + (MBINDING (PARAMS ARGS FNNAME) + (PROG1 (LET ((AEXPRP (AND AEXPRP (NOT (ATOM (CADDR FN))) + (EQ (CAAR (CADDR FN)) 'LAMBDA)))) + (COND ((NULL (CDDR FN)) + (MERROR "No LAMBDA body present")) + ((CDDDR FN) (MEVALN (CDDR FN))) + (T (MEVAL (CADDR FN))))) + ;; the MUNLOCAL should be unwind-protected, I can't + ;; see how I can work it into the MBINDING macro + ;; at this time. Too bad for the losers who use it. + (MUNLOCAL)))) + (CDADR FN) T)) + +(DEFMSPEC MPROGN (FORM) (MEVALN (CDR FORM))) + +(DEFMFUN MEVALN (L) ;; called in a few places externally. + (DO ((BODY L (CDR BODY)) ($%% '$%%)) ((NULL (CDR BODY)) (MEVAL (CAR BODY))) + (SETQ $%% (MEVAL (CAR BODY))))) + +;(DEFMSPEC DOLIST (FORM) ; temporary +; (SETF (CAR FORM) '(MPROGN)) (MEVAL FORM)) + +(DEFUN MQAPPLY1 (FORM) + (LET (((FN . ARGL) (CDR FORM)) (AEXPRP)) + (COND ((NOT (MQUOTEP FN)) (SETQ FN (MEVAL FN)))) + (COND ((ATOM FN) (MEVAL (CONS (CONS FN ARYP) ARGL))) + ((EQ (CAAR FN) 'LAMBDA) + (COND (ARYP (MERROR "Improper array call")) + (T (MLAMBDA FN ARGL (CADR FORM) NOEVALARGS)))) + (T (MAPPLY FN (MEVALARGS ARGL) (CADR FORM)))))) + +(DEFMFUN MEVAL (FORM) (SIMPLIFYA (MEVAL1 FORM) NIL)) + +(DEFMFUN MEVAL1 (FORM) + (COND ((ATOM FORM) + (PROG (VAL) + (COND ((NOT (SYMBOLP FORM)) (RETURN FORM)) + ((AND $NUMER (SETQ VAL (MGET FORM '$NUMER)) + (OR (NOT (EQ FORM '$%E)) $%ENUMER)) + (RETURN (MEVAL1 VAL))) + ((NOT (BOUNDP FORM)) + (IF (GET FORM 'BINDTEST) + (MERROR "~:M unbound variable" FORM) + (RETURN FORM))) + ((MFILEP (SETQ VAL (SYMEVAL FORM))) + (SETQ VAL + (EVAL (DSKGET (CADR VAL) (CADDR VAL) 'VALUE NIL))))) + (WHEN (AND $REFCHECK (MEMQ FORM (CDR $VALUES)) + (NOT (MEMQ FORM REFCHKL))) + (SETQ REFCHKL (CONS FORM REFCHKL)) + (MTELL "~:M has value~%" FORM)) + (RETURN VAL))) + ((OR (AND (ATOM (CAR FORM)) + (SETQ FORM (CONS (NCONS (CAR FORM)) (CDR FORM)))) + (ATOM (CAAR FORM))) + (LET ((BAKTRCL BAKTRCL) TRANSP) + (PROG (U ARYP) + (COND ((EQ DEBUG '$ALL) (SETQ BAKTRCL (CONS FORM BAKTRCL)))) + (SETQ ARYP (MEMQ 'ARRAY (CDAR FORM))) + (COND ((AND (NOT OPEXPRP) (NOT ARYP) + (MEMQ (CAAR FORM) '(MPLUS MTIMES MEXPT MNCTIMES))) + (GO C)) + ((AND $SUBSCRMAP ARYP + (DO ((X (MARGS FORM) (CDR X))) + ((OR (NULL X) (MXORLISTP (CAR X))) X))) + (SETQ NOEVALARGS NIL) (RETURN (SUBGEN FORM))) + ((EQ (CAAR FORM) 'MQAPPLY) (RETURN (MQAPPLY1 FORM)))) + (BADFUNCHK (CAAR FORM) (CAAR FORM) NIL) + A (SETQ U (OR (GETL (CAAR FORM) '(NOUN)) + (AND NOUNSFLAG (EQ (GETCHAR (CAAR FORM) 1) '%) + (NOT (OR (GETL-FUN (CAAR FORM) + '(SUBR FSUBR LSUBR)) + (GETL (CAAR FORM) + '(MFEXPR* MFEXPR*S)))) + (PROG2 ($VERBIFY (CAAR FORM)) + (GETL (CAAR FORM) '(NOUN)))) + (AND (NOT ARYP) $TRANSRUN + (SETQ TRANSP + (OR (MGETL (CAAR FORM) '(T-MFEXPR)) + (GETL (CAAR FORM) + '(TRANSLATED-MMACRO))))) + (AND (NOT ARYP) + (SETQ U + (OR (MGET (CAAR FORM) 'TRACE) + (AND $TRANSRUN + (GET (CAAR FORM) 'TRANSLATED) + (NOT (MGET (CAAR FORM) + 'LOCAL-FUN)) + (SETQ TRANSP T) (CAAR FORM)))) + (GETL-FUN U '(EXPR SUBR LSUBR))) + (COND (ARYP (MGETL (CAAR FORM) '(HASHAR ARRAY))) + ((MGETL (CAAR FORM) '(MEXPR MMACRO))) + ((MGETL (CAAR FORM) '(T-MFEXPR))) + (T (OR (GETL (CAAR FORM) + '(MFEXPR* MFEXPR*S)) + (GETL-FUN (CAAR FORM) + '(SUBR FSUBR EXPR FEXPR + LSUBR))))))) + (COND ((NULL U) (GO B)) + ((AND (MEMQ (CAR U) '(MEXPR MMACRO)) (MFILEP (CADR U))) + (SETQ U (LIST (CAR U) + (DSKGET (CADADR U) (CAR (CDDADR U)) + (CAR U) NIL)))) + ((AND (MEMQ (CAR U) '(ARRAY HASHAR)) (MFILEP (CADR U))) + (I-$UNSTORE (NCONS (CAAR FORM))) + (RETURN (MEVAL1 FORM)))) + (RETURN + (COND ((EQ (CAR U) 'HASHAR) + (HARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM))))) + ((MEMQ (CAR U) '(FEXPR FSUBR)) + (IF FEXPRERRP + (MERROR "Attempt to call ~A ~A from MACSYMA level.~ + ~%Send a bug note." + (CAR U) (CAAR FORM))) + (SETQ NOEVALARGS NIL) (APPLY (CAAR FORM) (CDR FORM))) + ((OR (AND (EQ (CAR U) 'SUBR) + (PROG2 (MARGCHK (CAAR FORM) (CDR FORM)) T)) + (EQ (CAR U) 'LSUBR)) +; ((MEMQ (CAR U) '(SUBR LSUBR)) +; (MARGCHK (CAAR FORM) (CDR FORM))) + (APPLY (CAAR FORM) (MEVALARGS (CDR FORM)))) + ((EQ (CAR U) 'NOUN) +; (MARGCHK (CAAR FORM) (CDR FORM)) + (COND ((OR (MEMQ (CAAR FORM) NOUNL) NOUNSFLAG) + (SETQ FORM (CONS (CONS (CADR U) (CDAR FORM)) + (CDR FORM))) + (GO A)) + (ARYP (GO B)) + ((MEMQ (CAAR FORM) '(%SUM %PRODUCT)) + (SETQ U (DO%SUM (CDR FORM) (CAAR FORM)) + NOEVALARGS NIL) + (CONS (NCONS (CAAR FORM)) U)) + (T (MEVAL2 (MEVALARGS (CDR FORM)) FORM)))) + ((EQ (CAR U) 'ARRAY) + (ARRFIND (CONS (CAR FORM) (MEVALARGS (CDR FORM))))) + ((EQ (CAR U) 'MEXPR) + (MLAMBDA (CADR U) (CDR FORM) (CAAR FORM) NOEVALARGS)) + ((MEMQ (CAR U) '(MMACRO TRANSLATED-MMACRO)) + (SETQ NOEVALARGS NIL) + (MEVAL (MMACRO-APPLY (CADR U) FORM))) + ((EQ (CAR U) 'MFEXPR*) + (SETQ NOEVALARGS NIL) (APPLY (CADR U) (NCONS FORM))) + #+Maclisp + ((EQ (CAR U) 'MFEXPR*S) + (SETQ NOEVALARGS NIL) + ;; use macsyma Trace if you want to trace this call. + (SUBRCALL T (CADR U) FORM)) + ((EQ (CAR U) 'T-MFEXPR) (APPLY (CADR U) (CDR FORM))) + (T (MARGCHK (CAAR FORM) (CDR FORM)) + (APPLY (CADR U) (MEVALARGS (CDR FORM)))))) + B #+(OR PDP10 Multics Franz) + (IF (AND (NOT ARYP) (LOAD-FUNCTION (CAAR FORM) T)) (GO A)) + (BADFUNCHK (CAAR FORM) (CAAR FORM) NIL) + (IF (EQ (TYPEP (CAAR FORM)) 'SYMBOL) + (SETQ U (BOUNDP (CAAR FORM))) + (RETURN (MEVAL1-EXTEND FORM))) + C (COND ((OR (NULL U) + (AND (GET (CAAR FORM) 'OPERATORS) (NOT ARYP)) + (EQ (CAAR FORM) (SETQ U (SYMEVAL (CAAR FORM))))) + (SETQ FORM (MEVAL2 (MEVALARGS (CDR FORM)) FORM)) + (RETURN (OR (AND (MGET (CAAR FORM) 'ATVALUES) + (AT1 FORM)) FORM))) + ((AND ARYP (GET (CAAR FORM) 'NONARRAY)) + (RETURN (CONS (CONS (CAAR FORM) ARYP) + (MEVALARGS (CDR FORM))))) + ((ATOM U) + (BADFUNCHK (CAAR FORM) U NIL) + (SETQ FORM (CONS (CONS (GETOPR U) ARYP) (CDR FORM))) + (GO A)) + ((EQ (CAAR U) 'LAMBDA) + (IF ARYP + (MERROR "Improper array call") + (RETURN (MLAMBDA U (CDR FORM) + (CAAR FORM) NOEVALARGS)))) + (T (RETURN (MAPPLY U (MEVALARGS (CDR FORM)) + (CAAR FORM)))))))) + (T (MAPPLY (CAAR FORM) (MEVALARGS (CDR FORM)) (CAAR FORM))))) + +;; This function substitutes for the use of GETL on the +;; EXPR, FEXPR, MACRO, SUBR, FSUBR, LSUBR, or ARRAY property. +;; Note: This function used to be incompatible with GETL simply +;; to save two conses per function call in MEVAL, but considering +;; the amount of consing going on elsewere (e.g. the variable binding!) +;; and considering the #+LISPM grossness this introduced, it was +;; a bad idea. N.B. If you want efficiency in macsyma evaluation +;; use the Macsyma->lisp translator. -gjc +;; DEFICIENCIES: Functions with some args "E and some args not +;; will fail unless MEVAL is changed to call fexprs by (EVAL `(,FOO ,@L)) +;; instead of (APPLY FOO L). However: Officially everything uses +;; DEFMSPEC now, there are no fexprs. +;;; **** This should be rewritten to use the new function FUNCTIONP. **** + +#+LISPM +(DEFUN GETL-LM-FCN-PROP (SYM PROPS) + (PROG (FN RPROP ARGS-INFO) + (SETQ RPROP + (AND (FBOUNDP SYM) + (SELECT (%DATA-TYPE (SETQ FN (FSYMEVAL SYM))) + (DTP-SYMBOL (RETURN (GETL-LM-FCN-PROP FN PROPS))) + (DTP-LIST (COND ((MEMQ (CAR FN) '(MACRO SUBST)) + 'MACRO FN) + ((EQ (CAR FN) 'NAMED-LAMBDA) + (IF (MEMQ '"E (CADDR FN)) + 'FEXPR 'EXPR)) + ((EQ (CAR FN) 'LAMBDA) + (IF (MEMQ '"E (CADR FN)) 'FEXPR 'EXPR)) + (T (FERROR () "Unknown definition of ~S -- ~S" + SYM FN)))) + (DTP-ARRAY-POINTER 'ARRAY) + ((DTP-FEF-POINTER DTP-U-ENTRY) + (SETQ ARGS-INFO (%ARGS-INFO FN)) + (COND ((BIT-TEST (+ %ARG-DESC-QUOTED-REST + %ARG-DESC-FEF-QUOTE-HAIR) + ARGS-INFO) + 'FSUBR) + ((NOT (= (LDB %%ARG-DESC-MIN-ARGS ARGS-INFO) + (LDB %%ARG-DESC-MAX-ARGS ARGS-INFO))) + 'LSUBR) + (T 'SUBR))) + (T (FERROR () "Unknown object in function cell of ~S -- ~S" + SYM FN))))) + (RETURN (AND RPROP + (MEMQ RPROP PROPS) + (LIST RPROP FN))))) + +#+NIL +(DEFUN GETL-NIL-FCN-PROP (SYM PROPS) + (IF (FBOUNDP SYM) + (LET* ((F (FSYMEVAL SYM)) + (PROP (IF (ATOM F) + (IF (EQ (TYPE-OF F) 'SUBR) 'SUBR 'EXPR) + (CAR F)))) + (IF (MEMQ PROP PROPS) + (LIST PROP F))))) + +(DEFMFUN MEVAL2 (NEWARGS OLD) + (LET ((NEW (CONS (CAR OLD) NEWARGS)) NOSIMP) + (COND ((NOT (MEMQ 'SIMP (CDAR OLD))) + (IF (AND (NOT (EQ (CAAR NEW) 'MLIST)) (EQUAL NEW OLD)) OLD NEW)) + ((PROG2 (SETQ NOSIMP (NOT (GET (CAAR NEW) 'OPERATORS))) (ALIKE1 NEW OLD)) + (IF NOSIMP OLD (CONS (DELSIMP (CAR OLD)) (CDR OLD)))) + (NOSIMP (IF ARYP NEW (CONS (CONS (CAAR NEW) '(SIMP)) NEWARGS))) + (T (CONS (CONS (CAAR NEW) ARYP) NEWARGS))))) + +(DEFUN MPARAMS (VARS) + (MAPCAR #'(LAMBDA (X) (COND ((ATOM X) X) + ((ATOM (CADR X)) (CADR X)) + (T (CADADR X)))) + (CDR VARS))) + +(DEFMFUN MOP (FORM) (IF (EQ (CAAR FORM) 'MQAPPLY) (CADR FORM) (CAAR FORM))) + +(DEFMFUN MARGS (FORM) (IF (EQ (CAAR FORM) 'MQAPPLY) (CDDR FORM) (CDR FORM))) + +(DEFUN BADFUNCHK (NAME VAL FLAG) + (IF (OR FLAG (NUMBERP VAL) (MEMQ VAL '(T NIL $%E $%PI $%I))) +; (OR FLAG (AND (NOT $OPERATORS) +; (OR (NUMBERP VAL) (MEMQ VAL '(T NIL $%E $%PI $%I))))) + (IF (AND (ATOM NAME) (NOT (EQUAL VAL NAME))) + (MERROR "~:M evaluates to ~M~ + ~%Improper name or value in functional position." + NAME VAL) + (MERROR "Improper name or value in functional position:~%~M" + VAL)))) + +#+MacLisp +(DEFUN MARGCHK (FN ARGS) + (LET (EXPR) + (OR (NOT (OR (SETQ EXPR (GET FN 'EXPR)) (GET FN 'SUBR))) + (NOT (ARGS FN)) + (CAR (ARGS FN)) + (LET ((NNEED (CDR (ARGS FN))) (NGIVEN (LENGTH ARGS))) + (WHEN (NOT (= NNEED NGIVEN)) + (IF (AND EXPR (NOT (MGET FN 'TRACE)) + (OR (NULL (CADR EXPR)) (NOT (ATOM (CADR EXPR))))) + (SETQ FN (CONS (NCONS FN) (CADR EXPR)))) + (MERROR "Too ~M arguments supplied to ~M:~%~M" + (IF (< NNEED NGIVEN) '|&many| '|&few|) + FN + (CONS '(MLIST) ARGS))))))) +#+Franz +(DEFUN MARGCHK (FN ARGS) + (LET (EXPR argdesc) + (OR (not (symbolp fn)) + (NOT (getd fn)) + (null (setq argdesc (car (get fn 'fcn-info)))) + (LET ((NNEED (car argdesc)) (NGIVEN (LENGTH ARGS))) + (cond ((NOT (= NNEED NGIVEN)) + (MERROR "Too ~M arguments supplied to ~M:~%~M" + (cond ((< NNEED NGIVEN) '|&many|) + (t '|&few|)) + FN + (CONS '(MLIST) ARGS)))))))) +#+LISPM +(DEFUN MARGCHK (FN ARGS &AUX ARG-DESC MIN-NARGS MAX-NARGS ACTUAL-NARGS) + (AND (SYMBOLP FN) + (FBOUNDP FN) + (PROGN (SETQ ARG-DESC (ARGS-INFO FN) + MIN-NARGS (LDB %%ARG-DESC-MIN-ARGS ARG-DESC) + MAX-NARGS (LDB %%ARG-DESC-MAX-ARGS ARG-DESC) + ACTUAL-NARGS (LENGTH ARGS)) + (OR (< ACTUAL-NARGS MIN-NARGS) + (AND (ZEROP (LOGAND (+ %ARG-DESC-QUOTED-REST %ARG-DESC-EVALED-REST) + ARG-DESC)) ; has a rest argument means + (> ACTUAL-NARGS MAX-NARGS)))) ; don't check max args. + (MERROR "Too ~M arguments supplied to ~M:~%~M" + (IF (< ACTUAL-NARGS MIN-NARGS) '|&few| '|&many|) + `((,FN) ,@(ARGLIST FN)) + `((MLIST) ,@ARGS)))) + +#+NIL +(DEFUN MARGCHK (FN ARGS) ()) + + +(DEFMFUN MBIND (LAMVARS FNARGS FNNAME) + (DO ((VARS LAMVARS (CDR VARS)) (ARGS FNARGS (CDR ARGS))) + ((COND ((AND VARS ARGS) NIL) + ((AND (NULL VARS) (NULL ARGS))) + (T (MERROR "Too ~M arguments supplied to ~M:~%~M" + (IF VARS '|&few| '|&many|) + (IF FNNAME (CONS (NCONS FNNAME) LAMVARS) + '|&a function|) + (CONS '(MLIST) FNARGS))))) + (LET ((VAR (CAR VARS))) + (IF (NOT (SYMBOLP VAR)) + (MERROR "Only symbolic atoms can be bound:~%~M" VAR)) + (SETQ BINDLIST (CONS VAR BINDLIST)) + (SETQ MSPECLIST (CONS (IF (BOUNDP VAR) (SYMEVAL VAR) MUNBOUND) + MSPECLIST)) + (MSET VAR (CAR ARGS))))) + +(DEFMFUN MUNBIND (VARS) + (DOLIST (VAR (REVERSE VARS)) + (COND ((EQ (CAR MSPECLIST) MUNBOUND) + (MAKUNBOUND VAR) (DELQ VAR $VALUES 1)) + (T (LET ((MUNBINDP T)) (MSET VAR (CAR MSPECLIST))))) + (SETQ MSPECLIST (CDR MSPECLIST) BINDLIST (CDR BINDLIST)))) + +(DEFMSPEC $LOCAL (L) (SETQ L (CDR L)) + (IF (NOT MLOCP) (MERROR "Improper call to LOCAL")) + (NOINTERRUPT 'TTY) + (DOLIST (VAR L) + (COND ((NOT (ATOM VAR)) + (NOINTERRUPT NIL) (IMPROPER-ARG-ERR VAR '$LOCAL)) + ((AND (MGET VAR 'ARRAY) + #+MacLisp (GET VAR 'ARRAY) + #+LISPM (AND (FBOUNDP VAR) (ARRAYP (FSYMEVAL VAR)))) + (NOINTERRUPT NIL) + (MERROR "Attempt to bind a complete array ~M" VAR))) + (SETQ MPROPLIST (CONS (GET VAR 'MPROPS) MPROPLIST) + FACTLIST (CONS (GET VAR 'DATA) FACTLIST)) + (DOLIST (FACT (CAR FACTLIST)) (PUTPROP FACT -1 'ULABS)) + (DELETE (ASSOC (NCONS VAR) $FUNCTIONS) $FUNCTIONS 1) + (DELETE (ASSOC (NCONS VAR) $MACROS) $MACROS 1) + (DELETE (ASSOC (NCONS VAR) $DEPENDENCIES) $DEPENDENCIES 1) + (DELQ VAR $ARRAYS 1) + (REMPROP VAR 'MPROPS) + (REMPROP VAR 'DATA)) + (RPLACA LOCLIST (REVERSE L)) + (SETQ MLOCP NIL) + (NOINTERRUPT NIL) + '$DONE) + +(DEFMSPEC MLOCAL (L) + (SETQ LOCLIST (CONS NIL LOCLIST)) + (LET ((MLOCP T)) (MEVAL `(($LOCAL) ,@(CDR L))))) + +(DEFUN MUNLOCAL NIL + (NOINTERRUPT 'TTY) + (DOLIST (VAR (CAR LOCLIST)) + ((LAMBDA (MPROP Y FACT) + (REMCOMPARY VAR) + (CPUT VAR MPROP 'MPROPS) + (COND ((SETQ Y (GET MPROP 'MEXPR)) + (ADD2LNC (CONS (NCONS VAR) (CDADR Y)) $FUNCTIONS)) + (T (DELETE (ASSOC (NCONS VAR) $FUNCTIONS) $FUNCTIONS 1))) + (COND ((SETQ Y (GET MPROP 'MMACRO)) + (ADD2LNC (CONS (NCONS VAR) (CDADR Y)) $MACROS)) + (T (DELETE (ASSOC (NCONS VAR) $MACROS) $MACROS 1))) + (COND ((OR (GET MPROP 'ARRAY) (GET MPROP 'HASHAR)) + (ADD2LNC VAR $ARRAYS)) + (T (DELQ VAR $ARRAYS 1))) + (COND ((SETQ Y (GET MPROP 'DEPENDS)) + (ADD2LNC (CONS (NCONS VAR) Y) $DEPENDENCIES)) + (T (DELETE (ASSOC (NCONS VAR) $DEPENDENCIES) $DEPENDENCIES 1))) + (REMPROPCHK VAR) + (MAPC #'REMOV (GET VAR 'DATA)) + (CPUT VAR FACT 'DATA) + (DOLIST (U FACT) (REMPROP U 'ULABS)) + (SETQ MPROPLIST (CDR MPROPLIST) FACTLIST (CDR FACTLIST))) + (CAR MPROPLIST) NIL (CAR FACTLIST))) + (SETQ LOCLIST (CDR LOCLIST)) + (NOINTERRUPT NIL)) + +(DEFMSPEC MSETQ (L) + (TWOARGCHECK L) + (MSET (SIMPLIFYA (CADR L) NIL) (MEVAL (CADDR L)))) + +(PROGN (DEFUN MSETQ MACRO (L) (LIST 'MSET (LIST 'QUOTE (CADR L)) (CADDR L)))) + ; A "run-time macro" needed by MATCOM/MATRUN. + +(DEFMFUN MSET (X Y) + (PROG NIL + (COND ((OR (NULL $SETCHECK) (EQ $SETCHECK '$SETCHECK))) + ((AND (OR (ATOM $SETCHECK) (MEMALIKE X (CDR $SETCHECK)) + (AND (NOT (ATOM X)) (MEMALIKE (CAAR X) (CDR $SETCHECK)))) + (NOT (EQ X Y))) + (DISPLA (LIST '(MTEXT) (DISP2 X) '| set to | Y)) + (IF $SETCHECKBREAK (LET (($SETVAL Y)) (MERRBREAK T) (SETQ Y $SETVAL))))) + (COND ((ATOM X) + (WHEN (OR (NOT (SYMBOLP X)) (MEMQ X '(T NIL)) (MGET X '$NUMER) + (= (GETCHARN X 1) #/&)) + (IF MUNBINDP (RETURN NIL)) + (IF (MGET X '$NUMER) + (MERROR + "~:M improper value assignment to a numerical quantity" X) + (MERROR "~:M improper value assignment" X))) + (LET ((F (GET X 'ASSIGN))) + (IF (AND F (OR (NOT (EQ X Y)) (MEMQ F '(NEVERSET READ-ONLY-ASSIGN)))) + (IF (EQ (FUNCALL F X Y) 'MUNBINDP) (RETURN NIL)))) + (COND ((AND (NOT (BOUNDP X)) (NOT DSKSETP)) (ADD2LNC X $VALUES)) + ((AND (NOT (EQ X Y)) (OPTIONP X)) + (IF $OPTIONSET (MTELL "~:M option is being set.~%" X)) + (IF (NOT (EQ X '$LINENUM)) (ADD2LNC X $MYOPTIONS)))) + (RETURN (SET X Y))) + ((MEMQ 'ARRAY (CDAR X)) (RETURN (ARRSTORE X Y))) + ((AND $SUBSCRMAP (MEMQ (CAAR X) '(MLIST $MATRIX))) + (RETURN (OUTERMAP1 'MSET X Y))) + (T (MERROR "Improper value assignment:~%~M" X))))) + +(DEFMSPEC $EV (L) (SETQ L (CDR L)) + ((LAMBDA (EVP NOUNL $FLOAT $NUMER $EXPOP $EXPON $DOALLMXOPS $DOSCMXOPS + DERIVFLAG $DETOUT NOUNSFLAG) + (IF (AND (CDR L) (NULL (CDDR L)) (EQ (CAR L) '$%E) (EQ (CADR L) '$NUMER)) + (SETQ L (APPEND L '($%ENUMER)))) + (DO ((L (CDR L) (CDR L)) (BNDVARS) (BNDVALS) (LOCVARS) (EXP (CAR L)) + (SUBSL) (EVFLG 0) (RATF) (DERIVLIST) (EVFUNL) (FUNCL) (PREDFLG) + (NOEVAL (MEMQ '$NOEVAL (CDR L)))) + ((NULL L) + (MBINDING (BNDVARS BNDVARS) + (MEVAL `((MLOCAL) ,@LOCVARS)) + (LET ($TRANSLATE) (MAPC #'MEVAL1 FUNCL)) + (LET ($NUMER) (SETQ EXP (MEVALATOMS EXP))) + (IF ($RATP EXP) (SETQ RATF T EXP ($RATDISREP EXP))) + (IF (SPECREPP EXP) (SETQ EXP (SPECDISREP EXP))) + (WHEN SUBSL + (SETQ EXP (SIMPLIFY EXP)) + (DOLIST (ITEM SUBSL) + (SETQ EXP (SUBSTITUTE (MEVAL (CAR ITEM)) + (MEVAL (CDR ITEM)) + EXP))))) + (MBINDING (BNDVARS BNDVALS) + (IF (AND $NUMER NOEVAL $%ENUMER) + (SETQ EXP (SUBSTITUTE %E-VAL '$%E EXP))) + (SETQ EXP (IF NOEVAL + (RESIMPLIFY EXP) + (SIMPLIFY (IF PREDFLG (MEVALP EXP) (MEVAL1 EXP))))) + (IF (OR (> EVFLG 0) $INFEVAL) + (PROG (EXP1) + (SETQ EXP (SPECREPCHECK EXP)) + LOOP (DO ((L EVFUNL (CDR L)) (EXP2 EXP)) + ((NULL L) (SETQ EXP1 (MEVAL EXP2))) + (SETQ EXP2 (LIST (NCONS (CAR L)) EXP2))) + (DOLIST (ITEM SUBSL) + (SETQ EXP1 (SUBSTITUTE (MEVAL (CAR ITEM)) + (MEVAL (CDR ITEM)) + EXP1))) + (COND ((OR (AND (NOT $INFEVAL) + (= (SETQ EVFLG (1- EVFLG)) 0)) + (PROG2 (SETQ EXP1 (SPECREPCHECK EXP1)) + (ALIKE1 EXP EXP1))) + (SETQ EXP EXP1)) + (T (SETQ EXP EXP1) (GO LOOP))))) + (IF (AND RATF (NOT $NUMER) (NOT $FLOAT)) + (SETQ EXP (LET ($NOREPEAT) (RATF EXP))))) + (MUNLOCAL) + EXP) + (IF (NOT (OR (ATOM (CAR L)) + (MEMQ 'ARRAY (CDAAR L)) + (MEMQ (CAAAR L) '(MQUOTE MSETQ MLIST MEQUAL MDEFINE + MDEFMACRO $EXPAND $LOCAL $DERIVLIST)))) + (SETQ L (CONS (MEVAL (CAR L)) (CDR L)))) + (COND ((OR (ATOM (CAR L)) (MEMQ 'ARRAY (CDAAR L)) (EQ (CAAAR L) 'MQUOTE)) + (OR (AND (SYMBOLP (CAR L)) + (COND ((EQ (CAR L) '$EVAL) (SETQ EVFLG (1+ EVFLG))) + ((MEMQ (CAR L) '($NOEVAL $RESCAN))) + ((EQ (CAR L) '$DETOUT) + (SETQ $DOALLMXOPS NIL $DOSCMXOPS NIL $DETOUT T)) + ((EQ (CAR L) '$NUMER) (SETQ $NUMER T $FLOAT T)) + ((EQ (CAR L) '$NOUNS) (SETQ NOUNSFLAG T)) + ((EQ (CAR L) '$PRED) (SETQ PREDFLG T)) + ((EQ (CAR L) '$EXPAND) + (SETQ $EXPOP $MAXPOSEX $EXPON $MAXNEGEX)) + ((EQ (CAR L) '%DERIVATIVE) + (SETQ DERIVFLAG T DERIVLIST NIL)) + ((GET (CAR L) 'EVFLAG) + (SETQ BNDVARS (CONS (CAR L) BNDVARS) + BNDVALS (CONS (GET (CAR L) 'EVFLAG) BNDVALS))) + ((GET (CAR L) 'EVFUN) + (SETQ EXP (EVFUNMAKE (CAR L) EXP) + EVFUNL (NCONC EVFUNL (NCONS (CAR L))))))) + (LET ((FL (MEVAL (CAR L)))) + (COND ((SYMBOLP FL) + (COND ((EQ FL '$DIFF) + (SETQ L (LIST* NIL '$DEL (CDR L)))) + ((EQ FL '$RISCH) + (SETQ L (LIST* NIL '$INTEGRATE (CDR L))))) + (SETQ NOUNL (CONS ($NOUNIFY FL) NOUNL))) + ((NUMBERP FL) (IMPROPER-ARG-ERR (CAR L) '$EV)) + ((EQ (CAAR FL) 'MLIST) + (SETQ L (APPEND FL (CDR L)))) + ((MEMQ (CAAR FL) '(MSETQ MEQUAL MDEFINE MDEFMACRO)) + (SETQ L (CONS NIL (CONS FL (CDR L))))) + (T (IMPROPER-ARG-ERR (CAR L) '$EV)))))) + ((NOT (MEMQ (CAAAR L) '(MSETQ MLIST MEQUAL MDEFINE MDEFMACRO + $EXPAND $LOCAL $DERIVLIST))) + (IMPROPER-ARG-ERR (CAR L) '$EV)) + ((EQ (CAAAR L) '$EXPAND) + (COND ((NULL (CDAR L)) (SETQ $EXPOP $MAXPOSEX $EXPON $MAXNEGEX)) + ((NULL (CDDAR L)) (SETQ $EXPOP (CADAR L) $EXPON $MAXNEGEX)) + (T (SETQ $EXPOP (CADAR L) $EXPON (CADDAR L))))) + ((MEMQ (CAAAR L) '(MDEFINE MDEFMACRO)) + (SETQ FUNCL (NCONC FUNCL (NCONS (CAR L))) + LOCVARS (APPEND LOCVARS + (NCONS (LET ((FUN (CADAR L))) + (IF (EQ (CAAR FUN) 'MQAPPLY) + (SETQ FUN (CADR FUN))) + ($VERBIFY (CAAR FUN))))))) + ((EQ (CAAAR L) '$LOCAL) (SETQ LOCVARS (APPEND LOCVARS (CDAR L)))) + ((EQ (CAAAR L) '$DERIVLIST) (SETQ DERIVFLAG T DERIVLIST (CDAR L))) + ((MEMQ (CAAAR L) '(MSETQ MEQUAL)) + (IF (AND (MSETQP (CAR L)) (MSETQP (CADDAR L))) + (SETQ L (NCONC (/:SPREAD (CAR L)) (CDR L)))) + (IF (OR NOEVAL (NOT (ATOM (CADAR L)))) + (SETQ SUBSL (NCONC SUBSL (LIST (CONS (CADDAR L) (CADAR L)))))) + (IF (ATOM (CADAR L)) + (SETQ BNDVARS (CONS (CADAR L) BNDVARS) + BNDVALS (CONS (MEVAL (SPECREPCHECK (CADDAR L))) BNDVALS)))) + (T (SETQ L (APPEND (CAR L) (CDR L))))))) + T NOUNL $FLOAT $NUMER $EXPOP $EXPON $DOALLMXOPS $DOSCMXOPS DERIVFLAG + $DETOUT NOUNSFLAG)) + +(DEFMFUN MEVALATOMS (EXP) + (COND ((ATOM EXP) (MEVAL1 EXP)) + ((MEMQ 'ARRAY (CDAR EXP)) + (LET ((EVARRP T) EXP1) + (SETQ EXP1 (MEVAL1 EXP)) + (IF (OR (EQ EXP1 'NOTEXIST) (AND (NOT (ATOM EXP1)) (EQ (CAAR EXP1) 'NOTEXIST))) + (CONS (CAR EXP) (MAPCAR #'MEVALATOMS (CDR EXP))) + EXP1))) + ((EQ (CAAR EXP) 'MQUOTE) (CADR EXP)) + ((MEMQ (CAAR EXP) '(MSETQ $DEFINE)) + (LIST (CAR EXP) (CADR EXP) (MEVALATOMS (CADDR EXP)))) + ((OR (AND (EQ (CAAR EXP) '$EV) + (CDR EXP) + (OR (NULL (CDDR EXP)) (EQUAL (CDDR EXP) '($EVAL)))) + (EQ (CAAR EXP) 'MPROGN)) + (CONS (CAR EXP) (CONS (MEVALATOMS (CADR EXP)) (CDDR EXP)))) + ((MEMQ (CAAR EXP) '($SUM $PRODUCT %SUM %PRODUCT)) + (IF MSUMP + (MEVAL EXP) + (LIST (CAR EXP) (CADR EXP) (CADDR EXP) + (MEVALATOMS (CADDDR EXP)) (MEVALATOMS (CAR (CDDDDR EXP)))))) + ((AND (OR (GETL-FUN (CAAR EXP) '(FSUBR FEXPR)) + (GETL (CAAR EXP) '(MFEXPR* MFEXPR*S))) + (NOT (GET (CAAR EXP) 'EVOK))) + EXP) + ((MGETL (CAAR EXP) '(MFEXPRP T-MFEXPR)) + (CONS (CAR EXP) + (DO ((A (OR (CDR (MGET (CAAR EXP) 'T-MFEXPR)) + (CDADR (MGET (CAAR EXP) 'MEXPR))) + (CDR A)) + (B (CDR EXP) (CDR B)) (L)) + ((NOT (AND A B)) (NREVERSE L)) + (COND ((MDEFLISTP A) + (RETURN (NRECONC L (IF (MQUOTEP (CADAR A)) + B + (MAPCAR #'MEVALATOMS B))))) + ((MQUOTEP (CAR A)) (SETQ L (CONS (CAR B) L))) + (T (SETQ L (CONS (MEVALATOMS (CAR B)) L))))))) + ((OR (EQ (CAAR EXP) 'MMACROEXPANDED) + (AND $TRANSRUN (GET (CAAR EXP) 'TRANSLATED-MMACRO)) + (MGET (CAAR EXP) 'MMACRO)) + (MEVALATOMS (MMACROEXPAND EXP))) + (T (CONS (CAR EXP) (MAPCAR #'MEVALATOMS (CDR EXP)))))) + +(PROG1 '(EVOK properties) + (MAPC #'(LAMBDA (X) (PUTPROP X T 'EVOK)) + '($MAP $MAPLIST $FULLMAP $MATRIXMAP $FULLMAPL $OUTERMAP $SCANMAP + $APPLY))) + +(DEFUN EVFUNMAKE (FUN EXP) + (IF (MSETQP EXP) + (LIST (CAR EXP) (CADR EXP) (EVFUNMAKE FUN (CADDR EXP))) + (LIST (NCONS FUN) EXP))) + +(DEFUN /:SPREAD (X) + (DO ((VAL (DO X X (CADDR X) NIL + (IF (NOT (MSETQP (CADDR X))) (RETURN (CADDR X))))) + (X X (CADDR X)) (L)) + ((NOT (MSETQP X)) L) + (SETQ L (CONS (LIST (CAR X) (CADR X) VAL) L)))) + +(DEFMFUN MSETQP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MSETQ))) + +(DEFMFUN MQUOTEP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MQUOTE))) + +(DEFMSPEC MQUOTE (FORM) (CADR FORM)) + +(DEFMFUN $SUBVARP (X) (AND (NOT (ATOM X)) (MEMQ 'ARRAY (CDAR X)) T)) + +(DEFMFUN MSETERR (X Y) + (IF MUNBINDP + 'MUNBINDP + (MERROR "Attempt to set ~:M to ~M~%Improper value assignment" X Y))) + +(PROG1 '(ASSIGN properties) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ASSIGN)) + '(($LINEL MSETCHK) (IBASE MSETCHK) (BASE MSETCHK) (MODULUS MSETCHK) + ($INFOLISTS NEVERSET) ($TRACE NEVERSET) ($RATWEIGHTS MSETCHK) + ($RATVARS MSETCHK) ($SETCHECK MSETCHK) ($GCD MSETCHK) + ($DOTASSOC MSETCHK) ($RATWTLVL MSETCHK) ($RATFAC MSETCHK) + ($ALL NEVERSET) ($NUMER NUMERSET) ($FORTINDENT MSETCHK) + ($GENSUMNUM MSETCHK) ($GENINDEX MSETCHK) ($FPPRINTPREC MSETCHK) + ($FLOATWIDTH MSETCHK) ($PARSEWINDOW MSETCHK) ($OPTIMPREFIX MSETCHK) + ($TTYINTNUM MSETCHK)))) + +(DEFMFUN MSETCHK (X Y) + (COND ((MEMQ X '(IBASE BASE)) + (COND ((EQ Y 'ROMAN)) + ((OR (NOT (EQ (TYPEP Y) 'FIXNUM)) (< Y 2)) (MSETERR X Y)) + ((EQ X 'IBASE) + #+MacLisp (IF (< Y 11) (SSTATUS + NIL) (SSTATUS + T))))) + ((MEMQ X '($LINEL $FORTINDENT $GENSUMNUM $FPPRINTPREC $FLOATWIDTH + $PARSEWINDOW $TTYINTNUM)) + (IF (NOT (EQ (TYPEP Y) 'FIXNUM)) (MSETERR X Y)) + #+MacLisp + (WHEN (EQ X '$LINEL) + (LINEL T (LINEL NIL Y)) + (DO L OUTFILES (CDR L) (NULL L) (LINEL (CAR L) Y)) + (SETQ LINEL Y)) + (COND ((AND (MEMQ X '($FORTINDENT $GENSUMNUM $FLOATWIDTH $TTYINTNUM)) (< Y 0)) + (MSETERR X Y)) + ((AND (EQ X '$PARSEWINDOW) (< Y -1)) (MSETERR X Y)) + ((AND (EQ X '$FPPRINTPREC) (OR (< Y 0) (= Y 1))) (MSETERR X Y)))) + ((MEMQ X '($GENINDEX $OPTIMPREFIX)) (IF (NOT (SYMBOLP Y)) (MSETERR X Y))) + ((EQ X '$DOTASSOC) (CPUT 'MNCTIMES Y 'ASSOCIATIVE)) + ((EQ X 'MODULUS) + (COND ((NULL Y)) + ((FIXP Y) + (IF (OR (NOT (PRIMEP Y)) (MEMBER Y '(1 0 -1))) + (MTELL "Warning: MODULUS being set to ~:M, a non-prime.~%" Y))) + (T (MSETERR X Y)))) + ((EQ X '$SETCHECK) + (IF (NOT (OR (MEMQ Y '($ALL T NIL)) ($LISTP Y))) (MSETERR X Y))) + ((EQ X '$GCD) (IF (NOT (OR (NULL Y) (MEMQ Y *GCDL*))) (MSETERR X Y))) + ((EQ X '$RATVARS) + (IF ($LISTP Y) (APPLY #'$RATVARS (CDR Y)) (MSETERR X Y))) + ((EQ X '$RATFAC) + (IF (AND Y $RATWTLVL) + (MERROR "RATFAC and RATWTLVL may not both be used at the same time."))) + ((EQ X '$RATWEIGHTS) + (COND ((NOT ($LISTP Y)) (MSETERR X Y)) + ((NULL (CDR Y)) (KILL1 '$RATWEIGHTS)) + (T (APPLY #'$RATWEIGHT (CDR Y))))) + ((EQ X '$RATWTLVL) + (IF (AND Y (NOT (EQ (TYPEP Y) 'FIXNUM))) (MSETERR X Y)) + (IF (AND Y $RATFAC) + (MERROR "RATFAC and RATWTLVL may not both be used at the same time."))))) + +(DEFMFUN NUMERSET (ASSIGN-VAR Y) + ASSIGN-VAR ; ignored + (MSET '$FLOAT Y)) + +(DEFMFUN NEVERSET (X ASSIGN-VAL) + ASSIGN-VAL ; ignored + (IF MUNBINDP 'MUNBINDP (MERROR "Improper value assignment to ~:M" X))) + +(DEFMFUN MMAPEV (L) + (IF (NULL (CDDR L)) + (MERROR "~:M called with fewer than two arguments." (CAAR L))) + (LET ((OP (GETOPR (MEVAL (CADR L))))) + (AUTOLDCHK OP) + (BADFUNCHK (CADR L) OP NIL) + (CONS OP (MAPCAR #'MEVAL (CDDR L))))) + +(DEFMSPEC $MAP (L) (APPLY #'MAP1 (MMAPEV L))) + +(DEFUN MAP1 N + (DO ((I N (1- I)) + (ARGI (SETARG N (FORMAT1 (ARG N))) (FORMAT1 (ARG (1- I)))) + (OP (OR (MAPATOM (ARG N)) (MOP (ARG N)))) + (FLAG (MAPATOM (ARG N)) + (OR FLAG (SETQ FLAG (MAPATOM ARGI)) + (AND (NOT MAPLP) (NOT (ALIKE1 (MOP ARGI) OP))))) + (ARGL NIL (CONS ARGI ARGL)) + (CDRL NIL (OR FLAG (CONS (MARGS ARGI) CDRL)))) + ((= I 1) (IF FLAG + (COND ((NOT $MAPERROR) + (IF $MAPPRINT (MTELL "MAP is doing an APPLY.~%")) + (FUNCER (ARG 1) ARGL)) + ((AND (= N 2) (MAPATOM (ARG 2))) + (IMPROPER-ARG-ERR (ARG 2) '$MAP)) + (T (MERROR "Arguments to MAP not uniform - cannot map."))) + (MCONS-OP-ARGS OP (APPLY #'MMAPCAR (CONS (ARG 1) CDRL))))))) + +(DEFMSPEC $MAPLIST (L) + (LET ((MAPLP T) RES) + (SETQ RES (APPLY #'MAP1 (MMAPEV L))) + (COND ((ATOM RES) (LIST '(MLIST) RES)) + ((EQ (CAAR RES) 'MLIST) RES) + (T (CONS '(MLIST) (MARGS RES)))))) + +(DEFUN MMAPCAR N + (DO ((ANS NIL (CONS (FUNCER (ARG 1) ARGL) ANS)) + (ARGL NIL NIL)) + ((DO ((I N (1- I))) ((= I 1) NIL) + (WHEN (NULL (ARG I)) + (WHEN (OR (< I N) (DO ((J 2 (1+ J))) ((= J N) NIL) + (IF (ARG J) (RETURN T)))) + (IF $MAPERROR + (MERROR "Arguments to MAP are not of the same length.")) + (IF $MAPPRINT (MTELL "MAP is truncating.~%"))) + (RETURN T)) + (SETQ ARGL (CONS (CAR (ARG I)) ARGL)) + (SETARG I (CDR (ARG I)))) + (NREVERSE ANS)))) + +(DEFUN MAPATOM (X) (OR (SYMBOLP X) (MNUMP X) ($SUBVARP X))) + +(DEFMFUN $MAPATOM (X) (IF (MAPATOM (SPECREPCHECK X)) T)) + +(DEFMSPEC $FULLMAP (L) (SETQ L (MMAPEV L)) (FMAP1 (CAR L) (CDR L) NIL)) + +(DEFUN FMAP1 (FN ARGL FMAPCAARL) + (SETQ ARGL (MAPCAR #'FORMAT1 ARGL)) + (DO ((OP (OR (MAPATOM (CAR ARGL)) (MOP (CAR ARGL)))) + (FMAPLVL (1- FMAPLVL)) (CDR1 ARGL (CDR CDR1)) (ARGI NIL NIL) + (CDRL NIL (CONS (MARGS (CAR CDR1)) CDRL))) + ((NULL CDR1) + (DO ((ANS NIL (CONS (IF BOTTOM (FUNCER FN CARARGL) + (FMAP1 FN CARARGL FMAPCAARL)) + ANS)) + (CARARGL NIL NIL) (CDRARGL NIL NIL) + (CDRL CDRL CDRARGL) (BOTTOM NIL NIL) + (DONE (WHEN (MEMQ NIL CDRL) + (WHEN (DOLIST (E CDRL) (IF E (RETURN T))) + (IF $MAPERROR + (MERROR + "FULLMAP found arguments with incompatible structure.")) + (IF $MAPPRINT (MTELL "FULLMAP is truncating.~%"))) + T))) + (DONE (MCONS-OP-ARGS OP (NREVERSE ANS))) + (DO ((OP (OR (SETQ BOTTOM (OR (ZEROP FMAPLVL) (MAPATOM (CAAR CDRL)))) + (MOP (CAAR CDRL)))) + (ELEML CDRL (CDR ELEML)) (CAARELEML NIL NIL)) + ((NULL ELEML) + (WHEN (AND DONE (DOLIST (E CDRARGL) (IF E (RETURN T)))) + (IF $MAPERROR + (MERROR "FULLMAP found arguments with incompatible structure.")) + (IF $MAPPRINT (MTELL "FULLMAP is truncating.~%")))) + (SETQ CAARELEML (CAAR ELEML)) + (OR BOTTOM + (SETQ BOTTOM + (OR (MAPATOM CAARELEML) + (NOT (ALIKE1 OP (MOP CAARELEML))) + (AND FMAPCAARL (NOT (EQ (CAAR CAARELEML) FMAPCAARL)))))) + (OR DONE (SETQ DONE (NULL (CDAR ELEML)))) + (SETQ CARARGL (NCONC (NCONS CAARELEML) CARARGL) + CDRARGL (NCONC CDRARGL (NCONS (CDAR ELEML))))))) + (SETQ ARGI (CAR CDR1)) + (IF (OR (MAPATOM ARGI) + (NOT (ALIKE1 OP (MOP ARGI))) + (AND FMAPCAARL (NOT (EQ (CAAR ARGI) FMAPCAARL)))) + (COND ($MAPERROR (MERROR "Incorrect call to FULLMAP.")) + (T (IF $MAPPRINT (MTELL "FULLMAP is doing an APPLY.~%")) + (RETURN (FUNCER FN ARGL))))))) + +(DEFMSPEC $MATRIXMAP (L) (LET ((FMAPLVL 2)) (APPLY #'FMAPL1 (MMAPEV L)))) + +(DEFMSPEC $FULLMAPL (L) (APPLY #'FMAPL1 (MMAPEV L))) + +(DEFMFUN FMAPL1 N + (LET ((HEADER '(MLIST)) ARGL) + (SETQ ARGL (FMAP1 (ARG 1) + (MAPCAR + #'(LAMBDA (Z) + (COND ((NOT (MXORLISTP Z)) + (MERROR "Argument to FULLMAPL is not a list or matrix.")) + ((EQ (CAAR Z) '$MATRIX) + (SETQ HEADER '($MATRIX)) + (CONS '(MLIST SIMP) (CDR Z))) + (T Z))) + (CDR (LISTIFY N))) + 'MLIST)) + (IF (DOLIST (E (CDR ARGL)) (IF (NOT ($LISTP E)) (RETURN T))) + ARGL + (CONS HEADER (CDR ARGL))))) + +(DEFMSPEC $OUTERMAP (L) + (APPLY (IF (= (LENGTH L) 3) #'FMAPL1 #'OUTERMAP1) (MMAPEV L))) + +(DEFMFUN OUTERMAP1 N + (LET (OUTARGS1 OUTARGS2) + (COND ((MXORLISTP (ARG 2)) + (SETQ OUTARGS1 (NCONS (ARG 1)) OUTARGS2 (LISTIFY (- 2 N))) + (FMAPL1 'OUTERMAP2 (ARG 2))) + (T (DO ((I 3 (1+ I))) + ((> I N) (FUNCER (ARG 1) (LISTIFY (- 1 N)))) + (WHEN (MXORLISTP (ARG I)) + (SETQ OUTARGS1 (LISTIFY (1- I)) + OUTARGS2 (IF (< I N) (LISTIFY (- I N)))) + (RETURN (FMAPL1 'OUTERMAP2 (ARG I))))))))) + +(DEFUN OUTERMAP2 N + (IF (NOT (ZEROP N)) + (APPLY #'OUTERMAP1 (APPEND OUTARGS1 (LISTIFY 1) OUTARGS2)))) + +(DEFMFUN FUNCER (FN ARGS) + (COND ((AND (NOT OPEXPRP) (MEMQ FN '(MPLUS MTIMES MEXPT MNCTIMES))) + (SIMPLIFY (CONS (NCONS FN) ARGS))) + ((OR (MEMQ FN '(OUTERMAP2 CONSTFUN)) + (AND $TRANSRUN (SYMBOLP FN) (GET FN 'TRANSLATED) + (NOT (MGET FN 'LOCAL-FUN)) (FBOUNDP FN))) + (APPLY FN (MAPCAR #'SIMPLIFY ARGS))) + (T (MAPPLY FN (MAPCAR #'SIMPLIFY ARGS) FN)))) + +(DEFMSPEC $QPUT (L) (SETQ L (CDR L)) + (IF (NOT (= (LENGTH L) 3)) (WNA-ERR '$QPUT)) + ($PUT (CAR L) (CADR L) (CADDR L))) + +(DEFMFUN $GET (ATOM IND) (PROP1 '$GET ATOM NIL IND)) + +(DEFMFUN $REM (ATOM IND) (PROP1 '$REM ATOM NIL IND)) + +(DEFMFUN $PUT (ATOM VAL IND) + (PROG1 (PROP1 '$PUT ATOM VAL IND) (ADD2LNC ATOM $PROPS))) + +(DEFUN PROP1 (FUN ATOM VAL IND) + (NONSYMCHK ATOM FUN) (NONSYMCHK IND FUN) + (LET ((U (MGET ATOM '$PROPS))) + (COND ((EQ FUN '$GET) (AND U (GET U IND))) + ((EQ FUN '$REM) (AND U (REMPROP U IND) '$DONE)) + ((NOT U) (MPUTPROP ATOM (LIST NIL IND VAL) '$PROPS) VAL) + (T (PUTPROP U VAL IND))))) + +(DEFMSPEC $DECLARE (L) (SETQ L (CDR L)) + (IF (ODDP (LENGTH L)) (MERROR "DECLARE takes an even number of arguments.")) + (DO ((L L (CDDR L)) (VARS) (FLAG NIL NIL)) ((NULL L) '$DONE) + (COND (($LISTP (CADR L)) + (DO L1 (CDADR L) (CDR L1) (IF (NULL L1) (SETQ FLAG T)) + (MEVAL `(($DECLARE) ,(CAR L) ,(CAR L1))))) + ((NONSYMCHK (CADR L) '$DECLARE)) + (T (SETQ VARS (DECLSETUP (CAR L) '$DECLARE)))) + (COND (FLAG) + ((MEMQ (CADR L) '($EVFUN $EVFLAG $SPECIAL $NONARRAY $BINDTEST)) + (DECLARE1 VARS T (STRIPDOLLAR (CADR L)) NIL)) + ((EQ (CADR L) '$NOUN) + (DOLIST (VAR VARS) (ALIAS (GETOPR VAR) ($NOUNIFY VAR)))) + ((MEMQ (CADR L) '($CONSTANT $NONSCALAR $SCALAR $MAINVAR)) + (DECLARE1 VARS T (CADR L) T)) + ((MEMQ (CADR L) OPERS) + (IF (MEMQ (CADR L) (CDR $FEATURES)) (DECLARE1 VARS T (CADR L) 'KIND)) + (DECLARE1 (MAPCAR #'GETOPR VARS) T (CADR L) 'OPERS)) + ((MEMQ (CADR L) (CDR $FEATURES)) (DECLARE1 VARS T (CADR L) 'KIND)) + ((EQ (CADR L) '$FEATURE) + (DOLIST (VAR VARS) (NONSYMCHK VAR '$DECLARE) (ADD2LNC VAR $FEATURES))) + ((EQ (CADR L) '$ALPHABETIC) (DECLARE1 VARS T T '$ALPHABETIC)) + (T (MERROR "Unknown property to DECLARE: ~:M" (CADR L)))))) + +(DEFUN DECLARE1 (VARS VAL PROP MPROPP) + (DOLIST (VAR VARS) + (SETQ VAR (GETOPR VAR)) + (NONSYMCHK VAR '$DECLARE) + (COND ((EQ MPROPP 'KIND) (DECLAREKIND VAR PROP)) + ((EQ MPROPP 'OPERS) + (PUTPROP (SETQ VAR (LINCHK VAR)) T PROP) (PUTPROP VAR T 'OPERS) + (IF (NOT (GET VAR 'OPERATORS)) (PUTPROP VAR 'SIMPARGS1 'OPERATORS))) + ((EQ MPROPP '$ALPHABETIC) + (PUTPROP (SETQ VAL (STRIPDOLLAR VAR)) T 'ALPHABET) + (ADD2LNC (GETCHARN VAL 1) ALPHABET)) + ((EQ PROP 'SPECIAL) (FLUIDIZE VAR)) + (MPROPP + (IF (AND (MEMQ PROP '($SCALAR $NONSCALAR)) + (MGET VAR (IF (EQ PROP '$SCALAR) '$NONSCALAR '$SCALAR))) + (MERROR "Inconsistent Declaration: ~:M" + `(($DECLARE) ,VAR ,PROP))) + (MPUTPROP VAR VAL PROP)) + (T (PUTPROP VAR VAL PROP))) + (IF (AND (GET VAR 'OP) (OPERATORP1 VAR) + (NOT (MEMQ (SETQ VAR (GET VAR 'OP)) (CDR $PROPS)))) + (SETQ MOPL (CONS VAR MOPL))) + (ADD2LNC (GETOP VAR) $PROPS))) + +(DEFUN LINCHK (VAR) + (IF (MEMQ VAR '($SUM $INTEGRATE $LIMIT $DIFF $TRANSPOSE)) ($NOUNIFY VAR) VAR)) + +(DEFMSPEC $REMOVE (FORM) (I-$REMOVE (CDR FORM))) + +(DEFMFUN I-$REMOVE (L) + (IF (ODDP (LENGTH L)) (MERROR "REMOVE takes an even number of arguments.")) + (DO ((L L (CDDR L)) (VARS) (FLAG NIL NIL)) ((NULL L) '$DONE) + (COND (($LISTP (CADR L)) + (DO L1 (CDADR L) (CDR L1) (IF (NULL L1) (SETQ FLAG T)) + (I-$REMOVE (LIST (CAR L) (CAR L1))))) + ((NONSYMCHK (CADR L) '$REMOVE)) + (T (SETQ VARS (DECLSETUP (CAR L) '$REMOVE)))) + (COND (FLAG) + ((EQ (CADR L) '$VALUE) (I-$REMVALUE VARS)) + ((EQ (CADR L) '$FUNCTION) + (REMOVE1 (MAPCAR #'$VERBIFY VARS) 'MEXPR T $FUNCTIONS T)) + ((EQ (CADR L) '$MACRO) + (REMOVE1 (MAPCAR #'$VERBIFY VARS) 'MMACRO T $MACROS T)) + ((EQ (CADR L) '$ARRAY) (MEVAL `(($REMARRAY) ,@VARS))) + ((MEMQ (CADR L) '($ALIAS $NOUN)) (REMALIAS1 VARS (EQ (CADR L) '$ALIAS))) + ((EQ (CADR L) '$MATCHDECLARE) (REMOVE1 VARS 'MATCHDECLARE T T NIL)) + ((EQ (CADR L) '$RULE) (REMRULE VARS)) + ((MEMQ (CADR L) '($EVFUN $EVFLAG $SPECIAL $NONARRAY $BINDTEST + $AUTOLOAD $ASSIGN)) + (REMOVE1 VARS (STRIPDOLLAR (CADR L)) NIL T NIL)) + ((MEMQ (CADR L) '($MODE $MODEDECLARE)) (REMOVE1 VARS 'MODE NIL 'FOO NIL)) + ((EQ (CADR L) '$ATVALUE) (REMOVE1 VARS 'ATVALUES T T NIL)) + ((MEMQ (CADR L) '($CONSTANT $NONSCALAR $SCALAR $MAINVAR $NUMER $ATOMGRAD)) + (REMOVE1 VARS (CADR L) T T NIL)) + ((MEMQ (CADR L) OPERS) (REMOVE1 (MAPCAR #'LINCHK VARS) (CADR L) NIL T NIL)) + ((MEMQ (CADR L) (CDR $FEATURES)) (REMOVE1 VARS (CADR L) NIL T NIL)) + ((EQ (CADR L) '$FEATURE) (DOLIST (VAR VARS) (DELQ VAR $FEATURES 1))) + ((MEMQ (CADR L) '($ALPHABETIC $TRANSFUN)) + (REMOVE1 VARS (CADR L) NIL T NIL)) + ((MEMQ (CADR L) '($GRADEF $GRAD)) (REMOVE1 VARS 'GRAD NIL $GRADEFS T)) + ((MEMQ (CADR L) '($DEPENDENCY $DEPEND $DEPENDS)) + (REMOVE1 VARS 'DEPENDS T $DEPENDENCIES T)) + ((MEMQ (CADR L) '($OP $OPERATOR)) (REMOVE1 VARS '$OP NIL 'FOO NIL)) + ((MEMQ (CADR L) '($DEFTAYLOR $TAYLORDEF)) (REMOVE1 VARS 'SP2 NIL T NIL)) + (T (MERROR "Unknown property to REMOVE: ~:M" (CADR L)))))) + +(DEFUN DECLSETUP (X FN) + (COND ((ATOM X) (NCONS X)) + ((EQ (CAAR X) '$NOUNIFY) (NCONS (MEVAL X))) + ((EQ (CAAR X) 'MLIST) + (MAPCAR #'(LAMBDA (VAR) + (COND ((ATOM VAR) VAR) + ((EQ (CAAR VAR) '$NOUNIFY) (MEVAL VAR)) + (T (IMPROPER-ARG-ERR VAR FN)))) + (CDR X))) + (T (IMPROPER-ARG-ERR X FN)))) + +(DEFMFUN REMOVE1 (VARS PROP MPROPP INFO FUNP) + (DO ((VARS VARS (CDR VARS)) (ALLFLG)) ((NULL VARS)) + (NONSYMCHK (CAR VARS) '$REMOVE) + (COND ((AND (EQ (CAR VARS) '$ALL) (NULL ALLFLG)) + (SETQ VARS (APPEND VARS (COND ((ATOM INFO) (CDR $PROPS)) + (FUNP (MAPCAR #'CAAR (CDR INFO))) + (T (CDR INFO)))) + ALLFLG T)) + (T ((LAMBDA (VAR FLAG) + (COND (MPROPP (MREMPROP VAR PROP) + (WHEN (MEMQ PROP '(MEXPR MMACRO)) + (MREMPROP VAR 'MLEXPRP) + (MREMPROP VAR 'MFEXPRP) + #-LISPM ; Happens automatically on LISPM + (IF (NOT (GET VAR 'TRANSLATED)) + (ARGS VAR NIL)) + (IF (MGET VAR 'TRACE) + (MACSYMA-UNTRACE VAR)))) + ((EQ PROP '$OP) (KILL-OPERATOR VAR)) + ((EQ PROP '$ALPHABETIC) + (REMPROP (SETQ PROP (STRIPDOLLAR VAR)) 'ALPHABET) + (DELETE (GETCHARN PROP 1) ALPHABET 1)) + ((EQ PROP '$TRANSFUN) + (REMOVE-TRANSL-FUN-PROPS VAR) + (REMOVE-TRANSL-ARRAY-FUN-PROPS VAR)) + ((OR (SETQ FLAG (MEMQ PROP (CDR $FEATURES))) (MEMQ PROP OPERS)) + (IF FLAG (UNKIND VAR PROP)) + (REMPROP VAR PROP) + (IF (NOT (GETL VAR (DELQ PROP (APPEND OPERS NIL) 1))) + (REMPROP VAR 'OPERS))) + (T (REMPROP VAR PROP))) + (COND ((EQ INFO T) (REMPROPCHK VAR)) + ((EQ INFO 'FOO)) + (FUNP (DELETE (ASSOC (NCONS VAR) INFO) INFO 1)) + (T (DELQ VAR INFO 1)))) + (GETOPR (CAR VARS)) NIL))))) + +(DEFUN REMOVE-TRANSL-FUN-PROPS (FUN) + (IF (MGET FUN 'TRACE) (MACSYMA-UNTRACE FUN)) + (WHEN (AND (GET FUN 'TRANSLATED) (NOT (EQ $SAVEDEF '$ALL))) + #+Maclisp + (DO ((PROPS '(EXPR SUBR LSUBR FEXPR FSUBR) (CDR PROPS))) + ((NULL PROPS)) + (REMPROP FUN (CAR PROPS))) + #-Maclisp + (FMAKUNBOUND FUN) + (REMPROP FUN 'TRANSLATED-MMACRO) + (MREMPROP FUN 'T-MFEXPR) + (REMPROP FUN 'FUNCTION-MODE) + #-LISPM + (IF (NOT (MGETL FUN '(MEXPR MMACRO))) (ARGS FUN NIL)) + (IF (NOT (GETL FUN '(A-EXPR A-SUBR))) (REMPROP FUN 'TRANSLATED)))) + +(DEFUN REMOVE-TRANSL-ARRAY-FUN-PROPS (FUN) + (WHEN (AND (GET FUN 'TRANSLATED) (NOT (EQ $SAVEDEF '$ALL))) + (REMPROP FUN 'A-EXPR) + (REMPROP FUN 'A-SUBR) + (IF (NOT (FBOUNDP FUN)) (REMPROP FUN 'TRANSLATED)))) + +(DEFMFUN REMPROPCHK (VAR) + (IF (AND (NOT (MGETL VAR '($CONSTANT $NONSCALAR $SCALAR $MAINVAR $NUMER + MATCHDECLARE $ATOMGRAD ATVALUES T-MFEXPR))) + (NOT (GETL VAR '(EVFUN EVFLAG TRANSLATED NONARRAY BINDTEST + OPR SP2 OPERATORS OPERS SPECIAL DATA + ALPHABET AUTOLOAD MODE)))) + (DELQ VAR $PROPS 1))) + +(DEFMSPEC $REMFUNCTION (L) (SETQ L (CDR L)) + (SETQ L (MAPCAR #'$VERBIFY L)) + (DO L1 L (CDR L1) (NULL L1) + (COND ((EQ (CAR L1) '$ALL) + (DISPLACE L1 (DELQ '$ALL L1)) + (NCONC L (MAPCAR #'CAAR (CDR $FUNCTIONS)) + (MAPCAR #'CAAR (CDR $MACROS)))) + ((NOT (OR (ASSOC (NCONS (CAR L1)) (CDR $FUNCTIONS)) + (ASSOC (NCONS (CAR L1)) (CDR $MACROS)))) + (RPLACA L1 NIL)))) + (REMOVE1 L 'MEXPR T $FUNCTIONS T) + (REMOVE1 L 'MMACRO T $MACROS T) + (CONS '(MLIST) L)) + +(DEFMSPEC $REMARRAY (L) (SETQ L (CDR L)) + (CONS '(MLIST) + (DO ((L L (CDR L)) (X) (PRED)) ((NULL L) (NREVERSE X)) + (COND ((EQ (CAR L) '$ALL) (SETQ L (APPEND L (CDR $ARRAYS)))) + (T (REMCOMPARY (CAR L)) (SETQ PRED (MREMPROP (CAR L) 'ARRAY)) + (SETQ PRED (OR (MREMPROP (CAR L) 'HASHAR) PRED)) + (SETQ PRED (OR (MREMPROP (CAR L) 'AEXPR) PRED)) + (SETQ X (CONS (AND PRED (PROG2 (DELQ (CAR L) $ARRAYS 1) (CAR L))) + X))))))) + +(DEFUN REMCOMPARY (X) + (COND ((EQ X (MGET X 'ARRAY)) (REMPROP X 'ARRAY-MODE) (REMPROP X 'ARRAY)))) + +(DEFMSPEC $REMVALUE (FORM) (I-$REMVALUE (CDR FORM))) + +(DEFMFUN I-$REMVALUE (L) + (CONS '(MLIST) + (DO ((L L (CDR L)) (X) (Y)) ((NULL L) (NREVERSE X)) + (COND ((EQ (CAR L) '$ALL) (SETQ L (APPEND L (CDR $VALUES)))) + (T (SETQ X (CONS (COND ((ATOM (CAR L)) + (IF (REMVALUE (CAR L) '$REMVALUE) (CAR L))) + ((SETQ Y (MGETL (CAAAR L) '(HASHAR ARRAY))) + (REMARRELEM Y (CAR L)) (CAR L))) + X))))))) + +(DEFMFUN REMARRELEM (ARY FORM) + (IF (MFILEP (CADR ARY)) (I-$UNSTORE (NCONS (CAAR FORM)))) + (LET ((Y (CAR (ARRAYDIMS (CADR ARY))))) + (ARRSTORE FORM (COND ((EQ Y 'FIXNUM) 0) ((EQ Y 'FLONUM) 0.0) (T MUNBOUND))))) + +(DEFMFUN REMRULE (L) + (DO ((L L (CDR L)) (Y)) ((NULL L)) + (COND ((EQ (CAR L) '$ALL) (SETQ L (APPEND L (CDR $RULES)))) + ((GET (CAR L) 'OPERATORS) ($REMRULE (CAR L) '$ALL)) + ((SETQ Y (RULEOF (CAR L))) ($REMRULE Y (CAR L))) + ((MGET (CAR L) '$RULE) + (REMPROP (CAR L) 'EXPR) (MREMPROP (CAR L) '$RULE) (DELQ (CAR L) $RULES 1))))) + +(DEFMFUN REMALIAS1 (L ALIASP) + (DO L L (CDR L) (NULL L) + (COND ((EQ (CAR L) '$ALL) (SETQ L (APPEND L (CDR $ALIASES)))) + ((OR ALIASP (GET (CAR L) 'NOUN)) (REMALIAS (CAR L) T))))) + +(DEFMFUN MGET (ATOM IND) + (LET ((PROPS (AND (SYMBOLP ATOM) (GET ATOM 'MPROPS)))) + (AND PROPS (GET PROPS IND)))) + +(DEFMFUN MPUTPROP (ATOM VAL IND) + (LET ((PROPS (GET ATOM 'MPROPS))) + (IF (NULL PROPS) (PUTPROP ATOM (SETQ PROPS (NCONS NIL)) 'MPROPS)) + (PUTPROP PROPS VAL IND))) + +#-NIL +(DEFMFUN MDEFPROP FEXPR (L) (MPUTPROP (CAR L) (CADR L) (CADDR L)) (CAR L)) + +(DEFMFUN MREMPROP (ATOM IND) + (LET ((PROPS (GET ATOM 'MPROPS))) (AND PROPS (REMPROP PROPS IND)))) + +(DEFMFUN MGETL (ATOM INDS) + (LET ((PROPS (GET ATOM 'MPROPS))) (AND PROPS (GETL PROPS INDS)))) + +(DEFMFUN $MATRIX N + (IF (= N 0) + (NCONS '($MATRIX)) + (LET ((L (LISTIFY N))) (MATCHECK L) (CONS '($MATRIX) L)))) + +(DEFUN MATCHECK (L) + (DOLIST (ROW L) + (IF (NOT ($LISTP ROW)) (MERROR "Invalid matrix row:~%~M" ROW))) + (DO ((L1 (CDR L) (CDR L1)) (N (LENGTH (CAR L)))) ((NULL L1)) + (IF (NOT (= N (LENGTH (CAR L1)))) + (MERROR "All matrix rows are not of the same length.")))) + +(DEFUN HARRFIND (FORM) + (PROG (ARY Y LISPSUB ITEML SUB NCELLS NITEMS) + (SETQ ARY (MGET (CAAR FORM) 'HASHAR)) + (COND ((NOT (= (FUNCALL ARY 2) (LENGTH (CDR FORM)))) + (MERROR "Array ~:M already has dimension ~:M~%~M" + (CAAR FORM) (FUNCALL ARY 2) FORM))) + (SETQ SUB (CDR FORM)) + (SETQ ITEML (FUNCALL ARY (SETQ LISPSUB (+ 3 (\ (HASHER SUB) (FUNCALL ARY 0)))))) + A (COND ((NULL ITEML) (GO B)) + ((ALIKE (CAAR ITEML) SUB) (RETURN (CDAR ITEML)))) + (SETQ ITEML (CDR ITEML)) + (GO A) + B (COND (EVARRP (RETURN 'NOTEXIST)) + ((NULL (SETQ Y (ARRFUNP (CAAR FORM)))) (RETURN (MEVAL2 SUB FORM)))) + (SETQ Y (ARRFUNCALL Y SUB)) + (SETQ ARY (MGET (CAAR FORM) 'HASHAR)) + (SETQ ITEML (FUNCALL ARY (SETQ LISPSUB (+ 3 (\ (HASHER SUB) (FUNCALL ARY 0)))))) + (SETQ SUB (NCONS (CONS SUB Y))) + (COND (ITEML (NCONC ITEML SUB)) (T (STORE (FUNCALL ARY LISPSUB) SUB))) + (STORE (FUNCALL ARY 1) (SETQ NITEMS (1+ (FUNCALL ARY 1)))) + (COND ((> NITEMS (SETQ NCELLS (FUNCALL ARY 0))) + (ARRAYSIZE (CAAR FORM) (+ NCELLS NCELLS)))) + (RETURN Y))) + +; Types of FIXNUM and FLONUM herein not currently compatible +; on LISP machine. Don't worry about it for now. +(DEFUN ARRFIND (FORM) + ((LAMBDA (SUB U V TYPE) + (SETQ V (DIMCHECK (CAAR FORM) SUB NIL)) + (COND (V (SETQ TYPE (CAR (ARRAYDIMS (MGET (CAAR FORM) 'ARRAY)))))) + (COND ((AND V (PROG2 (SETQ U (APPLY (MGET (CAAR FORM) 'ARRAY) SUB)) + (COND ((EQ TYPE 'FLONUM) (NOT (= U FLOUNBOUND))) + ((EQ TYPE 'FIXNUM) (NOT (= U FIXUNBOUND))) + (T (NOT (EQ U MUNBOUND)))))) + U) + (EVARRP 'NOTEXIST) + ((OR (NOT V) (NULL (SETQ U (ARRFUNP (CAAR FORM))))) + (COND ((EQ TYPE 'FLONUM) 0.0) + ((EQ TYPE 'FIXNUM) 0) + (T (MEVAL2 SUB FORM)))) + (T (SETQ U (ARRFUNCALL U SUB)) + (STORE (APPLY (MGET (CAAR FORM) 'ARRAY) SUB) U) + U))) + (CDR FORM) NIL NIL NIL)) + +(DEFMSPEC $ARRAY (X) (SETQ X (CDR X)) + (COND ((SYMBOLP (CAR X)) + ((LAMBDA (COMPP) + ((LAMBDA (FUN DIML FUNP OLD NEW NCELLS) + (COND ((MEMQ '$FUNCTION DIML) + (SETQ DIML (DELQ '$FUNCTION (APPEND DIML NIL) 1) FUNP T))) + (SETQ DIML (MAPCAR #'MEVAL DIML)) + (COND ((NULL DIML) (MERROR "Wrong number of args to ARRAY")) + ((> (LENGTH DIML) 5) (MERROR "ARRAY takes at most 5 indices")) + ((MEMQ NIL (MAPCAR #'(LAMBDA (U) (EQ (TYPEP U) 'FIXNUM)) DIML)) + (MERROR "Non-integer dimension - ARRAY"))) + (SETQ DIML (MAPCAR #'1+ DIML)) + (SETQ NEW (APPLY #'*ARRAY (CONS (COND (COMPP FUN) (T (GENSYM))) + (CONS #-LISPM (OR COMPP T) + #+LISPM T + DIML)))) + #+LISPM + (COND ((EQ COMPP 'FIXNUM) (FILLARRAY NEW '(0))) + ((EQ COMPP 'FLONUM) (FILLARRAY NEW '(0.0)))) + (COND ((NOT (MEMQ COMPP '(FIXNUM FLONUM))) (FILLARRAY NEW (LIST MUNBOUND))) + ((OR FUNP (ARRFUNP FUN)) + (FILLARRAY NEW (LIST (COND ((EQ COMPP 'FIXNUM) FIXUNBOUND) + (T FLOUNBOUND)))))) + (COND ((NULL (SETQ OLD (MGET FUN 'HASHAR))) + (MPUTPROP FUN NEW 'ARRAY)) + (T (COND ((NOT (= (FUNCALL OLD 2) (LENGTH DIML))) + (MERROR "Array ~:M already has ~:M dimension(s)" + FUN (FUNCALL OLD 2)))) + (SETQ NCELLS (+ 2 (FUNCALL OLD 0))) + (DO N 3 (1+ N) (> N NCELLS) + (DO ITEMS (FUNCALL OLD N) (CDR ITEMS) (NULL ITEMS) + (DO ((X (CAAR ITEMS) (CDR X)) (Y DIML (CDR Y))) + ((NULL X) + (IF (AND (MEMQ COMPP '(FIXNUM FLONUM)) + (NOT (EQ (TYPEP (CDAR ITEMS)) COMPP))) + (MERROR "Element and array type do not match:~%~M" + (CDAR ITEMS))) + (APPLY #'STORE (LIST (CONS NEW (CAAR ITEMS)) + (LIST 'QUOTE (CDAR ITEMS))))) + (IF (OR (NOT (EQ (TYPEP (CAR X)) 'FIXNUM)) + (< (CAR X) 0) + (NOT (< (CAR X) (CAR Y)))) + (MERROR "Improper index for declared array:~%~M" + (CAR X)))))) + (MREMPROP FUN 'HASHAR) + (MPUTPROP FUN NEW 'ARRAY))) + (ADD2LNC FUN $ARRAYS) + (IF (EQ COMPP 'FIXNUM) (PUTPROP FUN '$FIXNUM 'ARRAY-MODE)) + (IF (EQ COMPP 'FLONUM) (PUTPROP FUN '$FLOAT 'ARRAY-MODE)) + FUN) + ($VERBIFY (CAR X)) (COND (COMPP (SETQ COMPP (CDR COMPP)) (CDDR X)) (T (CDR X))) + NIL NIL NIL 0)) + (ASSQ (CADR X) '(($COMPLETE . T) ($INTEGER . FIXNUM) ($FIXNUM . FIXNUM) + ($FLOAT . FLONUM) ($FLONUM . FLONUM))))) + (($LISTP (CAR X)) + (DO U (CDAR X) (CDR U) (NULL U) (MEVAL `(($ARRAY) ,(CAR U) ,@(CDR X)))) + (CAR X)) + (T (MERROR "Improper first argument to ARRAY:~%~M" (CAR X))))) + +(DEFMFUN ARRSTORE (L R) + ((LAMBDA (FUN ARY SUB LISPSUB HASHL MQAPPLYP) + (COND ((SETQ ARY (MGET FUN 'ARRAY)) + (WHEN (MFILEP ARY) + (I-$UNSTORE (NCONS FUN)) (SETQ ARY (MGET FUN 'ARRAY))) + (DIMCHECK FUN (SETQ SUB (MAPCAR #'MEVAL (CDR L))) T) + (IF (AND (MEMQ (SETQ FUN (CAR (ARRAYDIMS ARY))) '(FIXNUM FLONUM)) + (NOT (EQ (TYPEP R) FUN))) + (MERROR "Improper assignment to complete array:~%~M" R)) + (EVAL (LIST 'STORE (CONS ARY SUB) (LIST 'QUOTE R)))) + ((SETQ ARY (MGET FUN 'HASHAR)) + (WHEN (MFILEP ARY) + (I-$UNSTORE (NCONS FUN)) (SETQ ARY (MGET FUN 'HASHAR))) + (IF (NOT (= (FUNCALL ARY 2) (LENGTH (CDR L)))) + (MERROR "Array ~:M has dimension ~:M; it was called by ~:M" + FUN (FUNCALL ARY 2) L)) + (SETQ SUB (MAPCAR #'MEVAL (CDR L))) + (SETQ HASHL (FUNCALL ARY (SETQ LISPSUB (+ 3 (\ (HASHER SUB) (FUNCALL ARY 0)))))) + (DO ((HASHL1 HASHL (CDR HASHL1))) + ((NULL HASHL1) + (COND ((NOT (EQ R MUNBOUND)) + (SETQ SUB (NCONS (CONS SUB R))) + (COND ((NULL HASHL) (STORE (FUNCALL ARY LISPSUB) SUB)) + (T (NCONC HASHL SUB))) + (STORE (FUNCALL ARY 1) (1+ (FUNCALL ARY 1)))))) + (COND ((ALIKE (CAAR HASHL1) SUB) + (COND ((EQ R MUNBOUND) (STORE (FUNCALL ARY 1) + (1- (FUNCALL ARY 1)))) + (T (NCONC HASHL (NCONS (CONS SUB R))))) + (STORE (FUNCALL ARY LISPSUB) (DELETE (CAR HASHL1) HASHL 1)) + (RETURN NIL)))) + (IF (> (FUNCALL ARY 1) (FUNCALL ARY 0)) + (ARRAYSIZE FUN (* 2 (FUNCALL ARY 0)))) + R) + ((AND (EQ FUN 'MQAPPLY) (MXORLISTP (SETQ ARY (MEVAL (CADR L)))) + (PROG2 (SETQ MQAPPLYP T L (CDR L)) NIL))) + ((AND (NOT MQAPPLYP) + (OR (NOT (BOUNDP FUN)) (NOT (OR (MXORLISTP (SETQ ARY (SYMEVAL FUN))) + (EQ (TYPEP ARY) 'ARRAY))))) + (IF (MEMQ FUN '(MQAPPLY $%)) (MERROR "Illegal use of :")) + (ADD2LNC FUN $ARRAYS) + (MPUTPROP FUN (SETQ ARY (GENSYM)) 'HASHAR) + (*ARRAY ARY T 7) (STORE (FUNCALL ARY 0) 4) (STORE (FUNCALL ARY 1) 0) + (STORE (FUNCALL ARY 2) (LENGTH (CDR L))) + (ARRSTORE L R)) + ((EQ (TYPEP ARY) 'ARRAY) + (ARRSTORE-EXTEND ARY (MEVALARGS (CDR L)) R)) + ((OR (EQ (CAAR ARY) 'MLIST) (= (LENGTH L) 2)) + (COND ((EQ (CAAR ARY) '$MATRIX) + (COND ((OR (NOT ($LISTP R)) (NOT (= (LENGTH (CADR ARY)) (LENGTH R)))) + (MERROR "Attempt to assign bad matrix row:~%~M" R)))) + ((NOT (= (LENGTH L) 2)) + (MERROR "Wrong number of indices:~%~M" (CONS '(MLIST) (CDR L))))) + ((LAMBDA (INDEX) + (COND ((NOT (EQ (TYPEP INDEX) 'FIXNUM)) + (MERROR "Index not an integer:~%~M" INDEX)) + ((AND (> INDEX 0) (< INDEX (LENGTH ARY))) + (RPLACA (NCDR (CDR ARY) INDEX) R)) + (T (MERROR "~A - index out of range" INDEX)))) + (MEVAL (CADR L))) + R) + (T (IF (NOT (= (LENGTH L) 3)) + (MERROR "Wrong number of indices:~%~M" (CONS '(MLIST) (CDR L)))) + ($SETELMX R (MEVAL (CADR L)) (MEVAL (CADDR L)) ARY) + R))) + ($VERBIFY (CAAR L)) NIL NIL 0 NIL NIL)) + +(DEFUN ARRFUNP (X) + (OR (AND $TRANSRUN (GETL X '(A-EXPR #+Maclisp A-SUBR))) (MGETL X '(AEXPR)))) + +(defmacro system-subrcall* (p argl) + (cond ((status feature maclisp) + `(subrcall* ,p ,argl)) + (t + `(error '|Don't think I can A-SUBR frobulate here!|)))) +#-NIL +(defmacro assemble-subrcall* () + (cond ((status feature maclisp) + (cond ((status feature pdp10) + '(PROGN 'COMPILE + (SETPLIST '|the subr| '(SUBR NIL)) + (lap-a-list + '((LAP SUBRCALL* SUBR) + (ARGS SUBRCALL* (() . 2)) + (HRRZ 3 '|the subr|) + (HRRZ 4 0 3) + (HRLM 1 0 4) + (MOVEI 1 '|the subr|) + (JCALL 2 '*APPLY) + () )))) + (t + ;; the above optimizes out the JSP PDLNMK + ;; which is not needed since we know the first argument + ;; is NOT a number. We are more interested in + ;; illustrating the issue than in bumming out + ;; a couple instructions, however there it is. + '(progn 'compile + (setplist '|the subr| '(SUBR NIL)) + (defun subrcall* (p argl) + (rplaca (cdr (plist '|the subr|)) p) + (apply #'|the subr| argl)))))) + (t nil))) +#-NIL +(assemble-subrcall*) + +(DEFUN ARRFUNCALL (ARRFUN SUBS) + (LET ((AEXPRP T)) + (CASEQ (CAR ARRFUN) + (AEXPR (MAPPLY (CADR ARRFUN) SUBS (CADR ARRFUN))) + (A-EXPR (APPLY (CADR ARRFUN) SUBS)) + (A-SUBR + (COMMENT "This is what the code used to look like:" + (EVAL (NCONC (LIST 'SUBRCALL NIL + (LIST 'QUOTE (CADR ARRFUN))) SUBS))) + (SYSTEM-SUBRCALL* (CADR ARRFUN) SUBS))))) + +(DEFUN HASHER (L) ; This is not the best way to write a hasher. But, + (IF (NULL L) ; please don't change this code or you're liable to + 0 ; break SAVE files. + (LOGAND #o77777 + (LET ((X (CAR L))) + (COND (($RATP X) (MERROR "Subscripts may not be in CRE form.")) + ((MEMQ (TYPEP X) '(FIXNUM FLONUM)) + (+ (IF (EQ (TYPEP X) 'FIXNUM) X (FIX (+$ X 0.0005))) + (* 7 (HASHER (CDR L))))) + ((ATOM X) (+ (SXHASH X) (HASHER (CDR L)))) + (T (+ 1 (SXHASH (CAAR X)) (HASHER (CDR X)) + (HASHER (CDR L))))))))) + +(DEFUN ARRAYSIZE (FUN N) + (PROG (OLD NEW INDX NCELLS CELL ITEM I Y) + (SETQ OLD (MGET FUN 'HASHAR)) + (MPUTPROP FUN (SETQ NEW (GENSYM)) 'HASHAR) + (*ARRAY NEW T (+ N 3)) + (STORE (FUNCALL NEW 0) N) + (STORE (FUNCALL NEW 1) (FUNCALL OLD 1)) + (STORE (FUNCALL NEW 2) (FUNCALL OLD 2)) + (SETQ INDX 2 NCELLS (+ 2 (FUNCALL OLD 0))) + A (IF (> (SETQ INDX (1+ INDX)) NCELLS) (RETURN T)) + (SETQ CELL (FUNCALL OLD INDX)) + B (IF (NULL CELL) (GO A)) + (SETQ I (+ 3 (\ (HASHER (CAR (SETQ ITEM (CAR CELL)))) N))) + (IF (SETQ Y (FUNCALL NEW I)) + (NCONC Y (NCONS ITEM)) + (STORE (FUNCALL NEW I) (NCONS ITEM))) + (SETQ CELL (CDR CELL)) + (GO B))) + +(DEFUN DIMCHECK (ARY SUB FIXPP) + (DO ((X SUB (CDR X)) (RET T) (Y (CDR (ARRAYDIMS (MGET ARY 'ARRAY))) (CDR Y))) + ((NULL Y) + (IF X (MERROR "Array ~:M has dimensions ~:M, but was called with ~:M" + ARY `((MLIST) + ,.(MAPCAR #'1- + (CDR (ARRAYDIMS (MGET ARY 'ARRAY))))) + `((MLIST) ,.SUB)) + RET)) + (COND ((OR (NULL X) (AND (EQ (TYPEP (CAR X)) 'FIXNUM) + (OR (< (CAR X) 0) (NOT (< (CAR X) (CAR Y)))))) + (SETQ Y NIL X (CONS NIL T))) + ((NOT (EQ (TYPEP (CAR X)) 'FIXNUM)) + (IF FIXPP (SETQ Y NIL X (CONS NIL T)) (SETQ RET NIL)))))) + +(DEFUN CONSTLAM (LAM) + (IF AEXPRP + `(,(CAR LAM) ,(CADR LAM) ,@(MBINDING ((MPARAMS (CADR LAM))) + (MAPCAR #'MEVAL (CDDR LAM)))) + + LAM)) + +(DEFMSPEC $DEFINE (L) + (TWOARGCHECK L) + (SETQ L (CDR L)) + (MEVAL `((MDEFINE) + ,(COND ((MQUOTEP (CAR L)) (CADAR L)) + ((AND (NOT (ATOM (CAR L))) + (MEMQ (CAAAR L) '($EV $FUNMAKE $ARRAYMAKE))) + (MEVAL (CAR L))) + (T (DISP2 (CAR L)))) + ,(MEVAL (CADR L))))) + +(DEFMSPEC MDEFINE (L) + (TWOARGCHECK L) + (SETQ L (CDR L)) + ((LAMBDA (FUN BODY ARGS SUBS ARY FNNAME MQDEF REDEF) + (COND ((OR (ATOM FUN) + (AND (SETQ MQDEF (EQ (CAAR FUN) 'MQAPPLY)) + (MEMQ 'ARRAY (CDAR FUN)))) + (MERROR "Improper function definition:~%~M" FUN)) + (MQDEF (IF (OR (ATOM (CADR FUN)) + (NOT (SETQ ARY (MEMQ 'ARRAY (CDAADR FUN))))) + (MERROR "Improper function definition:~%~M" (CADR FUN)) + (SETQ SUBS (CDADR FUN) ARGS (CDDR FUN) FUN (CADR FUN) + FNNAME ($VERBIFY (CAAR FUN))))) + ((PROG2 (SETQ FNNAME ($VERBIFY (CAAR FUN))) + (OR (MOPP FNNAME) (MEMQ FNNAME '($ALL $ALLBUT $%)))) + (MERROR "Improper function name: ~:@M" FNNAME)) + ((SETQ ARY (MEMQ 'ARRAY (CDAR FUN))) (SETQ SUBS (CDR FUN))) + (T (SETQ ARGS (CDR FUN) REDEF (MREDEF-CHECK FNNAME)))) + (IF (NOT ARY) (REMOVE1 (NCONS FNNAME) 'MMACRO T $MACROS T)) + (MDEFCHK FNNAME (OR ARGS (AND (NOT MQDEF) SUBS)) ARY MQDEF) + (IF (NOT (EQ FNNAME (CAAR FUN))) (RPLACA (CAR FUN) FNNAME)) + (COND ((NOT ARY) (IF (AND EVP (MEMQ FNNAME (CAR LOCLIST))) + (MPUTPROP FNNAME T 'LOCAL-FUN) + (REMOVE-TRANSL-FUN-PROPS FNNAME)) + (ADD2LNC (CONS (NCONS FNNAME) ARGS) $FUNCTIONS) + (MPUTPROP FNNAME (MDEFINE1 ARGS BODY) 'MEXPR) + #+MacLisp + (IF (NOT REDEF) + (ARGS FNNAME (IF (NOT (MGET FNNAME 'MLEXPRP)) + (CONS NIL (LENGTH ARGS))))) + (IF $TRANSLATE (TRANSLATE-FUNCTION FNNAME))) + ((PROG2 (ADD2LNC FNNAME $ARRAYS) + (SETQ ARY (MGETL FNNAME '(HASHAR ARRAY))) + (REMOVE-TRANSL-ARRAY-FUN-PROPS FNNAME)) + (WHEN (MFILEP (CADR ARY)) + (I-$UNSTORE (NCONS FNNAME)) + (SETQ ARY (MGETL FNNAME '(HASHAR ARRAY)))) + (IF (NOT (= (IF (EQ (CAR ARY) 'HASHAR) + (FUNCALL (CADR ARY) 2) + (LENGTH (CDR (ARRAYDIMS (CADR ARY))))) + (LENGTH SUBS))) + (MERROR "Array ~:M already defined with different dimensions" + FNNAME)) + (MDEFARRAY FNNAME SUBS ARGS BODY MQDEF)) + (T (MPUTPROP FNNAME (SETQ ARY (GENSYM)) 'HASHAR) + (*ARRAY ARY T 7) + (STORE (FUNCALL ARY 0) 4) + (STORE (FUNCALL ARY 1) 0) + (STORE (FUNCALL ARY 2) (LENGTH SUBS)) + (MDEFARRAY FNNAME SUBS ARGS BODY MQDEF))) + (CONS '(MDEFINE SIMP) #-LISPM L #+LISPM (COPYLIST L))) + (CAR L) (CADR L) NIL NIL NIL NIL NIL NIL)) + +; Checks to see if a user is clobbering the name of a system function. +; Prints a warning and returns T if he is, and NIL if he isn't. +(DEFUN MREDEF-CHECK (FNNAME) + (COND ((AND (NOT (MGET FNNAME 'MEXPR)) + (OR (AND #+MacLisp + (GETL FNNAME '(SUBR FSUBR MFEXPR*S LSUBR AUTOLOAD)) + #+Franz (getd fnname) + #+NIL + (OR (GET FNNAME MFEXPR*) + (GETL-NIL-FCN-PROP FNNAME '(SUBR))) + #+LISPM + (OR (GET FNNAME 'AUTOLOAD) + (GETL-LM-FCN-PROP FNNAME '(SUBR FSUBR LSUBR)) + (GET FNNAME 'MFEXPR*S)) + (NOT (GET FNNAME 'TRANSLATED))) + (MOPP FNNAME))) + (PRINC "Warning - you are redefining the MACSYMA ") + (IF (GETL FNNAME '(VERB OPERATORS)) + (PRINC "command ") (PRINC "function ")) + (PRINC (STRIPDOLLAR FNNAME)) + (TERPRI) + #+(OR MACLISP FRANZ) (ARGS FNNAME NIL) + T))) + +(DEFUN MDEFARRAY (FUN SUBS ARGS BODY MQDEF) + (COND ((AND (NULL ARGS) (NOT MQDEF)) (MPUTPROP FUN (MDEFINE1 SUBS BODY) 'AEXPR)) + ((NULL (DOLIST (U SUBS) + (IF (NOT (OR ($CONSTANTP U) (= (GETCHARN U 1) #/&))) + (RETURN T)))) + (ARRSTORE (CONS (NCONS FUN) SUBS) (MDEFINE1 ARGS BODY))) + (T (MDEFCHK FUN SUBS T NIL) + (MPUTPROP FUN (MDEFINE1 SUBS (MDEFINE1 ARGS BODY)) 'AEXPR)))) + +(DEFMFUN MSPECFUNP (FUN) + (AND (OR (GETL-FUN FUN '(FSUBR FEXPR MACRO)) + (GETL FUN '(MFEXPR* MFEXPR*S)) + (AND $TRANSRUN (GET FUN 'TRANSLATED-MMACRO)) + (MGET FUN 'MMACRO)) + (NOT (GET FUN 'EVOK)))) + +(DEFUN MDEFINE1 (ARGS BODY) + (IF FUNDEFSIMP + (LET ((SBODY (SIMPLIFY BODY))) + (WHEN (AND (NOT (ATOM BODY)) (NOT (ATOM SBODY))) + (RPLACA BODY (CAR SBODY)) (RPLACD BODY (CDR SBODY))))) + (LIST '(LAMBDA) (CONS '(MLIST) ARGS) BODY)) + +(DEFUN MDEFCHK (FUN ARGS ARY MQDEF) + (DO ((L ARGS (CDR L)) (MFEX) (MLEX)) + ((NULL L) (AND MFEX (NOT MQDEF) (MPUTPROP FUN MFEX 'MFEXPRP)) + (AND MLEX (NOT MQDEF) (MPUTPROP FUN MLEX 'MLEXPRP))) + (IF (NOT (OR (MDEFPARAM (CAR L)) + (AND (OR (NOT ARY) MQDEF) + (OR (AND MFEXPRP (MQUOTEP (CAR L)) + (MDEFPARAM (CADAR L)) (SETQ MFEX T)) + (AND (MDEFLISTP L) + (OR (MDEFPARAM (CADAR L)) + (AND MFEXPRP (MQUOTEP (CADAR L)) + (MDEFPARAM (CADR (CADAR L))) + (SETQ MFEX T))) + (SETQ MLEX T)))))) + (MERROR "Improper parameter in function definition for ~:M:~%~M" + FUN (CAR L))))) + +(DEFUN MDEFPARAM (X) + (AND (ATOM X) (NOT (CONSTANTP X)) (NOT (= (GETCHARN X 1) #/&)))) + +(DEFUN MDEFLISTP (L) + (AND (NULL (CDR L)) ($LISTP (CAR L)) (CDAR L) (NULL (CDDAR L)))) + +(DEFMFUN MOPP (X) + (AND (NOT (EQ X 'MQAPPLY)) + (OR (MOPP1 X) + (AND (NOT EVP) (GET X 'OPERATORS) (NOT (RULECHK X)) (NOT (GET X 'OPERS)))))) + +(DEFMFUN MOPP1 (X) (AND (SETQ X (GET X 'OP)) (NOT (MEMQ X (CDR $PROPS))))) + +;(DEFMFUN $CALL FEXPR (L) +; (IF (NULL L) (MERROR "Wrong number of args to CALL")) +; (MEVAL (CONS (NCONS (CAR L)) (CDR L)))) + +;(DEFMFUN $ACALL FEXPR (L) +; (IF (NULL L) (MERROR "Wrong number of args to ACALL")) +; (MEVAL (CONS (CONS (CAR L) '(ARRAY)) (CDR L)))) + +(DEFMSPEC $APPLY (L) + (TWOARGCHECK L) + (LET ((FUN (MEVAL (CADR L))) (ARG (MEVAL (CADDR L)))) + (IF (NOT ($LISTP ARG)) + (MERROR "Attempt to apply ~:M to ~M~ + ~%Second argument to APPLY must be a list." + FUN ARG)) + (AUTOLDCHK (SETQ FUN (GETOPR FUN))) + (MAPPLY FUN (CDR ARG) (CADR L)))) + +(DEFUN AUTOLDCHK (FUN) + (IF (AND (SYMBOLP FUN) + (GET FUN 'AUTOLOAD) + (NOT (OR (FBOUNDP FUN) (MFBOUNDP FUN)))) + (LOAD-FUNCTION FUN T))) + +(DEFMSPEC $DISPFUN (L) (SETQ L (CDR L)) + (COND ((OR (CDR L) (NOT (EQ (CAR L) '$ALL))) (DISPFUN1 L NIL NIL)) + (T (DISPFUN1 (CDR $FUNCTIONS) T NIL) + (DISPFUN1 (MAPCAN #'(LAMBDA (X) (IF (MGET X 'AEXPR) (NCONS X))) + (CDR $ARRAYS)) + NIL T) + (DISPFUN1 (CDR $MACROS) T NIL)))) + +(DEFUN DISPFUN1 (L FLAG MAEXPRP) + (DOLIST (FUN L) ($LDISP (CONSFUNDEF (IF FLAG (CAAR FUN) FUN) MAEXPRP NIL))) + '$DONE) + +(DEFMSPEC $FUNDEF (X) (CONSFUNDEF (FEXPRCHECK X) NIL NIL)) + +(DEFUN CONSFUNDEF (X MAEXPRP STRINGP) + (PROG (ARRYP NAME FUN) + (SETQ ARRYP (AND (NOT (ATOM X)) (NOT (EQ (CAAR X) 'MQAPPLY)) (MEMQ 'ARRAY (CDAR X)))) + (COND ((ATOM X) (SETQ NAME ($VERBIFY X) + FUN (OR (AND (NOT MAEXPRP) (MGETL NAME '(MEXPR MMACRO))) + (MGETL NAME '(AEXPR))))) + (ARRYP (SETQ FUN (MEVAL1 (SETQ NAME (CONS (LIST ($VERBIFY (CAAR X)) 'ARRAY) (CDR X))))) + (IF (OR (ATOM FUN) (NOT (EQ (CAAR FUN) 'LAMBDA))) (SETQ FUN NIL)))) + (COND ((NOT FUN) (COND (STRINGP (RETURN X)) ((MEMQ 'EDIT STATE-PDL) (TERPRI))) + (MERROR "~:M is not the name of a user function." X)) + ((AND (NOT ARRYP) (MFILEP (CADR FUN))) + (SETQ FUN (LIST (CAR FUN) (DSKGET (CADADR FUN) (CAR (CDDADR FUN)) (CAR FUN) NIL))))) + (RETURN + (CONS (IF (EQ (CAR FUN) 'MMACRO) '(MDEFMACRO SIMP) '(MDEFINE SIMP)) + (COND (ARRYP (CONS (CONS '(MQAPPLY) (CONS NAME (CDADR FUN))) (CDDR FUN))) + (T ((LAMBDA (BODY) + (COND ((AND (EQ (CAR FUN) 'AEXPR) (NOT (ATOM BODY)) + (EQ (CAAR BODY) 'LAMBDA)) + (LIST (CONS '(MQAPPLY) (CONS (CONS (CONS NAME '(ARRAY)) + (CDR (CADADR FUN))) + (CDADR BODY))) + (CADDR BODY))) + (T (LIST (CONS (CONS NAME (IF (EQ (CAR FUN) 'AEXPR) '(ARRAY))) + (CDR (CADADR FUN))) + BODY)))) + (CADDR (CADR FUN))))))))) + + +(DEFMFUN $FUNMAKE (FUN ARGS) + (IF (NOT (OR (SYMBOLP FUN) ($SUBVARP FUN) + (AND (NOT (ATOM FUN)) (EQ (CAAR FUN) 'LAMBDA)))) + (MERROR "Bad first argument to FUNMAKE: ~M" FUN)) + (IF (NOT ($LISTP ARGS)) (MERROR "Bad second argument to FUNMAKE: ~M" ARGS)) + (MCONS-OP-ARGS (GETOPR FUN) (CDR ARGS))) + +(DEFMFUN MCONS-OP-ARGS (OP ARGS) + (IF (SYMBOLP OP) (CONS (NCONS OP) ARGS) (LIST* '(MQAPPLY) OP ARGS))) + +(DEFMFUN OPTIONP (X) + (AND (BOUNDP X) (NOT (MEMQ X (CDR $VALUES))) (NOT (MEMQ X (CDR $LABELS))))) + +(DEFMSPEC MCOND (FORM) (SETQ FORM (CDR FORM)) + (DO ((U FORM (CDDR U)) (V)) + ((NULL U) NIL) + (COND ((EQ (SETQ V (MEVALP (CAR U))) T) (RETURN (MEVAL (CADR U)))) + (V (RETURN (LIST* '(MCOND) V (MAPCAR #'MEVAL-ATOMS (CDR U)))))))) + +(DEFUN MEVAL-ATOMS (FORM) + (COND ((ATOM FORM) (MEVAL1 FORM)) + ((EQ (CAAR FORM) 'MQUOTE) (CADR FORM)) + ((AND (OR (GETL-FUN (CAAR FORM) '(FSUBR FEXPR)) + (GETL (CAAR FORM) '(MFEXPR* MFEXPR*S))) + (NOT (MEMQ (CAAR FORM) '(MCOND MAND MOR MNOT MPROGN MDO MDOIN)))) + FORM) + (T (RECUR-APPLY #'MEVAL-ATOMS FORM)))) + +(DEFMSPEC MDO (FORM) (SETQ FORM (CDR FORM)) + ((LAMBDA (MDOP VAR NEXT TEST DO) + (SETQ NEXT (OR (CADDDR FORM) (LIST '(MPLUS) (OR (CADDR FORM) 1) VAR)) + TEST (LIST '(MOR) + (COND ((NULL (CAR (CDDDDR FORM))) NIL) + (T (LIST (IF (MNEGP ($NUMFACTOR (SIMPLIFY (CADDR FORM)))) + '(MLESSP) + '(MGREATERP)) + VAR (CAR (CDDDDR FORM))))) + (CADR (CDDDDR FORM))) + DO (CADDR (CDDDDR FORM))) + (MBINDING ((NCONS VAR) + (NCONS (IF (NULL (CADR FORM)) 1 (MEVAL (CADR FORM))))) + (DO ((VAL) (BINDL BINDLIST)) + ((IS TEST) '$DONE) + (COND ((NULL (SETQ VAL (*CATCH 'MPROG (PROG2 (MEVAL DO) NIL)))) + (MSET VAR (MEVAL NEXT))) + ((ATOM VAL) (MERROR "GO not in BLOCK:~%~M" VAL)) + ((NOT (EQ BINDL BINDLIST)) + (MERROR "Illegal RETURN:~%~M" (CAR VAL))) + (T (RETURN (CAR VAL))))))) + T (OR (CAR FORM) 'MDO) NIL NIL NIL)) + +(DEFMSPEC MDOIN (FORM) (SETQ FORM (CDR FORM)) + ((LAMBDA (MDOP VAR SET TEST ACTION) + (SETQ SET (IF (ATOM (SETQ SET (FORMAT1 (MEVAL (CADR FORM))))) + (MERROR "Atomic 'IN' argument to DO statement:~%~M" SET) + (MARGS SET)) + TEST (LIST '(MOR) + (IF (CAR (CDDDDR FORM)) + (LIST '(MGREATERP) VAR (CAR (CDDDDR FORM)))) + (CADR (CDDDDR FORM))) + ACTION (CADDR (CDDDDR FORM))) + (COND ((ATOM SET) '$DONE) + (T (MBINDING ((NCONS VAR) (NCONS (CAR SET))) + (DO ((VAL) (BINDL BINDLIST)) + ((OR (ATOM SET) (IS TEST)) + '$DONE) + (COND ((NULL (SETQ VAL (*CATCH 'MPROG (PROG2 (MEVAL ACTION) NIL)))) + (IF (SETQ SET (CDR SET)) (MSET VAR (CAR SET)))) + ((ATOM VAL) (MERROR "GO not in BLOCK:~%~M" VAL)) + ((NOT (EQ BINDL BINDLIST)) + (MERROR "Illegal RETURN:~%~M" (CAR VAL))) + (T (RETURN (CAR VAL))))))))) + T (OR (CAR FORM) 'MDO) NIL NIL NIL)) + +(DEFMSPEC MPROG (PROG) (SETQ PROG (CDR PROG)) + (LET (VARS VALS (MLOCP T)) + (IF ($LISTP (CAR PROG)) (SETQ VARS (CDAR PROG) PROG (CDR PROG))) + (SETQ LOCLIST (CONS NIL LOCLIST)) + (DO ((L VARS (CDR L))) ((NULL L) (SETQ VALS VARS)) + (IF (NOT (ATOM (CAR L))) (RETURN (SETQ VALS T)))) + (IF (EQ VALS T) + (SETQ VALS (MAPCAR #'(LAMBDA (V) + (COND ((ATOM V) V) + ((EQ (CAAR V) 'MSETQ) (MEVAL (CADDR V))) + (T (MERROR + "Improper form in BLOCK variable list: ~M" + V)))) + VARS) + VARS (MAPCAR #'(LAMBDA (V) (IF (ATOM V) V (CADR V))) VARS))) + (MBINDING (VARS VALS) + (DO ((PROG PROG (CDR PROG)) (MPROGP PROG) + (BINDL BINDLIST) (VAL '$DONE) (RETP) (X) ($%% '$%%)) + ((NULL PROG) (MUNLOCAL) VAL) + (COND ((ATOM (CAR PROG)) + (IF (NULL (CDR PROG)) + (SETQ RETP T VAL (MEVAL (CAR PROG))))) + ((NULL (SETQ X (*CATCH 'MPROG + (PROG2 (SETQ VAL (SETQ $%% (MEVAL (CAR PROG)))) + NIL))))) + ((NOT (EQ BINDL BINDLIST)) + (IF (NOT (ATOM X)) + (MERROR "Illegal RETURN:~%~M" (CAR X)) + (MERROR "Illegal GO:~%~M" X))) + ((NOT (ATOM X)) (SETQ RETP T VAL (CAR X))) + ((NOT (SETQ PROG (MEMBER X MPROGP))) + (MERROR "No such tag as ~:M" X))) + (IF RETP (SETQ PROG '(NIL))))))) + +(DEFMFUN MRETURN (X) + (IF (AND (NOT MPROGP) (NOT MDOP)) + (MERROR "RETURN not in BLOCK:~%~M" X)) + (*THROW 'MPROG (NCONS X))) + +(DEFMSPEC MGO (TAG) + (SETQ TAG (FEXPRCHECK TAG)) + (COND ((NOT MPROGP) (MERROR "GO not in BLOCK:~%~M" TAG)) + ((ATOM TAG) (*THROW 'MPROG TAG)) + (T (MERROR "Argument to GO not atomic:~%~M" TAG)))) + +(DEFMSPEC $SUBVAR (L) (SETQ L (CDR L)) + (IF (NULL L) (WNA-ERR '$SUBVAR)) (MEVAL (CONS '(MQAPPLY ARRAY) L))) + +(DEFMFUN RAT (X Y) `((RAT SIMP) ,X ,Y)) + +(DEFMFUN $EXP (X) `((MEXPT) $%E ,X)) + +(DEFMFUN $SQRT (X) `((%SQRT) ,X)) + +(DEFMFUN ADD2LNC (ITEM LIST) + (WHEN (NOT (MEMALIKE ITEM (IF ($LISTP LIST) (CDR LIST) LIST))) + (IF (NOT (ATOM ITEM)) (DELETE (ASSOC (CAR ITEM) LIST) LIST 1)) + (NCONC LIST (NCONS ITEM)))) + +(DEFMFUN BIGFLOATM* (BF) + (IF (NOT (MEMQ 'SIMP (CDAR BF))) + (SETQ BF (CONS (LIST* (CAAR BF) 'SIMP (CDAR BF)) (CDR BF)))) + (IF $FLOAT ($FLOAT BF) BF)) + +(DEFMFUN $ALLBUT N (CONS '($ALLBUT) (LISTIFY N))) + +(DEFMFUN MFILEP (X) (AND (NOT (ATOM X)) (EQ (CAAR X) 'MFILE))) + +#-NIL +(DEFMFUN DSKSETQ FEXPR (L) (LET ((DSKSETP T)) (MSET (CAR L) (EVAL (CADR L))))) + +(DEFMFUN DSKRAT (X) + (ORDERPOINTER (CADDAR X)) + (MAPC #'(LAMBDA (A B) (DSKRAT-SUBST A B (CDDDDR (CAR X))) ; for TAYLOR forms + (DSKRAT-SUBST A B (CDR X))) + GENVAR (CADDDR (CAR X))) + (RPLACA (CDDDAR X) GENVAR) + #-(OR LISPM NIL) (GCTWA) + (IF (MEMQ 'TRUNC (CAR X)) (SRCONVERT X) X)) ; temporary + +(DEFUN DSKRAT-SUBST (X Y Z) + (COND ((ATOM Z) Z) + (T (IF (EQ Y (CAR Z)) (RPLACA Z X) (DSKRAT-SUBST X Y (CAR Z))) + (DSKRAT-SUBST X Y (CDR Z)) + Z))) + +(DEFMFUN |''MAKE-FUN| (NOUN-NAME X) + (LET (($NUMER T) ($FLOAT T)) + (SIMPLIFYA (LIST (NCONS NOUN-NAME) (RESIMPLIFY X)) T))) + +(DEFMACRO |''MAKE| (FUN NOUN) + `(DEFMFUN ,FUN (X) (|''MAKE-FUN| ',NOUN X))) + +(|''MAKE| $LOG %LOG) +(|''MAKE| $SIN %SIN) (|''MAKE| $COS %COS) (|''MAKE| $TAN %TAN) +(|''MAKE| $COT %COT) (|''MAKE| $SEC %SEC) (|''MAKE| $CSC %CSC) +(|''MAKE| $SINH %SINH) (|''MAKE| $COSH %COSH) (|''MAKE| $TANH %TANH) +(|''MAKE| $COTH %COTH) (|''MAKE| $SECH %SECH) (|''MAKE| $CSCH %CSCH) +(|''MAKE| $ASIN %ASIN) (|''MAKE| $ACOS %ACOS) (|''MAKE| $ATAN %ATAN) +(|''MAKE| $ACOT %ACOT) (|''MAKE| $ASEC %ASEC) (|''MAKE| $ACSC %ACSC) +(|''MAKE| $ASINH %ASINH) (|''MAKE| $ACOSH %ACOSH) (|''MAKE| $ATANH %ATANH) +(|''MAKE| $ACOTH %ACOTH) (|''MAKE| $ASECH %ASECH) (|''MAKE| $ACSCH %ACSCH) +(|''MAKE| $GAMMA %GAMMA) + +(DEFMFUN $BINOMIAL (X Y) + (LET (($NUMER T) ($FLOAT T)) (SIMPLIFY (LIST '(%BINOMIAL) X Y)))) + +(PROG1 '(EVFUN properties) + (MAPC #'(LAMBDA (X) (PUTPROP X T 'EVFUN)) + '($RADCAN $FACTOR $RATSIMP $TRIGEXPAND $TRIGREDUCE $LOGCONTRACT + $ROOTSCONTRACT $BFLOAT $RATEXPAND $FULLRATSIMP $RECTFORM + $POLARFORM))) + +(PROG1 '(EVFLAG properties) + (MAPC #'(LAMBDA (X) (PUTPROP X T 'EVFLAG)) + '($EXPONENTIALIZE $%EMODE $DEMOIVRE $LOGEXPAND $LOGARC $LOGNUMER + $RADEXPAND $KEEPFLOAT $LISTARITH $FLOAT $RATSIMPEXPONS $RATMX + $SIMP $SIMPSUM $ALGEBRAIC $RATALGDENOM $FACTORFLAG $RATFAC + $INFEVAL $%ENUMER $PROGRAMMODE $LOGNEGINT $LOGABS $LETRAT + $HALFANGLES $EXPTISOLATE $ISOLATE_WRT_TIMES $SUMEXPAND + $NUMER_PBRANCH M1PBRANCH $DOTSCRULES))) + +(MDEFPROP $%E 2.71828182845904523536 $NUMER) ; (EXP 1) [wrong in ITS-MACLISP] +(MDEFPROP $%PI 3.14159265358979323846 $NUMER) ; (ATAN 0 -1) +(MDEFPROP $%PHI 1.61803398874989484820 $NUMER) ; (1+sqrt(5))/2 +(MDEFPROP $%GAMMA 0.5772156649015328606 $NUMER) ; Euler's constant + +(MDEFPROP $HERALD_PACKAGE (NIL $TRANSLOAD T) $PROPS) +(MDEFPROP $LOAD_PACKAGE (NIL $TRANSLOAD T) $PROPS) + +(DEFPROP BIGFLOAT BIGFLOATM* MFEXPR*) +(DEFPROP LAMBDA CONSTLAM MFEXPR*) +(DEFPROP QUOTE CADR MFEXPR*) ; Needed by MATCOM/MATRUN. + +(EVAL-WHEN (EVAL COMPILE) (SETQ IBASE OLD-IBASE)) + + +; Undeclarations for the file: +(DECLARE (NOTYPE N I J NNEED NGIVEN NCELLS NITEMS LISPSUB INDX EVFLG)) + diff --git a/src/jpg/ode2.trlisp b/src/jpg/ode2.trlisp new file mode 100644 index 00000000..05707c20 --- /dev/null +++ b/src/jpg/ode2.trlisp @@ -0,0 +1,231 @@ +;;; -*- Mode: Lisp; Package: Macsyma -*- +;;; Translated code for DSK:JPG;ODE2 69 + +;;; TRANSL-AUTOLOAD version by GJC on FRIDAY, October 2, 1981, at 2:55:39 +;;; TRHOOK version 5 TRMODE version NIL DCL version 7/28/81 17:25:57 +;;; MCOMPI version NIL TRDATA version 66 ACALL version NIL +;;; FCALL version NIL TRANSQ version NIL MDEFUN version NIL +;;; MTAGS version NIL TRPRED version 2 TROPER version 13 +;;; TRANSF version 11 TRANS5 version 25 TRANS4 version NIL +;;; TRANS3 version 46 TRANS2 version 39 TRANS1 version 106 +;;; TRUTIL version 22 TRANSL version 1154 TRANSS version 79 +(includef (cond ((status feature ITS) '|DSK:LIBMAX;TPRELU >|) + ((status feature Multics) '|translate|) + ((status feature Unix) '|libmax/tprelu.l|) + (t (error '|Unknown system, see GJC@MIT-MC|)))) + +(eval-when (compile eval) + (or (status feature lispm) + (setq *infile-name-key* + ((lambda (file-name) + ;; temp crock for multics. + (cond ((eq (typep file-name) 'list) + (namestring file-name)) + (t file-name))) + (truename infile))))) + +(eval-when (compile) + (setq $tr_semicompile 'NIL) + (setq forms-to-compile-queue ())) + +(comment |DSK:JPG;ODE2 68|) + +(DECLARE (SPECIAL $INTFACTOR $ODEINDEX)) +(DEF-MTRVAR $YNEW (QUOTE $YNEW) 1.) +(DEFMTRFUN-EXTERNAL ($ODE2 $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $MSG1 (QUOTE $MSG1) 1.) +(DEFMTRFUN-EXTERNAL ($ODE2A $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $MSG2 (QUOTE $MSG2) 1.) +(DEFMTRFUN-EXTERNAL ($ODE1A $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($DESIMP $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $Y (QUOTE $Y) 1.) +(DEF-MTRVAR $X (QUOTE $X) 1.) +(DEFMTRFUN-EXTERNAL ($PR2 $BOOLEAN MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($FTEST $BOOLEAN MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($SOLVE1 $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $F (QUOTE $F) 1.) +(DEF-MTRVAR $G (QUOTE $G) 1.) +(DEFMTRFUN-EXTERNAL ($LINEAR2 $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $%C (QUOTE $%C) 1.) +(DEFMTRFUN-EXTERNAL ($SOLVELNR $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($SEPARABLE $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($INTEGFACTOR $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $YOLD (QUOTE $YOLD) 1.) +(DEF-MTRVAR $Q (QUOTE $Q) 1.) +(DEFMTRFUN-EXTERNAL ($EXACT $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($SOLVEHOM $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($SOLVEBERNOULLI $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($GENHOM $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($HOM2 $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $ALL (QUOTE $ALL) 1.) +(DEF-MTRVAR $PNZ (QUOTE $PNZ) 1.) +(DEF-MTRVAR $%K1 (QUOTE $%K1) 1.) +(DEF-MTRVAR $%K2 (QUOTE $%K2) 1.) +(DEF-MTRVAR $ZERO (QUOTE $ZERO) 1.) +(DEF-MTRVAR $POS (QUOTE $POS) 1.) +(DEF-MTRVAR $EXPONENTIALIZE NIL 1.) +(DEFMTRFUN-EXTERNAL ($CC2 $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($EXACT2 $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($XCC2 $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $METHOD (QUOTE $METHOD) 1.) +(DEF-MTRVAR $CONSTCOEFF (QUOTE $CONSTCOEFF) 1.) +(DEF-MTRVAR $YP (QUOTE $YP) 1.) +(DEFMTRFUN-EXTERNAL ($VARP $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($REDUCE2 $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($NLX $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($NLY $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($NLXY $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($PTTEST $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $PT (QUOTE $PT) 1.) +(DEFMTRFUN-EXTERNAL ($EULER2 $ANY MDEFINE NIL NIL)) +(DEF-MTRVAR $INTEGER (QUOTE $INTEGER) 1.) +(DEF-MTRVAR $%J (QUOTE $%J) 1.) +(DEF-MTRVAR $%Y (QUOTE $%Y) 1.) +(DEFMTRFUN-EXTERNAL ($BESSEL2 $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($IC1 $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($BC2 $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($IC2 $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($NOTEQN $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($BOUNDTEST $ANY MDEFINE NIL NIL)) +(DEFMTRFUN-EXTERNAL ($FAILURE $BOOLEAN MDEFINE NIL NIL)) + +(DEFPROP $ODE2 T TRANSLATED) +(ADD2LNC (QUOTE $ODE2) $PROPS) +(DEFMTRFUN ($ODE2 $ANY MDEFINE NIL NIL) ($EQ $YOLD $X) NIL ((LAMBDA ($DERIVSUBST) NIL (SIMPLIFY ($SUBSTITUTE $YOLD (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) (SIMPLIFY (MFUNCTION-CALL $ODE2A (SIMPLIFY ($SUBSTITUTE (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) $YOLD $EQ)) (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) $X))))) NIL)) + +(DEFPROP $ODE2A T TRANSLATED) +(ADD2LNC (QUOTE $ODE2A) $PROPS) +(DEFMTRFUN ($ODE2A $ANY MDEFINE NIL NIL) ($EQ $Y $X) NIL ((LAMBDA ($DE $A1 $A2 $A3 $A4 $Q) NIL (PROG NIL (SETQ $INTFACTOR NIL) (SETQ $METHOD (QUOTE $NONE)) (COND (($FREEOF (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X 2.)) $EQ) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $ODE1A $EQ $Y $X))))) (RETURN $Q)) (T (RETURN NIL))))) (COND ((NOT (LIKE (SIMPLIFY ($DERIVDEGREE (SETQ $DE (SIMPLIFY (MFUNCTION-CALL $DESIMP (ADD* ($LHS $EQ) (SIMPLIFY (LIST (QUOTE (MMINUS)) ($RHS $EQ))))))) $Y $X)) 2.)) (RETURN (SIMPLIFY (MFUNCTION-CALL $FAILURE (TRD-MSYMEVAL $MSG1 (QUOTE $MSG1)) $EQ))))) (SETQ $A1 (SIMPLIFY ($COEFF $DE (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X 2.))))) (SETQ $A2 (SIMPLIFY ($COEFF $DE (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X))))) (SETQ $A3 (SIMPLIFY ($COEFF $DE $Y))) (SETQ $A4 (SIMPLIFY ($EXPAND (ADD* $DE (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $A1 (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X 2.))))) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $A2 (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X))))) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $A3 $Y))))))) (COND ((AND (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $PR2 $A1))) (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $PR2 $A2))) (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $PR2 $A3))) (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $PR2 $A4))) (IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $HOM2 $A1 $A2 $A3)))))) (COND ((LIKE $A4 0.) (RETURN $Q)) (T (RETURN (SIMPLIFY (MFUNCTION-CALL $VARP $Q (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV $A4 $A1)))))))))) (RETURN (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $REDUCE2 $DE))))) (RETURN $Q)) (T (RETURN NIL)))))) (QUOTE $DE) (QUOTE $A1) (QUOTE $A2) (QUOTE $A3) (QUOTE $A4) (QUOTE $Q))) + +(DEFPROP $ODE1A T TRANSLATED) +(ADD2LNC (QUOTE $ODE1A) $PROPS) +(DEFMTRFUN ($ODE1A $ANY MDEFINE NIL NIL) ($EQ $Y $X) NIL ((LAMBDA ($DE $DES $F $G $Q) NIL (PROG NIL (COND ((NOT (LIKE (SIMPLIFY ($DERIVDEGREE (SETQ $DE (SIMPLIFY ($EXPAND (ADD* ($LHS $EQ) (SIMPLIFY (LIST (QUOTE (MMINUS)) ($RHS $EQ))))))) $Y $X)) 1.)) (RETURN (SIMPLIFY (MFUNCTION-CALL $FAILURE (TRD-MSYMEVAL $MSG1 (QUOTE $MSG1)) $EQ))))) (COND ((LIKE (SIMPLIFY (MFUNCTION-CALL $LINEAR2 $DE (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X)))) NIL) (RETURN (SIMPLIFY (MFUNCTION-CALL $FAILURE (TRD-MSYMEVAL $MSG2 (QUOTE $MSG2)) $EQ))))) (SETQ $DES (SIMPLIFY (MFUNCTION-CALL $DESIMP $DE))) (SETQ $DE (SIMPLIFY (MFUNCTION-CALL $SOLVE1 $DES (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X))))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $SOLVELNR $DE))))) (RETURN $Q))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $SEPARABLE $DE))))) (RETURN $Q))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $INTEGFACTOR $G $F))))) (RETURN (SIMPLIFY (MFUNCTION-CALL $EXACT (MUL* $Q $G) (MUL* $Q $F)))))) (COND ((LIKE (SIMPLIFY (MFUNCTION-CALL $LINEAR2 $DES (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $Y $X)))) NIL) (RETURN (SIMPLIFY (MFUNCTION-CALL $FAILURE (TRD-MSYMEVAL $MSG2 (QUOTE $MSG2)) $EQ))))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $INTEGFACTOR $G $F))))) (RETURN (SIMPLIFY (MFUNCTION-CALL $EXACT (MUL* $Q $G) (MUL* $Q $F)))))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $SOLVEHOM $DE))))) (RETURN $Q))) (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $SOLVEBERNOULLI $DE))))) (RETURN $Q))) (RETURN (COND ((IS-BOOLE-CHECK (SIMPLIFY (MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $GENHOM $DE))))) (RETURN $Q)) (T (RETURN NIL)))))) (QUOTE $DE) (QUOTE $DES) (QUOTE $F) (QUOTE $G) (QUOTE $Q))) + +(DEFPROP $DESIMP T TRANSLATED) +(ADD2LNC (QUOTE $DESIMP) $PROPS) +(DEFMTRFUN ($DESIMP $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($INFLAG) NIL (PROG NIL (SETQ $EQ (SIMPLIFY ($FACTOR $EQ))) (COND ((OR ($ATOM $EQ) (NOT (LIKE (SIMPLIFY ($INPART $EQ 0.)) (QUOTE &*)))) (RETURN (SIMPLIFY ($EXPAND $EQ))))) (SETQ $EQ (SIMPLIFY (MAP1 (GETOPR (M-TLAMBDA ($U) NIL (COND (($FREEOF (SIMPLIFY ($NOUNIFY (QUOTE $DIFF))) $U) 1.) (T $U)))) $EQ))) (RETURN (SIMPLIFY ($EXPAND $EQ))))) T)) + +(DEFPROP $PR2 T TRANSLATED) +(ADD2LNC (QUOTE $PR2) $PROPS) +(DEFMTRFUN ($PR2 $BOOLEAN MDEFINE NIL NIL) ($F) NIL ($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) $F)) + +(DEFPROP $FTEST T TRANSLATED) +(ADD2LNC (QUOTE $FTEST) $PROPS) +(DEFMTRFUN ($FTEST $BOOLEAN MDEFINE NIL NIL) ($CALL) NIL (NOT (LIKE (SETQ $Q $CALL) NIL))) + +(DEFPROP $SOLVE1 T TRANSLATED) +(ADD2LNC (QUOTE $SOLVE1) $PROPS) +(DEFMTRFUN ($SOLVE1 $ANY MDEFINE NIL NIL) ($EQ $Y) NIL ((LAMBDA ($PROGRAMMODE) NIL (SIMPLIFY ($FIRST (SIMPLIFY ($SOLVE $EQ $Y))))) T)) + +(DEFPROP $LINEAR2 T TRANSLATED) +(ADD2LNC (QUOTE $LINEAR2) $PROPS) +(DEFMTRFUN ($LINEAR2 $ANY MDEFINE NIL NIL) ($EXPR $X) NIL ((LAMBDA NIL NIL (PROG NIL (SETQ $F (SIMPLIFY ($RATCOEF $EXPR $X))) (COND ((NOT ($FREEOF $X (TRD-MSYMEVAL $F (QUOTE $F)))) (RETURN NIL))) (SETQ $G (SIMPLIFY ($RATSIMP (ADD* $EXPR (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* (TRD-MSYMEVAL $F (QUOTE $F)) $X))))))) (RETURN ($FREEOF $X (TRD-MSYMEVAL $G (QUOTE $G)))))))) + +(DEFPROP $SOLVELNR T TRANSLATED) +(ADD2LNC (QUOTE $SOLVELNR) $PROPS) +(DEFMTRFUN ($SOLVELNR $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($F $G $W) NIL (PROG NIL (COND ((LIKE (SIMPLIFY (MFUNCTION-CALL $LINEAR2 ($RHS $EQ) (TRD-MSYMEVAL $Y (QUOTE $Y)))) NIL) (RETURN NIL))) (SETQ $W (SIMPLIFY ($EXP (SIMPLIFY ($INTEGRATE $F (TRD-MSYMEVAL $X (QUOTE $X))))))) (SETQ $METHOD (QUOTE $LINEAR)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (MUL* $W (ADD* (SIMPLIFY ($INTEGRATE (DIV $G $W) (TRD-MSYMEVAL $X (QUOTE $X)))) (TRD-MSYMEVAL $%C (QUOTE $%C))))))))) (QUOTE $F) (QUOTE $G) (QUOTE $W))) + +(DEFPROP $SEPARABLE T TRANSLATED) +(ADD2LNC (QUOTE $SEPARABLE) $PROPS) +(DEFMTRFUN ($SEPARABLE $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($XPART $YPART $FLAG $INFLAG) NIL (PROG NIL (SETQ $EQ (SIMPLIFY ($FACTOR ($RHS $EQ)))) (COND ((OR ($ATOM $EQ) (NOT (LIKE (SIMPLIFY ($INPART $EQ 0.)) (QUOTE &*)))) (SETQ $EQ (LIST (QUOTE (MLIST)) $EQ)))) (DO (($U) (MDO (CDR $EQ) (CDR MDO))) ((NULL MDO) (QUOTE $DONE)) (SETQ $U (CAR MDO)) (COND (($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) $U) (SETQ $YPART ($CONS $U $YPART))) (($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) $U) (SETQ $XPART ($CONS $U $XPART))) (T (RETURN (SETQ $FLAG T))))) (COND ((LIKE $FLAG T) (RETURN NIL))) (COND ((LIKE $XPART (QUOTE ((MLIST)))) (SETQ $XPART 1.)) (T (SETQ $XPART (SIMPLIFY (MAPPLY-TR (QUOTE &*) $XPART))))) (COND ((LIKE $YPART (QUOTE ((MLIST)))) (SETQ $YPART 1.)) (T (SETQ $YPART (SIMPLIFY (MAPPLY-TR (QUOTE &*) $YPART))))) (SETQ $METHOD (QUOTE $SEPARABLE)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY ($RATSIMP (SIMPLIFY ($INTEGRATE (DIV 1. $YPART) (TRD-MSYMEVAL $Y (QUOTE $Y)))))) (ADD* (SIMPLIFY ($RATSIMP (SIMPLIFY ($INTEGRATE $XPART (TRD-MSYMEVAL $X (QUOTE $X)))))) (TRD-MSYMEVAL $%C (QUOTE $%C)))))))) (QUOTE ((MLIST))) (QUOTE ((MLIST))) NIL T)) + +(DEFPROP $INTEGFACTOR T TRANSLATED) +(ADD2LNC (QUOTE $INTEGFACTOR) $PROPS) +(DEFMTRFUN ($INTEGFACTOR $ANY MDEFINE NIL NIL) ($M $N) NIL ((LAMBDA ($B1 $B2 $DMDX $DMDY $DNDX $DNDY $DD $%E_TO_NUMLOG) NIL (PROG NIL (SETQ $DMDY (SIMPLIFY ($RATSIMP (SIMPLIFY ($DIFF $M (TRD-MSYMEVAL $Y (QUOTE $Y))))))) (SETQ $DNDX (SIMPLIFY ($RATSIMP (SIMPLIFY ($DIFF $N (TRD-MSYMEVAL $X (QUOTE $X))))))) (COND ((LIKE (SETQ $DD (ADD* $DMDY (SIMPLIFY (LIST (QUOTE (MMINUS)) $DNDX)))) 0.) (RETURN 1.))) (SETQ $DMDX (SIMPLIFY ($RATSIMP (SIMPLIFY ($DIFF $M (TRD-MSYMEVAL $X (QUOTE $X))))))) (SETQ $DNDY (SIMPLIFY ($RATSIMP (SIMPLIFY ($DIFF $N (TRD-MSYMEVAL $Y (QUOTE $Y))))))) (COND ((AND (LIKE (ADD* $DMDX (SIMPLIFY (LIST (QUOTE (MMINUS)) $DNDY))) 0.) (LIKE (ADD* $DMDY $DNDX) 0.)) (RETURN (DIV 1. (ADD* (POWER $M 2.) (POWER $N 2.)))))) (COND (($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) (SETQ $B1 (SIMPLIFY ($RATSIMP (DIV $DD $N))))) (RETURN (SIMPLIFY ($EXP (SIMPLIFY ($INTEGRATE $B1 (TRD-MSYMEVAL $X (QUOTE $X))))))))) (RETURN (COND (($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (SETQ $B2 (SIMPLIFY ($RATSIMP (DIV $DD $M))))) (RETURN (SIMPLIFY ($EXP (SIMPLIFY ($INTEGRATE (SIMPLIFY (LIST (QUOTE (MMINUS)) $B2)) (TRD-MSYMEVAL $Y (QUOTE $Y)))))))) (T (RETURN NIL)))))) (QUOTE $B1) (QUOTE $B2) (QUOTE $DMDX) (QUOTE $DMDY) (QUOTE $DNDX) (QUOTE $DNDY) (QUOTE $DD) T)) + +(DEFPROP $EXACT T TRANSLATED) +(ADD2LNC (QUOTE $EXACT) $PROPS) +(DEFMTRFUN ($EXACT $ANY MDEFINE NIL NIL) ($M $N) NIL ((LAMBDA ($A) NIL (PROG NIL (SETQ $INTFACTOR (SIMPLIFY ($SUBSTITUTE (TRD-MSYMEVAL $YOLD (QUOTE $YOLD)) (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) (TRD-MSYMEVAL $Q (QUOTE $Q))))) (SETQ $A (SIMPLIFY ($INTEGRATE (SIMPLIFY ($RATSIMP $M)) (TRD-MSYMEVAL $X (QUOTE $X))))) (SETQ $METHOD (QUOTE $EXACT)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY ($RATSIMP (ADD* $A (SIMPLIFY ($INTEGRATE (SIMPLIFY ($RATSIMP (ADD* $N (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY ($DIFF $A (TRD-MSYMEVAL $Y (QUOTE $Y))))))))) (TRD-MSYMEVAL $Y (QUOTE $Y))))))) (TRD-MSYMEVAL $%C (QUOTE $%C))))))) (QUOTE $A))) + +(DEFPROP $SOLVEHOM T TRANSLATED) +(ADD2LNC (QUOTE $SOLVEHOM) $PROPS) +(DEFMTRFUN ($SOLVEHOM $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($QQ $A1 $A2) NIL (PROG NIL (SETQ $A1 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (MUL* (TRD-MSYMEVAL $X (QUOTE $X)) $QQ) (TRD-MSYMEVAL $Y (QUOTE $Y)) ($RHS $EQ)))))) (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) $A1)) (RETURN NIL))) (SETQ $A2 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (DIV (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))) $QQ (SIMPLIFY ($INTEGRATE (DIV 1. (ADD* $A1 (SIMPLIFY (LIST (QUOTE (MMINUS)) $QQ)))) $QQ))))))) (SETQ $METHOD (QUOTE $HOMOGENEOUS)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (MUL* (TRD-MSYMEVAL $%C (QUOTE $%C)) (TRD-MSYMEVAL $X (QUOTE $X))) (SIMPLIFY ($EXP $A2))))))) (QUOTE $QQ) (QUOTE $A1) (QUOTE $A2))) + +(DEFPROP $SOLVEBERNOULLI T TRANSLATED) +(ADD2LNC (QUOTE $SOLVEBERNOULLI) $PROPS) +(DEFMTRFUN ($SOLVEBERNOULLI $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($A1 $A2 $N) NIL (PROG NIL (SETQ $A1 (SIMPLIFY ($COEFF (SETQ $EQ (SIMPLIFY ($EXPAND ($RHS $EQ)))) (TRD-MSYMEVAL $Y (QUOTE $Y)) 1.))) (COND ((NOT ($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) $A1)) (RETURN NIL))) (SETQ $N (SIMPLIFY ($HIPOW (SIMPLIFY ($RATSIMP (ADD* $EQ (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $A1 (TRD-MSYMEVAL $Y (QUOTE $Y)))))))) (TRD-MSYMEVAL $Y (QUOTE $Y))))) (SETQ $A2 (SIMPLIFY ($COEFF $EQ (TRD-MSYMEVAL $Y (QUOTE $Y)) $N))) (COND ((OR (NOT ($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) $A2)) (NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $N)) (LIKE $N 0.) (NOT (LIKE $EQ (SIMPLIFY ($EXPAND (ADD* (MUL* $A1 (TRD-MSYMEVAL $Y (QUOTE $Y))) (MUL* $A2 (POWER (TRD-MSYMEVAL $Y (QUOTE $Y)) $N)))))))) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($INTEGRATE $A1 (TRD-MSYMEVAL $X (QUOTE $X))))) (SETQ $METHOD (QUOTE $BERNOULLI)) (SETQ $ODEINDEX $N) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (MUL* (SIMPLIFY ($EXP $A1)) (POWER (ADD* (MUL* (ADD* 1. (SIMPLIFY (LIST (QUOTE (MMINUS)) $N))) (SIMPLIFY ($INTEGRATE (MUL* $A2 (SIMPLIFY ($EXP (MUL* (ADD* $N -1.) $A1)))) (TRD-MSYMEVAL $X (QUOTE $X))))) (TRD-MSYMEVAL $%C (QUOTE $%C))) (DIV 1. (ADD* 1. (SIMPLIFY (LIST (QUOTE (MMINUS)) $N))))))))))) (QUOTE $A1) (QUOTE $A2) (QUOTE $N))) + +(DEFPROP $GENHOM T TRANSLATED) +(ADD2LNC (QUOTE $GENHOM) $PROPS) +(DEFMTRFUN ($GENHOM $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($G $U $N $A1 $A2 $A3) NIL (PROG NIL (SETQ $G (DIV (MUL* ($RHS $EQ) (TRD-MSYMEVAL $X (QUOTE $X))) (TRD-MSYMEVAL $Y (QUOTE $Y)))) (SETQ $N (SIMPLIFY ($RATSIMP (DIV (MUL* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY ($DIFF $G (TRD-MSYMEVAL $X (QUOTE $X))))) (MUL* (TRD-MSYMEVAL $Y (QUOTE $Y)) (SIMPLIFY ($DIFF $G (TRD-MSYMEVAL $Y (QUOTE $Y))))))))) (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $N)) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (DIV $U (POWER (TRD-MSYMEVAL $X (QUOTE $X)) $N)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $G))))) (SETQ $A2 (SIMPLIFY ($INTEGRATE (DIV 1. (MUL* $U (ADD* $N $A1))) $U))) (COND ((NOT ($FREEOF (SIMPLIFY ($NOUNIFY (QUOTE $INTEGRATE))) $A2)) (RETURN NIL))) (SETQ $A3 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (MUL* (TRD-MSYMEVAL $Y (QUOTE $Y)) (POWER (TRD-MSYMEVAL $X (QUOTE $X)) $N)) $U $A2))))) (SETQ $METHOD (QUOTE $GENHOM)) (SETQ $ODEINDEX $N) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $X (QUOTE $X)) (MUL* (TRD-MSYMEVAL $%C (QUOTE $%C)) (SIMPLIFY ($EXP $A3)))))))) (QUOTE $G) (QUOTE $U) (QUOTE $N) (QUOTE $A1) (QUOTE $A2) (QUOTE $A3))) + +(DEFPROP $HOM2 T TRANSLATED) +(ADD2LNC (QUOTE $HOM2) $PROPS) +(DEFMTRFUN ($HOM2 $ANY MDEFINE NIL NIL) ($A1 $A2 $A3) NIL ((LAMBDA ($AP $AQ $PT) NIL (PROG NIL (SETQ $AP (DIV $A2 $A1)) (SETQ $AQ (DIV $A3 $A1)) (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $CC2 $AP $AQ (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q))))) (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $EXACT2 $A1 $A2 $A3))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q))))) (COND ((LIKE (SETQ $PT (SIMPLIFY (MFUNCTION-CALL $PTTEST $AP))) NIL) (GO $END))) (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $EULER2 $AP $AQ))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q))))) (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $BESSEL2 $AP $AQ))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q))))) $END (RETURN (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $XCC2 $AP $AQ))) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q)))) (T (RETURN NIL)))))) (QUOTE $AP) (QUOTE $AQ) (QUOTE $PT))) + +(DEFPROP $CC2 T TRANSLATED) +(ADD2LNC (QUOTE $CC2) $PROPS) +(DEFMTRFUN ($CC2 $ANY MDEFINE NIL NIL) ($F $G $Y $X) NIL ((LAMBDA ($A $SIGN $RADEXPAND $ALPHA) NIL (PROG NIL (COND ((NOT (AND ($FREEOF $X $Y $F) ($FREEOF $X $Y $G))) (RETURN NIL))) (SETQ $METHOD (QUOTE $CONSTCOEFF)) (SETQ $A (ADD* (POWER $F 2.) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* 4. $G))))) (COND (($FREEOF (QUOTE $%I) $A) (SETQ $SIGN (SIMPLIFY ($ASKSIGN $A)))) (T (SETQ $RADEXPAND T) (SETQ $SIGN (TRD-MSYMEVAL $PNZ (QUOTE $PNZ))))) (COND ((LIKE $SIGN (TRD-MSYMEVAL $ZERO (QUOTE $ZERO))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) $Y (MUL* (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (MUL* $F $X) 2.))))) (ADD* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) $X)))))))) (COND ((LIKE $SIGN (TRD-MSYMEVAL $POS (QUOTE $POS))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) $Y (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY ($EXP (DIV (MUL* (ADD* (SIMPLIFY (LIST (QUOTE (MMINUS)) $F)) (SIMPLIFY (LIST (QUOTE (%SQRT)) $A))) $X) 2.)))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY ($EXP (DIV (MUL* (ADD* (SIMPLIFY (LIST (QUOTE (MMINUS)) $F)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY (LIST (QUOTE (%SQRT)) $A))))) $X) 2.)))))))))) (SETQ $A (SIMPLIFY (LIST (QUOTE (MMINUS)) $A))) (SETQ $ALPHA (DIV (MUL* $X (SIMPLIFY (LIST (QUOTE (%SQRT)) $A))) 2.)) (COND ((LIKE (TRD-MSYMEVAL $EXPONENTIALIZE NIL) NIL) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) $Y (MUL* (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (MUL* $F $X) 2.))))) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (LIST (QUOTE (%SIN)) $ALPHA))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (LIST (QUOTE (%COS)) $ALPHA)))))))))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) $Y (MUL* (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (MUL* $F $X) 2.))))) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY ($EXP (MUL* (QUOTE $%I) $ALPHA)))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* (QUOTE $%I) $ALPHA))))))))))))) (QUOTE $A) (QUOTE $SIGN) (TRD-MSYMEVAL $ALL (QUOTE $ALL)) (QUOTE $ALPHA))) + +(DEFPROP $EXACT2 T TRANSLATED) +(ADD2LNC (QUOTE $EXACT2) $PROPS) +(DEFMTRFUN ($EXACT2 $ANY MDEFINE NIL NIL) ($A1 $A2 $A3) NIL ((LAMBDA ($B1) NIL (PROG NIL (COND ((LIKE (SIMPLIFY ($RATSIMP (ADD* (SIMPLIFY ($DIFF $A1 (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY ($DIFF $A2 (TRD-MSYMEVAL $X (QUOTE $X)))))) $A3))) 0.) (SETQ $B1 (SIMPLIFY ($EXP (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY ($INTEGRATE (SIMPLIFY ($RATSIMP (DIV (ADD* $A2 (SIMPLIFY (LIST (QUOTE (MMINUS)) (SIMPLIFY ($DIFF $A1 (TRD-MSYMEVAL $X (QUOTE $X))))))) $A1))) (TRD-MSYMEVAL $X (QUOTE $X)))))))))) (T (RETURN NIL))) (SETQ $METHOD (QUOTE $EXACT)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) $B1 (SIMPLIFY ($INTEGRATE (DIV 1. (MUL* $A1 $B1)) (TRD-MSYMEVAL $X (QUOTE $X))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) $B1))))))) (QUOTE $B1))) + +(DEFPROP $XCC2 T TRANSLATED) +(ADD2LNC (QUOTE $XCC2) $PROPS) +(DEFMTRFUN ($XCC2 $ANY MDEFINE NIL NIL) ($AP $AQ) NIL ((LAMBDA ($D $B1 $Z $RADEXPAND) NIL (PROG NIL (COND ((LIKE $AQ 0.) (RETURN NIL))) (SETQ $D (SIMPLIFY ($RATSIMP (DIV (ADD* (SIMPLIFY ($DIFF $AQ (TRD-MSYMEVAL $X (QUOTE $X)))) (MUL* 2. $AP $AQ)) (MUL* 2. (POWER $AQ (RREMAINDER 3. 2.))))))) (COND (($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $D) (SETQ $B1 (SIMPLIFY (MFUNCTION-CALL $CC2 $D 1. (TRD-MSYMEVAL $Y (QUOTE $Y)) $Z)))) (T (RETURN NIL))) (SETQ $METHOD (QUOTE $XFORMTOCONSTCOEFF)) (RETURN (SIMPLIFY ($SUBSTITUTE (SIMPLIFY ($INTEGRATE (SIMPLIFY (LIST (QUOTE (%SQRT)) $AQ)) (TRD-MSYMEVAL $X (QUOTE $X)))) $Z $B1))))) (QUOTE $D) (QUOTE $B1) (QUOTE $Z) (TRD-MSYMEVAL $ALL (QUOTE $ALL)))) + +(DEFPROP $VARP T TRANSLATED) +(ADD2LNC (QUOTE $VARP) $PROPS) +(DEFMTRFUN ($VARP $ANY MDEFINE NIL NIL) ($SOLN $G) NIL ((LAMBDA ($Y1 $Y2 $Y3 $Y4 $WR $HEURISTIC) NIL (PROG NIL (SETQ $Y1 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) 1.)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) 0.))) ($RHS $SOLN)))))) (SETQ $Y2 (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) 0.)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) 1.))) ($RHS $SOLN)))))) (SETQ $WR (ADD* (MUL* $Y1 (SIMPLIFY ($DIFF $Y2 (TRD-MSYMEVAL $X (QUOTE $X))))) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $Y2 (SIMPLIFY ($DIFF $Y1 (TRD-MSYMEVAL $X (QUOTE $X))))))))) (COND ((LIKE $WR 0.) (RETURN NIL))) (COND ((AND (LIKE (TRD-MSYMEVAL $METHOD (QUOTE $METHOD)) (TRD-MSYMEVAL $CONSTCOEFF (QUOTE $CONSTCOEFF))) (NOT ($FREEOF (QUOTE %SIN) $WR)) (NOT ($FREEOF (QUOTE %COS) $WR))) (SETQ $HEURISTIC T) (SETQ $WR (SIMPLIFY ($RATSIMP (SIMPLIFY ($TRIGREDUCE $WR))))))) (SETQ $Y3 (SIMPLIFY ($RATSIMP (DIV (MUL* $Y1 $G) $WR)))) (SETQ $Y4 (SIMPLIFY ($RATSIMP (DIV (MUL* $Y2 $G) $WR)))) (SETQ $YP (SIMPLIFY ($RATSIMP (ADD* (MUL* $Y2 (SIMPLIFY ($INTEGRATE $Y3 (TRD-MSYMEVAL $X (QUOTE $X))))) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* $Y1 (SIMPLIFY ($INTEGRATE $Y4 (TRD-MSYMEVAL $X (QUOTE $X))))))))))) (COND ((LIKE $HEURISTIC T) (SETQ $YP (SIMPLIFY ($RATSIMP (SIMPLIFY ($TRIGREDUCE (TRD-MSYMEVAL $YP (QUOTE $YP))))))))) (SETQ $METHOD (QUOTE $VARIATIONOFPARAMETERS)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* ($RHS $SOLN) (TRD-MSYMEVAL $YP (QUOTE $YP)))))))) (QUOTE $Y1) (QUOTE $Y2) (QUOTE $Y3) (QUOTE $Y4) (QUOTE $WR) NIL)) + +(DEFPROP $REDUCE2 T TRANSLATED) +(ADD2LNC (QUOTE $REDUCE2) $PROPS) +(DEFMTRFUN ($REDUCE2 $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($B1 $QQ) NIL (PROG NIL (SETQ $B1 (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) $QQ)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))) $QQ))) $EQ))) (COND (($FREEOF (TRD-MSYMEVAL $Y (QUOTE $Y)) $B1) (RETURN (SIMPLIFY (MFUNCTION-CALL $NLX $EQ))))) (RETURN (COND (($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) $B1) (RETURN (SIMPLIFY (MFUNCTION-CALL $NLY $EQ)))) (T (RETURN NIL)))))) (QUOTE $B1) (QUOTE $QQ))) + +(DEFPROP $NLX T TRANSLATED) +(ADD2LNC (QUOTE $NLX) $PROPS) +(DEFMTRFUN ($NLX $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($DE $B $A1 $V) NIL (PROG NIL (SETQ $DE (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $V (TRD-MSYMEVAL $X (QUOTE $X)))))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))) $V))) $EQ))) (COND ((LIKE (SETQ $B (SIMPLIFY (MFUNCTION-CALL $ODE1A $DE $V (TRD-MSYMEVAL $X (QUOTE $X))))) NIL) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) $V (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%C (QUOTE $%C)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1))))) $B))) (RETURN (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $NLXY $A1 (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))))))) (SETQ $METHOD (QUOTE $FREEOFY)) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q)))) (T (RETURN NIL)))))) (QUOTE $DE) (QUOTE $B) (QUOTE $A1) (QUOTE $V))) + +(DEFPROP $NLY T TRANSLATED) +(ADD2LNC (QUOTE $NLY) $PROPS) +(DEFMTRFUN ($NLY $ANY MDEFINE NIL NIL) ($EQ) NIL ((LAMBDA ($DE $B $A1 $YZ $V) NIL (PROG NIL (SETQ $DE (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)) 2.)) (MUL* $V (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) $V $YZ))))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))) $V)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) $YZ))) $EQ))) (COND ((LIKE (SETQ $B (SIMPLIFY (MFUNCTION-CALL $ODE1A $DE $V $YZ))) NIL) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) $V (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X)))))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) $YZ (TRD-MSYMEVAL $Y (QUOTE $Y)))) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $%C (QUOTE $%C)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1))))) $B))) (RETURN (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $NLXY $A1 (SIMPLIFY (LIST (QUOTE (%DERIVATIVE)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))))))) (SETQ $METHOD (QUOTE $FREEOFX)) (RETURN (TRD-MSYMEVAL $Q (QUOTE $Q)))) (T (RETURN NIL)))))) (QUOTE $DE) (QUOTE $B) (QUOTE $A1) (QUOTE $YZ) (QUOTE $V))) + +(DEFPROP $NLXY T TRANSLATED) +(ADD2LNC (QUOTE $NLXY) $PROPS) +(DEFMTRFUN ($NLXY $ANY MDEFINE NIL NIL) ($EQ $DE) NIL ((LAMBDA ($PROGRAMMODE $EQ1) NIL (PROG NIL (SETQ $EQ1 (SIMPLIFY ($SOLVE $EQ $DE))) (SETQ $EQ1 (SIMPLIFY ((LAMBDA (MAPLP RES) (SETQ RES (MAP1 (GETOPR (M-TLAMBDA ($ZZ) NIL (COND ((MFUNCTION-CALL $FTEST (SIMPLIFY (MFUNCTION-CALL $ODE1A $ZZ (TRD-MSYMEVAL $Y (QUOTE $Y)) (TRD-MSYMEVAL $X (QUOTE $X))))) (SIMPLIFY ($SUBSTITUTE (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (TRD-MSYMEVAL $%C (QUOTE $%C)) (TRD-MSYMEVAL $Q (QUOTE $Q)))))))) $EQ1)) (COND ((ATOM RES) (LIST (QUOTE (MLIST)) RES)) ((EQ (CAAR RES) (QUOTE MLIST)) RES) (T (CONS (QUOTE (MLIST)) (CDR RES))))) T NIL))) (RETURN (COND ((= ($LENGTH $EQ1) 1.) (RETURN (SIMPLIFY ($FIRST $EQ1)))) (T (RETURN $EQ1)))))) T (QUOTE $EQ1))) + +(DEFPROP $PTTEST T TRANSLATED) +(ADD2LNC (QUOTE $PTTEST) $PROPS) +(DEFMTRFUN ($PTTEST $ANY MDEFINE NIL NIL) ($A) NIL ((LAMBDA ($A1 $A2 $A3) NIL (PROG NIL (COND ((LIKE (SETQ $A1 (SIMPLIFY ($RATSIMP $A))) 0.) (RETURN NIL))) (SETQ $A1 (SIMPLIFY ($EXPAND (DIV 1. $A1)))) (COND ((LIKE (SETQ $A2 (SIMPLIFY ($COEFF $A1 (TRD-MSYMEVAL $X (QUOTE $X)) 1.))) 0.) (RETURN NIL))) (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) $A2)) (RETURN NIL))) (SETQ $A3 (SIMPLIFY ($COEFF $A1 (TRD-MSYMEVAL $X (QUOTE $X)) 0.))) (RETURN (COND ((NOT (LIKE $A1 (ADD* (MUL* $A2 (TRD-MSYMEVAL $X (QUOTE $X))) $A3))) (RETURN NIL)) (T (RETURN (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV $A3 $A2))))))))) (QUOTE $A1) (QUOTE $A2) (QUOTE $A3))) + +(DEFPROP $EULER2 T TRANSLATED) +(ADD2LNC (QUOTE $EULER2) $PROPS) +(DEFMTRFUN ($EULER2 $ANY MDEFINE NIL NIL) ($A $B) NIL ((LAMBDA ($DC $RP $IP $ALPHA $BETA $SIGN $RADEXPAND) NIL (PROG NIL (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (SETQ $BETA (SIMPLIFY ($RATSIMP (MUL* $B (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) 2.))))))) (RETURN NIL))) (SETQ $METHOD (QUOTE $EULER)) (SETQ $ALPHA (MUL* $A (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))) (SETQ $DC (SIMPLIFY ($RATSIMP (ADD* (POWER (ADD* $ALPHA -1.) 2.) (SIMPLIFY (LIST (QUOTE (MMINUS)) (MUL* 4. $BETA))))))) (SETQ $RP (SIMPLIFY ($RATSIMP (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (ADD* $ALPHA -1.) 2.)))))) (SETQ $SIGN (SIMPLIFY ($ASKSIGN $DC))) (COND ((LIKE $SIGN (TRD-MSYMEVAL $ZERO (QUOTE $ZERO))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (MUL* (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) $RP) (ADD* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (LIST (QUOTE (%LOG)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))))))))))) (COND ((LIKE $SIGN (TRD-MSYMEVAL $POS (QUOTE $POS))) (SETQ $IP (DIV (SIMPLIFY (LIST (QUOTE (%SQRT)) $DC)) 2.)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) (ADD* $RP $IP))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) (ADD* $RP (SIMPLIFY (LIST (QUOTE (MMINUS)) $IP))))))))))) (SETQ $DC (SIMPLIFY (LIST (QUOTE (MMINUS)) $DC))) (SETQ $IP (DIV (SIMPLIFY (LIST (QUOTE (%SQRT)) $DC)) 2.)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (MUL* (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) $RP) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (LIST (QUOTE (%SIN)) (MUL* $IP (SIMPLIFY (LIST (QUOTE (%LOG)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (LIST (QUOTE (%COS)) (MUL* $IP (SIMPLIFY (LIST (QUOTE (%LOG)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))))))))))))))) (QUOTE $DC) (QUOTE $RP) (QUOTE $IP) (QUOTE $ALPHA) (QUOTE $BETA) (QUOTE $SIGN) NIL)) + +(DEFPROP $BESSEL2 T TRANSLATED) +(ADD2LNC (QUOTE $BESSEL2) $PROPS) +(DEFMTRFUN ($BESSEL2 $ANY MDEFINE NIL NIL) ($A $B) NIL ((LAMBDA ($NU $B1 $INTP $RADEXPAND) NIL (PROG NIL (COND ((NOT ($FREEOF (TRD-MSYMEVAL $X (QUOTE $X)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (SETQ $B1 (SIMPLIFY ($RATSIMP (MUL* (ADD* 1. (SIMPLIFY (LIST (QUOTE (MMINUS)) $B))) (POWER (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))) 2.))))))) (RETURN NIL))) (COND ((NOT (LIKE (SIMPLIFY ($RATSIMP (MUL* $A (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))))) 1.)) (RETURN NIL))) (SETQ $NU (SIMPLIFY (LIST (QUOTE (%SQRT)) $B1))) (SETQ $METHOD (QUOTE $BESSEL)) (COND ((LIKE $NU (RREMAINDER 1. 2.)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (DIV (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (LIST (QUOTE (%SIN)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (LIST (QUOTE (%COS)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))))) (SIMPLIFY (LIST (QUOTE (%SQRT)) (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT))))))))))))) (COND ((IS-BOOLE-CHECK (SIMPLIFY ($FEATUREP $NU (TRD-MSYMEVAL $INTEGER (QUOTE $INTEGER))))) (SETQ $INTP (QUOTE $Y))) (($NUMBERP $NU) (SETQ $INTP (QUOTE $N)))) $LOOP (COND ((NOT (OR (LIKE $INTP (QUOTE $Y)) (LIKE $INTP (QUOTE $N)))) (SETQ $INTP (SIMPLIFY ($READONLY (QUOTE &I/s) $NU (QUOTE |&an integer? Type Y or N.|)))) (GO $LOOP))) (COND ((LIKE $INTP (QUOTE $Y)) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (MAPPLY (MARRAYREF (TRD-MSYMEVAL $%J (QUOTE $%J)) $NU) (LIST (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))) (QUOTE (($%J ARRAY) $NU))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (MAPPLY (MARRAYREF (TRD-MSYMEVAL $%Y (QUOTE $%Y)) $NU) (LIST (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))) (QUOTE (($%Y ARRAY) $NU))))))))))) (RETURN (SIMPLIFY (LIST (QUOTE (MEQUAL)) (TRD-MSYMEVAL $Y (QUOTE $Y)) (ADD* (MUL* (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (SIMPLIFY (MAPPLY (MARRAYREF (TRD-MSYMEVAL $%J (QUOTE $%J)) $NU) (LIST (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))) (QUOTE (($%J ARRAY) $NU))))) (MUL* (TRD-MSYMEVAL $%K2 (QUOTE $%K2)) (SIMPLIFY (MAPPLY (MARRAYREF (TRD-MSYMEVAL $%J (QUOTE $%J)) (SIMPLIFY (LIST (QUOTE (MMINUS)) $NU))) (LIST (ADD* (TRD-MSYMEVAL $X (QUOTE $X)) (SIMPLIFY (LIST (QUOTE (MMINUS)) (TRD-MSYMEVAL $PT (QUOTE $PT)))))) (QUOTE (($%J ARRAY) ((MMINUS) $NU)))))))))))) (QUOTE $NU) (QUOTE $B1) (QUOTE $INTP) (TRD-MSYMEVAL $ALL (QUOTE $ALL)))) + +(DEFPROP $IC1 T TRANSLATED) +(ADD2LNC (QUOTE $IC1) $PROPS) +(DEFMTRFUN ($IC1 $ANY MDEFINE NIL NIL) ($SOLN $XC $YC) NIL (PROGN (SIMPLIFY (MFUNCTION-CALL $NOTEQN $XC)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $YC)) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%C) (TRD-MSYMEVAL $%C (QUOTE $%C)))) (SIMPLIFY ($RATSIMP (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) (SIMPLIFY (LIST (QUOTE (MEQUAL)) (QUOTE $%C) ($RHS (SIMPLIFY (MFUNCTION-CALL $SOLVE1 (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $XC $YC) $SOLN)) (TRD-MSYMEVAL $%C (QUOTE $%C)))))))) $SOLN)))))) + +(DEFPROP $BC2 T TRANSLATED) +(ADD2LNC (QUOTE $BC2) $PROPS) +(DEFMTRFUN ($BC2 $ANY MDEFINE NIL NIL) ($SOLN $XA $YA $XB $YB) NIL ((LAMBDA ($PROGRAMMODE $BACKSUBST $SINGSOLVE $TEMP) NIL (PROG NIL (SIMPLIFY (MFUNCTION-CALL $NOTEQN $XA)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $YA)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $XB)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $YB)) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%K1) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)))) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%K2) (TRD-MSYMEVAL $%K2 (QUOTE $%K2)))) (SETQ $TEMP (SIMPLIFY ((LAMBDA (MAPLP RES) (SETQ RES (MAP1 (GETOPR (M-TLAMBDA&ENV (($ZZ) ($SOLN)) NIL (SIMPLIFY ($SUBSTITUTE $ZZ $SOLN)))) (SIMPLIFY ($SOLVE (LIST (QUOTE (MLIST)) (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $XA $YA) $SOLN)) (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $XB $YB) $SOLN))) (LIST (QUOTE (MLIST)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (TRD-MSYMEVAL $%K2 (QUOTE $%K2))))))) (COND ((ATOM RES) (LIST (QUOTE (MLIST)) RES)) ((EQ (CAAR RES) (QUOTE MLIST)) RES) (T (CONS (QUOTE (MLIST)) (CDR RES))))) T NIL))) (RETURN (COND ((= ($LENGTH $TEMP) 1.) (RETURN (SIMPLIFY ($FIRST $TEMP)))) (T (RETURN $TEMP)))))) T T T (QUOTE $TEMP))) + +(DEFPROP $IC2 T TRANSLATED) +(ADD2LNC (QUOTE $IC2) $PROPS) +(DEFMTRFUN ($IC2 $ANY MDEFINE NIL NIL) ($SOLN $XA $YA $DYA) NIL ((LAMBDA ($PROGRAMMODE $BACKSUBST $SINGSOLVE $TEMP) NIL (PROG NIL (SIMPLIFY (MFUNCTION-CALL $NOTEQN $XA)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $YA)) (SIMPLIFY (MFUNCTION-CALL $NOTEQN $DYA)) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%K1) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)))) (SIMPLIFY (MFUNCTION-CALL $BOUNDTEST (QUOTE $%K2) (TRD-MSYMEVAL $%K2 (QUOTE $%K2)))) (SETQ $TEMP (ADD* ($LHS $SOLN) (SIMPLIFY (LIST (QUOTE (MMINUS)) ($RHS $SOLN))))) (SETQ $TEMP (SIMPLIFY ((LAMBDA (MAPLP RES) (SETQ RES (MAP1 (GETOPR (M-TLAMBDA&ENV (($ZZ) ($SOLN)) NIL (SIMPLIFY ($SUBSTITUTE $ZZ $SOLN)))) (SIMPLIFY ($SOLVE (LIST (QUOTE (MLIST)) (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $XA $YA) $SOLN)) (SIMPLIFY ($SUBSTITUTE (LIST (QUOTE (MLIST)) $DYA $XA) (SIMPLIFY (LIST (QUOTE (MEQUAL)) ($LHS $DYA) (SIMPLIFY (LIST (QUOTE (MMINUS)) (DIV (SIMPLIFY ($SUBSTITUTE 0. ($LHS $DYA) (SIMPLIFY ($DIFF $TEMP ($LHS $XA))))) (SIMPLIFY ($DIFF $TEMP ($LHS $YA))))))))))) (LIST (QUOTE (MLIST)) (TRD-MSYMEVAL $%K1 (QUOTE $%K1)) (TRD-MSYMEVAL $%K2 (QUOTE $%K2))))))) (COND ((ATOM RES) (LIST (QUOTE (MLIST)) RES)) ((EQ (CAAR RES) (QUOTE MLIST)) RES) (T (CONS (QUOTE (MLIST)) (CDR RES))))) T NIL))) (RETURN (COND ((= ($LENGTH $TEMP) 1.) (RETURN (SIMPLIFY ($FIRST $TEMP)))) (T (RETURN $TEMP)))))) T T T (QUOTE $TEMP))) + +(DEFPROP $NOTEQN T TRANSLATED) +(ADD2LNC (QUOTE $NOTEQN) $PROPS) +(DEFMTRFUN ($NOTEQN $ANY MDEFINE NIL NIL) ($X) NIL (COND ((OR ($ATOM $X) (NOT (LIKE (SIMPLIFY ($INPART $X 0.)) (QUOTE &=)))) (DISPLAY-FOR-TR NIL NIL $X) (DISPLAY-FOR-TR NIL NIL (QUOTE |&Not an equation|)) (SIMPLIFY ($ERROR))))) + +(DEFPROP $BOUNDTEST T TRANSLATED) +(ADD2LNC (QUOTE $BOUNDTEST) $PROPS) +(DEFMTRFUN ($BOUNDTEST $ANY MDEFINE NIL NIL) ($X $Y) NIL (COND ((NOT (LIKE $X $Y)) (DISPLAY-FOR-TR NIL NIL $X) (DISPLAY-FOR-TR NIL NIL (QUOTE |&Must not be bound|)) (SIMPLIFY ($ERROR))))) + +(DEFPROP $FAILURE T TRANSLATED) +(ADD2LNC (QUOTE $FAILURE) $PROPS) +(DEFMTRFUN ($FAILURE $BOOLEAN MDEFINE NIL NIL) ($MSG $EQ) NIL (PROGN (COND ((NOT ($STATUS $FEATURE &ODE)) (DISPLAY-FOR-TR T NIL (SIMPLIFY ($SUBSTITUTE (TRD-MSYMEVAL $YOLD (QUOTE $YOLD)) (TRD-MSYMEVAL $YNEW (QUOTE $YNEW)) $EQ))) (DISPLAY-FOR-TR NIL NIL $MSG))) NIL)) + +(SETQ $MSG1 (QUOTE |&Not a proper differential equation|)) + +(SETQ $MSG2 (QUOTE |&First order equation not linear in y'|)) + + +(compile-forms-to-compile-queue) + + \ No newline at end of file diff --git a/src/jpg/plot.67 b/src/jpg/plot.67 new file mode 100644 index 00000000..6b99f470 --- /dev/null +++ b/src/jpg/plot.67 @@ -0,0 +1,307 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1981 Massachusetts Institute of Technology ** + +(macsyma-module plot) + +(DECLARE (SPLITFILE GRAPH2) + (SPECIAL $RATPRINT $XAXIS $YAXIS LINEL $PLOTHEIGHT $NUMER $FLOAT + $BFLOAT ^W ^R TTY $CALCOMPNUM $MULTGRAPH $FLOAT2BF $%ENUMER) + (FLONUM LOW HIGH INC XLOW XHIGH XINC YLOW YHIGH YINC VAL + (ROUNDUP FLONUM) (FMEVAL)) + (FIXNUM LINEL $PLOTHEIGHT I M N ORG) + (NOTYPE (POINTSUBST NOTYPE FLONUM FLONUM FIXNUM)) + (*EXPR $FLOAT) + (*LEXPR MAP1) + (ARRAY* (NOTYPE PLOTARY 1))) + +(DEFUN VERTCHAR MACRO (X) + (COND ((STATUS FEATURES ITS) ''/[) (T ''/|))) ; ascii 124. + +(DEFMSPEC $PARAMPLOT (L) (SETQ L (CDR L)) + (IF (NOT (MFBOUNDP '$PLOT)) (LOAD-FUNCTION '$PLOT T)) + (IF (< (LENGTH L) 4) (MERROR "Too few arguments to PARAMPLOT")) + ((LAMBDA (FUNLX FUNLY VAR ARG4 $NUMER $FLOAT $BFLOAT LOW HIGH INTFLG INC + $RATPRINT $FLOAT2BF $%ENUMER) + (SETQ L (CDDDDR L) + FUNLX (COND (($LISTP FUNLX) (CDR FUNLX)) (T (LIST FUNLX))) + FUNLY (COND (($LISTP FUNLY) (CDR FUNLY)) (T (LIST FUNLY)))) + (COND ((NOT (= (LENGTH FUNLX) (LENGTH FUNLY))) + (MERROR "Arguments to PARAMPLOT are of unequal length")) + ((NOT (NUMBERP (SETQ ARG4 (FMEVAL1 ARG4)))) + (IF (NOT ($LISTP ARG4)) (MERROR "Invalid argument to PARAMPLOT:~%~M" ARG4)) + (SETQ L (GRAPHOPTS L)) + (GRAPH (DO ((FUNLX FUNLX (CDR FUNLX)) (XSETS)) ((NULL FUNLX) XSETS) + (SETQ XSETS + (NCONC XSETS + (NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR) + (LIST '(FMEVAL) (CAR FUNLX))) + ARG4)))))) + (DO ((FUNLY FUNLY (CDR FUNLY)) (YSETS)) ((NULL FUNLY) YSETS) + (SETQ YSETS + (NCONC YSETS + (NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR) + (LIST '(FMEVAL) (CAR FUNLY))) + ARG4)))))) + L '$DONE)) + (T (IF (NULL L) (MERROR "Too few arguments to PARAMPLOT")) + (SETQ HIGH (FMEVAL (CAR L)) LOW ARG4 L (CDR L)) + (SETQ L (GRAPHOPTS (COND ((AND L (EQ (CAR L) '$INTEGER)) + (SETQ INTFLG T) (CDR L)) + (T L)))) + (COND (INTFLG (SETQ HIGH (FLOAT (FIX HIGH)) + LOW (COND ((ZEROP (*DIF LOW (FIX LOW))) LOW) + (T (FLOAT (FIX (+$ LOW 0.999999)))))))) + (SETQ INC (//$ (-$ HIGH LOW) (COND #+MULTICS ($MULTGRAPH (FLOAT $CALCOMPNUM)) + (T (FLOAT (- LINEL 5)))))) + (IF (NOT (PLUSP INC)) + (MERROR "Invalid arguments to PARAMPLOT:~%~M" + (LIST '(MLIST SIMP) LOW HIGH))) + (SETQ INC (COND (INTFLG (FLOAT (FIX (+$ INC 0.999999)))) + (T (ROUNDUP INC)))) + (DO ((VAL LOW (+$ VAL INC)) + (XSETS (DO ((FUNLX FUNLX (CDR FUNLX)) (LL NIL (CONS (LIST NIL) LL))) + ((NULL FUNLX) LL))) + (YSETS (DO ((FUNLY FUNLY (CDR FUNLY)) (LL NIL (CONS (LIST NIL) LL))) + ((NULL FUNLY) LL)))) + ((> VAL HIGH) (GRAPH (MAPCAR 'CDR XSETS) (MAPCAR 'CDR YSETS) L '$DONE)) + (DO ((FUNLX FUNLX (CDR FUNLX)) (XSETS XSETS (CDR XSETS))) + ((NULL FUNLX)) + (RPLACD (CAR XSETS) + (CONS (FMEVAL (LIST '($EV) (CAR FUNLX) + (LIST '(MEQUAL) VAR + (COND (INTFLG (FIX VAL)) (T VAL))))) + (CDAR XSETS)))) + (DO ((FUNLY FUNLY (CDR FUNLY)) (YSETS YSETS (CDR YSETS))) + ((NULL FUNLY)) + (RPLACD (CAR YSETS) + (CONS (FMEVAL (LIST '($EV) (CAR FUNLY) + (LIST '(MEQUAL) VAR + (COND (INTFLG (FIX VAL)) (T VAL))))) + (CDAR YSETS)))))))) + (COND ((ATOM (CAR L)) (MEVAL (CAR L))) (T (CAR L))) + (COND ((ATOM (CADR L)) (MEVAL (CADR L))) (T (CADR L))) + (CADDR L) (CADDDR L) T T NIL 0.0 0.0 NIL 0.0 NIL T T)) + +(DEFMSPEC $MULTIGRAPH (L) (SETQ L (CDR L)) + (IF (NOT (MFBOUNDP '$PLOT)) (LOAD-FUNCTION '$PLOT T)) + ((LAMBDA (ARG1 XSETS YSETS $NUMER $FLOAT $BFLOAT $FLOAT2BF $%ENUMER) + (IF (NOT ($LISTP ARG1)) (MERROR "Invalid first argument to MULTIGRAPH")) + (DO ((ARG1 (CDR ARG1) (CDR ARG1)) (LL) (XSET) (YSET)) + ((NULL ARG1)) + (IF (OR (NOT ($LISTP (SETQ LL (MEVAL (CAR ARG1))))) + (NOT (= (LENGTH LL) 3)) + (NOT ($LISTP (SETQ XSET (MEVAL (CADR LL))))) + (NOT ($LISTP (SETQ YSET (MEVAL (CADDR LL))))) + (NOT (= (LENGTH XSET) (LENGTH YSET)))) + (MERROR "Invalid first argument to MULTIGRAPH")) + (SETQ XSETS (NCONC XSETS (NCONS (MAPCAR 'FMEVAL (CDR XSET)))) + YSETS (NCONC YSETS (NCONS (MAPCAR 'FMEVAL (CDR YSET)))))) + (GRAPH XSETS YSETS (GRAPHOPTS (CDR L)) '$DONE)) + (MEVAL (CAR L)) NIL NIL T T NIL T T)) + +(DECLARE (SPLITFILE GRAPH)) + +(COND ((NOT (BOUNDP '$XAXIS)) (SETQ $XAXIS NIL))) +(COND ((NOT (BOUNDP '$YAXIS)) (SETQ $YAXIS NIL))) + +(DEFMSPEC $PLOT (L) (SETQ L (CDR L)) + (IF (< (LENGTH L) 3) (MERROR "Too few arguments to PLOT")) + ((LAMBDA (FUNL VAR ARG3 $NUMER $FLOAT $BFLOAT LOW HIGH INTFLG INC $RATPRINT $FLOAT2BF $%ENUMER) + (SETQ L (CDDDR L) FUNL (COND (($LISTP FUNL) (CDR FUNL)) (T (LIST FUNL)))) + (COND ((NOT (NUMBERP (SETQ ARG3 (FMEVAL1 ARG3)))) + (IF (NOT ($LISTP ARG3)) (MERROR "Invalid argument to PLOT:~%~M" ARG3)) + (SETQ L (GRAPHOPTS L)) + (GRAPH (MAPCAR 'FMEVAL (CDR ARG3)) + (DO ((FUNL FUNL (CDR FUNL)) (YSETS)) ((NULL FUNL) YSETS) + (SETQ YSETS + (NCONC YSETS + (NCONS (CDR (MAP1 (LIST '(LAMBDA) (LIST '(MLIST) VAR) + (LIST '(FMEVAL) (CAR FUNL))) + ARG3)))))) + L (CONS '(MLIST) FUNL))) + (T (IF (NULL L) (MERROR "Too few arguments to PLOT")) + (SETQ HIGH (FMEVAL (CAR L)) LOW ARG3 L (CDR L)) + (SETQ L (GRAPHOPTS (COND ((AND L (EQ (CAR L) '$INTEGER)) + (SETQ INTFLG T) (CDR L)) + (T L)))) + (COND (INTFLG (SETQ HIGH (FLOAT (FIX HIGH)) + LOW (COND ((ZEROP (*DIF LOW (FIX LOW))) LOW) + (T (FLOAT (FIX (+$ LOW 0.999999)))))))) + (SETQ INC (//$ (-$ HIGH LOW) (COND #+MULTICS ($MULTGRAPH (FLOAT $CALCOMPNUM)) + (T (FLOAT (- LINEL 5)))))) + (IF (NOT (PLUSP INC)) + (MERROR "Invalid arguments to PLOT:~%~M" + (LIST '(MLIST SIMP) LOW HIGH))) + (SETQ INC (COND (INTFLG (FLOAT (FIX (+$ INC 0.999999)))) + (T (ROUNDUP INC)))) + (DO ((VAL LOW (+$ VAL INC)) (XSET) + (YSETS (DO ((FUNL FUNL (CDR FUNL)) (LL NIL (CONS (LIST NIL) LL))) + ((NULL FUNL) LL)))) + ((> VAL HIGH) (GRAPH XSET (MAPCAR 'CDR YSETS) L (CONS '(MLIST) FUNL))) + (SETQ XSET (CONS VAL XSET)) + (DO ((FUNL FUNL (CDR FUNL)) (YSETS YSETS (CDR YSETS))) + ((NULL FUNL)) + (RPLACD (CAR YSETS) + (CONS (FMEVAL (LIST '($EV) (CAR FUNL) + (LIST '(MEQUAL) VAR + (COND (INTFLG (FIX VAL)) (T VAL))))) + (CDAR YSETS)))))))) + (IF (AND (SYMBOLP (CAR L)) (NOT (EQ (CAR L) (CADR L)))) + (MEVAL (CAR L)) + (CAR L)) + (CADR L) (CADDR L) T T NIL 0.0 0.0 NIL 0.0 NIL T T)) + +(DEFUN FMEVAL (X) + (COND ((FIXP (SETQ X (MEVAL X))) (FLOAT X)) + ((FLOATP X) X) + (($BFLOATP X) ($FLOAT X)) + (T (MERROR "Not floating point:~%~M" X)))) + +(DEFUN FMEVAL1 (X) + (COND ((FIXP (SETQ X (MEVAL X))) (FLOAT X)) (($BFLOATP X) ($FLOAT X)) (T X))) + +(DEFMSPEC $GRAPH (L) (SETQ L (CDR L)) + ((LAMBDA (ARG1 XSET YSET $NUMER $FLOAT $BFLOAT $FLOAT2BF $%ENUMER) + (SETQ L (CDR L)) + (COND ((NOT ($LISTP ARG1)) (MERROR "Invalid first argument to GRAPH")) + (($LISTP (CADR ARG1)) + (DO ARG1 (CDR ARG1) (CDR ARG1) (NULL ARG1) + (IF (OR (NOT ($LISTP (CAR ARG1))) (CDDDAR ARG1)) + (MERROR "Invalid first argument to GRAPH")) + (SETQ XSET (CONS (FMEVAL (CADAR ARG1)) XSET) + YSET (CONS (FMEVAL (CADDAR ARG1)) YSET))) + (SETQ YSET (LIST YSET))) + (T (COND ((NOT ($LISTP (SETQ YSET (MEVAL (CAR L))))) + (MERROR "Invalid second argument to GRAPH")) + (($LISTP (CADR YSET)) (SETQ YSET (CDR YSET))) + (T (SETQ YSET (LIST YSET)))) + (SETQ L (CDR L) XSET (MAPCAR 'FMEVAL (CDR ARG1)) + YSET (DO ((YSET YSET (CDR YSET)) (YSETS)) ((NULL YSET) YSETS) + (COND ((NOT ($LISTP (CAR YSET))) + (MERROR "Invalid second argument to GRAPH")) + ((NOT (= (LENGTH ARG1) (LENGTH (CAR YSET)))) + (MERROR "Arguments to GRAPH are of unequal length"))) + (SETQ YSETS (NCONC YSETS (NCONS (MAPCAR 'FMEVAL (CDAR YSET))))))))) + (GRAPH XSET YSET (GRAPHOPTS L) '$DONE)) + (MEVAL (CAR L)) NIL NIL T T NIL T T)) + +(DEFUN GRAPHOPTS (L) + (IF (> (LENGTH L) 3) (MERROR "Too many arguments to GRAPH or PLOT")) + (DO ((L L (CDR L)) (CHARL) (XLABEL) (YLABEL)) + ((NULL L) (CONS CHARL (SUBST NIL '$FALSE (LIST XLABEL YLABEL)))) + (COND (($LISTP (CAR L)) + (IF CHARL (MERROR "Invalid argument to GRAPH or PLOT:~%~M" (CAR L))) + (SETQ CHARL (FULLSTRIP (CDAR L)))) + (XLABEL (SETQ YLABEL (CAR L))) + (T (SETQ XLABEL (COND ((NULL (CAR L)) '$FALSE) (T (CAR L)))))))) + +(DEFUN GRAPH (XSET YSETS OPTL RETVAL) + ((LAMBDA (1SETP CHARL XLABEL YLABEL XHIGH XLOW XINC YHIGH YLOW YINC) + (PROG (L) + (COND #+MULTICS + ($MULTGRAPH + (RETURN (MULTPLOT (CAR CHARL) (STRIPDOLLAR XLABEL) (STRIPDOLLAR YLABEL) + (SETQ XSET (COND (1SETP XSET) (T (APPLY 'APPEND XSET)))) + (APPLY 'APPEND YSETS) (LENGTH XSET) RETVAL))) + (T (SETQ L (COND (1SETP XSET) (T (APPLY 'APPEND XSET)))) + (SETQ XLOW (APPLY 'MIN L) XHIGH (APPLY 'MAX L)) + (SETQ XINC (ROUNDUP (//$ (-$ XHIGH XLOW) (FLOAT (- LINEL 5))))) + (SETQ L (APPLY 'APPEND YSETS) YLOW (APPLY 'MIN L) YHIGH (APPLY 'MAX L)) + (SETQ YINC (ROUNDUP (//$ (-$ YHIGH YLOW) (FLOAT (- $PLOTHEIGHT 6))))) + (COND ((ZEROP XINC) + (PRINC (COND (XLABEL (MAKNAM (MAKSTRING XLABEL))) + (T '|X-coordinate|))) + (PRINC '| is constant value |) (PRINC XLOW) (RETURN '$DONE)) + ((ZEROP YINC) + (PRINC (COND (YLABEL (MAKNAM (MAKSTRING YLABEL))) + (T '|Y-coordinate|))) + (PRINC '| is constant value |) (PRINC YLOW) (RETURN '$DONE))) + (*ARRAY 'PLOTARY T (1+ $PLOTHEIGHT)) + (COND (1SETP (SETQ XSET (POINTSUBST XSET XLOW XINC 5)))) + (DO ((YSETS YSETS (CDR YSETS)) (CHARL CHARL (AND CHARL (CDR CHARL)))) + ((NULL YSETS)) + (DO ((XSET (COND (1SETP XSET) + (T (PROG2 NIL (POINTSUBST (CAR XSET) XLOW XINC 5) + (SETQ XSET (CDR XSET))))) + (CDR XSET)) + (YSET (POINTSUBST (CAR YSETS) YLOW YINC 6) (CDR YSET)) + (CHAR (OR (AND CHARL (CAR CHARL)) '*))) + ((NULL XSET)) + (GRAPHINSERT (CAR XSET) (CAR YSET) CHAR))) + (COND ($XAXIS + (COND ((OR (PLUSP YLOW) (MINUSP YHIGH)) + (MTELL "X-axis is off graph") (SLEEP 2)) + (T (DO ((N LINEL (1- N)) + (YCOORD (CAR (POINTSUBST (NCONS 0.0) YLOW YINC 6)))) + ((< N 5)) + (GRAPHINSERT N YCOORD '|.|)))))) + (COND ($YAXIS + (COND ((OR (PLUSP XLOW) (MINUSP XHIGH)) + (MTELL "Y-axis is off graph") (SLEEP 2)) + (T (DO ((N 6 (1+ N)) + (XCOORD (CAR (POINTSUBST (NCONS 0.0) XLOW XINC 5)))) + ((> N $PLOTHEIGHT)) + (GRAPHINSERT XCOORD N '|.|)))))) + (STORE (PLOTARY 5) (DO ((N LINEL (1- N)) (L)) ((< N 4) L) + (SETQ L (CONS N (CONS '- L))))) + (STORE (PLOTARY 4) + (DO ((N 5 (+ N 2)) (I 0 (+ I 2)) (L)) ((> N LINEL) (NREVERSE L)) + (SETQ L (CONS I (CONS N L))) (COND ((= I 8) (SETQ I -2))))) + (SETQ L (CONS NIL (APPEND '(X O R G =) (EXPLODEC XLOW) + '(/ Y O R G =) (EXPLODEC YLOW) + '(/ X D E L T A =) (EXPLODEC XINC) + '(/ Y D E L T A =) (EXPLODEC YINC)))) + (STORE (PLOTARY 3) (GRAPHDO L)) + (SETQ L (CONS NIL (APPEND '(X M A X =) (EXPLODEC XHIGH) + '(/ Y M A X =) (EXPLODEC YHIGH)))) + (STORE (PLOTARY 2) (GRAPHDO L)) + (DO ((N 6 (1+ N))) ((> N $PLOTHEIGHT)) + (STORE (PLOTARY N) (CONS 4 (CONS (VERTCHAR) (PLOTARY N))))) + (DO ((N 6 (+ N 2)) (I 0 (+ I 2))) ((> N $PLOTHEIGHT)) + (STORE (PLOTARY N) (CONS 3 (CONS I (PLOTARY N)))) + (COND ((= I 8) (SETQ I -2)))) + (AND YLABEL + (DO ((I (+ 7 (// $PLOTHEIGHT 2)) (1- I)) (YL (MAKSTRING YLABEL) (CDR YL))) + ((OR (NULL YL) (= I 4))) + (STORE (PLOTARY I) (CONS 1 (CONS (CAR YL) (PLOTARY I)))))) + (AND XLABEL (SETQ XLABEL (CONS NIL (MAKSTRING XLABEL))) + (DO ((N (- (// LINEL 2) 4) (1+ N)) (XL XLABEL (CDDR XL))) + ((OR (NULL (CDR XL)) (> N LINEL)) + (STORE (PLOTARY 1) (CDR XLABEL))) + (RPLACD XL (CONS N (CDR XL))))) + (CURSORPOS 'C) + (DO ((N $PLOTHEIGHT (1- N))) ((= N 0)) + (TERPRI) + (DO ((I 1 (1+ I)) (L (PLOTARY N))) + ((OR (> I LINEL) (NULL L))) + (COND ((= I (CAR L)) (PRINC (CADR L)) (SETQ L (CDDR L))) + (T (PRINC '/ ))))) + (COND ((AND (NOT (ZEROP TTY)) (NULL ^W)) (TYI*))) + (TERPRI) (TERPRI) (*REARRAY 'PLOTARY) (RETURN '$DONE))))) + (FLOATP (CAR XSET)) (CAR OPTL) (CADR OPTL) (CADDR OPTL) 0.0 0.0 0.0 0.0 0.0 0.0)) + +(DEFUN POINTSUBST (SET LOW INC ORG) + (DO ((SET SET (CDR SET)) (L)) ((NULL SET) L) + (SETQ L (CONS (+ ORG (FIX (+$ 0.5 (//$ (-$ (CAR SET) LOW) INC)))) L)))) + +(DEFUN GRAPHINSERT (XCOORD YCOORD CHAR) + ((LAMBDA (L) + (STORE (PLOTARY YCOORD) + (DO LL L (CDDR LL) NIL + (COND ((AND (CDR LL) (= XCOORD (CADR LL))) (RETURN (CDR L))) + ((OR (NULL (CDR LL)) (NOT (> XCOORD (CADR LL)))) + (RPLACD LL (NCONC (LIST XCOORD CHAR) (CDR LL))) + (RETURN (CDR L))))))) + (CONS NIL (PLOTARY YCOORD)))) + +(DEFUN ROUNDUP (INC) + (COND ((= INC 0.0) 0.0) + ((> INC 10.0) (*$ 10.0 (ROUNDUP (//$ INC 10.0)))) + ((< INC 1.0) (//$ (ROUNDUP (*$ INC 10.0)) 10.0)) + (T (*QUO (FIX (+$ (*$ INC 10.0) 0.999999)) 10.0)))) + +(DEFUN GRAPHDO (L) + (DO ((LL L (CDDR LL)) (N 1 (1+ N))) ((NULL (CDR LL)) (CDR L)) + (RPLACD LL (CONS N (CDR LL))))) + \ No newline at end of file diff --git a/src/jpg/suprv.619 b/src/jpg/suprv.619 new file mode 100644 index 00000000..c5cc1a82 --- /dev/null +++ b/src/jpg/suprv.619 @@ -0,0 +1,2724 @@ +;;; -*- Mode: Lisp; Package: Macsyma; Ibase: 10 -*- + +; ** (c) Copyright 1982 Massachusetts Institute of Technology ** + +(macsyma-module suprv) + +;; #+MACLISP is ITS, Twenex, or Multics MacLisp. +;; #+PDP10 is ITS or Twenex MacLisp. +;; #+LISPM is the Lisp Machine or the Lisp Machine compiler running on ITS. +;; #+MACLISP and #+LISPM indicate which system a piece of code is intended +;; "for", not which system the code is being compiled "in". +;; #+GC means include gctime messages, and ok to call GCTWA here and there. +;; #-MAXII means not needed in new macsyma I/O and system organization. + +;; Setting BASE to 10 at compile time needed for LAP to work. + +(EVAL-WHEN (EVAL COMPILE) + (SETQ OLD-IBASE IBASE OLD-BASE BASE) + (SETQ IBASE 10. BASE 10.)) + +#+NIL +(EVAL-WHEN (EVAL COMPILE) + (SET-FEATURE 'MAXII)) + +(DECLARE (GENPREFIX /\S) + (SPECIAL M$+ GCFLAG GCT $LASTTIME $PARSETIME $DISPTIME + BINDLIST LOCLIST ERRSET $LABELS LINELABLE $BATCOUNT $FILESIZE + ST REPHRASE $DISPFLAG REFCHKL BAKTRCL RUBOUT TTYHEIGHT + CNTLY NEWLINE DSKFNP DSKSAVEP MOPL *RSET CNTL@ + ^W ^R ^Q ^D LF TAB FF CNTLC ALT BATCONL CR VT ^H ^S BSP + $VALUES $FUNCTIONS $ARRAYS $ALIASES $GRADEFS $DEPENDENCIES + $RULES $PROPS $RATVARS $RATVARSWITCH DEBUG ERRBRKSW ERRCATCH + VARLIST GENVAR $DEVICE $FILENAME $FILENUM LBP RBP + $GENSUMNUM CHECKFACTORS $FEATURES FEATUREL $BACKTRACE + $WEIGHTLEVELS TELLRATLIST $DONTFACTOR $INFOLISTS LOADFILES + $DSKALL ERRLIST ALLBUTL LISPERRPRINT BACKRUB + GC-DAEMON GC-OVERFLOW DEMONL $DYNAMALLOC ALLOCLEVEL INFILE + ALARMCLOCK $C18MAXTIME $FILEID DCOUNT GCLINENUM THISTIME + $NOLABELS $BATCHKILL DISPFLAG SAVENO MCATCH BRKLVL SAVEFILE + STRING ST1 $PROMPT STIME0 $%% $ERROR + *IN-$BATCHLOAD* *IN-TRANSLATE-FILE* + LESSORDER GREATORDER $ERRORFUN MBREAK REPRINT POS $STRDISP + $DSKUSE SMART-TTY RUBOUT-TTY MORE-^W OLDST ALPHABET + $LOADPRINT TTYINTS OPERS + *RATWEIGHTS $RATWEIGHTS QUITMSG MQUITMSG CONTMSG + LOADF DISPLAY-FILE $GRIND SCROLLP $CURSORDISP + STRINGDISP $LISPDISP MEXPRP DEFAULTF READING + BPORG GCSYML ^AMSG ^BMSG ^HMSG + STATE-PDL PROMPTMSG GCPROMPT COMMAND PRINTMSG MRG-PUNT + NEW-C-LINE-HOOK TRANSP $CONTEXTS $SETCHECK $MACROS + UNDF-FNCTN AUTOLOAD) +#+LISPM (SPECIAL ERROR-CALL) +#+Franz (special ptport display-to-disk) + (*EXPR REPRINT) + (*LEXPR CONCAT $FILEDEFAULTS $PRINT) + (FIXNUM $FILESIZE DCOUNT $BATCOUNT I N N1 N2 TTYHEIGHT + $FILENUM THISTIME GCT TIM GCLINENUM ALLOCLEVEL + BRKLVL CMTCNT BPORG BPORG0 (COMPUTIME FIXNUM FIXNUM) + (CASIFY FIXNUM) (GETLABCHARN)) + (FLONUM U1 STIME0) + (NOTYPE (ASCII-NUMBERP FIXNUM)) + (ARRAY* (FIXNUM DISPLAY-FILE 1))) + +;; This affects the runtime environment. ALJABR;LOADER also does this, but +;; leave it here for other systems. On the Lisp Machine, this is bound +;; per stack group. + +#-LISPM (SETQ BASE 10. IBASE 10. *NOPOINT T) + +#+PDP10 +(PROG1 '(AUTOLOAD properties) + (LET ((FILESPEC (PURCOPY '(FASL DSK MACSYM)))) + (MAPC #'(LAMBDA (X) + (LET ((FILE (IF (ATOM (CAR X)) (CONS (CAR X) FILESPEC) (CAR X)))) + (DOLIST (FUN (CDR X)) (PUTPROP FUN FILE 'AUTOLOAD)))) + '((LIMIT $LIMIT $LDEFINT) (IRINTE INTE) + (MATCOM $MATCHDECLARE $DEFMATCH $TELLSIMP $TELLSIMPAFTER $DEFRULE) + (MATRUN $DISPRULE $REMRULE $APPLY1 $APPLYB1 $APPLY2 $APPLYB2 + APPLY1 APPLY1HACK APPLY2 APPLY2HACK + FINDBE FINDFUN FINDEXPON FINDBASE PART+ PART*) +; (MATCH $MATCHDECLARE $DEFRULE $DEFMATCH $RPPLY $MARKOV $MARKOB +; $APPLYTD1 $APPLYTD2 $APPLYBP1 $APPLYBP2 $ENABLE $DISABLE +; $TELLSIMP $TELLSIMPAFTER $TELLPRESIMP $TELLPOSTSIMP $BUILTIN +; $RULES $DISPRULE $REMRULE NEWRULE PRENABLE SIMPRULE DEFMRUN +; $APPLY1 $APPLY2 $APPLYB1 $APPLYB2 KILLRULE) + (TLIMIT $TLIMIT $TLDEFINT TLIMP) (HOMOG HREDUCE) + ((APLOT2 FASL DSK SHARE) + $PLOT2 $PLOT3D $PARAMPLOT2 $CONTOURPLOT2 $LOADPLOTS $GRAPH2 + $GRAPH3D $NAMEPLOT $REPLOT $REPLOT4 $SAVEPLOTS) + ((TEKPLT FASL DSK SHARE) + $PLOTMODE $CLEAR $HARDCOPY $NAMEFILE PLOTMODE1) + ((LISPT FASL DSK LIBLSP) $TECO $TSTRING $EMACS) + (FORTRA $FORTRAN $FORTMX) (SCS $SCSIMP $DISTRIB $FACOUT) + (TRANSS $TRANSLATE $TRANSLATE_FILE $COMPFILE) + (TRANSL TRANSLATE-FUNCTION TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION) + (MCOMPI $COMPILE $COMPILE_LISP_FILE) + (ALGFAC CPBGZASS CPTOM FIXMINPOLY FINDIBASE) + (NALGFA $SPLITFIELD $ALGFAC $PFACTORALG NALGFAC) + (OPTION $OPTIONS) (CPOLY $ALLROOTS) (LDISP LINEAR-DISPLA) + (DEFINT $DEFINT) (POLYRZ $NROOTS $REALROOTS STURM1) + (RISCH $RISCH RISCHINT) (OPTIM $OPTIMIZE $COLLAPSE) + (POIS3 $POISSIMP $PRINTPOIS $INTOPOIS $OUTOFPOIS) (POIS2 POISLIM1) + (ALGSYS $ALGSYS) (RESIDU $RESIDUE) + (MTRACE $TRACE $UNTRACE MACSYMA-UNTRACE $TIMER) (PRIMER $PRIMER) + (NEWDET $NEWDET $PERMANENT) ((CTENSR FASL DSK SHARE) $TSETUP) + (LAPLAC $LAPLACE $ILT) (SIN SININT INTEGRATOR) + (PADE $PADE) (SININT RATINT) (UFACT CPRES1) + (SERIES $POWERSERIES) (TRGRED $TRIGREDUCE SP1) + (HAYAT SRDISREP SRF SRCONVERT $TAYLOR $TAYLORINFO TAY-ORDER PSCOEFF1) + (FLOAT FPFORMAT BIGFLOAT2RAT FPPREC1 $BFLOAT FPSCAN FPENTIER + *FPATAN DIM-BIGFLOAT FP2FLO) + (EEZ EEZGCD) (NEWFAC NMULTFACT LCCHECK NCPBER3) + ((FASDMP FASL DSK LIBLSP) *FASDUMP) (SCHATC M1 M2 SCHATCHEN) + (NISIMP $LET $LETSIMP) (MDOT SIMPNCT SIMPNCEXPT) + (SUMCON $SUMCONTRACT $INTOSUM $BASHINDICES $NICEINDICES) + (SYNEX $PREFIX $INFIX $POSTFIX $NOFIX $MATCHFIX $NARY) + (RPART $REALPART $IMAGPART RIPART CABS $RECTFORM $POLARFORM $CABS + $CARG TRISPLIT) + (ZERO $ZEROEQUIV) (LOGARC $LOGARC LOGARC HALFANGLE) (SPRDET SPRDET) + (NEWINV NEWINV) (LINNEW TMLATTICE) (APROPO $APROPOS) + (NUMTH $PRIME $TOTIENT $DIVSUM $JACOBI $GCFACTOR) + ((ODE FASL DSK ODE) $ODE) + ((ODE2 FASL DSK SHARE) $ODE2) ((ELIM FASL DSK SHARE1) $ELIMINATE) + (ROMBRG $ROMBERG $ROMBERG_SUBR) ((DESOLN LISP DSK SHARE) $DESOLVE) + (NUMAPL SUBRCALLP SUBRCALL$P MACSYMACALLP FMAPPLY) + ((BESSEL FASL DSK SHARE) $BESSEL) ((INTSCE LISP DSK SHARE1) $INTSCE) + ((NUSUM > DSK SHARE) $NUSUM $FUNCSOLVE) + (SOLVE $SOLVE $LINSOLVE SOLVE SOLVEX) + (EZGCD $EZGCD FASTCONT EZGCD EZGCD2) ((HENSEL FASL DSK NRAT) SPHGCD) + ((INVERT LISP DSK SHARE1) $ADJOINT $INVERT) + (ASKP $ASKINTEGER ASK-INTEGER ASK-EVOD ASK-INTEGERP ASK-PROP) + ((DUMP FASL DSK SHARE) $DUMPARRAYS $LOADARRAYS) + (UPDATE $UPDATE_SAVED_FILE) (CHAR $GETCHARN) + (FCALL MFUNCTION-CALL TRD-MSYMEVAL EXPT$ M-TLAMBDA M-TLAMBDA& + M-TLAMBDA&ENV M-TLAMBDA&ENV& FUNGEN&ENV-FOR-MEVAL + FUNGEN&ENV-FOR-MEVALSUMARG M-TLAMBDA-I + COMPILE-FORMS-TO-COMPILE-QUEUE) + (EVALW $EVAL_WHEN) (SUSPEN $SUSPEND) + ((TRGSMP FASL DSK SHARE) $TRIGSIMP) + (INTPOL $INTERPOLATE $INTERPOLATE_SUBR) + ((ARRAY FASL DSK SHARE) $LISTARRAY $FILLARRAY $REARRAY) + ((DSKUSE FASL DSK SHARE2) $DISKUSE $FULLDISKUSE $PRINTDISKUSE $DISKFREE) + ((EIGEN FASL DSK SHARE) $EIGENVALUES $EIGENVECTORS) + (ACALL MARRAYREF MARRAYSET $ARRAYAPPLY $ARRAYSETAPPLY MFUNCALL + DISPLAY-FOR-TR INSURE-ARRAY-PROPS MAPPLY-TR INTERVAL-ERROR + IS-BOOLE-CHECK MAKE-ALAMBDA $MAYBE *MMINUS) + (TRMODE $MODEDECLARE $DEFINE_VARIABLE DEF-MTRVAR $MODE_IDENTITY + ASSIGN-MODE-CHECK FLUIDIZE $BIND_DURING_TRANSLATION) + (TRPROP META-ADD2LNC META-PUTPROP META-MPUTPROP META-FSET) + (SUBLIS $SUBLIS) (MTREE $APPLY_NOUNS) + (MDEFUN MDEFUN MDEFUN-TR DEFMTRFUN DEFMTRFUN-EXTERNAL) + ((FILEOP FASL DSK SHARE) + $PRINTFILE $LISTFILES $QLISTFILES $FILELENGTH $FILELIST $RENAMEFILE) + (MMACRO MDEFMACRO $MACROEXPAND $MACROEXPAND1 MMACRO-APPLY MMACROEXPANDED + MMACROEXPAND MMACROEXPAND1) + ((LRATS FASL DSK SHARE2) $LRATSUBST $FULLRATSUBST) + ((PACKG FASL DSK SHAREM) $HERALD_PACKAGE $LOAD_PACKAGE) + ((STENSR > DSK LSH) $TRIGSUM) + (DOVER $DOVER_FILE $DOVARD_FILE) + (TRDEBG $LISPDEBUGMODE) (MTAGS TAGS-START//END) + (AR $MAKE_ARRAY DIMENSION-ARRAY-OBJECT ARRSTORE-EXTEND + MEVAL1-EXTEND) + (NUMER GET-ARRAY MAKE-TRAMP$) + ((QQ FASL DSK SHARE1) $QUANC8) + ((HYP FASL DSK SHARE1) $HGFRED HGFSIMP-EXEC CHECKSIGNTM) + ((HYPGEO FASL DSK SHARE1) $SPECINT) + (BUILDQ $BUILDQ MBUILDQ-SUBST))))) + +; This page is for SPLITFILE AUTOLOAD properties + +#+PDP10 +(PROG1 '(SPLITFILE AUTOLOAD properties) + (LET ((FILESPEC (PURCOPY '(FASL DSK MAXOUT)))) + (MAPC #'(LAMBDA (X) + (LET ((FILE (CONS (CAR X) FILESPEC))) + (DOLIST (FUN (CDR X)) (PUTPROP FUN FILE 'AUTOLOAD)))) + '((DIFF2 DIFFINT DIFFSUM DIFFLAPLACE DIFFNCEXPT STOTALDIFF) ; JPG;COMM2 + (AT $ATVALUE $AT AT1) (DERIVD $DERIVDEGREE) + (BOX $DPART $LPART $BOX $REMBOX) + (ATAN2 SIMPATAN2) (ARITHF $FIBTOPHI $NUMERVAL) + (MAPF $SCANMAP SUBGEN) (LOGCON $LOGCONTRACT) + (RTCON $ROOTSCONTRACT) (NTERMS $NTERMS) + (GENMAT $GENMATRIX $COPYMATRIX $COPYLIST) + (ARRAYF $ARRAYMAKE $ARRAYINFO) (ADDROW $ADDROW $ADDCOL) + (ALIAS $MAKEATOMIC $ORDERGREAT $ORDERLESS $UNORDER) + (CONCAT $CONCAT $GETCHAR) (TTYINI $TTY_INIT) + (PLOG SIMPPLOG) (BINOML SIMPBINOCOEF BINOCOMP) ; PAULW;CSIMP2 + (GAMMA SIMPBETA SIMPGAMMA) (ERF SIMPERF) + (EMATRIX $ZEROMATRIX $EMATRIX) (COEFM $COEFMATRIX $AUGCOEFMATRIX) + (ENTERM $ENTERMATRIX) (XTHRU $XTHRU) (XRTOUT XRUTOUT) + (KRONEC PKRONECK) (RATWT $RATWEIGHT WTPTIMES WTPEXPT) ; RAT;RATOUT + (FASTT $FASTTIMES) (HORNER $HORNER) (RATDIF $RATDIFF) (PFET $PFET) + (PFRAC $PARTFRAC PARTFRAC) (MODGCD NEWGCD) + (MRESUL $RESULTANT RESULTANT $POLY_DISCRIMINANT) ;RAT;RESULT + (SUBRES SUBRESULT) + (REDRES REDRESULT) (MODRES MODRESULT) (BEZOUT $BEZOUT) + (PLYGAM PSISIMP) (PLYLOG LISIMP) ;WGD;SPECFN + (MSORT $SORT) (MAKEL $MAKELIST $SUBLIST) ; DAS;MSTUFF + (SCUBIC SOLVECUBIC) (SQUART SOLVEQUARTIC) ; MAXSRC;PSOLVE + (GRAPH $PLOT $GRAPH) (GRAPH2 $PARAMPLOT $MULTIGRAPH) ; JPG;PLOT + (CFFUN $CF $CFEXPAND $CFDISREP $QUNIT) ; RZ;COMBIN + (SUM SIMPSUM2) (MINFCT $MINFACTORIAL $FACTCOMB $MAKEFACT $MAKEGAMMA) + (DECOMP $POLYDECOMP POLYDECOMP) + (EULBRN $EULER SIMPEULER $BERN SIMPBERN $BERNPOLY) + (ZETA $ZETA $FIB) (PRODCT $PRODUCT SIMPPROD) + (TAYRAT $TAYTORAT) + (TRIGEX $TRIGEXPAND TRIGEXPAND) ; MRG;TRIGO + (HYPER SIMP-%SINH SIMP-%COSH SIMP-%TANH SIMP-%COTH SIMP-%CSCH SIMP-%SECH) + (ATRIG SIMP-%ASIN SIMP-%ACOS SIMP-%ACOT SIMP-%ACSC SIMP-%ASEC) + (AHYPER SIMP-%ASINH SIMP-%ACOSH SIMP-%ATANH SIMP-%ACOTH SIMP-%ACSCH SIMP-%ASECH) + (OUTEX $MAKE_INDEX_FILE) (OUTEY $OPEN_INDEX_FILE) ; MAXSRC;OUTEX + (DESCR $DESCRIBE MDESCRIBE $HELP) (EXAMPL $EXAMPLE) ; MAXSRC;DESCRI + (STATUS $ALARMCLOCK $SEND $BUG $MAIL $WHO $TIMEDATE) ; MAXSRC;OUTMIS + (ISOLAT $ISOLATE $PICKAPART $REVEAL) + (PROPFN $PROPERTIES $PROPVARS $PRINTPROPS) + (SCREEN $PAUSE $CLEARSCREEN) + (CHANGV $CHANGEVAR) (COMBF $COMBINE) + (FACSUM $FACTORSUM $GFACTORSUM) (FACOUT $FACTOROUT))))) + +#+Franz +(eval-when (compile eval) (setsyntax '/ 2)) ; make esc a character +#+Franz (setq infile nil) + +(PROGN (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPALIAS)) + '((+ $+) (- $-) (* $*) (// $//) (^ $^) (/. $/.) (< $<) (= $=) + (> $>) (/( $/() (/) $/)) (/[ $/[) (/] $/]) (/, $/,) (/: $/:) + (/! $/!) (/# $/#) (/' $/') (/; $/;))) + #-MAXII + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OP2C)) + '((* ((#/* . $**))) (^ ((#/^ . $^^))) + (/: ((#/= . $/:=) (#/: . $/:/:))) (/! ((#/! . $/!/!))) + (< ((#/= . $<=))) (> ((#/= . $>=))) (/' ((#/' . $/'/'))))) + #-MAXII + (DEFPROP /: (((#/: #/=) . $/:/:=)) OP3C) + (MAPC #'(LAMBDA (X) (SET (CAR X) (ASCII (CADR X)))) + '((CNTL@ #^@) (CNTLC #^C) (BSP #\BS) (TAB #\TAB) (LF #\LF) + (VT #\VT) (FF #\FF) (CR #\CR) (CNTLY #^Y) (SP #\SP) + (NEWLINE #\NEWLINE) (RUBOUT #\RUBOUT))) + (SETQ GCSYML NIL) + (DOTIMES (I 14.) (PUSH (GENSYM) GCSYML)) + (SETQ ALT #-MULTICS ' #+MULTICS '&) +#-LISPM (SETQ $PLOTUNDEFINED (*$ 2.0 -8.5070591E+37)) + (SETQ $LASTTIME '((MLIST) 0 0) THISTIME 0 GCT 0 GCFLAG NIL + $PARSETIME NIL $DISPTIME NIL MEXPRP NIL) + (SETQ BATCONL NIL $BATCOUNT 0 $BATCHKILL NIL $STRDISP T $GRIND NIL) + (SETQ $RATVARSWITCH T ZUNDERFLOW T MOPL NIL ALIASCNTR 100.) + (SETQ REFCHKL NIL DEBUG NIL BAKTRCL NIL ERRBRKSW NIL MBREAK NIL $ERRORFUN NIL + ERRCATCH NIL DEMONL (LIST NIL) MCATCH NIL BRKLVL -1 + ALLBUTL NIL LOADF NIL $BACKTRACE '$BACKTRACE) + (SETQ *IN-$BATCHLOAD* NIL *IN-TRANSLATE-FILE* NIL) + (SETQ BACKRUB #-Franz nil #+Franz t) + (SETQ $DEBUGMODE NIL $BOTHCASES NIL + $PAGEPAUSE NIL $DSKGC NIL $POISLIM 5) + (SETQ $PROMPT '_ $LOADPRINT T ^S NIL LOADFILES NIL) +; (SETQ $FILEID NIL $C18MAXTIME 150.0E6) + (SETQ $NOLABELS NIL $ALIASES '((MLIST SIMP)) LESSORDER NIL GREATORDER NIL) + (SETQ $INFOLISTS + (PURCOPY '((MLIST SIMP) $LABELS $VALUES $FUNCTIONS $MACROS $ARRAYS + $MYOPTIONS $PROPS $ALIASES $RULES $GRADEFS + $DEPENDENCIES $LET_RULE_PACKAGES))) + (SETQ $LABELS '((MLIST SIMP)) $DSKUSE NIL $DEVICE '$DSK $DISPFLAG T LINELABLE NIL) + (SETQ REPHRASE NIL ST NIL OLDST NIL REPRINT NIL POS NIL) + (SETQ DCOUNT 0 $FILENUM 0 $STORENUM 1000. $FILESIZE 16. $DSKALL T + NEW-C-LINE-HOOK NIL DSKFNP NIL TTYINTS T + GCLINENUM 0 DSKSAVEP NIL SAVENO 0 $DYNAMALLOC NIL ALLOCLEVEL 0) + (SETQ QUITMSG " " + MQUITMSG " (Into LISP. Type control-G to get to MACSYMA.)" + CONTMSG "(Type to continue, to terminate.)" + ^AMSG " (Type EXIT; to exit.)" + ^BMSG #-Multics "LISP (Type P to continue.)" + #+Multics "LISP (Type P to continue)" + ^HMSG " +(Use the RUBOUT or DEL(ETE) key to erase a character.)" ^DMSG-ON " +(Printout of GC statistics turned on. Type control-D again to turn them off.) +" ^DMSG-OFF " +(Printout of GC statistics turned off.) +" GCPROMPT "Type ALL; NONE; a level-no. or the name of the space. +" MORE-^W NIL + LISPERRPRINT T PRINTMSG NIL PROMPTMSG NIL MRG-PUNT NIL READING NIL) +; (SETQ $CALCOMPNUM 100.) + (SETQ STATE-PDL (PURCOPY (NCONS 'LISP-TOPLEVEL))) +#+MULTICS (SETQ $PLOT3DSIZE 20 $MULTGRAPH T) +#+MACLISP (SSTATUS _ T) +#+MACLISP (SSTATUS FEATURE NOLDMSG) +#+MULTICS (ALLOC '(LIST (150000. NIL 0.2))) + '(Random properties)) + +;; Global variables defined by this package. + +(DEFMVAR $% '$% "The last D-line computed, corresponds to lisp *" NO-RESET) +(DEFMVAR $INCHAR '$C + "The alphabetic prefix of the names of expressions typed by the user.") +(DEFMVAR $OUTCHAR '$D + "The alphabetic prefix of the names of expressions returned by the system.") +(DEFMVAR $LINECHAR '$E + "The alphabetic prefix of the names of intermediate displayed expressions.") +(DEFMVAR $LINENUM 1 "the line number of the last expression." FIXNUM NO-RESET) +(DEFMVAR $DIREC 'JRMU + "The default file directory for SAVE, STORE, FASSAVE, and STRINGOUT." + NO-RESET) +(DEFMVAR CASEP T + "Causes translation of characters from lower to upper case on ITS, + and from upper to lower case on Multics and Franz.") +;(DEFMVAR $ERREXP '$ERREXP) +(DEFMVAR USER-TIMESOFAR NIL) + +#+Franz +(defmvar $ignoreeof nil + "Causes EOFs at top level to be ignored, else an EOF brings the user to LISP level.") + +#+PDP10 (DEFMVAR $TTYINTNUM #^U) +#+PDP10 (DEFMVAR $TTYINTFUN NIL) + +(DEFVAR MOREMSG "--Pause--") +(DEFVAR MORECONTINUE "--Continued--") +(DEFVAR MOREFLUSH NIL) +(DEFMVAR $MOREWAIT NIL "needs to be documented" NO-RESET) + +(DEFMVAR ALIASLIST NIL + "is used by the MAKEATOMIC scheme which has never been completed" + NO-RESET) + +;; Again, something to do with a LAP intermediate. +#-NIL +(DECLARE (SETQ BASE 8)) + +;; Various system incompatibilities. This should be restructured at some point. +;; System dependent functions are prefixed with "SYS-". + +#-Multics +(DEFMACRO SYS-DEFAULTF (X) `(DEFAULTF ,X)) + +#+Multics +(DEFUN SYS-DEFAULTF (X) + (SETQ X (NAMELIST X)) + (IF (EQ (CAR X) '*) + (DEFAULTF (CONS (CAR (DEFAULTF NIL)) (CDR X))) + (DEFAULTF X))) + +(DEFUN SYS-GCTIME () + #-Franz (STATUS GCTIME) + #+Franz (cadr (ptime))) + +#.(SETQ NALT #-MULTICS #\ALT #+MULTICS #/&) + +(DEFMVAR $CHANGE_FILEDEFAULTS #+PDP10 T #-PDP10 NIL + "Does DDT-style file defaulting iff T") + +(DEFMVAR $FILE_STRING_PRINT #+PDP10 NIL #-PDP10 T + "If TRUE, filenames are output as strings; if FALSE, as lists.") + +(DEFMVAR $SHOWTIME #-MULTICS NIL #+MULTICS T) + +#-MAXII +(DEFUN CONTINUE NIL + (LET ((STATE-PDL (CONS 'MACSYMA-TOPLEVEL STATE-PDL))) + (PROG ($DISPFLAG TEST N REPRINT POS) + #-(or Multics Franz) (SETQ ERRLIST '((ERRLFUN NIL)) QUITMSG MQUITMSG) + #+(or Multics Franz) (SETQ ERRLIST '((SUPUNBIND) (CONTINUE))) + (IF (NULL REPHRASE) (SETQ ST NIL)) + A2 (IF (NOT (CHECKLABEL $INCHAR)) (SETQ $LINENUM (1+ $LINENUM))) + A (MAKELABEL $INCHAR) + A1 (IF ^S (SETQ #.TTYOFF NIL ^S NIL)) + (MTERPRI) + (PRINTLABEL) + (SETQ POS (CURSORPOS)) + (IF (NOT (ZEROP (LISTEN))) (SETQ REPRINT T)) + (IF NEW-C-LINE-HOOK (FUNCALL NEW-C-LINE-HOOK)) + B (SETQ N (LET ((READING T)) (TYI))) + #+Franz (cond ((greaterp n 0)) + ($ignoreeof (go b)) + (t (*break T '|Entering lisp:|) (go b))) + (COND ((= N #\FF) (FORMFEED) (GO VT)) + ((= N #\VT) (GO VT)) + ((= N #\BS) (COND (BACKRUB (IF ST (POP ST)) (GO B)) + (T (LET (#.WRITEFILEP) (PRINC ^HMSG)) (GO VT)))) + #+Franz ((= N #^B) (*break T '|Entering lisp:|) (go b)) + ((= N #^Y) + (IF REPHRASE (SETQ REPHRASE NIL) (SETQ ST (APPEND OLDST ST))) + (GO REPRT)) + ((OR (= N #\SP) (= N #\CR) (= N #\TAB)) + (COND ((AND (NOT REPHRASE) ST) (PUSH N ST)) + ((AND (NULL ST) (= N #\CR)) (SETQ POS (CURSORPOS)))) + (GO B)) + #-LISPM + ((= N #.NALT) ; Enter the editor + (SETQ TEST (EDIT* (REVERSE ST))) (SETQ REPHRASE NIL) + (WHEN TEST (SETQ REPRINT T) (GO A1)) (GO REPRT)) + (#-LISPM (< N 32.) #+LISPM (NOT (ZEROP (LDB %%KBD-CONTROL N))) + (SETQ REPRINT T) (GO B)) ; Test for control characters + (REPHRASE (SETQ REPHRASE NIL ST NIL))) + (COND ((= N #/;) (SETQ $DISPFLAG T) (GO D)) + ((= N #/$) (SETQ $DISPFLAG NIL) (GO D)) + ((= N #/?) + (WHEN (AND ST (= (CAR ST) #/?) + (NOT (AND (CDR ST) (= (CADR ST) #/\)))) + (SETQ ST NIL) (GO A1))) + ((AND (= N #/\) (PROG2 (SETQ ST (CONS N ST) N (TYI)) NIL))) + #-(or Franz Multics) + ((= N #\RUBOUT) (RUBOUT* ST) (IF ST (POP ST)) (GO B))) + (PUSH N ST) + (GO B) + VT (IF REPHRASE (SETQ REPHRASE NIL ST NIL)) + REPRT(REPRINT ST (= N #\FF)) (GO B) + D (SETQ REPRINT NIL) + (COND ((NULL ST) (GO A1)) + (#.WRITEFILEP + (LET ((#.TTYOFF T)) + (PRINC (MAKNAM (REVERSE (CONS N ST)))) + #+Franz (terpr)))) + (SETQ REPHRASE T OLDST ST) + (COND ((NULL (SETQ TEST (PARSE1))) (GO A)) + ((NULL (SETQ TEST (CONTINUE1 (CAR TEST)))) + (COND (MBREAK (ERRLFUN1 MBREAK)) (T (ERRLFUN T) (GO A2)))) + (T (SETQ $% (CAR TEST)) (MAKELABEL $OUTCHAR) + (WHEN (NOT $NOLABELS) + (SET LINELABLE $%) + (PUTPROP LINELABLE (CONS (CADR $LASTTIME) (CADDR $LASTTIME)) + 'TIME)) + (COND ($DISPFLAG (REMPROP LINELABLE 'NODISP) (DISPLAY*)) + (T (PUTPROP LINELABLE T 'NODISP))) + (SETQ $LINENUM (1+ $LINENUM)))) + (GO A)))) +#+NIL +(DEFUN LINE-PROMPT () + (FORMAT () "(~A) " (MAKNAM (CDR (EXPLODEN LINELABLE))))) +#+NIL +;; this can be used anywere MREAD-WITH-PROMPT is defined. +(DEFUN CONTINUE () + (IF (NOT (CHECKLABEL $INCHAR)) (SETQ $LINENUM (1+ $LINENUM))) + (DO ((STATE-PDL (CONS 'MACSYMA-TOPLEVEL STATE-PDL)) + ($DISPFLAG) + (TEST)) + (()) + (MAKELABEL $INCHAR) + (SETQ TEST (MREAD-WITH-PROMPT (LINE-PROMPT))) + (IF (EQ (CAAR TEST) 'DISPLAYINPUT) (SETQ $DISPFLAG T)) + (SETQ TEST (CONTINUE1 (CADDR TEST))) + (SETQ $% TEST) + (MAKELABEL $OUTCHAR) + (WHEN (NOT $NOLABELS) + (SET LINELABLE $%) + (PUTPROP LINELABLE (CONS (CADR $LASTTIME) (CADDR $LASTTIME)) + 'TIME)) + (COND ($DISPFLAG (REMPROP LINELABLE 'NODISP) (DISPLAY*)) + (T (PUTPROP LINELABLE T 'NODISP))) + (SETQ $LINENUM (1+ $LINENUM)))) + +#-MAXII +(DEFUN CONTINUE1 (TEST) + (LET ((STATE-PDL (CONS 'COMPUTING STATE-PDL))) + (PROG (X THISTIME #+GC GCT) + #-Franz (MTERPRI) + (SETQ M$+ TEST) + (WHEN (NOT $NOLABELS) + (SET LINELABLE TEST) + (IF $DISPFLAG (REMPROP LINELABLE 'NODISP) + (PUTPROP LINELABLE T 'NODISP))) + #+GC (IF GCFLAG (LET (^D) (GC))) + #+GC (SETQ GCT (SYS-GCTIME)) + (SETQ THISTIME (RUNTIME)) + (SETQ TEST #-LISPM (ERRSET (MEVAL* TEST)) + #+LISPM (TOP-MEVAL TEST) + $LASTTIME (LIST '(MLIST SIMP) + (COMPUTIME (RUNTIME) THISTIME) + #+GC (COMPUTIME (SYS-GCTIME) GCT) + #-GC 0)) + (WHEN $SHOWTIME (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI)) + (SETQ X (GCTIMEP $SHOWTIME (CADDR $LASTTIME))) + (MTELL-OPEN "~A msec." (CADR $LASTTIME)) + (IF (NULL TEST) (PRINC " so far")) + #+GC (IF X (MTELL-OPEN " GCtime= ~A msec." + (CADDR $LASTTIME))) + (MTERPRI)) + (RETURN TEST)))) +#+NIL +(DEFUN CONTINUE1 (TEST) + (LET ((STATE-PDL (CONS 'COMPUTING STATE-PDL)) + X THISTIME #+GC GCT WIN) + (MTERPRI) + (WHEN (NOT $NOLABELS) + (SET LINELABLE TEST) + (IF $DISPFLAG (REMPROP LINELABLE 'NODISP) + (PUTPROP LINELABLE T 'NODISP))) + #+GC (IF GCFLAG (LET (^D) (GC))) + #+GC (SETQ GCT (SYS-GCTIME)) + (SETQ THISTIME (RUNTIME)) + (UNWIND-PROTECT + (PROG1 (MEVAL* TEST) (SETQ WIN T)) + (SETQ $LASTTIME (LIST '(MLIST SIMP) + (COMPUTIME (RUNTIME) THISTIME) + #+GC (COMPUTIME (SYS-GCTIME) GCT) + #-GC 0)) + (WHEN $SHOWTIME (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI)) + (SETQ X (GCTIMEP $SHOWTIME (CADDR $LASTTIME))) + (MTELL-OPEN "~A msec." (CADR $LASTTIME)) + #+GC (IF X (MTELL-OPEN " GCtime= ~A msec." + (CADDR $LASTTIME))) + (IF (NOT WIN) (PRINC " so far")) + (MTERPRI))))) + +(DEFMFUN MEVAL* (TEST) + (LET (REFCHKL BAKTRCL CHECKFACTORS) + (PROG2 (IF $RATVARSWITCH (SETQ VARLIST (CDR $RATVARS))) + (MEVAL TEST) + (CLEARSIGN)))) + +(DEFMFUN MAKELABEL (X) + (WHEN (AND $DSKUSE (NOT $NOLABELS) (> (SETQ DCOUNT (1+ DCOUNT)) $FILESIZE)) + (SETQ DCOUNT 0) (DSKSAVE)) + (SETQ LINELABLE (CONCAT X $LINENUM)) + (IF (NOT $NOLABELS) + (IF (OR (NULL (CDR $LABELS)) + (WHEN (MEMQ LINELABLE (CDDR $LABELS)) + (DELQ LINELABLE $LABELS 1) T) + (NOT (EQ LINELABLE (CADR $LABELS)))) + (SETQ $LABELS (CONS (CAR $LABELS) (CONS LINELABLE (CDR $LABELS)))))) + LINELABLE) + +(DEFMFUN PRINTLABEL NIL + (MTELL-OPEN "(~A) " (MAKNAM (CDR (EXPLODEN LINELABLE))))) + +(DEFMFUN MEXPLODEN (X &AUX (BASE 10.) (*NOPOINT T)) (EXPLODEN X)) + +(DEFMFUN ADDLABEL (LABEL) + (SETQ $LABELS (CONS (CAR $LABELS) (CONS LABEL (DELQ LABEL (CDR $LABELS) 1))))) + +(DEFMFUN TYI* NIL + #+Multics (CLEAR-INPUT NIL) + (DO N (TYI) (TYI) NIL + (COND ((OR (= N #\NewLine) (AND (> N 31) (NOT (= N #\RUBOUT)))) + (RETURN N)) + ((= N #\FORM) (FORMFEED) (PRINC (STRIPDOLLAR $PROMPT)))))) + +(DEFUN CONTINUEP NIL + (PRINC (STRIPDOLLAR $PROMPT)) + (= (TYI*) #-Multics #\Space #+Multics #\NewLine)) + +(DEFUN CHECKLABEL (X) ; CHECKLABEL returns T iff label is not in use + (NOT (OR $NOLABELS (= $LINENUM 0) (BOUNDP (CONCAT X $LINENUM))))) + +(DEFUN GCTIMEP (TIMEP TIM) + (COND ((AND (EQ TIMEP '$ALL) (NOT (ZEROP TIM))) (PRINC "Totaltime= ") T) + (T (PRINC "Time= ") NIL))) + +;; If $BOTHCASES is T, lower case letters will not be converted to upper case. + +(DEFMFUN $BOTHCASES (X) (BOTHCASES1 NIL X)) + +(DEFUN BOTHCASES1 (SYMBOL VALUE) + SYMBOL ;Always bound to $BOTHCASES. Ignored. + ;; This won't work with the Lisp Machine reader. + #+MacLisp (DO I 97. (1+ I) (> I 122.) + (SETSYNTAX I (IF VALUE 1 321.) (IF VALUE I (- I 32.)))) + (SETQ CASEP (NOT VALUE)) VALUE) + +;(DEFUN BACKSPACE1 (NIL X) +; (COND (X (ADD2LNC 8 ALPHABET) +; (SETSYNTAX 8 322. NIL)) +; (T (DELETE 8 ALPHABET 1) +; (SETSYNTAX 8 131392. NIL))) +; (SETQ BSPP X)) + +#+LISPM +(DEFUN LISTEN () 0) ; Doesn't exist yet. + +(DEFUN DISPLAY* (&AUX (RET NIL) (TIM 0)) + #+GC (IF (EQ GCFLAG '$ALL) (LET (^D) (GC))) + (SETQ TIM (RUNTIME) + RET (LET ((ERRSET 'ERRBREAK2) (THISTIME -1)) + (ERRSET (DISPLA (LIST '(MLABLE) LINELABLE $%))))) + (IF (NULL RET) (MTELL "~%Error during display~%")) + (IF $DISPTIME (MTELL-OPEN "Displaytime= ~A msec.~%" (COMPUTIME (RUNTIME) TIM))) + RET) + +#+PDP10 +(DEFMFUN FORMFEED NIL (LET (#.TTYOFF) (CURSORPOS 'C))) + +#+Franz +(defmfun formfeed nil (tyo #\ff)) + +#+MULTICS +(DEFMFUN FORMFEED NIL + (IF (NOT (ZEROP (PAGEL NIL))) + (IOG VT (MAPC 'TYO '(31. 32. 48. 119. 100. 74. 126. 36. 13.)) + (CHARPOS NIL 0) (LINENUM NIL 0)) + (TYO 12.))) + +#-(or Franz Multics) +(DEFMFUN RUBOUT* (STG) + (LET (#.TTYOFF #.WRITEFILEP) + (COND (RUBOUT-TTY + (COND ((OR REPRINT (NULL STG) + (= (CAR STG) #\CR) (= (CAR STG) #\TAB)) + (COND (SMART-TTY + (CURSORPOS (CAR POS) (CDR POS)) (CURSORPOS 'L) + (IF (CDR STG) (PRINC (MAKNAM (REVERSE (CDR STG))))) + (SETQ REPRINT NIL)) + ((OR REPRINT STG) (REPRINT (CDR STG) NIL)))) + (T (CURSORPOS 'X)))) + (STG (TYO (CAR STG)))))) + +(DEFMFUN REPRINT (STG FFP) + (LET (#.TTYOFF #.WRITEFILEP) + (IF (NOT FFP) (MTERPRI)) + (CASEQ (CAR STATE-PDL) + (MACSYMA-TOPLEVEL (PRINTLABEL)) + (RETRIEVE (IF (EQ MRG-PUNT 'BREAK) (PRINC (STRIPDOLLAR $PROMPT))))) + (SETQ POS (CURSORPOS)) + (IF STG (PRINC (MAKNAM (REVERSE STG)))) + (SETQ REPRINT NIL))) + +;; The PDP10 is one of the only systems which autoload. +;; The definition for non-autoloading systems is in MAXMAC. - CWH +;; For now we'll let a USER put autoload properties on symbols +;; and at least let them get found on Multics. - Jim 3/24/81 +;; Franz also autoloads -- jkf +;; +#+(or Franz PDP10) +(DEFMFUN FIND-FUNCTION (FUNC) (OR (FBOUNDP FUNC) (LOAD-FUNCTION FUNC NIL))) + +#+(or Franz MACLISP) +(DEFMFUN LOAD-FUNCTION (FUNC MEXPRP) ; The dynamic loader + (LET ((FILE (GET FUNC 'AUTOLOAD))) + (IF FILE (FUNCALL AUTOLOAD (CONS FUNC FILE))))) + +#+(or Franz MACLISP) +(DEFMFUN FIND0 (FUNCPAIR) ; This is the normal value of AUTOLOAD. + (LET (((FUNC . FILE) FUNCPAIR)) + (LET (MEXPRP) (LOAD-FILE FILE)) + (COND ((AND MEXPRP (GET FUNC 'MACRO)) + (MERROR "LISP MACROs may not be called from MACSYMA level.")) + ((OR (FBOUNDP FUNC) (AND MEXPRP (MFBOUNDP FUNC))) + ;; Win. Lisp-defined, or called from macsyma level and + ;; is macsyma-defined. + (NCONS FUNC)) + ((AND (NOT MEXPRP) (MFBOUNDP FUNC)) + ;; Sort of a loss, called from lisp level, but defined + ;; only at macsyma level. We want the undefined function + ;; handler to take over now, and make sure we never get called + ;; on this loser again. + (REMPROP FUNC 'AUTOLOAD) + (FUNCALL UNDF-FNCTN (NCONS FUNC))) + (T (MERROR "~A not found" FUNC))))) + +(DEFMFUN LOAD-FILE (FILE) ($LOAD (TO-MACSYMA-NAMESTRING FILE))) + +(DEFMSPEC $LOADFILE (FORM) + (LOADFILE (FILESTRIP (CDR FORM)) NIL (NOT (MEMQ $LOADPRINT '(NIL $AUTOLOAD))))) + + + +#-Franz +(DEFMSPEC $SETUP_AUTOLOAD (L) + (SETQ L (CDR L)) + (IF (NULL (CDR L)) (WNA-ERR '$SETUP_AUTOLOAD)) + (LET ((FILE (NAMELIST (MERGEF ($FILENAME_MERGE (CAR L)) + `((DSK ,(STATUS UDIR)) NOFILE))))) + (DOLIST (FUNC (CDR L)) + (NONSYMCHK FUNC '$SETUP_AUTOLOAD) + (PUTPROP (SETQ FUNC (DOLLARIFY-NAME FUNC)) FILE 'AUTOLOAD) + (ADD2LNC FUNC $PROPS))) + '$DONE) + +(DEFMFUN DOLLARIFY (L) + (LET ((ERRSET 'ERRBREAK1)) + (CONS '(MLIST SIMP) + (MAPCAR #'(LAMBDA (X) + (LET (Y) + (COND ((NUMBERP X) X) + ((NUMBERP (SETQ Y (CAR (ERRSET + (READLIST + (MEXPLODEN X)) + NIL)))) + Y) + (T (MAKEALIAS X))))) + L)))) + +(DEFMFUN MFBOUNDP (FUNC) + (OR (MGETL FUNC '(MEXPR MMACRO)) + (GETL FUNC '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S)))) + +(DEFMFUN FILENAMEL (FILE) + (COND ((ATOM FILE) (SETQ FILE (NCONS FILE))) + (($LISTP FILE) (SETQ FILE (CDR FILE))) + (T (MERROR "Not a proper filename ~M" FILE))) + (FILESTRIP FILE)) + +#+MACLISP +(DEFMFUN LOADFILE (FILE FINDP PRINTP) ; FILE may be in any acceptable LISP format. + (LET ((TIM 0) ERROR (SAVENO 0) TRUEF RECURP (BPORG0 BPORG)) + (WHEN FINDP (SETQ TIM (RUNTIME)) + (IF (NULL LOADF) (SETQ LOADF DEFAULTF) (SETQ RECURP T)) + (IF (MEMQ $LOADPRINT '(NIL $LOADFILE)) (SETQ PRINTP NIL))) + (SETQ TRUEF (TRUEFNAME FILE)) + (WHEN PRINTP (OR RECURP (MTERPRI)) + (IF $FILE_STRING_PRINT + (MTELL-OPEN "~A being loaded" (NAMESTRING TRUEF)) + (PRINL (APPEND (CDR TRUEF) (CAR TRUEF) '(|being loaded|)))) + (MTERPRI)) + (WHEN (NULL + (ERRSET + (COND (FINDP (LET ((Y (NOINTERRUPT 'TTY))) (LOAD FILE) (NOINTERRUPT Y))) + (T (IF $CHANGE_FILEDEFAULTS (SYS-DEFAULTF FILE)) (LOAD FILE))))) + (NOINTERRUPT NIL) (SETQ ERROR T)) + (IF (NOT (= BPORG BPORG0)) + (SETQ LOADFILES (CONS (LIST (NAMESTRING TRUEF) BPORG0 BPORG) LOADFILES))) + (COND ((NOT FINDP) (IF $CHANGE_FILEDEFAULTS (SYS-DEFAULTF FILE))) + ((NOT RECURP) (IF LOADF (SETQ DEFAULTF LOADF LOADF NIL)) (TIMEORG TIM))) + (WHEN ERROR + (WHEN (AND (= (SYS-FREE-MEMORY) 0) FINDP (FASLP TRUEF)) + (MTELL-OPEN "Package not entirely loaded in.~%") + (MTELL-OPEN "You will probably have to load up a new MACSYMA!!~%")) + (LET ((ERRSET 'ERRBREAK1)) + (MTELL-OPEN "~%Error in LOADFILE attempt") (ERROR))) + (IF PRINTP (MTELL-OPEN "Loading done~%")) + '$DONE)) + +#+LISPM ; This is quite different from the Maclisp version. +(DEFMFUN LOADFILE (FILE FINDP PRINTP &AUX (SAVENO 0)) + (AND FINDP (MEMQ $LOADPRINT '(NIL $LOADFILE)) (SETQ PRINTP NIL)) + ;; Should really get the truename of FILE. + (IF PRINTP (FORMAT T "~%~A being loaded.~%" FILE)) + (LOAD FILE) ; LOAD will decide whether fasl or not, etc. + '$DONE) + +#+Franz +(DEFUN LOADFILE (FILE FINDP PRINTP ) + (AND FINDP (MEMQ $LOADPRINT '(NIL $LOADFILE)) (SETQ PRINTP NIL)) + (COND (PRINTP (MTERPRI) + (PRINC FILE) ; Should really get the truename. + (PRINC '| being loaded.|) + (MTERPRI))) + (Load FILE) ; LOAD will have to figure out whether fasl or not, etc. + '$DONE) + +(DEFMFUN TRUEFNAME (FILE) + (OR (PROBEF FILE) + (CLOSE (OPEN FILE '(IN FIXNUM))) + ; The OPEN is to generate the appropriate error handling. + ; The CLOSE is just to be nice. + #+Multics FILE + ; The Multics CLOSE function returns T always. + ; At least we know we can open and close the file. + ; On Multics PROBEF calls ALLFILES which demands access to + ; the directory. + )) + +#-LISPM +(DEFMFUN MTRUENAME (FILEOBJ) + (LET ((FILE (IF (EQ (STATUS OPSYS) 'ITS) + (TRUENAME FILEOBJ) + (TRUEFNAME (NAMELIST FILEOBJ))))) + (MFILE-OUT FILE))) + +#+LISPM +(DEFMFUN MTRUENAME (STREAM) + (MFILE-OUT (UNEXPAND-PATHNAME (FUNCALL STREAM ':NAME)))) + +(DEFMFUN CARFILE (FILE) ; FILE is in OldIO list format. + (IF (= (LENGTH FILE) 3) (CDR FILE) FILE)) + +#-MAXII +(DEFMSPEC $BATCON (L) (SETQ L (CDR L)) + (COND ((OR (NULL L) (> (LENGTH L) 2)) (WNA-ERR '$BATCON)) + ((NULL BATCONL) (MERROR "BATCH and DEMO have never been called."))) + (LET ((X (MEVAL (CAR L)))) + (BATCH1 (LIST (CONS '(MLIST) (CAR BATCONL)) + (COND ((NULL X) $BATCOUNT) + ((EQ (TYPEP X) 'FIXNUM) X) + ((NOT (EQ X T)) (CAR L)) + (T (1+ $BATCOUNT))) + (COND ((NULL (CDR L)) + (COND ((EQ (TYPEP X) 'FIXNUM) (1- X)) + ((OR (NULL X) (EQ X T)) (CADR BATCONL)) + (T T))) + (T (MEVAL (CADR L))))) + (CADDR BATCONL) + $BATCOUNT + NIL))) + +#-MAXII +(DEFMSPEC $BATCH (L) (BATCH1 (CDR L) NIL NIL NIL)) + +#-MAXII +(DEFMSPEC $DEMO (L) (BATCH1 (CDR L) T NIL NIL)) + +;; SPECP is T if the file is being batched for TRANSL, or $LOAD, +;; or some other special purpose. +#-Franz +(DEFMACRO FILEPOS-CHECK () `(IF SPECP (SETQ FILEPOS (FILEPOS FILE-OBJ)))) +#+Franz +(defmacro filepos-check () nil) + +#-MAXII +(DEFMFUN BATCH1 (L DEMOP BATCONP SPECP) + (LET ((FN (IF DEMOP '$DEMO '$BATCH))) + (LET ((STATE-PDL (LIST* 'BATCH (IF *IN-TRANSLATE-FILE* '$TRANSLATE FN) STATE-PDL)) + (INFILE INFILE) + (TRANSLP (AND SPECP (NOT *IN-$BATCHLOAD*)))) + (PROG (FILE TEST TEST1 TEST2 INDEX HIGH $DISPFLAG + FILEPOS ;; set to filepos at first token of expression read. + EOF /\FLAG X CMTP ^Q CMTCNT FILE-OBJ FILE-NAME) + (SETQ EOF (NCONS NIL) INDEX 1 HIGH -1 CMTCNT 0) + + (COND ((OR (NULL L) (ATOM (CAR L))) + (SETQ FILE L) + (GO Z)) + ((NOT (EQ (CAAAR L) 'MLIST)) (IMPROPER-ARG-ERR (CAR L) FN)) + (T (SETQ FILE (CDAR L)))) + Z1 (COND ((NULL (SETQ L (CDR L))) (GO Z)) + ((NOT (ATOM (SETQ INDEX (MEVAL (CAR L))))) + (IMPROPER-ARG-ERR INDEX FN)) + ((MEMQ INDEX '(T NIL)) (SETQ INDEX 1) (GO Z1)) + ((NOT (EQ (TYPEP INDEX) 'FIXNUM)) + (SETQ INDEX (MAKSTRING* INDEX)))) + (WHEN (CDR L) + (IF (CDDR L) (WNA-ERR FN)) + (SETQ X (MEVAL (CADR L))) + (COND ((AND (EQ (TYPEP INDEX) 'FIXNUM) (EQ (TYPEP X) 'FIXNUM)) + (SETQ HIGH (- X INDEX))) + ((NULL X) (SETQ HIGH NIL)) + ((NOT (EQ X T)) (IMPROPER-ARG-ERR X FN)))) + + + Z (SETQ FILE (COND (BATCONP FILE) + ((AND BATCONL (NULL FILE)) (CAR (LAST BATCONL))) + (T (FILESTRIP FILE)))) + + (SETQ INFILE (SETQ FILE-OBJ (OPEN FILE '(READ ASCII)))) + ;; If user does BATCH or DEMO, update the file defaults. + ;; Don't do this for file translation. + #+MACLISP (IF (AND (NOT TRANSLP) $CHANGE_FILEDEFAULTS) (SYS-DEFAULTF FILE)) + #+LISPM (SETQ FILE-NAME (FILE-EXPAND-PATHNAME FILE)) + #+MACLISP (SETQ FILE-NAME (TRUENAME FILE-OBJ)) + #+Franz (setq file-name file) + ; Multics returns a true STRING from TRUENAME above. -JIM + #+PDP10 (SETQ FILE-NAME (APPEND (CDR FILE-NAME) (CAR FILE-NAME))) + (IF TRANSLP (GO A)) + (WHEN (AND $BATCHKILL BATCONL + #+MACLISP (NOT (EQUAL FILE-NAME (CAR BATCONL))) + #+LISPM (NOT (EQUAL FILE-NAME (CAR (LAST BATCONL))))) + (KILL1 $BATCHKILL) + (IF (EQ $BATCHKILL T) ($RESET)) + #+GC (GCTWA)) + (SETQ BATCONL (LIST #-LISPM FILE-NAME + #+LISPM (UNEXPAND-PATHNAME FILE-NAME) + HIGH DEMOP + #+PDP10 FILE #-PDP10 FILE-NAME) + $BATCOUNT 0) + + + (COND (SPECP (GO A)) + ((EQUAL INDEX 1) (GO READ)) + ((NOT (EQ (TYPEP INDEX) 'FIXNUM)) (GO ALOOP))) + + ;; skip over 'index' input expressions. + ;; 'test' will be the current character and 'test1' the + ;; previous character + + + ILOOP (COND ((EQ (SETQ TEST (READCH FILE-OBJ EOF)) EOF) + (SETQ $BATCOUNT (OR BATCONP 0)) + (MERROR "Premature EOF in file")) + ((EQ TEST '/\) (READCH FILE-OBJ)) + ((AND (EQ TEST '*) (EQ TEST1 '//)) (SETQ TEST1 NIL CMTP 1) (GO CMT)) + ((MEMQ TEST '(/; $)) + (SETQ $BATCOUNT (1+ $BATCOUNT)) + (IF (= (SETQ INDEX (1- INDEX)) 1) (GO READ)))) + (SETQ TEST1 TEST) + (GO ILOOP) + + ALOOP (COND ((= (SETQ TEST2 (TYI FILE-OBJ -1)) -1) + (SETQ $BATCOUNT (OR BATCONP 0)) + (MERROR "~A not found in file" (MAKNAM INDEX))) + ((AND (PROG2 (SETQ TEST (ASCII (CASIFY TEST2))) (NULL TEST1)) + (OR (< TEST2 32.) (EQ TEST '/ ))) + (GO ALOOP)) + ((AND (EQ TEST '*) (EQ (CAR TEST1) '//)) (SETQ CMTP 2) (GO CMT)) + ((MEMQ TEST '(/; $)) + (SETQ $BATCOUNT (1+ $BATCOUNT) TEST1 NIL) (GO ALOOP)) + ((EQ TEST #-Franz CR #+Franz LF) + (SETQ TEST1 NIL) + (GO ALOOP)) + ((EQ TEST '/\) (SETQ TEST1 (CONS TEST TEST1) TEST (READCH FILE-OBJ))) + ((EQ TEST '&) + (IF (EQ (CAR TEST1) '/ ) (SETQ TEST1 (CDR TEST1))) + (IF (AND (EQ (CAR TEST1) '&) (CDR TEST1) (NOT (EQ (CADR TEST1) '/\)) + (EQUAL INDEX (REVERSE (CDR TEST1)))) + (GO READ)))) + (SETQ TEST1 (CONS TEST TEST1)) + (GO ALOOP) + READ (SETQ $LINENUM (1+ $LINENUM)) + A #+(OR PDP10 LISPM) + (SETQ TEST (IF #+PDP10 (NULL (STATUS FILEMODE FILE-OBJ)) + #+LISPM (NOT (FILE-OPEN FILE-OBJ)) + EOF + (READCH FILE-OBJ EOF))) + #-(OR PDP10 LISPM) + (SETQ TEST (READCH FILE-OBJ EOF)) + (COND ((EQ TEST EOF) (MTERPRI) + ;; PDP10 Lisps do this automatically + #-PDP10 (CLOSE FILE-OBJ) + (RETURN '|&BATCH DONE|)) + ((OR (EQ TEST '/ ) (EQ TEST #-Franz CR #+Franz LF) + (EQ TEST LF) (EQ TEST FF) (EQ TEST TAB) + #+MACLISP (OR (EQ TEST CNTLC) (EQ TEST CNTL@))) + (GO A)) + (T ;; end of whitespace loop. + (FILEPOS-CHECK))) + (SETQ ST NIL) + (MAKELABEL $INCHAR) (MTERPRI) (PRINTLABEL) + (WHEN TEST2 (SETQ TEST2 NIL) (PRINC (MAKNAM INDEX)) (PRINC '|&& |)) + (GO B1) + + ;; collecting loop + ;; characters are collected in list 'st'. + ;; Collection ends when a ; or $ is seen and in that case + ;; control transfers to label 'd' + ;; + B (SETQ TEST (READCH FILE-OBJ EOF)) + B1 (COND (/\FLAG (SETQ /\FLAG NIL)) + ((EQ TEST EOF) + (WHEN (NULL ST) + (MTERPRI) #+LISPM (CLOSE FILE-OBJ) (RETURN '|&BATCH DONE|)) + (IF SPECP (SETQ #.TTYOFF NIL)) + (MTELL "~%EOF met") (SETQ REPHRASE T) (GO ERR)) + ((OR (EQ TEST '/ ) + (EQ TEST #-Franz CR #+Franz LF) + (EQ TEST TAB)) + (IF (NULL ST) (GO B))) + ((EQ TEST LF) (GO B)) +#+MACLISP ((OR (EQ TEST CNTLC) (EQ TEST CNTL@)) (GO B)) + ((EQ TEST FF) (WHEN ST (MTERPRI) (SETQ TEST '/ ) (GO C)) (GO B)) + ((PROG2 (FILEPOS-CHECK) + ;; must be set here too because of whitespace loop above. + (AND (EQ TEST '*) ST (EQ (CAR ST) '//))) + (PRINC '*) (SETQ TEST1 NIL) (GO CMT)) + ((EQ TEST '&) + (WHEN (AND (EQ (CAR ST) '&) (CDR ST) (NOT (EQ (CADR ST) '/\))) + (PRINC TEST) (PRINC '/ ) (SETQ ST NIL) + (WHEN (NULL HIGH) (CLOSE FILE-OBJ) + (RETURN '|&BATCH TERMINATED|)) + (GO B))) + ((EQ TEST '/\) (SETQ /\FLAG T)) + ((EQ TEST '/;) (SETQ $DISPFLAG T) (GO D)) + ((EQ TEST '$) (SETQ $DISPFLAG NIL) (GO D))) + (PRINC TEST) + C (IF REPHRASE (SETQ REPHRASE NIL ST NIL)) + (SETQ ST (CONS TEST ST)) + (GO B) + + CMT ;; comment scanner + ;; this is reached via a 'go' from a number of places. + ;; If 'cmtp' is 1 then go to 'iloop' after comment + ;; If 'cmtp' is 2 then go to 'aloop' after comment + ;; Otherwise go to B + (SETQ TEST (READCH FILE-OBJ EOF)) + (COND ((EQ TEST EOF) (IF SPECP (SETQ #.TTYOFF NIL)) + (MTELL "EOF met inside of comment") + (SETQ REPHRASE T) (GO ERR)) + ((NOT (OR CMTP + #-(or Franz Multics) (EQ TEST LF) + #+MACLISP (OR (EQ TEST CNTLC) (EQ TEST CNTL@)))) + (PRINC TEST))) + (COND ((AND (EQ TEST '//) (EQ TEST1 '*)) + (UNLESS (ZEROP CMTCNT) + (SETQ TEST1 NIL CMTCNT (1- CMTCNT)) (GO CMT)) + (COND ((EQUAL CMTP 1) (SETQ CMTP NIL) (GO ILOOP)) + ((EQUAL CMTP 2) (SETQ TEST1 NIL CMTP NIL) (GO ALOOP))) + (WHEN (NULL (SETQ ST (CDR ST))) (MTERPRI) (MTERPRI)) (GO B)) + ((AND (EQ TEST '*) (EQ TEST1 '//)) + (SETQ TEST1 NIL CMTCNT (1+ CMTCNT)) (GO CMT))) + (SETQ TEST1 TEST) + (GO CMT) + + ;; end of scan. At this point, a $ or ; has terminated + ;; a line of input which is sitting reversed in the list 'st'. + ;; The symbol 'test' still holds the $ or ; + ;; + D (PRINC TEST) + + #+Franz (terpr) + + (DO L ST (CDR L) (NULL L) (RPLACA L (ASCII-CHK (CAR L)))) + (SETQ OLDST ST $BATCOUNT (1+ $BATCOUNT)) + (COND ((NULL ST) (GO D1)) + ((NULL (SETQ REPHRASE T + TEST (IF SPECP (LET (#.TTYOFF) (PARSE1)) (PARSE1)))) + (GO ERR)) + (SPECP (TRANSLATE-MACEXPR (CAR TEST) FILEPOS) (GO A)) + ((NULL (SETQ TEST (CONTINUE1 (CAR TEST)))) (GO ERR))) + (SETQ $% (CAR TEST)) + (MAKELABEL $OUTCHAR) + (UNLESS $NOLABELS + (SET LINELABLE $%) + (PUTPROP LINELABLE (CONS (CADR $LASTTIME) (CADDR $LASTTIME)) 'TIME)) + (COND ($DISPFLAG (REMPROP LINELABLE 'NODISP) + (IF (NULL (DISPLAY*)) (GO ERR))) + (T (PUTPROP LINELABLE T 'NODISP))) + (SETQ $LINENUM (1+ $LINENUM)) + D1 (WHEN (AND DEMOP (LET (#.TTYOFF) (NOT (CONTINUEP)))) + (CLOSE FILE-OBJ) (RETURN '|&DEMO TERMINATED|)) + (WHEN (AND (EQ (TYPEP HIGH) 'FIXNUM) + (NOT (< HIGH 0)) + (< (SETQ HIGH (1- HIGH)) 0)) + (CLOSE FILE-OBJ) (RETURN '|&BATCH DONE|)) + (GO A) + ERR (CLOSE FILE-OBJ) + (LET ((ERRSET 'ERRBREAK1)) + (IF SPECP (SETQ #.TTYOFF NIL)) + (DO L ST (CDR L) (NULL L) (RPLACA L (ASCII-CHK (CAR L)))) + (MERROR "~%Error in ~:M file" + (IF *IN-TRANSLATE-FILE* '$TRANSLATE FN))))))) + +(DEFMSPEC $KILL (FORM) (MAPC #'KILL1 (CDR FORM)) #+GC (GCTWA) '$DONE) + +(DEFMFUN KILL1 (X) + ((LAMBDA (Z) + (COND ((AND ALLBUTL (MEMQ X ALLBUTL))) + ((EQ (SETQ X (GETOPR X)) '$LABELS) + (DOLIST (U (CDR $LABELS)) + (COND ((AND ALLBUTL (MEMQ U ALLBUTL)) + (SETQ Z (NCONC Z (NCONS U)))) + (T (MAKUNBOUND U) (REMPROP U 'TIME) + (REMPROP U 'NODISP)))) + (SETQ $LABELS (CONS '(MLIST SIMP) Z) $LINENUM 0 DCOUNT 0)) + ((MEMQ X '($VALUES $ARRAYS $ALIASES $RULES $PROPS $LET_RULE_PACKAGES)) + (MAPC #'KILL1 (CDR (SYMEVAL X)))) + ((MEMQ X '($FUNCTIONS $MACROS $GRADEFS $DEPENDENCIES)) + (MAPC #'(LAMBDA (Y) (KILL1 (CAAR Y))) (CDR (SYMEVAL X)))) + ((EQ X '$MYOPTIONS)) + ((EQ X '$TELLRATS) (SETQ TELLRATLIST NIL)) + ((EQ X '$RATWEIGHTS) (SETQ *RATWEIGHTS NIL $RATWEIGHTS '((MLIST SIMP)))) + ((EQ X '$FEATURES) + (COND ((NOT (EQUAL (CDR $FEATURES) FEATUREL)) + (SETQ $FEATURES (CONS '(MLIST SIMP) (APPEND FEATUREL NIL)))))) + ((OR (EQ X T) (EQ X '$ALL)) + (MAPC #'KILL1 (CDR $INFOLISTS)) + (SETQ $RATVARS '((MLIST SIMP)) VARLIST NIL GENVAR NIL + CHECKFACTORS NIL GREATORDER NIL LESSORDER NIL $GENSUMNUM 0 + $WEIGHTLEVELS '((MLIST)) *RATWEIGHTS NIL $RATWEIGHTS '((MLIST SIMP)) + TELLRATLIST NIL $DONTFACTOR '((MLIST)) $SETCHECK NIL) + (KILLALLCONTEXTS)) + ((SETQ Z (ASSQ X '(($CLABELS . $INCHAR) ($DLABELS . $OUTCHAR) + ($ELABELS . $LINECHAR)))) + (MAPC #'(LAMBDA (Y) (REMVALUE Y '$KILL)) (GETLABELS* (EVAL (CDR Z)) NIL))) + ((AND (EQ (TYPEP X) 'FIXNUM) (NOT (< X 0))) (REMLABELS X)) + ((ATOM X) + (SETQ Z (OR (AND (MEMQ X (CDR $ALIASES)) (GET X 'NOUN)) (GET X 'VERB))) + (COND ((OR (NULL ALLBUTL) (NOT (MEMQ Z ALLBUTL))) + (REMVALUE X '$KILL) (REMCOMPARY X) + (IF (MEMQ X (CDR $CONTEXTS)) ($KILLCONTEXT X)) + (IF (MGET X '$RULE) + (LET ((Y (RULEOF X))) + (COND (Y ($REMRULE Y X)) + (T #+MACLISP (REMPROP X 'EXPR) + #-MACLISP (FMAKUNBOUND X) + (DELQ X $RULES 1))))) + (IF (AND (GET X 'OPERATORS) (RULECHK X)) ($REMRULE X '$ALL)) + (IF (MGET X 'TRACE) (MACSYMA-UNTRACE X)) + (WHEN (GET X 'TRANSLATED) + (REMOVE-TRANSL-FUN-PROPS X) + (REMOVE-TRANSL-ARRAY-FUN-PROPS X)) + (IF (NOT (GET X 'SYSCONST)) (REMPROP X 'MPROPS)) + (DOLIST (U '(BINDTEST NONARRAY EVFUN EVFLAG OPERS SPECIAL MODE)) + (REMPROP X U)) + (DOLIST (U OPERS) + (IF (AND (REMPROP X U) + (EQ (GET X 'OPERATORS) 'SIMPARGS1)) + (REMPROP X 'OPERATORS))) + (WHEN (MEMQ X (CDR $PROPS)) + (REMPROP X 'SP2) (KILLFRAME X) + (LET ((Y (STRIPDOLLAR X))) + (REMPROP Y 'ALPHABET) (DELETE (GETCHARN Y 1) ALPHABET 1))) + (LET ((Y (GET X 'OP))) + (IF (AND Y (NOT (MEMQ Y MOPL)) (MEMQ Y (CDR $PROPS))) + (KILL-OPERATOR X))) + (REMALIAS X NIL) (DELQ X $ARRAYS 1) (REMPROPCHK X) + #+MACLISP (ARGS X NIL) + (DELETE (ASSOC (NCONS X) $FUNCTIONS) $FUNCTIONS 1) + (DELETE (ASSOC (NCONS X) $MACROS) $MACROS 1) + (LET ((Y (ASSOC (NCONS X) $GRADEFS))) + (WHEN Y (REMPROP X 'GRAD) (DELETE Y $GRADEFS 1))) + (DELETE (ASSOC (NCONS X) $DEPENDENCIES) $DEPENDENCIES 1) + (IF Z (KILL1 Z))))) + ((AND (EQ (CAAR X) 'MLIST) (EQ (TYPEP (CADR X)) 'FIXNUM) + (OR (AND (NULL (CDDR X)) (SETQ X (APPEND X (NCONS (CADR X))))) + (AND (EQ (TYPEP (CADDR X)) 'FIXNUM) (NOT (> (CADR X) (CADDR X)))))) + (LET (($LINENUM (CADDR X))) (REMLABELS (- (CADDR X) (CADR X))))) + ((SETQ Z (MGETL (CAAR X) '(HASHAR ARRAY))) (REMARRELEM Z X)) + ((AND (EQ (CAAR X) '$ALLBUT) + (NOT (DOLIST (U (CDR X)) (IF (NOT (SYMBOLP U)) (RETURN T))))) + (LET ((ALLBUTL (CDR X))) (KILL1 T))) + (T (IMPROPER-ARG-ERR X '$KILL)))) + NIL)) + +(DEFMFUN REMLABELS (N) + (PROG (L X) + (SETQ L (LIST (EXPLODEN $INCHAR) (EXPLODEN $OUTCHAR) (EXPLODEN $LINECHAR))) + LOOP (SETQ X (MEXPLODEN $LINENUM)) + (DO L L (CDR L) (NULL L) (REMVALUE (IMPLODE (APPEND (CAR L) X)) '$KILL)) + (IF (OR (MINUSP (SETQ N (1- N))) (= $LINENUM 0)) (RETURN NIL)) + (SETQ $LINENUM (1- $LINENUM)) + (GO LOOP))) + +(DEFMFUN REMVALUE (X FN) + (COND ((NOT (SYMBOLP X)) (IMPROPER-ARG-ERR X FN)) + ((BOUNDP X) + (LET (Y) + (COND ((OR (SETQ Y (MEMQ X (CDR $VALUES))) (MEMQ X (CDR $LABELS))) + (COND (Y (DELQ X $VALUES 1)) + (T (DELQ X $LABELS 1) + (REMPROP X 'TIME) (REMPROP X 'NODISP) + (IF (NOT (ZEROP DCOUNT)) (SETQ DCOUNT (1- DCOUNT))))) + (MAKUNBOUND X) T) + ((GET X 'SPECIAL) (MAKUNBOUND X) T) + (TRANSP (SET X X) T) + ((EQ X '$DEFAULT_LET_RULE_PACKAGE) T) + (T (MTELL "Warning: Illegal REMVALUE attempt:~%~M" X) NIL)))))) + +(DEFMFUN RULEOF (RULE) + (OR (MGET RULE 'RULEOF) + (LET ((OP (CAAADR (MGET RULE '$RULE))) L) + (AND (SETQ L (GET OP 'RULES)) (MEMQ RULE L) OP)))) + +(DEFMFUN $DEBUGMODE (X) (DEBUGMODE1 NIL X)) + +#-NIL +(DEFUN DEBUGMODE1 (ASSIGN-VAR Y) + ASSIGN-VAR ; ignored + #+MACLISP (SETQ DEBUG (COND (Y (*RSET T) Y) (T (*RSET NIL)))) + #+Franz (prog2 (setq debug y) (debugging y)) + #+LISPM (SETQ DEBUG (SETQ *RSET Y))) + +#-NIL +(DEFMFUN ERRBREAK (Y) ; The ERRSET interrupt function + (COND + (DEBUG + ((LAMBDA (BRKLVL VARLIST GENVAR ERRBRKL LINELABLE) + (PROG (X ^Q #.TTYOFF O^R #+MACLISP ERRSET #+LISPM ERROR-CALL TIM $%% + #+Franz errset + $BACKTRACE #+LISPM RETVAL OLDST) + (SETQ #+(or Franz MACLISP) ERRSET #+LISPM ERROR-CALL 'ERRBREAK1) + (SETQ TIM (RUNTIME) $%% '$%% + $BACKTRACE (CONS '(MLIST SIMP) BAKTRCL)) + (SETQ O^R #.WRITEFILEP #.WRITEFILEP (AND #.WRITEFILEP (NOT DSKFNP))) + (MTERPRI) + (IF Y (PRINC 'MACSYMA-BREAK) (PRINC 'ERROR-BREAK)) + (UNLESS (ZEROP BRKLVL) (PRINC " level ") (PRINC BRKLVL)) + (PRINC ^AMSG) + (MTERPRI) + A (COND + ((NULL + (*CATCH 'MACSYMA-BREAK + (LET ((STATE-PDL (CONS 'MACSYMA-BREAK STATE-PDL))) + (ERRSET + (COND ((EQ (SETQ X (RETRIEVE1 NIL 'BREAK)) '$EXIT) + (TIMEORG TIM) #+LISPM (SETQ RETVAL 'EXIT) (GO END)) + ((EQ X '$LISP) +#+MACLISP (LET ((STATE-PDL (CONS 'LISP-BREAK STATE-PDL))) + (*BREAK T 'LISP) (MTERPRI)) ; ^B also works +#+LISPM (SETQ RETVAL 'LISP) +#+LISPM (GO END)) + ((EQ X '$TOPLEVEL) + (COND ((*CATCH 'MBREAK + (LET (ST OLDST REPHRASE + (MBREAK (CONS BINDLIST LOCLIST))) + (SETQ $LINENUM (1+ $LINENUM)) + (CONTINUE))) + (GO END)) + (T (MTELL-OPEN "Back to the break~%")))) + (T (LET (($DISPFLAG DISPFLAG)) (SETQ $%% (MEVAL X))) + (IF DISPFLAG (DISPLA $%%) (MTERPRI)))))))) + (ERRLFUN1 ERRBRKL) + (MTELL-OPEN "~%(Still in break loop)~%"))) + (GO A) + END (PRINC "Exited from the break ") + (IF (NOT (ZEROP BRKLVL)) (PRINC BRKLVL)) + (MTERPRI) + (IF O^R (SETQ #.WRITEFILEP T)) +#+(or Franz MACLISP) (RETURN NIL) #+LISPM (RETURN RETVAL))) + (1+ BRKLVL) VARLIST GENVAR (CONS BINDLIST LOCLIST) LINELABLE)))) + +#-NIL +(DEFUN ERRBREAK1 (IGNORE) IGNORE NIL) ; Used to nullify ERRSETBREAKs + +#-NIL +(DEFUN ERRBREAK2 (IGNORE) + ; An alternate ERRSET interr. function; used by PARSE and DISPLAY + IGNORE ; ignored + (LET ((STATE-PDL (CONS 'LISP-BREAK STATE-PDL))) (*BREAK ERRBRKSW 'ERST))) + +#-MAXII +(DEFUN MERRBREAK (X) ; The ^A interrupt function + (COND ((NOT (MEMQ 'EDIT STATE-PDL)) + (LET ((DEBUG T) + (STATE-PDL (CONS '^A-BREAK STATE-PDL)) + #-Multics (MOREMSG "--Pause--")) + #+PDP10 (ENDPAGEFN T 'MORE-FUN) + #+PDP10 (IF (NULL X) (BUFFCLEAR NIL)) + (IF (OR (NULL X) $SHOWTIME) (TIMESOFAR T)) + #+MACLISP (NOINTERRUPT NIL) + (ERRBREAK T)) + #+PDP10 (TTYRETFUN T)) + (T (MTELL "~%Control-A does not work while editing~%")))) + +;; The ^B interrupt function +(DEFUN MPAUSE (X) + X ;Ignored + (LET ((STATE-PDL (LIST* 'LISP-BREAK '^B-BREAK STATE-PDL)) + (MOREMSG "--Pause--")) + #+PDP10 (ENDPAGEFN T 'MORE-FUN) + #+PDP10 (BUFFCLEAR NIL) + (TIMESOFAR T) + #+MACLISP (NOINTERRUPT NIL) + (*BREAK T ^BMSG)) + #+PDP10 (TTYRETFUN T)) + +#+PDP10 +(DEFUN BUFFCLEAR (FLAG) + (COND (SMART-TTY (CLEAR-INPUT T) (IF FLAG (CLEAR-OUTPUT T))) + (T (IF FLAG (CLEAR-OUTPUT T)) (CLEAR-INPUT T)))) + +#+(or Franz MACLISP) +(DEFUN TIMESOFAR (X) ; The ^] interrupt function + (LET ((#.TTYOFF (AND (EQUAL X 1) #.TTYOFF)) + (#.WRITEFILEP (AND #.WRITEFILEP (NOT DSKFNP)))) + (COND ((= THISTIME -1) (MTELL-OPEN "~%Computing the display now")) + ((NOT (ZEROP THISTIME)) + (LET ((BASE 10.) (N 0)) + (MTELL-OPEN "~%~A msec." (COMPUTIME (RUNTIME) THISTIME)) + (IF (AND (EQ $SHOWTIME '$ALL) + (NOT (ZEROP GCT)) + (NOT (ZEROP (SETQ N (COMPUTIME (SYS-GCTIME) GCT))))) + (MTELL-OPEN " (~A msec.)" N)) + (IF USER-TIMESOFAR (MAPC #'FUNCALL (REVERSE USER-TIMESOFAR)))))) + (IF (NULL X) (MTERPRI)))) + +#+MACLISP +(DEFUN MQUIT (X) ; The ^G interrupt function + (IF (NULL X) (BUFFCLEAR T)) + (ERRLFUN 'MQUIT) (SETQ ERRLIST '((SUPUNBIND) (CONTINUE))) (^G)) + +#+PDP10 +;; The ^S interrupt function +(DEFUN MQUIET (X Y) + X Y ;Ignored. + (CLEAR-OUTPUT T) (SETQ #.TTYOFF T ^S T)) + +(DEFMSPEC $TOBREAK (X) + (IF MBREAK (*THROW 'MBREAK (CDR X)) + (MERROR "TOBREAK may be used only within a MACSYMA break."))) + +(DEFUN ERRLFUN (X) + (WHEN (NULL + (ERRSET + (PROGN #-LISPM (SETQ ^S NIL) + #+PDP10 (CLOSE SAVEFILE) + #-LISPM (IF LOADF (SETQ DEFAULTF LOADF LOADF NIL)) + #+PDP10 (ENDPAGEFN T 'MORE-FUN)))) + #-LISPM (SETQ ^Q NIL) (MTELL-OPEN "~%ERRLFUN has been clobbered.")) + (IF $ERRORFUN (IF (NULL (ERRSET (MAPPLY $ERRORFUN NIL $ERRORFUN))) + (MTELL "~%Incorrect ERRORFUN"))) + (WHEN (NULL + (ERRSET + (PROGN (IF (NOT (EQ X 'MQUIT)) (SUPUNBIND)) (CLEARSIGN)))) + #-LISPM (SETQ ^Q NIL) (MTELL-OPEN "~%ERRLFUN has been clobbered.")) + (WHEN (NULL X) (PRINC QUITMSG) (SETQ QUITMSG " "))) + +(DEFUN SUPUNBIND NIL + (MUNBIND (REVERSE BINDLIST)) (DO NIL ((NULL LOCLIST)) (MUNLOCAL))) + +(DEFUN ERRLFUN1 (MPDLS) + (DO ((L BINDLIST (CDR L)) (L1)) ((EQ L (CAR MPDLS)) (MUNBIND L1)) + (SETQ L1 (CONS (CAR L) L1))) + (DO NIL ((EQ LOCLIST (CDR MPDLS))) (MUNLOCAL))) + +(DEFUN GETALIAS (X) (COND ((GET X 'ALIAS)) ((EQ X '$FALSE) NIL) (T X))) + +(DEFUN MAKEALIAS (X) (IMPLODE (CONS #/$ (EXPLODEN X)))) + +#-MAXII +(PROGN 'COMPILE + +(DEFUN PARSE1 NIL + (LET (RET (TIM 0)) + #+GC (IF (EQ GCFLAG '$ALL) (LET (^D) (GC))) + (SETQ TIM (RUNTIME) RET (PARSE2)) + (IF $PARSETIME (MTELL-OPEN "~%Parsetime= ~A msec." (COMPUTIME (RUNTIME) TIM))) + RET)) + +(DEFUN PARSE2 NIL + (LET ((ERRSET #+(OR Franz MACLISP) 'ERRBREAK2 #+LISPM NIL)) + (ERRSET (PARSE3 (SCAN (REVERSE (CONS #/; ST)))) #+LISPM NIL))) + +(DEFUN PARSE3 (STRING) + (LET ((LINELABLE LINELABLE) (ST1 STRING)) (PARSE '$ANY 0))) + +(DEFUN SCAN (INPUT) + (PROG (ANS TOKEN CHAR X DOTP FLAG) + B (COND ((NULL INPUT) (COND ((NOT (EQ (CAR ANS) '$/;)) + (MERROR "~%Dangling /\"))) + (RETURN (NREVERSE ANS))) + ((ASCII-NUMBERP (CAR INPUT)) (SETQ DOTP NIL) (GO NLOOP)) + ((AND (= (CAR INPUT) #/.) (ASCII-NUMBERP (CADR INPUT))) + (SETQ DOTP T) (GO NLOOP)) + ((= (CAR INPUT) #/") (GO DQUOT)) + ((MEMBER (CAR INPUT) '(#\SP #\CR #\newline #\TAB)) (GO C)) + ((ALPHABETP (CAR INPUT)) (GO VLOOP)) + ((= (CAR INPUT) #/\) + (COND ((NOT (ALPHABETP (CADR INPUT))) (SETQ FLAG '/\))) (GO V\)) + ((= (CAR INPUT) #/?) + (SETQ FLAG '?) + (COND ((= (CADR INPUT) #/") (SETQ INPUT (CDR INPUT)) (GO DQUOT)) + ((= (CADR INPUT) #/\) + (SETQ TOKEN (CONS '// TOKEN)) (SETQ INPUT (CDR INPUT)))) + (COND ((NULL (CDDR INPUT)) (MERROR "~%Misuse of ?"))) + (GO V\))) + (SETQ CHAR (ASCII (CAR INPUT))) + (COND ((AND (SETQ X (GET CHAR 'OP3C)) + (SETQ X (ASSOC (LIST (CADR INPUT) (CADDR INPUT)) X))) + (SETQ ANS (CONS (CDR X) ANS) INPUT (CDDDR INPUT)) (GO B)) + ((AND (SETQ X (GET CHAR 'OP2C)) (SETQ X (ASSQ (CADR INPUT) X))) + (SETQ ANS (CONS (CDR X) ANS) INPUT (CDDR INPUT)) (GO B))) + (SETQ ANS (CONS (OR (GET CHAR 'OPALIAS) + (IMPLODE (LIST '$ (CAR INPUT)))) + ANS)) + C (SETQ INPUT (CDR INPUT)) + (GO B) + V\ (SETQ INPUT (CDR INPUT)) + (SETQ TOKEN (CONS (CAR INPUT) TOKEN) INPUT (CDR INPUT)) + (GO VL1) + VLOOP(SETQ TOKEN (CONS (CASIFY (CAR INPUT)) TOKEN) INPUT (CDR INPUT)) + VL1 (COND ((NULL INPUT) (MERROR "~%Dangling /\")) + ((OR (ASCII-NUMBERP (CAR INPUT)) (ALPHABETP (CAR INPUT))) + (GO VLOOP)) + ((= (CAR INPUT) #/\) + (COND ((EQ FLAG '?) (SETQ TOKEN (CONS '// TOKEN)))) (GO V\))) + (SETQ ANS (CONS (COND (FLAG (PROG2 NIL + (COND ((EQ FLAG '/\) + (IMPLODE (CONS '& (NREVERSE TOKEN)))) + ((NULL (SETQ TOKEN (ERRSET + (READLIST + (NREVERSE TOKEN)) + NIL))) + (MERROR "~%Misuse of ?")) + (T (CAR TOKEN))) + (SETQ FLAG NIL))) + (T (GETALIAS (IMPLODE (CONS '$ (NREVERSE TOKEN)))))) + ; note that only $-ed tokens are GETALIASed. + ANS) + TOKEN NIL) + (GO B) + NLOOP(SETQ TOKEN (CONS (CASIFY (CAR INPUT)) TOKEN) INPUT (CDR INPUT)) + (COND ((OR (ASCII-NUMBERP (CAR INPUT)) + (AND (= (CAR INPUT) #/.) (NOT DOTP) (SETQ DOTP T))) + (GO NLOOP)) + ((AND (= (CAR TOKEN) #/.) (SETQ TOKEN (CONS '/0 TOKEN)) NIL)) + ((AND (MEMBER (CAR INPUT) '(#/E #/B #/e #/b)) DOTP (NULL FLAG) + (OR (AND (OR (= (CADR INPUT) #/+) (= (CADR INPUT) #/-)) + (ASCII-NUMBERP (CADDR INPUT))) + (ASCII-NUMBERP (CADR INPUT)))) + (SETQ TOKEN (CONS (CASIFY (CAR INPUT)) TOKEN) + FLAG (CASIFY (CAR INPUT)) + INPUT (CDR INPUT)) + (GO NLOOP))) + (SETQ ANS (CONS (COND ((MEMBER FLAG '(#/B #/b)) (SCANBF TOKEN)) + (T (READLIST (NREVERSE TOKEN)))) + ANS) + TOKEN NIL FLAG NIL) + (GO B) + DQUOT(SETQ INPUT (CDR INPUT)) + (COND ((NULL INPUT) (MERROR "~%/" must occur in pairs.")) + ((= (CAR INPUT) #/\) (SETQ INPUT (CDR INPUT))) + ((= (CAR INPUT) #/") + (SETQ INPUT (CDR INPUT) + ANS (CONS (IMPLODE + (COND (FLAG (SETQ FLAG NIL) (NREVERSE TOKEN)) + (T (CONS '& (NREVERSE TOKEN))))) + ANS) + TOKEN NIL) + (GO B))) + (SETQ TOKEN (CONS (CAR INPUT) TOKEN)) + (GO DQUOT))) + +#+PDP10 +(DEFUN CASIFY (N) ; lower case to upper case + (IF (AND (>= N #/a) (<= N #/z) CASEP) (- N #.(- #/a #/A)) N)) + +#+(or Franz Multics) +(DEFUN CASIFY (N) ; upper case to lower case + (IF (AND (>= N #/A) (<= N #/Z) CASEP) (+ N #.(- #/a #/A)) N)) + +#+LISPM +(DEFUN CASIFY (N) + (IF (OR CASEP (NOT (ZEROP (LDB %%KBD-CONTROL-META N)))) (CHAR-UPCASE N) N)) + +(DEFUN SCANBF (TOKEN) + (PROG (FRAC XPT) + (IF (MEMBER (CAR TOKEN) '(#/+ #/-)) (SETQ TOKEN (CONS #/0 TOKEN))) + XPT (SETQ XPT (CONS (CAR TOKEN) XPT) TOKEN (CDR TOKEN)) + (IF (NOT (MEMBER (CAR TOKEN) '(#/B #/b))) (GO XPT)) + (SETQ TOKEN (CDR TOKEN)) + FRAC (SETQ FRAC (CONS (CAR TOKEN) FRAC) TOKEN (CDR TOKEN)) + (IF (NOT (= (CAR TOKEN) #/.)) (GO FRAC)) + (SETQ TOKEN (CDR TOKEN)) + (RETURN (FPSCAN (CONS #/0 (NREVERSE TOKEN)) FRAC XPT)))) + +(DEFUN ASCII-CHK (X) (IF (NUMBERP X) X (GETCHARN X 1))) + +;; END of MOBY #-MAXII PROGN 'COMPILE +) + +;; (DEFMSPEC $F (FORM) (SETQ FORM (FEXPRCHECK FORM)) ...) +;; makes sure that F was called with exactly one argument and +;; returns that argument. + +(DEFMFUN FEXPRCHECK (FORM) + (IF (OR (NULL (CDR FORM)) (CDDR FORM)) + (MERROR "~:M takes just one argument." (CAAR FORM)) + (CADR FORM))) + +(DEFMFUN NONSYMCHK (X FN) + (UNLESS (SYMBOLP X) + (MERROR "The argument to ~:M must be a symbolic name. ~M" FN X))) + +(DEFMFUN NONVARCHK (X FN FLAG 2NDP) + (WHEN (OR (MNUMP X) (INTEGERP X) (AND FLAG (ATOM X) (CONSTANT X)) + (AND (NOT (ATOM X)) (NOT (EQ (CAAR X) 'MQAPPLY)) (MOPP1 (CAAR X)))) + (MERROR "Non-variable~Margument to ~:M: ~M" + (IF 2NDP '|& 2nd | '|& |) FN X))) + +(DEFMFUN PRINL (L) (DOLIST (X L) (PRINC X) (TYO #\SP))) + +(DEFMFUN $PRINT N + (IF (= N 0) + '((MLIST SIMP)) + (LET ((L (LISTIFY N))) + (DO L L (CDDR L) (NULL L) (RPLACD L (CONS '| | (CDR L)))) + (DISPLA (SETQ PRINTMSG (CONS '(MTEXT) L))) + (CADR (REVERSE L))))) + +#-MAXII +(DEFMFUN $READ N + (LET (PRINTMSG) + (IF (> N 0) (APPLY #'$PRINT (LISTIFY N))) + (MEVAL (RETRIEVE PRINTMSG 'NOPRINT)))) + +#-MAXII +(DEFMFUN $READONLY N + (LET (PRINTMSG) + (IF (> N 0) (APPLY #'$PRINT (LISTIFY N))) (RETRIEVE PRINTMSG 'NOPRINT))) + +#-MAXII +(DEFUN RETR-PRINT (MSG FLAG) + (COND ((NULL MSG)) + ((ATOM MSG) (PRINC MSG) (MTERPRI)) + (FLAG (MAPC #'PRINC (CDR MSG)) (MTERPRI)) + (T (DISPLA MSG) (MTERPRI)))) + +#-MAXII +(DEFMFUN RETRIEVE (MSG FLAG) (LET (OLDST) (RETRIEVE1 MSG FLAG))) + +; RETRIEVE1 is also called by ERRBREAK. +; If MRG-PUNT is T, a (MAPC 'PRINC (CDR PROMPTMSG)) is done. +; This is to get around DISPLA bugs re terpri's in atoms +#-MAXII +(DEFUN RETRIEVE1 (MSG MRG-PUNT) + (COND ((NOT (EQ MRG-PUNT 'NOPRINT)) (RETR-PRINT MSG MRG-PUNT))) + (LET ((PROMPTMSG MSG) (STATE-PDL (CONS 'RETRIEVE STATE-PDL))) + (PROG (TEST N ST REPRINT POS #.TTYOFF) + A (IF (EQ MRG-PUNT 'BREAK) (PRINC (STRIPDOLLAR $PROMPT))) + #-Franz (SETQ POS (CURSORPOS)) + #-Franz (IF (NOT (ZEROP (LISTEN))) (SETQ REPRINT T)) + B (SETQ N (LET ((READING T)) (TYI))) + C (COND ((= N #.NALT) + (WHEN (EDIT* (REVERSE ST)) (SETQ REPRINT T) (MTERPRI) (GO A)) + (GO VT)) + ((= N #/?) + (WHEN (AND ST (= (CAR ST) #/?) + (NOT (AND (CDR ST) (= (CADR ST) #/\)))) + (SETQ ST NIL) (MTERPRI) (GO A))) + ((= N #\VT) (GO VT)) + ((= N #\BS) (COND (BACKRUB (IF ST (POP ST)) (GO B)) + (T (LET (#.WRITEFILEP) (PRINC ^HMSG)) (GO VT)))) + ((= N #\FF) (FORMFEED) (GO FF)) + (#+(or Franz MACLISP) (= N #^Y) + #+LISPM (AND (NOT (ZEROP (LDB %%KBD-CONTROL N))) (= N #^Y)) + (SETQ ST (APPEND OLDST ST)) (GO VT)) + ((OR (= N #\SP) (= N #\CR) (= N #\TAB)) + (WHEN (NULL ST) (IF (= N #\CR) (SETQ POS (CURSORPOS))) (GO B))) + ((< N 32.) (SETQ REPRINT T) (GO B)) ; Test for control characters + ((OR (= N #/;) (= N #/$)) + (IF (EQ MRG-PUNT 'BREAK) (SETQ DISPFLAG (= N #/;))) (GO D)) + ((AND (= N #/\) (PROG2 (SETQ ST (CONS N ST) N (TYI)) NIL))) + ((= N #\RUBOUT) (RUBOUT* ST) (IF ST (POP ST)) (GO B))) + (PUSH N ST) + (GO B) + FF (LET (#.TTYOFF #.WRITEFILEP) (RETR-PRINT MSG (EQ MRG-PUNT T))) + VT (REPRINT ST (= N #\FF)) + (GO B) + D (SETQ REPRINT NIL) + (COND ((NULL ST) (MTERPRI) (GO A)) + (#.WRITEFILEP + (LET ((#.TTYOFF T)) + (PRINC (MAKNAM (REVERSE (CONS N ST)))) + #+Franz (terpr)))) + (SETQ OLDST ST) + (WHEN (SETQ TEST (PARSE2)) + (IF (NULL ^Q) (MTERPRI)) (RETURN (CAR TEST))) + (MTERPRI) + (IF (EQ MRG-PUNT 'BREAK) (PRINC (STRIPDOLLAR $PROMPT))) + #-Franz (SETQ POS (CURSORPOS)) + #-Franz (IF (NOT (ZEROP (LISTEN))) (SETQ REPRINT T)) + (SETQ N (LET ((READING T)) (TYI))) + (COND (#+(or Franz MACLISP) (= N #^Y) + #+LISPM (AND (NOT (ZEROP (LDB %%KBD-CONTROL N))) (= N #^Y)) + (GO VT)) + ((NOT (= N #.NALT)) (SETQ ST NIL))) + (GO C)))) + +(DEFMSPEC $PLAYBACK (X) (SETQ X (CDR X)) + (LET ((STATE-PDL (CONS 'PLAYBACK STATE-PDL))) + (PROG (L L1 L2 NUMBP SLOWP NOSTRINGP INPUTP TIMEP GRINDP INCHAR LARGP) + (SETQ INCHAR (GETLABCHARN $INCHAR)) + ; Only the 1st alphabetic char. of $INCHAR is tested + (SETQ TIMEP $SHOWTIME GRINDP $GRIND) + (DO X X (CDR X) (NULL X) + (COND ((EQ (TYPEP (CAR X)) 'FIXNUM) (SETQ NUMBP (CAR X))) + ((EQ (CAR X) '$ALL)) + ((EQ (CAR X) '$SLOW) (SETQ SLOWP T)) + ((EQ (CAR X) '$NOSTRING) (SETQ NOSTRINGP T)) + ((EQ (CAR X) '$GRIND) (SETQ GRINDP T)) + ((EQ (CAR X) '$INPUT) (SETQ INPUTP T)) + ((MEMQ (CAR X) '($SHOWTIME $TIME)) (SETQ TIMEP (OR TIMEP T))) + ((MEMQ (CAR X) '($GCTIME $TOTALTIME)) (SETQ TIMEP '$ALL)) + ((SETQ L2 (LISTARGP (CAR X))) + (SETQ L1 (NCONC L1 (GETLABELS (CAR L2) (CDR L2) NIL)) LARGP T)) + (T (IMPROPER-ARG-ERR (CAR X) '$PLAYBACK)))) + (COND ((AND LARGP (NULL NUMBP)) (GO LOOP)) + ((AND (SETQ L (CDR $LABELS)) (NOT $NOLABELS)) (SETQ L (CDR L)))) + (WHEN (OR (NULL NUMBP) (< (LENGTH L) NUMBP)) + (SETQ L1 (REVERSE L)) (GO LOOP)) + (DO ((I NUMBP (1- I)) (L2)) ((ZEROP I) (SETQ L1 (NCONC L1 L2))) + (SETQ L2 (CONS (CAR L) L2) L (CDR L))) + LOOP (IF (NULL L1) (RETURN '$DONE)) + ((LAMBDA (ERRSET INCHARP) + (ERRSET + (COND ((AND (NOT NOSTRINGP) INCHARP) + (LET ((LINELABLE (CAR L1))) (MTERPRI) (PRINTLABEL)) + (IF GRINDP (MGRIND (MEVAL1 (CAR L1)) NIL) + (MAPC #'TYO (MSTRING (MEVAL1 (CAR L1))))) + (IF (GET (CAR L1) 'NODISP) (PRINC '$) (PRINC '/;)) + (MTERPRI)) + ((OR INCHARP + (PROG2 (WHEN (AND TIMEP (SETQ L (GET (CAR L1) 'TIME))) + (SETQ X (GCTIMEP TIMEP (CDR L))) + (MTELL-OPEN "~A msec." (CAR L)) + #+GC (IF X (MTELL-OPEN " GCtime= ~A msec." (CDR L))) + (MTERPRI)) + (NOT (OR INPUTP (GET (CAR L1) 'NODISP))))) + (MTERPRI) (DISPLA (LIST '(MLABLE) (CAR L1) (MEVAL1 (CAR L1))))) + (T (GO A))))) + 'ERRBREAK2 (= (GETLABCHARN (CAR L1)) INCHAR)) + (IF (AND SLOWP (CDR L1) (NOT (CONTINUEP))) (RETURN '$TERMINATED)) + A (SETQ L1 (CDR L1)) + (GO LOOP)))) + +(DEFUN LISTARGP (X) + (LET (HIGH) + (IF (AND ($LISTP X) (EQ (TYPEP (CADR X)) 'FIXNUM) + (OR (AND (NULL (CDDR X)) (SETQ HIGH (CADR X))) + (AND (EQ (TYPEP (SETQ HIGH (CADDR X))) 'FIXNUM) + (NOT (> (CADR X) HIGH))))) + (CONS (CADR X) HIGH)))) + +;(DEFUN C18BATCHER NIL +; ((LAMBDA (L USER) +; (GCTWA) +; (SETQ ALARMCLOCK '(LAMBDA (X) (*THROW 'TIMECHECK 'TOOMUCHTIME))) +; (ALARMCLOCK 'RUNTIME $C18MAXTIME) +; (COND ((NULL (ERRSET (UREAD BATIN /< DSK C18) NIL)) ($QUIT))) +; (TERPRI) +; (PRINL (APPEND (STATUS UREAD) '(BEGUN))) +; (TERPRI) +; (UWRITE DSK C18) +; (SETQ #.WRITEFILEP T #.TTYOFF T) +; (ERRSET (COND ((EQ (*CATCH 'TIMECHECK ($BATCH BATIN /< DSK C18)) 'TOOMUCHTIME) +; (PRINC '|/ +;you've taken more than the allotted time!|)) +; (T (SETQ $% '$BATCH/ DONE) (MAKELABEL $OUTCHAR) (DISPLAY*)))) +; (APPLY #'UFILE (LIST 'BATOUT (MAKNAM (COND ($FILEID (SETQ L (STRING* $FILEID))) +; (T (NREVERSE (MEXPLODEN (RUNTIME)))))))) +; (UKILL BATIN /< DSK C18) +; (COND ((AND $FILEID (> (LENGTH L) 3)) +; (SETQ USER (LIST (CAR L) (CADR L) (CADDR L))) +; (VALRET (MAKNAM (APPEND (EXPLODEN '/:SEND/ ) USER (EXPLODEN '/ BATOUT/ ) +; L (EXPLODEN '/ IS/ NOW/ AVAILABLE/./ +;// P)))))) +; (COND ((NULL (ERRSET (UREAD BATIN /< DSK C18) NIL)) ($QUIT)) +; (T (VALRET '/:MACSYMA/ +;)))) +; NIL NIL)) + +(DEFMSPEC $ALIAS (FORM) + (IF (ODDP (LENGTH (SETQ FORM (CDR FORM)))) + (MERROR "ALIAS takes an even number of arguments.")) + (DO ((L NIL (CONS (ALIAS (POP FORM) (POP FORM)) + L))) + ((NULL FORM) + `((MLIST SIMP),@(NREVERSE L))))) + +(DEFMFUN ALIAS (X Y) + (COND ((NONSYMCHK X '$ALIAS)) + ((NONSYMCHK Y '$ALIAS)) + ((NOT (EQ (GETCHAR X 1) '$)) + (MERROR "/"-ed symbols may not be aliased. ~M" X)) + ((GET X 'REVERSEALIAS) + (IF (NOT (EQ X Y)) + (MERROR "~M already is aliased." X))) + (T (PUTPROP X Y'ALIAS) + (PUTPROP Y (STRIPDOLLAR X) 'REVERSEALIAS) + (ADD2LNC Y $ALIASES) + Y))) + +(DEFMFUN REMALIAS (X REMP) + (LET ((Y (AND (OR REMP (MEMQ X (CDR $ALIASES))) (GET X 'REVERSEALIAS)))) + (COND ((AND Y (EQ X '%DERIVATIVE)) + (REMPROP X 'REVERSEALIAS) (DELQ X $ALIASES 1) + (REMPROP '$DIFF 'ALIAS) '$DIFF) + (Y (REMPROP X 'REVERSEALIAS) (REMPROP X 'NOUN) (DELQ X $ALIASES 1) + (REMPROP (SETQ X (MAKEALIAS Y)) 'ALIAS) (REMPROP X 'VERB) X)))) + +(DEFMFUN STRIPDOLLAR (X) + (COND ((NOT (ATOM X)) + (COND ((AND (EQ (CAAR X) 'BIGFLOAT) (NOT (MINUSP (CADR X)))) (IMPLODE (FPFORMAT X))) + (T (MERROR "Atomic arg required:~%~M" X)))) + ((NUMBERP X) X) + ((NULL X) 'FALSE) + ((EQ X T) 'TRUE) + ((MEMQ (GETCHAR X 1) '($ % &)) #-Franz (IMPLODE (CDR (EXPLODEN X))) + #+Franz (concat (substring x 2))) + (T X))) + +(DEFMFUN FULLSTRIP (X) (MAPCAR #'FULLSTRIP1 X)) + +(DEFMFUN FULLSTRIP1 (X) + (OR (AND (NUMBERP X) X) + (GET X 'REVERSEALIAS) + (LET ((U (ASSQR X ALIASLIST))) (IF U (IMPLODE (STRING*1 (CAR U))))) + (STRIPDOLLAR X))) + +(DEFUN STRING* (X) + (OR (AND (NUMBERP X) (EXPLODEN X)) + (LET ((U (ASSQR X ALIASLIST))) (IF U (STRING*1 (CAR U)))) + (STRING*1 X))) + +(DEFUN STRING*1 (X) (LET (STRINGDISP $LISPDISP) (MAKESTRING X))) + +(DEFUN MAKSTRING* (X) + (SETQ X (STRING* X)) + (DO L X (CDR L) (NULL L) (RPLACA L (ASCII (CAR L)))) + X) + +(DEFMFUN $NOUNIFY (X) + (LET (Y U) + (NONSYMCHK X '$NOUNIFY) + (SETQ X (AMPERCHK X)) + (COND ((GET X 'VERB)) + ((GET X 'NOUN) X) + ((OR (SETQ U (MEMQ (CAR (SETQ Y (EXPLODEC X))) '($ M))) + (NOT (EQ (CAR Y) '%))) + (SETQ Y (IMPLODE (CONS '% (IF U (CDR Y) Y)))) + (PUTPROP Y X 'NOUN) (PUTPROP X Y 'VERB)) + (T X)))) + +(DEFMFUN $VERBIFY (X) + (NONSYMCHK X '$VERBIFY) + (SETQ X (AMPERCHK X)) + (COND ((GET X 'NOUN)) + ((AND (= (GETCHARN X 1) #/%) + (PROG2 ($NOUNIFY (IMPLODE (CONS #/$ (CDR (EXPLODEN X))))) (GET X 'NOUN)))) + (T X))) + +(DEFMFUN AMPERCHK (NAME) + (IF (= (GETCHARN NAME 1) #/&) + (OR (GET NAME 'OPR) (IMPLODE (CONS #/$ (CASIFY-EXPLODEN NAME)))) + NAME)) + +(DEFMFUN DOLLARIFY-NAME (NAME) + (LET ((N (GETCHARN NAME 1))) + (COND ((= N #/&) + (OR (GET NAME 'OPR) + (LET ((NAMEL (CASIFY-EXPLODEN NAME)) AMPNAME DOLNAME) + (COND ((GET (SETQ AMPNAME (IMPLODE (CONS #/& NAMEL))) 'OPR)) + (T (SETQ DOLNAME (IMPLODE (CONS #/$ NAMEL))) + (PUTPROP DOLNAME AMPNAME 'OP) + (PUTPROP AMPNAME DOLNAME 'OPR) + (ADD2LNC AMPNAME $PROPS) + DOLNAME))))) + ((= N #/%) ($VERBIFY NAME)) + (T NAME)))) + +(DEFMFUN $RANDOM N (APPLY #'RANDOM (LISTIFY N))) + +(DEFMSPEC $STRING (FORM) + (SETQ FORM (STRMEVAL (FEXPRCHECK FORM))) + (SETQ FORM (IF $GRIND (STRGRIND FORM) (MSTRING FORM))) + (SETQ ST (REVERSE FORM) REPHRASE T) + (IMPLODE (CONS #/& FORM))) + +(DEFMFUN MAKSTRING (X) + (SETQ X (MSTRING X)) (DO L X (CDR L) (NULL L) (RPLACA L (ASCII (CAR L)))) X) + +(DEFMFUN STRMEVAL (X) + (COND ((ATOM X) (MEVAL1 X)) + ((MEMQ (CAAR X) '(MSETQ MDEFINE MDEFMACRO)) X) + (T (MEVAL X)))) + +(PROG1 '(ALIAS properties) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ALIAS) + (PUTPROP (CADR X) (CADDR X) 'REVERSEALIAS)) + '(($BLOCK MPROG BLOCK) ($LAMBDA LAMBDA LAMBDA) + ($ABS MABS ABS) ($SUBST $SUBSTITUTE SUBST) + ($GO MGO GO) ($SIGNUM %SIGNUM SIGNUM) + ($RETURN MRETURN RETURN) ($FACTORIAL MFACTORIAL FACTORIAL) + ($NOUUO NOUUO NOUUO) ($RSET *RSET RSET) + ($IBASE IBASE IBASE) ($OBASE BASE OBASE) ($NOPOINT *NOPOINT NOPOINT) + ($MODULUS MODULUS MODULUS) ($ZUNDERFLOW ZUNDERFLOW ZUNDERFLOW) + ($TTYOFF #.TTYOFF TTYOFF) ($WRITEFILE_ON #.WRITEFILEP WRITEFILE_ON) + ($MODE_DECLARE $MODEDECLARE MODE_DECLARE))) + (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ALIAS)) + '(($RATCOEFF $RATCOEF) ($RATNUM $RATNUMER) ($TRUE T) + ($BINOM %BINOMIAL) ($DERIVATIVE $DIFF) ($PROD $PRODUCT) + ($BOTHCOEFF $BOTHCOEF)))) + +(DEFMFUN CASIFY-EXPLODEN (X) + (SETQ X (EXPLODEN X)) + (IF (= (CAR X) #/&) (MAPCAR #'CASIFY (CDR X)) (CDR X))) + +(DEFMSPEC $STRINGOUT (X) (SETQ X (CDR X)) + ((LAMBDA (FILE ERROR L1) + (SETQ FILE #-Franz (IF ($LISTP (CAR X)) + (PROG1 #+MACLISP (FILESTRIP (CDAR X)) + #+LISPM (FULLSTRIP (CDAR X)) + (SETQ X (CDR X))) + (MFILE)) + #+Franz (prog1 (filestrip x) (setq x (cdr x)))) +#+MACLISP + (OPEN (CNAMEF SAVEFILE (CONS (CARFILE (CDDR FILE)) '(|!STRG!| OUTPUT))) '(OUT ASCII)) +#+LISPM + (SETQ SAVEFILE (OPEN (FILESTRIP (APPEND '(|!STRG!| OUTPUT) (CDDR FILE))) '(OUT ASCII))) +#+Franz + (setq savefile (outfile file)) + (COND ((NULL + (ERRSET + (DO L X (CDR L) (NULL L) + (COND ((MEMQ (CAR L) '($ALL $INPUT)) + (SETQ L (NCONC (GETLABELS* $INCHAR T) (CDR L)))) + ((EQ (CAR L) '$VALUES) + (SETQ L (NCONC (MAPCAN + #'(LAMBDA (X) + (IF (BOUNDP X) + (NCONS (LIST '(MSETQ) X (SYMEVAL X))))) + (CDR $VALUES)) + (CDR L)))) + ((EQ (CAR L) '$FUNCTIONS) + (SETQ L (NCONC (MAPCAR + #'(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL)) + (CDR $FUNCTIONS)) + (MAPCAN + #'(LAMBDA (X) + (IF (MGET X 'AEXPR) + (NCONS (CONSFUNDEF X T NIL)))) + (CDR $ARRAYS)) + (MAPCAR + #'(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL)) + (CDR $MACROS)) + (CDR L)))) + ((SETQ L1 (LISTARGP (CAR L))) + (SETQ L (NCONC (GETLABELS (CAR L1) (CDR L1) T) (CDR L))))) + (IF (NULL L) (RETURN NIL)) + (TERPRI SAVEFILE) + (IF $GRIND (MGRIND (STRMEVAL (CAR L)) SAVEFILE) + #-Franz (PRINC (MAKNAM (MSTRING (STRMEVAL (CAR L)))) + SAVEFILE) + #+Franz (mapc #'(lambda (ch) (tyo ch savefile)) + (mstring (strmeval (car l))))) + (IF (OR (AND (ATOM (CAR L)) (GET (CAR L) 'NODISP)) (NOT $STRDISP)) + (TYO #/$ SAVEFILE) + (TYO #/; SAVEFILE))))) + (SETQ ERROR T))) + (TERPRI SAVEFILE) + #-Franz (RENAMEF SAVEFILE FILE) + #+(OR LISPM Franz) (CLOSE SAVEFILE) + #+MacLisp (SYS-DEFAULTF FILE) + (IF ERROR (LET ((ERRSET 'ERRBREAK1)) (MERROR "Error in STRINGOUT attempt"))) + #+MACLISP (MTRUENAME SAVEFILE) + #+(or Franz LISPM) (MFILE-OUT FILE)) + NIL NIL NIL)) + + +;; Obsolete. FPPREC:10 is the replacement. + +#+PDP10 (PROGN 'COMPILE + (DEFMFUN $FPPREC (X) (FPPREC1 NIL X)) + (DEFMFUN $POISLIM (X) (POISLIM1 NIL X))) + +(DEFMSPEC $LABELS (CHAR) + (SETQ CHAR (FEXPRCHECK CHAR)) + (NONSYMCHK CHAR '$LABELS) + (CONS '(MLIST SIMP) (NREVERSE (GETLABELS* CHAR NIL)))) + +(DEFMFUN $%TH (X) + (PROG (L OUTCHAR) + (IF (OR (NOT (EQ (TYPEP X) 'FIXNUM)) (= X 0)) + (IMPROPER-ARG-ERR X '$%TH)) + (IF (> X 0) (SETQ X (- X))) + (IF (CDR $LABELS) + (SETQ L (CDDR $LABELS) OUTCHAR (GETLABCHARN $OUTCHAR))) + LOOP (IF (NULL L) (MERROR "Improper call to %TH")) + (IF (AND (= (GETLABCHARN (CAR L)) OUTCHAR) (= (SETQ X (1+ X)) 0)) + ; Only the 1st alphabetic character of $OUTCHAR is tested. + (RETURN (MEVAL (CAR L)))) + (SETQ L (CDR L)) + (GO LOOP))) + +(DEFMFUN GETLABELS (N1 N2 FLAG) ; FLAG = T for STRINGOUT, = NIL for PLAYBACK and SAVE. + (DO ((I N1 (1+ I)) (L1) + (L (IF FLAG (LIST (EXPLODEN $INCHAR)) + (LIST (EXPLODEN $INCHAR) (EXPLODEN $LINECHAR) + (EXPLODEN $OUTCHAR))))) + ((> I N2) (NREVERSE L1)) + (DO ((L L (CDR L)) (X (MEXPLODEN I)) (Z)) ((NULL L)) + (IF (BOUNDP (SETQ Z (IMPLODE (APPEND (CAR L) X)))) + (SETQ L1 (CONS Z L1)))))) + +(DEFMFUN GETLABELS* (CHAR FLAG) ; FLAG = T only for STRINGOUT + (DO ((L (IF FLAG (CDDR $LABELS) (CDR $LABELS)) (CDR L)) + (CHAR (GETLABCHARN CHAR)) (L1)) + ((NULL L) L1) + (IF (= (GETLABCHARN (CAR L)) CHAR) + ; Only the 1st alphabetic character is tested. + (SETQ L1 (CONS (CAR L) L1))))) + +(DEFMFUN GETLABCHARN (LABEL) + (LET ((CHAR (GETCHARN LABEL 2))) (IF (= CHAR #/%) (GETCHARN LABEL 3) CHAR))) + +#+MACLISP +(DEFMFUN $UUO NIL (SSTATUS UUOLINKS)) + +#+MULTICS +(DEFMFUN $CLINE (X) (CLINE (GET_PNAME (STRIPDOLLAR X))) '$DONE) + +; Error-handling stuff, not converted for lisp-machine yet. + +(DEFMSPEC $ERRCATCH (FORM) + (LET ((ERRCATCH (CONS BINDLIST LOCLIST)) RET) + (IF (NULL (SETQ RET (LET (DEBUG) + (ERRSET (MEVALN (CDR FORM)) LISPERRPRINT)))) + (ERRLFUN1 ERRCATCH)) + (CONS '(MLIST) RET))) + +;(DEFMFUN $ERROR N ; Moved to MAXSRC;MERROR +; (LET ((MSG (LISTIFY N))) +; (IF (> N 0) (APPLY #'$PRINT MSG)) +; (IF ERRCATCH (ERROR)) +; (IF DEBUG (LET (($ERROR (CONS '(MLIST SIMP) (FSTRINGC MSG)))) +; (ERRBREAK NIL))) +; (MQUIT T))) + +#-MAXII +(DEFMFUN $BREAK N (PROG1 (APPLY #'$PRINT (LISTIFY N)) (MERRBREAK T))) + +(DEFMSPEC $CATCH (FORM) + (LET ((MCATCH (CONS BINDLIST LOCLIST))) + (PROG1 (*CATCH 'MCATCH (MEVALN (CDR FORM))) (ERRLFUN1 MCATCH)))) + +(DEFMFUN $THROW (EXP) + (IF (NULL MCATCH) (MERROR "THROW not within CATCH:~%~M" EXP)) + (*THROW 'MCATCH EXP)) + +(DEFMSPEC $TIME (L) (SETQ L (CDR L)) + (MTELL-OPEN "TIME or [TOTALTIME, GCTIME] in msecs.:~%") + (CONS '(MLIST SIMP) + (MAPCAR + #'(LAMBDA (X) + (OR (AND (SETQ X (OR (GET X 'TIME) + (AND (EQ X '$%) (CONS (CADR $LASTTIME) + (CADDR $LASTTIME))))) + (IF (= (CDR X) 0) + (CAR X) + (LIST '(MLIST SIMP) (CAR X) (CDR X)))) + '$UNKNOWN)) + L))) + +(DEFMFUN TIMEORG (TIM) + (IF (> THISTIME 0) (SETQ THISTIME (+ THISTIME (- (RUNTIME) TIM))))) + +; Take difference of two times, return result in milliseconds. +#+LISPM (DEFMFUN COMPUTIME (N1 N2) (// (* 50. (TIME-DIFFERENCE N1 N2)) 3.)) + +#+MACLISP +(DEFMFUN COMPUTIME (N1 N2) (// (- (+ N1 500.) N2) 1000.)) + +#+Franz (progn 'compile + +;--- computime (n1,n2) :: compute time difference in milliseconds +; n1,n2 : times in jiffies (1/60 ths of a second) +; return: length of time from n2 to n1 in milliseconds +(defmfun computime (n1 n2) (// (* (- n1 n2) 1000.) 60.)) + +;--- runtime :: return total runtime for this process (in jiffies) +(defun runtime nil (car (ptime))) + +) + +#+PDP10 (PROGN 'COMPILE + +(DEFMFUN $TO_LISP NIL (^G)) + +(DEFMFUN $QUIT NIL (VALRET '//.)) ; this format does a silent kill + +(DEFMFUN $LOGOUT NIL + (IF (STATUS HACTRN) (VALRET '/:LOGOUT/ +) ($QUIT))) + +;;Circlecross does something to the Lisp Machine reader at a very +;;low level. It must be slashified here. + +(DEFMFUN $DDT NIL (VALRET '|:/into DDT: // +|) '$DONE) +) + +#+LISPM (PROGN 'COMPILE +(DEFMFUN $QUIT () (*THROW 'MACSYMA-QUIT NIL)) +(DEFMFUN $LOGOUT () (LOGOUT)) +) + +#+Multics (PROGN 'COMPILE +(DEFMFUN $QUIT () (QUIT)) +(DEFMFUN $LOGOUT () (CLINE "logout")) +(DEFMFUN $DDT () (IOC Z)) +) + +#+PDP10 +(DEFMFUN FILESTRIP (X) + (COND ((NULL X) (APPEND (CDR DEFAULTF) (CAR DEFAULTF))) + ((NULL (CDR (SETQ X (FULLSTRIP X)))) + (SETQ X (MERGEF (CAR X) (CONS (CAR DEFAULTF) + (IF (EQ (STATUS OPSYS) 'ITS) '(* >) + '(* /1))))) + (APPEND (CDR X) (CAR X))) + ((NULL (CDDR X)) (APPEND X (CAR DEFAULTF))) + ((NULL (CDDDR X)) + (IF (NUMBERP (CADDR X)) (MERROR "Bad file specification")) + ; To get around a bug in MERGEF. + (SETQ X (MERGEF X DEFAULTF)) (APPEND (CDR X) (CAR X))) + (T X))) + +#+MULTICS +(DEFMFUN FILESTRIP (X) + (COND ((NULL X) NIL) + ((ATOM X) (FULLSTRIP1 X)) + (T (IF (NULL (CDR (SETQ X (FULLSTRIP X)))) (SETQ X (CAR X))) X))) + + +;--- filestrip +; argument is a list containing the filename, which is a symbol or string. +; +#+Franz +(defmfun filestrip (f) + (cond ((null f) (merror "You must supply a filename~%")) + ((and (dtpr f) + (cond ((or (symbolp (car f)) (stringp (car f))) + (stripdollar (car f)))))) + (t (merror "Illegal filename ~M" f)))) + +(DEFMFUN FILEPRINT (FNAME) ; Takes filename in NAMELIST format. + (COND ($FILE_STRING_PRINT (PRINC (NAMESTRING FNAME)) (PRINC " ")) + (T (PRINC "[") + (PRINC (CADR FNAME)) (PRINC ", ") + (PRINC (CADDR FNAME)) (PRINC ", ") + (WHEN (CDDDR FNAME) (PRINC (CADDDR FNAME)) (PRINC ", ")) ; For TOPS-20 + (PRINC (CAAR FNAME)) (PRINC ", ") + (PRINC (CADAR FNAME)) (PRINC "] ")))) + +(DEFMFUN MFILE-OUT (FNAME) ; Takes filename in NAMELIST or OldIO list format. + (IF $FILE_STRING_PRINT + (IMPLODE (CONS #/& (EXPLODEN (NAMESTRING FNAME)))) + (DOLLARIFY (IF (ATOM (CAR FNAME)) FNAME (APPEND (CDR FNAME) (CAR FNAME)))))) + +; File-processing stuff. Lisp Machine version in MC:LMMAX;LMSUP. + +#+PDP10 +(DEFMSPEC $WRITEFILE (L) (SETQ L (CDR L)) + (IF #.WRITEFILEP (MERROR "File already open for writing.")) + (IF (> (LENGTH L) 2) (WNA-ERR '$WRITEFILE)) + (LET (U) (SETQ U (IF (AND L (NULL (CDR L)) + (PROG2 (SETQ U (NAMELIST (FULLSTRIP1 (CAR L)))) + (NOT (EQUAL (CAR U) (IF (EQ (STATUS OPSYS) 'ITS) + '(* *) + '(|| ||)))))) + (CAR U) + (FULLSTRIP L))) + (SETQ U (APPLY #'UWRITE U) #.WRITEFILEP T) + (IF $FILE_STRING_PRINT + (IF (EQ (STATUS OPSYS) 'ITS) + (CONCAT '/& (CAR U) '/: (CADR U) '/;) + (CONCAT '/& (CAR U) '/: '< (CADR U) '>)) + (DOLLARIFY U)))) + +#+Franz +(defmspec $writefile (l) + (setq display-to-disk (cadr l)) + (setq ptport (outfile (filestrip (cdr l)))) + display-to-disk) + +#+PDP10 +(DEFMSPEC $APPENDFILE (L) (SETQ L (CDR L)) + (IF #.WRITEFILEP (MERROR "File already open for writing.")) + (APPLY #'UAPPEND (FILESTRIP L)) (SETQ #.WRITEFILEP T) ($FILEDEFAULTS)) + +#+Franz +(DEFMSPEC $APPENDFILE (L) + (setq display-to-disk (cadr l)) + (setq ptport (outfile (filestrip (cdr l)) 'append)) + display-to-disk) + +#+PDP10 +(DEFMSPEC $CLOSEFILE (L) (SETQ L (CDR L)) + (APPLY #'UFILE (IF (NULL L) (MFILE) (FILESTRIP L))) + (IF (AND (= (LENGTH L) 4) (NOT (EQ (CADAR DEFAULTF) (FULLSTRIP1 (CAR (LAST L)))))) + (MTELL "Warning: Specified CLOSEFILE directory is incorrect.")) + ($FILEDEFAULTS)) + +#+Franz +(DEFMSPEC $closefile (l) (SETQ L (CDR L)) + (close ptport) + (setq l display-to-disk display-to-disk nil) + l) + +#-Franz +(DEFUN MFILE NIL + (FULLSTRIP (LIST $FILENAME (SETQ $FILENUM (1+ $FILENUM)) $DEVICE $DIREC))) + + +#+MACLISP +(DEFMSPEC $DELFILE (L) (SETQ L (CDR L)) + (PROG2 (SETQ L (SYS-DEFAULTF (FILESTRIP L))) ($FILEDEFAULTS) (DELETEF L))) + +#+MACLISP +(DEFMFUN $FILEDEFAULTS N + (COND ((= N 1) (SYS-DEFAULTF (FILENAMEL (ARG 1)))) + ((> N 1) (WNA-ERR '$FILEDEFAULTS))) + (LET ((FILE (OR (PROBEF DEFAULTF) DEFAULTF))) (MFILE-OUT FILE))) + +;;; The Multics Version of Writefile and Closefile. +;;; Appendfile is not implemented yet. +#+MULTICS (PROGN 'COMPILE +(LOAD-MACSYMA-MACROS SYSTEM_ERROR_HANDLER) + +(DEFMVAR WRITEFILE-IN-PROGRESS () "T if there is a writefile happening") +(DEFMVAR WRITEFILE-^R () "Value of ^R before writefile") +(DEFMVAR WRITEFILE-NAME "" "Full pathname of temporary writefile file") + +(DEFUN MAKE-WRITEFILE-FILENAME (USER-SUPPLIED-NAME) + (LET ((IS-A-DIR (SYSTEM-INTERFACE-ERROR ("Writefile") + (DIRECTORY-OR-FILE USER-SUPPLIED-NAME "")))) + (COND ((NOT (STRING-EQUAL IS-A-DIR "directory")) + (MERROR "Writefile: ~:M is not a directory" USER-SUPPLIED-NAME)))) + (COND ((SYSTEM-INTERFACE-ERROR ("Writefile") + (DIRECTORY-P USER-SUPPLIED-NAME 'APPEND)) + (STRING-APPEND USER-SUPPLIED-NAME ">writefile.output")) + (T (MERROR "Writefile: You have incorrect directory access to ~:M." + USER-SUPPLIED-NAME)))) + +(DEFUN MAKE-CLOSEFILE-FILENAME (TEMPORARY-WRITEFILE-NAME ENTRYNAME + &AUX (DIR-NAME + (DIRECTORY-NAME TEMPORARY-WRITEFILE-NAME))) + (IF (OR (STRING-SEARCH-CHAR #/> ENTRYNAME) + (STRING-SEARCH-CHAR #/< ENTRYNAME)) + (MERROR "Closefile: illegal entryname. ~:M" ENTRYNAME)) + (LET ((PATHNAME (SYSTEM-INTERFACE-ERROR ("Closefile") + (ABSOLUTE-PATHNAME (STRING-APPEND DIR-NAME ">" + ENTRYNAME))))) + PATHNAME)) + +(DEFMSPEC $WRITEFILE (X) (SETQ X (CDR X)) + (IF (NOT (NULL WRITEFILE-IN-PROGRESS)) + (MERROR "Writefile: writefile already in progress.")) + (LET ((USER-SUPPLIED-NAME ())) + (COND ((> (LENGTH X) 1) (WNA-ERR '$WRITEFILE)) + ((= (LENGTH X) 1) (SETQ USER-SUPPLIED-NAME (STRIPDOLLAR (CAR X)))) + (T (SETQ USER-SUPPLIED-NAME (PATHNAME-UTIL "hd")))) + (SETQ WRITEFILE-NAME (MAKE-WRITEFILE-FILENAME USER-SUPPLIED-NAME)) +;;;THE ABOVE EITHER ERRS OUT OR GIVES SOMETHING BACK. + (PUSH (OPEN WRITEFILE-NAME '(OUT ASCII)) OUTFILES) + (SETQ WRITEFILE-^R #.WRITEFILEP) + (SETQ #.WRITEFILEP T) + (SETQ WRITEFILE-IN-PROGRESS T) + `((MLIST) ,(STRING-TO-MSTRING WRITEFILE-NAME)))) + +(DEFMSPEC $CLOSEFILE (ENTRY-NAME) (SETQ ENTRY-NAME (CDR ENTRY-NAME)) + (IF (NOT (EQUAL (LENGTH ENTRY-NAME) 1)) + (WNA-ERR '$CLOSEFILE)) + (SETQ ENTRY-NAME (CAR ENTRY-NAME)) + (COND ((MSTRINGP ENTRY-NAME) + (SETQ ENTRY-NAME (MSTRING-TO-STRING ENTRY-NAME))) + ((SYMBOLP ENTRY-NAME) + (SETQ ENTRY-NAME (STRING (STRIPDOLLAR ENTRY-NAME)))) + (T (MERROR "Closefile: ~:M illegal argument" ENTRY-NAME))) + (LET ((NEW-FILENAME (MAKE-CLOSEFILE-FILENAME WRITEFILE-NAME ENTRY-NAME)) + (OPEN-WRITEFILE (CAR OUTFILES))) + (CLOSE OPEN-WRITEFILE) + (RENAMEF OPEN-WRITEFILE NEW-FILENAME) + (POP OUTFILES) + (SETQ #.WRITEFILEP WRITEFILE-^R) + (SETQ WRITEFILE-^R ()) + (SETQ WRITEFILE-IN-PROGRESS ()) + (SETQ WRITEFILE-NAME ()) + `((MLIST) ,(STRING-TO-MSTRING NEW-FILENAME)))) +) +;;; End of Multics version of WRITEFILE, CLOSEFILE code. + +;; This prevents single blank lines from appearing at the top of video +;; terminals. If at the upper left corner and we want to print a blank +;; line, leave the cursor there and send the blank line to transcript +;; files only. + +#+(OR PDP10 NIL LISPM) +(DEFMFUN MTERPRI (&AUX (X (CURSORPOS))) + (IF (AND SMART-TTY X (EQUAL X '(0 . 0))) + (LET ((#.TTYOFF T)) (TERPRI)) + (TERPRI))) + +#+(or Franz Multics) +(DEFMFUN MTERPRI () (TERPRI)) + +#+PDP10 +(DEFMFUN MORE-FUN (NIL) + (ENDPAGEFN T NIL) + (COND ((NOT (OR (< (CAR (OR (CURSORPOS) '(0 . 0))) 10.) + (= (- TTYHEIGHT 2) (CAR (CURSORPOS))))) + (CURSORPOS 'E) (SLEEP .01))) + (NOINTERRUPT NIL) + (COND ((= 0 (BOOLE 1 1_25. (CADDR (STATUS TTY)))) + (CURSORPOS 'Z) (CURSORPOS '/]) + ((LAMBDA (^Q) + ((LAMBDA (#.WRITEFILEP #.TTYOFF STATE-PDL) + (PRINC MOREMSG) (TYIPEEK) + (IF $MOREWAIT + (DO ((L (IF (EQ $MOREWAIT '$ALL) + '(#\SP #\CR) + '(#\SP #\CR #\RUBOUT)))) + ((MEMBER (TYIPEEK) L)) + (TYI)) + (DO () ((NOT (MEMBER (TYIPEEK) '(#^D #^S #^V #^])))) + (TYI))) + (COND (SMART-TTY (CURSORPOS 'Z) (CURSORPOS '/])) (T (TERPRI)))) + NIL NIL (CONS 'MORE-WAIT STATE-PDL)) + (COND ((= #\SP (TYIPEEK)) + (IF MORECONTINUE (LET (#.WRITEFILEP #.TTYOFF) (PRINC MORECONTINUE))) (TYI)) + ((= #\RUBOUT (TYIPEEK)) + (LET ((#.TTYOFF T)) (TERPRI)) + (IF MOREFLUSH (PRINC MOREFLUSH)) + (TYI) + (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T)) + #.WRITEFILEP (AND #.WRITEFILEP (NULL MOREFLUSH)))) + (T (COND ((OR (MEMQ 'BATCH STATE-PDL) + (AND (< (TYIPEEK) 32.) + (NOT (MEMBER (TYIPEEK) + '(2 7 11. 12. 25. 27. + 28. 29. 30.))))) + (TYI))) + (IF MOREFLUSH (LET (#.WRITEFILEP #.TTYOFF) (PRINC MOREFLUSH))) + (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T)))))) + NIL))) + (IF (AND SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP)))) + (COND (RUBOUT-TTY (LET (#.TTYOFF) (CURSORPOS T T) (CURSORPOS '/]))) + (T (SLEEP 0.4) (FORMFEED))) + (LET (#.TTYOFF #.WRITEFILEP) (TERPRI))) + (ENDPAGEFN T 'MORE-FUN)) + +#+PDP10 (ENDPAGEFN T 'MORE-FUN) + +; More processing stuff. +; This isn't the best way to do it on the Lisp machine, +; it's a minimally modified version of the Maclisp one. + +#+LISPM (DECLARE (SPECIAL TV:MORE-PROCESSING-GLOBAL-ENABLE)) + +#+LISPM +(DEFMFUN MORE-FUN (FILE) + FILE ;ignored + (FUNCALL TERMINAL-IO ':MORE-EXCEPTION)) + +#+LISPM +(DEFUN MORE-FUN-INTERNAL (TERMINAL-IO &AUX (STANDARD-INPUT 'SI:TERMINAL-IO-SYN-STREAM)) + ; This clears the rest of the screen, unless we're at the bottom + ; or too close to the top. + (COND ((NOT (OR (< (CAR (CURSORPOS)) 10.) + (= (- TTYHEIGHT 2) (CAR (CURSORPOS))))) + (CURSORPOS 'E))) + ; Now go to the bottom of the screen and cause a more, unless disabled. + (COND (TV:MORE-PROCESSING-GLOBAL-ENABLE + (CURSORPOS 'Z) (CURSORPOS 'L) + ((LAMBDA (^Q) + ((LAMBDA (#.WRITEFILEP #.TTYOFF STATE-PDL) + (PRINC MOREMSG) (TYIPEEK) + ; Now see what the user feels like typing in. + (COND ($MOREWAIT + (DO ((L (COND ((EQ $MOREWAIT '$ALL) '(32. 141.)) ; sp, cr + (T '(32. 141. 135.))))) ; sp, cr, rubout + ((MEMBER (TYIPEEK) L)) + (TYI T))) ; eat other characters + (T (DO () ((NOT (MEMBER (TYIPEEK) '(4 19. 22. 29.)))) + (TYI T)))) ; eat ^], etc. + ; Now erase the MORE message + (COND (SMART-TTY (CURSORPOS 'Z) (CURSORPOS 'L)) (T (TERPRI)))) + NIL NIL (CONS 'MORE-WAIT STATE-PDL)) + ; Now decide whether to continue or flush + (COND ((= #\SP (TYIPEEK)) + (IF MORECONTINUE (LET (#.WRITEFILEP #.TTYOFF) (PRINC MORECONTINUE))) + (TYI T)) ; eat the space + ((= #\RUBOUT (TYIPEEK)) + (LET ((#.TTYOFF T)) (TERPRI)) + (IF MOREFLUSH (PRINC MOREFLUSH)) + (TYI T) ; eat the rubout + (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T)) + #.WRITEFILEP (AND #.WRITEFILEP (NULL MOREFLUSH)))) + (T (COND ((OR (MEMQ 'BATCH STATE-PDL) + (AND (< (TYIPEEK) 32.) + (NOT (MEMBER (TYIPEEK) + '(2 7 11. 12. 25. 27. 28. 29. 30.)))) + (>= (TYIPEEK) 128.)) + (TYI T))) ; eat cr or other control character. + (IF MOREFLUSH (LET (#.WRITEFILEP #.TTYOFF) (PRINC MOREFLUSH))) + (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T)))))) + NIL))) + ; Now home up, or advance to next line, and continue display. + (IF SMART-TTY + (COND (RUBOUT-TTY (LET (#.TTYOFF) (CURSORPOS T T) (CURSORPOS 'L))) + (T (SLEEP 0.4) (FORMFEED))) + (LET (#.TTYOFF #.WRITEFILEP) (TERPRI)))) + +;; More PDP10-only stuff + +#+PDP10 (PROGN 'COMPILE + +(DEFMFUN $PAGEPAUSE (X) (PAGEPAUSE1 NIL X)) + +(DEFUN PAGEPAUSE1 (NIL X) + (SYSCALL 0 'TTYSET TYO (CAR (STATUS TTY)) (CADR (STATUS TTY)) + (BOOLE (COND (X 4) (T 7)) (CADDR (STATUS TTY)) 1_25.))) + ; Bit 3.8 (%TSMOR) of TTYSTS + +(DEFUN TTYINTSOFF NIL + (COND ((STATUS TTY) ; If NIL, we don't have the TTY + (NOINTERRUPT 'TTY) + (SSTATUS TTY (CAR (STATUS TTY)) (CADR (STATUS TTY)) ; Defer echoing + (BOOLE 7 8._18. (CADDR (STATUS TTY)))) + ; Bit 3.4 (%TSNOE) of TTYSTS + (SETQ TTYINTS NIL)))) + +(DEFUN TTYINTSON NIL + ((LAMBDA (TTY-STATUS) + (SSTATUS TTY (CAR TTY-STATUS) (CADR TTY-STATUS) ; Allow echoing + (BOOLE 2 8._18. (CADDR TTY-STATUS))) + (SETQ TTYINTS T) (NOINTERRUPT NIL)) + (SYSCALL 3 'TTYGET TYO))) + +(DEFUN SETCURSORPOS (N1 N2) (SYSCALL 0 'SCPOS TYO N1 N2)) + +) ;; End of PDP10-only stuff + +;;; TRANSL properties for STATUS and SSTATUS in MAXSRC;TRANS5 > +#+(or Franz MACLISP NIL) +(DEFMSPEC $STATUS (L) (SETQ L (CDR L)) + (IF L (NONSYMCHK (CAR L) '$STATUS)) + (COND ((OR (NULL L) + (AND (EQ (CAR L) '$FEATURE) (CDDR L)) + (AND (NOT (EQ (CAR L) '$FEATURE)) (CDR L))) + (WNA-ERR '$STATUS))) + (LET ((KEYWORD (CAR L))) + (CASEQ KEYWORD + ($RUNTIME (LIST '(MTIMES SIMP) (// (+ (RUNTIME) 500.) 1000.) '$MSEC)) + ($TOTALGCTIME (LIST '(MTIMES SIMP) (COMPUTIME (STATUS GCTIME) 0) '$MSEC)) + ($TIME (COND ((PLUSP THISTIME) + (LIST '(MTIMES SIMP) (COMPUTIME (RUNTIME) THISTIME) '$MSEC)) + (T '$UNKNOWN))) + ($GCTIME (COND ((PLUSP GCT) + (LIST '(MTIMES SIMP) (COMPUTIME (STATUS GCTIME) GCT) '$MSEC)) + (T '$UNKNOWN))) + ($REALTIME (LIST '(MTIMES SIMP) (-$ (TIME) STIME0) '%SEC)) + ($DAYTIME (CONS '(MLIST) (STATUS DAYTIME))) + ($DATE (CONS '(MLIST) (STATUS DATE))) + ($DAY (MAKEALIAS (STATUS DOW))) + ($FREECORE (LIST '(MTIMES SIMP) (// (sys-free-memory) 1024.) + '$BLOCKS)) + ($FEATURE (COND ((NULL (CDR L)) (DOLLARIFY (STATUS FEATURES))) + (T #-NIL + (APPLY #'STATUS + `(FEATURE ,(FULLSTRIP1 (CADR L)))) + #+NIL + (FEATUREP (FULLSTRIP1 (CADR L))) + ))) + ($STATUS '((MLIST SIMP) $RUNTIME $TOTALGCTIME $TIME $GCTIME $REALTIME $DAYTIME + $DATE $DAY $FREECORE $FEATURE $STATUS)) + (T (MERROR "Unknown argument - STATUS:~%~M" KEYWORD))))) + +#+LISPM +(DEFMSPEC $STATUS (FORM) (POP FORM) + (LET ((KEYWORD (POP FORM)) + (FEATURE (POP FORM))) + (CHECK-ARG KEYWORD SYMBOLP "a symbolic name") + (CHECK-ARG FEATURE SYMBOLP "a symbolic name") + (COMPILER-LET ((OBSOLETE-FUNCTION-WARNING-SWITCH NIL)) + (CASEQ KEYWORD + ($FEATURE (COND ((NULL FEATURE) (DOLLARIFY (STATUS FEATURES))) + ((MEMQ (FULLSTRIP1 FEATURE) (STATUS FEATURES)) T))) + ($STATUS '((MLIST SIMP) $FEATURE $STATUS)) + (T (MERROR "Unknown argument - STATUS:~%~M" KEYWORD)))))) + +#+(or Franz MACLISP) +(DEFMSPEC $SSTATUS (L) (SETQ L (CDR L)) + (COND ((OR (NULL L) (NULL (CDR L))) (MERROR "SSTATUS takes >1 argument."))) + (LET (((KEYWORD ACT . REST) L)) + (NONSYMCHK KEYWORD '$SSTATUS) + (COND ((EQ KEYWORD '$FEATURE) + (COND ((NOT (NULL REST)) (WNA-ERR '$SSTATUS))) + (NONSYMCHK ACT '$SSTATUS) + (APPLY #'SSTATUS `(FEATURE ,(FULLSTRIP1 ACT)))) + (T (MERROR "Unknown argument - SSTATUS:~%~M" KEYWORD))))) + +; Allocation level 0 is +; (ALLOC '(LIST (16000. 30000. 0.3) FIXNUM (5000. 9000. 0.3) +; FLONUM (1600. 3000. 0.3) BIGNUM (1600. 3000. 0.3) +; SYMBOL (6200. 7200. 0.15) ARRAY (150. 400. 50.))) + +#+MACLISP +(PROGN 'COMPILE +(DEFMSPEC $ALLOC (FORM) (I-$ALLOC (CDR FORM))) +(DEFMFUN I-$ALLOC (L) + (DO ((L L (CDR L)) (X)) ((NULL L) '$DONE) + (COND ((OR (AND (EQ (TYPEP (CAR L)) 'FIXNUM) (> (CAR L) 0) (< (CAR L) 5) + (OR (NOT (> (CAR L) ALLOCLEVEL)) (SETQ ALLOCLEVEL (1- (CAR L))))) + (MEMQ (CAR L) '($ALL $LIST))) + (COND ((= ALLOCLEVEL 0) + (ALLOC '(LIST (16000. 39000. NIL) FIXNUM (5000. 10000. NIL) + FLONUM (1600. 3500. NIL) BIGNUM (1600. 3500. NIL) + SYMBOL (6200. 7600. NIL) ARRAY (150. 450. NIL)))) + ((= ALLOCLEVEL 1) + (ALLOC '(LIST (18000. 48000. NIL) FIXNUM (6000. 11000. NIL) + FLONUM (1800. 4000. NIL) BIGNUM (1800. 4000. NIL) + SYMBOL (6500. 8000. NIL) ARRAY (180. 500. NIL)))) + ((= ALLOCLEVEL 2) + (ALLOC '(LIST (18000. 57000. NIL) FIXNUM (6000. 12000. NIL) + FLONUM (1800. 4500. NIL) BIGNUM (1800. 4500. NIL) + SYMBOL (6500. 8500. NIL) ARRAY (180. 550. NIL)))) + ((= ALLOCLEVEL 3) + (ALLOC '(LIST (20000. 67000. NIL) FIXNUM (8000. 14000. NIL) + FLONUM (2000. 5000. NIL) BIGNUM (2000. 5000. NIL) + SYMBOL (7000. 9000. NIL) ARRAY (200. 600. NIL)))) + (T (PRINC "You're already at maximum allocation") (RETURN '$DONE))) + (SETQ ALLOCLEVEL (1+ ALLOCLEVEL))) + ((SETQ X (ASSQ (STRIPDOLLAR (CAR L)) + '((FIXNUM . 2000.) (FLONUM . 1500.) (BIGNUM . 1500.) + (SYMBOL . 1000.) (ARRAY . 100.) (HUNK2 . 1000.) (HUNK4 . 1000.) + (HUNK8 . 1000.) (HUNK16 . 1000.) (HUNK32 . 1000.)))) + (ALLOC (LIST (CAR X) + (LIST NIL (+ (CDR X) (CADR (GET (CONS NIL (ALLOC T)) (CAR X)))) + NIL)))) + (T (MERROR "Incorrect argument to ALLOC:~%~M" (CAR L)))))) +) +#+Franz +(defmfun $alloc (type pages) (allocate (stripdollar type) pages)) +; type should be list, fixnum etc. + + +;; GC Interrupt functions. + +#+PDP10 (PROGN 'COMPILE + +(DEFUN GCLFUN (SPACE) ; The GC-LOSSAGE and PDL-OVERFLOW interrupt function + (COND ((AND (NOT (= ALLOCLEVEL 5)) (= (SYS-FREE-MEMORY) 0) + ; i.e. state is "NO CORE AVAILABLE". + (MEMQ SPACE '(LIST FIXNUM FLONUM BIGNUM SYMBOL ARRAY))) + (SETQ ALLOCLEVEL 4) (GCOFUN SPACE)) + (T (LET (FREECOREP) + (WHEN (EQ SPACE 'SYMBOL) (SETQ GCSYML NIL) (GCTWA)) + (TERPRI) + (COND ((AND (= (SYS-FREE-MEMORY) 0) + (NOT (MEMQ SPACE '(REGPDL SPECPDL)))) + (MTELL-OPEN "CORE capacity exceeded (while requesting ~A space).~%" + SPACE) + (MTELL-OPEN "SAVE a few expressions if you can.~%") + (PRINC "You will probably have to load up a new MACSYMA!!")) + (T (SETQ FREECOREP T) + (MTELL-OPEN "~A storage capacity exceeded " SPACE))) + (IF (MEMQ SPACE '(REGPDL SPECPDL)) (PRINC "(Infinite recursion?)")) + (TERPRI) + (LET ((MTOP (MEMQ 'MACSYMA-TOPLEVEL STATE-PDL))) + (WHEN MTOP (TIMESOFAR 1) + (IF (> THISTIME 0) (MTELL-OPEN " so far~%") + (TERPRI))) + (COND (DEBUG (LET (($ERROR (CONS '(MLIST SIMP) + (IF FREECOREP + (LIST "~A storage capacity exceeded " SPACE) + (LIST "CORE capacity exceeded (while requesting ~A space).~%" + SPACE))))) + (ERRBREAK NIL))) + ((AND *RSET (NOT MTOP)) (*RSETFUN NIL))) + (COND (ERRCATCH (ERROR)) (MTOP (MQUIT T)) (T (^G)))))))) + +(DEFUN GCOFUN (SPACE) ; The GC-OVERFLOW interrupt function + (IF (NULL TTYINTS) (PROG2 (TTYINTSON) (GCOFUN1 SPACE) (TTYINTSOFF)) + (GCOFUN1 SPACE))) + +(DEFUN GCOFUN1 (SPACE) + ((LAMBDA (#.TTYOFF #.WRITEFILEP) + (PROG (^Q X) + (COND ((= ALLOCLEVEL 4) + (ALLOC '(LIST (NIL NIL 1000) FIXNUM (NIL NIL 100) + FLONUM (NIL NIL 100) BIGNUM (NIL NIL 100) + SYMBOL (NIL NIL 100) ARRAY (NIL NIL 6))) + (SETQ ALLOCLEVEL 5) (RETURN '(T))) + ((= ALLOCLEVEL 5) (MTELL-OPEN "~%Maximum allocation exceeded") + (GCLFUN SPACE)) + ($DYNAMALLOC + (SETQ X (COND ((MEMQ SPACE '(FIXNUM FLONUM BIGNUM SYMBOL ARRAY + HUNK2 HUNK4 HUNK8 HUNK16 HUNK32)) + SPACE) + (T '$ALL))) + (COND ((EQ $DYNAMALLOC '$PRINT) + (MTELL-OPEN "~%More ~A space was needed.~%" SPACE))) + (GO ALLOC))) + (SETQ #.TTYOFF NIL) + (IF (= THISTIME -1) (MTELL-OPEN "~%(Computing the display now)")) + (SETQ X (LIST '(MTEXT) + " +You have run out of " SPACE " space. +Do you want more? +" GCPROMPT)) + (SETQ X (RETRIEVE X T)) + LOOP (COND ((NOT (MEMQ X '($ALL $NONE $OK 1 2 3 4 $LIST $FIXNUM + $FLONUM $BIGNUM $SYMBOL $ARRAY + $HUNK2 $HUNK4 $HUNK8 $HUNK16 $HUNK32))) + (CURSORPOS 'A) + (SETQ X (RETRIEVE GCPROMPT NIL)) + (GO LOOP)) + ((EQ X '$NONE) (GCLFUN SPACE)) + ((EQ X '$OK) (RETURN '(T)))) + ALLOC(I-$ALLOC (LIST X)) (RETURN '(T)))) + #.TTYOFF (AND #.WRITEFILEP (NOT DSKFNP)))) + +(DEFUN GCDEMON (SPACES) ; The GC-DAEMON interrupt function + (DO ((X (IF (= (SYS-FREE-MEMORY) 0) (SETQ GC-DAEMON NIL) SPACES) (CDR X)) + (Y) (N1 0) (N2 0)) + ((NULL X)) + (COND ((ZEROP (CADAR X)) + ((LAMBDA (U1) + (COND ((OR (NOT (EQ (CAR DEMONL) (CAAR X))) + (> (ABS (//$ (-$ U1 (CAR (LAST DEMONL))) U1)) 0.03)) + (SETQ DEMONL (LIST (CAAR X) U1))) + ((= (LENGTH DEMONL) 3) + (SETQ Y (GET (CONS NIL (ALLOC T)) (CAAR X))) + (COND ((AND Y (PROG2 (SETQ N1 (CAR Y) N2 (CADR Y)) (< N1 (- N2 1000)))) + (ALLOC (LIST (CAAR X) (LIST (MIN N2 (+ N1 2000)) NIL NIL))))) + (SETQ DEMONL (LIST NIL))) + (T (NCONC DEMONL (NCONS U1)))) + (RETURN T)) + (FLOAT (CADDAR X))))))) + +) ;; End of GC interrupt functions. + +;; DSKGC(TRUE); will cause user defined values, functions, arrays and line +;; labelled expressions to be stored on disk whenever the system determines +;; storage is getting low. Only needed on PDP10s. Other systems have this +;; built in. Its called paging. + +#+PDP10 (PROGN 'COMPILE + +(DEFMFUN $DSKGC (X) (DSKGC1 NIL X)) + +(DEFUN DSKGC1 (NIL X) + (SETQ GC-OVERFLOW + (COND (X (IF (< ALLOCLEVEL 4) (I-$ALLOC '(4))) 'GCDFUN) + (T 'GCOFUN))) + '$DONE) + +(DEFUN GCDFUN (SPACE) ; The DSKGC interrupt function + (COND ((OR (= GCLINENUM $LINENUM) (STATUS FILEMODE SAVEFILE)) (GCOFUN SPACE)) + (T (SETQ GCLINENUM $LINENUM) + (LET ((GC-OVERFLOW 'GCOFUN) (DSKSAVEP T)) + (I-$STORE '($LABELS $VALUES $FUNCTIONS $ARRAYS)))))) + +) ;; End of disk GC conditionalization. + +#-PDP10 (PROGN 'COMPILE +(DEFMFUN $DSKGC (X) X NIL) +(DEFUN DSKGC1 (X Y) X Y NIL) +) + +;; Various functions which get run when interrupts go off. The interrupt +;; functions in this form are present only in PDP10 and Multics MacLisp. + +#+MacLisp +(PROGN 'COMPILE + +(DEFUN *RSETFUN (NIL) ; The *RSET interrupt function + (AND *RSET (PROG (#.TTYOFF ^Q) (*BREAK T '*RSET)))) + +(DEFUN FAILFUN (X) ; The FAIL-ACT interrupt function + (COND #+PDP10 ((EQ (CAR X) 'ERRLIST) '(T)) + ((MEMQ (CAR X) '(BASE IBASE)) (SET (CAR X) 10) '(T)) + (T (ERRPRINT NIL) NIL))) + +) ;; End of *RSET, FAIL-ACT interrupt functions. + +#+PDP10 (PROGN 'COMPILE + +;; Functions for the Macsyma-user-level tty interrupt facility. + +(DEFMFUN TTYINTFUNSETUP (NIL FLAG) + (IF FLAG (SSTATUS TTYINT $TTYINTNUM 'TTYINTFUN) + (SSTATUS TTYINT $TTYINTNUM NIL))) + +(DEFMFUN TTYINTFUN (NIL NIL) ; The ^U (or other) interrupt function + (NOINTERRUPT NIL) + (MAPPLY $TTYINTFUN NIL $TTYINTFUN)) + +;; These interrupt functions are present only in PDP10 MacLisp. + +;; This function gets called when the operating system supervisor +;; returns the console to Macsyma. It reprints the current c-line, or the +;; editor buffer, or whatever is appropriate. + +(defmfun ttyretfun (x) + (let (#.TTYOFF #.WRITEFILEP (readp (and reading (zerop (listen))))) + (cursorpos 'a) + (when (not (or (eq x T) + (and (eq (car state-pdl) 'MACSYMA-TOPLEVEL) readp))) + ; Do nothing if you never left MACSYMA or are at + ; top level MACSYMA read. + (PRINC "Back to MACSYMA") + (caseq (memq-stpdl '(LISP-TOPLEVEL LISP-BREAK RETRIEVE + MACSYMA-TOPLEVEL)) + ((LISP-TOPLEVEL LISP-BREAK) + (PRINC ", at LISP level. ")) + (T (PRINC ". ")))) + + (or (memq (car state-pdl) '(COMPUTING PLAYBACK BATCH)) + (let ((F (TO-MACSYMA-NAMESTRING + `((DSK ,(STATUS HSNAME)) ,(STATUS UNAME) |_MAXIM|)))) + ;; $LOAD is good for hacking lisp or macsyma level code. + (AND (PROBEF F) + (UNWIND-PROTECT (ERRSET ($LOAD F)) + (DELETEF F) + (CURSORPOS 'a))))) + + (caseq (car state-pdl) + (COMPUTING (PRINC "Computation continuing.")) + (EDIT (PRINC "Inside Editor.")) + ((RETRIEVE MACSYMA-BREAK) + (COND ((OR (EQ (CAR STATE-PDL) 'MACSYMA-BREAK) + (EQ (CADR STATE-PDL) 'MACSYMA-BREAK)) + (PRINC "MACSYMA-BREAK") + (UNLESS (ZEROP BRKLVL) (PRINC " level ") (PRINC BRKLVL)) + (PRINC ".")) + (T (PRINC "Waiting for input.")))) + (BATCH (caseq (cadr state-pdl) + ($TRANSLATE (PRINC "TRANSLATE_FILE continuing.")) + ($DEMO (PRINC "DEMO continuing.")) + (T (PRINC "BATCH continuing.")))) + (PLAYBACK (PRINC "PLAYBACK continuing.")) + (LISP-BREAK (PRINC "LISP-BREAK."))) + (if (not (and (eq (car state-pdl) 'MACSYMA-TOPLEVEL) readp)) (terpri)) +;; Maybe do some redisplay + (caseq (car state-pdl) + (EDIT (prtext) (if readp (reprint command t))) + ((MACSYMA-TOPLEVEL RETRIEVE) + (retr-print promptmsg (eq mrg-punt t)) + (if readp (reprint (if (or (not rephrase) + (eq (car state-pdl) 'RETRIEVE)) + st) + t))) + (MORE-WAIT (PRINC moremsg))))) + +;;; MEMQ-STPDL is like a MEMQ, except that it finds the first cons of the +;;; STATE-PDL who's car is an EQ member of a list, rather than EQ to a +;;; single item. + +(DEFUN MEMQ-STPDL (ATOMS) + (DO ((LIST STATE-PDL (CDR LIST))) + ((OR (NULL LIST) (MEMQ (CAR LIST) ATOMS)) (CAR LIST)))) + +(DEFMFUN IOLFUN (X) ; The IO-LOSSAGE interrupt function + (COND ((EQ (CAR X) 'OPEN) + (FILEPRINT (NAMELIST (CADR X))) ; the file + (PRINC (CAADDR (ERRFRAME NIL)))) ; the error msg + (T (ERRPRINT NIL))) + NIL) + +(DEFMFUN MACHERRFUN (TYPE LOC PC JPC) ; Machine Error Handler + LOC JPC ;Ignored. + (TERPRI) + (COND ((EQ TYPE 'EXAMINE) (MTELL ";reference to non-existent memory")) + ((EQ TYPE 'DEPOSIT) (MTELL ";write into read-only memory")) + ((EQ TYPE 'EVAL) (MTELL ";illegal machine operation")) + ((EQ TYPE 'ODDP) (MTELL ";parity error")) + (T (MTELL ";~A error" TYPE))) + (MERROR " from location ~S~%;program trapped while in ~S" PC (SUBR PC))) + +) ;; End of PDP-10 only interrupt functions. + +;; TTY interrupt functions. This form for PDP10 MacLisp only. + +#+PDP10 (PROGN 'COMPILE + +(DECLARE (SETQ BASE 10.)) ; Must be set to 10 for outputting lap code. + +(DEFUN XQUIT (NIL NIL) ; The ^X interrupt function + (CASEQ (MEMQ-STPDL '(MACSYMA-TOPLEVEL MACSYMA-BREAK LISP-TOPLEVEL LISP-BREAK)) + (MACSYMA-BREAK (*THROW 'MACSYMA-BREAK NIL)) + (MACSYMA-TOPLEVEL (COND (MBREAK (*THROW 'MBREAK NIL)) (T (MQUIT NIL)))) + (T (ERROR 'QUIT)))) + +(PROGN (SSTATUS TTYINT #^A '(LAMBDA (NIL NIL) (MERRBREAK NIL))) + (SSTATUS TTYINT #^B '(LAMBDA (NIL NIL) (MPAUSE NIL))) + (SSTATUS TTYINT #^C NIL) + (SSTATUS TTYINT #^D + '(LAMBDA (NIL NIL) + (COND (^D (PRINC ^DMSG-OFF) (SETQ ^D NIL)) + (T (PRINC ^DMSG-ON) (SETQ ^D T))))) + (SSTATUS TTYINT #^G '(LAMBDA (NIL NIL) (MQUIT NIL))) + (SSTATUS TTYINT #^H NIL) ; This line is unnecessary. + (SSTATUS MACRO #^Q NIL) + (SSTATUS TTYINT #^R NIL) + (SSTATUS TTYINT #^S 'MQUIET) + (SSTATUS TTYINT #^T NIL) + (SSTATUS TTYINT #^X 'XQUIT) + (SSTATUS TTYINT #^] '(LAMBDA (NIL NIL) (TIMESOFAR NIL))) + (SSTATUS TTYINT #^^ #^G) ; quits into LISP + '(Setup of TTY interrupt functions)) +) ;; End of TTY interrupt functions. + +#+Multics (PROGN 'COMPILE + +(DECLARE (SETQ BASE 10.)) ; Must be set to 10 for outputting lap code. + +(PROGN (SSTATUS interrupt 2 'MERRBREAK) ;^A break. + (SSTATUS interrupt 1 'MPAUSE) ;^B break. + ;(SSTATUS TTYINT #^C NIL) ;Done by the LISP. + ;(SSTATUS TTYINT #^D + ; '(LAMBDA (NIL NIL) + ; (COND (^D (PRINC ^DMSG-OFF) (SETQ ^D NIL)) + ; (T (PRINC ^DMSG-ON) (SETQ ^D T))))) ;Done by the LISP. + ;(SSTATUS TTYINT #^G '(LAMBDA (NIL NIL) (MQUIT NIL))) ;Doesn't exist. + ;(SSTATUS TTYINT #^H NIL) ; This line is unnecessary. + ;(SSTATUS MACRO #^Q NIL) ;I don't know what this is for -Jim. + ;(SSTATUS TTYINT #^R NIL) + ;(SSTATUS TTYINT #^S 'MQUIET) + ;(SSTATUS TTYINT #^T NIL) + ;(SSTATUS TTYINT #^X 'XQUIT) ;This has gotta get caught by an errset. + (sstatus interrupt 15. '(lambda (x) + x ;ignored + (timesofar nil))) ;^] interrupt. + (sstatus interrupt 16 '(lambda (x) + ((lambda (errlist) + (^g)) + '((errlfun ()))))) ;^^ interrupt. + '(Setup of TTY interrupt functions)) +) + +#+LISPM (SETQ ERROR-CALL 'ERRBREAK) + +(PROGN (DO L '($SQRT $ERF $SIN $COS $TAN $LOG $PLOG $SEC $CSC $COT $SINH $COSH + $TANH $SECH $CSCH $COTH $ASIN $ACOS $ATAN $ACOT $ACSC $ASEC $ASINH + $ACOSH $ATANH $ACSCH $ASECH $ACOTH $BINOMIAL $GAMMA $GENFACT $DEL) + (CDR L) (NULL L) + ((LAMBDA (X) + (PUTPROP (CAR L) X 'ALIAS) + (PUTPROP X (STRIPDOLLAR (CAR L)) 'REVERSEALIAS)) + ($NOUNIFY (CAR L)))) + ($NOUNIFY '$SUM) ($NOUNIFY '$PRODUCT) + ($NOUNIFY '$INTEGRATE) ($NOUNIFY '$LIMIT) + (DEFPROP $DIFF %DERIVATIVE VERB) (DEFPROP %DERIVATIVE $DIFF NOUN) + '(NOUN properties)) + +(PROGN (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ASSIGN)) + '(($DEBUGMODE DEBUGMODE1) ($BOTHCASES BOTHCASES1) + ($PAGEPAUSE PAGEPAUSE1) ($DSKGC DSKGC1) ($TTYINTFUN TTYINTFUNSETUP) + ($FPPREC FPPREC1) ($POISLIM POISLIM1))) + (MAPC #'(LAMBDA (X) (PUTPROP X 'NEVERSET 'ASSIGN)) (CDR $INFOLISTS)) + (DEFPROP $CONTEXTS NEVERSET ASSIGN) + '(ASSIGN properties)) + +;; Do this last so that all of the preceding forms are evaluated using +;; the standard error handlers and interrupt functions. + +#+MACLISP +(SETQ ERRSET 'ERRBREAK ALARMCLOCK NIL AUTOLOAD 'FIND0 + UNDF-FNCTN 'UUF-HANDLER UNBND-VRBL 'M-UBV-EH WRNG-TYPE-ARG 'M-WTA-EH + UNSEEN-GO-TAG NIL + WRNG-NO-ARGS 'M-WNA-EH FAIL-ACT 'FAILFUN *RSET-TRAP '*RSETFUN) + +#+Franz +(setq errset 'errbreak undf-fnctn 'uuf-handler autoload 'find0) + +#+Franz +(signal 2 'errbreak) ; have errbreak handle interrupts + +#+PDP10 +(SETQ GC-LOSSAGE 'GCLFUN GC-DAEMON 'GCDEMON GC-OVERFLOW 'GCOFUN + PDL-OVERFLOW 'GCLFUN IO-LOSSAGE 'IOLFUN MACHINE-ERROR 'MACHERRFUN) + + +; Undeclarations for the file: +(DECLARE (NOTYPE I N N1 N2 U1)) + +(EVAL-WHEN (EVAL COMPILE) (SETQ BASE OLD-BASE IBASE OLD-IBASE)) + diff --git a/src/lisp/lock.mail b/src/lisp/lock.mail new file mode 100755 index 00000000..4e8ce60e --- /dev/null +++ b/src/lisp/lock.mail @@ -0,0 +1,104 @@ + +MAXTUL 12/17/81 18:12:17 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK MAXTUL) MCLDMP /26) ((DSK LSPDMP) |CL.DMP| /1130)) + +JONL 12/24/81 17:12:24 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK JONL) TS ECL) ((DSK LSPDMP) |CL.DMP| /1130)) + +JONL 12/24/81 17:12:24 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK JONL) TS ECL) ((DSK LSPDMP) |CL.DMP| /1130)) + +JONL 12/24/81 17:12:24 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK JONL) TS ECL) ((DSK JONL) TS ECL) ((DSK LSPDMP) |CL.DMP| /1130)) + +JONL 12/25/81 9:12:25 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK LSPDMP) ECLDMP /1130) ((DSK LSPDMP) |CL.DMP| /1130)) + +JONL 12/25/81 9:12:25 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK LSPDMP) ECLDMP /1130) ((DSK LSPDMP) |CL.DMP| /1130)) + +MAXTUL 1/5/82 19:1:5 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK MAXTUL) MCLDMP /27) ((DSK LSPDMP) |CL.DMP| /1130)) + +MAXTUL 1/5/82 19:1:5 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK MAXTUL) MCLDMP /27) ((DSK LSPDMP) |CL.DMP| /1130)) + +JONL 1/27/82 12:1:27 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK LSPDMP) ECLDMP /1130) ((DSK LSPDMP) |CL.DMP| /1130)) + +WGD 1/30/82 22:1:30 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK FLAVOR) TS CLFLAV) ((DSK LSPDMP) |CL.DMP| /1130)) + +GJC 2/10/82 14:2:10 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK GJC) TS B)) + +GJC 2/10/82 15:2:10 +(/2122 ((DSK LSPDMP) MACDMP /1046) ((DSK GJC) TS B)) + +JONL 2/17/82 21:2:17 +(/2122 ((DSK LSPDMP) MACDMP /1047)) + +JONL 2/17/82 21:2:17 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131)) + +JONL 2/17/82 22:2:17 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131)) + +JONL 2/17/82 22:2:17 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131)) + +JONL 2/18/82 0:2:18 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131)) + +JONL 2/18/82 0:2:18 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) |CL.DMP| /1131)) + +JONL 2/27/82 15:2:27 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) NADMP /1064)) + +JONL 2/27/82 15:2:27 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) NADMP /1066)) + +JONL 2/27/82 15:2:27 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK LSPDMP) NACDMP /1131) ((DSK LSPDMP) |CL.DMP| /1131)) + +MAXTUL 5/30/82 22:5:30 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK MAXTUL) MCLDMP /28) ((DSK LSPDMP) |CL.DMP| /1131)) + +MAXTUL 9/8/82 17:9:8 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK MAXTUL) MCLDMP /29) ((DSK LSPDMP) |CL.DMP| /1131)) + +MAXTUL 9/8/82 18:9:8 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK MAXTUL) MCLDMP /29) ((DSK LSPDMP) |CL.DMP| /1131)) + +WGD 10/14/82 21:10:14 +(/2122 ((DSK LSPDMP) SHBDMP |47.122|)) + +WGD 10/17/82 22:10:17 +(/2122 ((DSK LSPDMP) SHBDMP |47.122|) ((DSK FLAVOR) TS NNFLAV)) + +WGD 10/17/82 22:10:17 +(/2122 ((DSK LSPDMP) SHBDMP |45.122|) ((DSK FLAVOR) TS NNFLAV)) + +MAXTUL 3/22/83 0:3:22 +(/2122 ((DSK LSPDMP) MACDMP /1047) ((DSK MAXTUL) MCLDMP /30) ((DSK LSPDMP) |CL.DMP| /1131)) + + +ALAN 6/16/83 17:6:16 +(/2138 ((DSK LSPDMP) MACDMP /1048)) + +ALAN 6/16/83 17:6:16 +(/2138 ((DSK LSPDMP) SHBDMP |47.138|)) + +ALAN 6/16/83 18:6:16 +(/2138 ((DSK LSPDMP) SHBDMP |47.138|) ((DSK LSPDMP) |CL.DMP| /1134)) + +ALAN 6/16/83 19:6:16 +(/2138 ((DSK LSPDMP) MACDMP /1048) ((DSK LSPDMP) |CL.DMP| /1135)) + +MAXTUL 7/24/83 1:7:24 +(/2138 ((DSK LSPDMP) MACDMP /1048) ((DSK MAXTUL) MCLDMP /31) ((DSK LSPDMP) |CL.DMP| /1135)) + +MAXTUL 7/24/83 2:7:24 +(/2138 ((DSK LSPDMP) MACDMP /1048) ((DSK MAXTUL) MCLDMP /31) ((DSK LSPDMP) |CL.DMP| /1135)) + \ No newline at end of file diff --git a/src/macrak/logarc.27 b/src/macrak/logarc.27 new file mode 100644 index 00000000..70df0fed --- /dev/null +++ b/src/macrak/logarc.27 @@ -0,0 +1,55 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module logarc) + +;;; Logarc and Halfangles + +(defmfun $logarc (exp) + (cond ((atom exp) exp) + ((arcp (caar exp)) (logarc (caar exp) ($logarc (cadr exp)))) + ((eq (caar exp) '$atan2) + (logarc '%atan ($logarc (div (cadr exp) (caddr exp))))) + (t (recur-apply #'$logarc exp)))) + +(defmfun logarc (f x) + ;;Gives logarithmic form of arc trig and hyperbolic functions + (let ((s (memq f '(%acos %atan %asinh %atanh)))) + (cond + ((memq f '(%acos %asin)) + (mul (min%i) + (take '(%log) + (add (mul (if s '$%i 1) + (root (add 1 (neg (power x 2))) 2)) + (mul (if s 1 '$%i) x))))) + ((memq f '(%atan %acot)) + (mul (i//2) + (take '(%log) (div (add 1 (morp s (mul '$%i x))) + (add (mul '$%i x) (porm s 1)))))) + ((memq f '(%asinh %acosh)) + (take '(%log) (add x (root (add (power x 2) (porm s 1)) 2)))) + ((memq f '(%atanh %acoth)) + (mul (half) (take '(%log) (div (add 1 x) (morp s (add x -1)))))) + ((memq f '(%asec %acsc %asech %acsch)) + (logarc (get (get (get f '$inverse) 'recip) '$inverse) (inv x))) + (t (merror "Bad argument to Logarc"))))) + +(defun halfangle (f a) + (and (mtimesp a) + (ratnump (cadr a)) + (equal (caddr (cadr a)) 2) + (halfangleaux f (mul 2 a)))) + +(defun halfangleaux (f a) ;; f=function; a=twice argument + (let ((sw (memq f '(%cos %cot %coth %cosh)))) + (cond ((memq f '(%sin %cos)) + (power (div (add 1 (porm sw (take '(%cos) a))) 2) (1//2))) + ((memq f '(%tan %cot)) + (div (add 1 (porm sw (take '(%cos) a))) (take '(%sin) a))) + ((memq f '(%sinh %cosh)) + (power (div (add (take '(%cosh) a) (porm sw 1)) 2) (1//2))) + ((memq f '(%tanh %coth)) + (div (add (take '(%cosh) a) (porm sw 1)) (take '(%sinh) a))) + ((memq f '(%sec %csc %sech %csch)) + (inv (halfangleaux (get f 'recip) a)))))) diff --git a/src/macrak/rpart.263 b/src/macrak/rpart.263 new file mode 100644 index 00000000..a55448f7 --- /dev/null +++ b/src/macrak/rpart.263 @@ -0,0 +1,509 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module rpart) + +;;; Complex variable utilities +;;; +;;; Macsyma functions: $realpart $imagpart $rectform $polarform +;;; $cabs $carg +;;; Utility functions: trisplit risplit absarg cabs andmapc andmapcar + +(load-macsyma-macros rzmac) + +(declare (special negp* $%emode $radexpand rp-polylogp + $domain $m1pbranch $logarc rischp $keepfloat) + (*lexpr $expand) + (genprefix ~rp)) + +(defmvar implicit-real nil "If t RPART assumes radicals and logs + of real quantities are real and doesn't ask sign questions") + +(defmvar generate-atan2 t "Controls whether RPART will generate ATAN's + or ATAN2's, default is to make ATAN2's") + +(defmfun $realpart (xx) (car (trisplit xx))) + +(defmfun $imagpart (xx) (cdr (trisplit xx))) + +;;;Rectform gives a result of the form a+b*%i. + +(defmfun $rectform (xx) + (let ((ris (trisplit xx))) + (add (car ris) (mul (cdr ris) '$%i)))) + +;;;Polarform gives a result of the form a*%e^(%i*b). + +(defmfun $polarform (xx) + (cond ((and (not (atom xx)) (memq (caar xx) '(mequal mlist $matrix))) + (cons (car xx) (mapcar '$polarform (cdr xx)))) + (t ((lambda (aas $%emode) + (mul (car aas) (powers '$%e (mul '$%i (cdr aas))))) + (absarg xx) nil)))) + +;;; Cabs gives the complex absolute value. Nota bene: an expression may +;;; be syntactically real without being real (e.g. sqrt(x), x<0). Thus +;;; Cabs must lead an independent existence from Abs. + +(defmfun $cabs (xx) (cabs xx)) + +;;; Carg gives the complex argument. +(defmfun $carg (xx) (cdr (absarg xx))) + +(defvar absflag nil) + +;; The function of Absflag is to communicate to Absarg that only the absolute +;; value part of the result is wanted. This allows Absarg to avoid asking +;; questions irrelevant to the absolute value. For instance, Cabs(x) is +;; invariably Abs(x), while the complex phase may be 0 or %pi. Note also +;; the steps taken in Absarg to assure that Asksign's will happen before Sign's +;; as often as possible, so that, for instance, Abs(x) can be simplified to +;; x or -x if the sign of x must be known for some other reason. These +;; techniques, however, are not perfect. + +;; The internal cabs, used by other Macsyma programs. +(defmfun cabs (xx) (let ((absflag t)) (car (absarg xx)))) + +;; Some objects can only appear at the top level of a legal simplified +;; expression: CRE forms and equations in particular. + +(defmfun trisplit (el) ;Top level of risplit + (cond ((atom el) (risplit el)) + ((specrepp el) (trisplit (specdisrep el))) + ((eq (caar el) 'mequal) (dot-sp-ri (cdr el) '(mequal simp))) + (t (risplit el)))) + +;;; Auxiliaries + +;; These are Macsyma equivalents to (mapcar 'trisplit ...). They must +;; differ from other maps for two reasons: the lists are Macsyma lists, +;; and therefore prefixed with list indicators; and the results must +;; be separated: ((a . b) (c . d)) becomes something like ([a,c].[b,d]). + +(defun dsrl (el) (dot-sp-ri (cdr el) '(mlist simp))) + +(defun dot-sp-ri (el ind) + (dot--ri (mapcar 'trisplit el) ind)) + +;; Dot--ri does the ((a.b)(c.d))->([a,c].[b,d]) transformation with +;; minimal Cons'ing. + +(defun dot--ri (el ind) + (do ((i el (cdr i)) (k)) + ((null i) (cons (cons ind (nreverse k)) (cons ind el))) + ((lambda (cdari) (setq k (rplacd (car i) k)) + (rplaca i cdari)) + (cdar i)))) + +(defun risplit-mplus (l) + (do ((rpart) (ipart) (m (cdr l) (cdr m))) + ((null m) (cons (addn rpart t) (addn ipart t))) + ((lambda (sp) + (cond ((=0 (car sp))) + (t (setq rpart (cons (car sp) rpart)))) + (cond ((=0 (cdr sp))) + (t (setq ipart (cons (cdr sp) ipart))))) + (risplit (car m))))) + +(defun risplit-times (l) + ((lambda (risl) + (cond ((null (cdr risl)) (cons (muln (car risl) t) 0)) + (t (do ((rpart 1) (ipart 0) (m (cdr risl) (cdr m))) + ((null m) + (cons (muln (cons rpart (car risl)) t) + (muln (cons ipart (car risl)) t))) + (psetq rpart (sub (mul rpart (caar m)) + (mul ipart (cdar m))) + ipart (add (mul ipart (caar m)) + (mul rpart (cdar m)))))))) + (do ((purerl nil) (compl nil) (l (cdr l) (cdr l))) + ((null l) (cons purerl compl)) + ;;This is what Risl is bound to + ((lambda (sp) + (cond ((=0 (cdr sp)) (setq purerl (rplacd sp purerl))) + ((or (atom (car sp)) (atom (cdr sp))) + (setq compl (cons sp compl))) + ((and (eq (caaar sp) 'mtimes) +;;;Try risplit z/w and notice denominator. If this check were not made, +;;; the real and imaginary parts would not each be over a common denominator. + (eq (caadr sp) 'mtimes) + ((lambda (nr ni) + (cond ((equal (car nr) (car ni)) + (setq + purerl (cons (car nr) purerl) + compl + (cons (cons (muln (nreverse (cdr nr)) t) + (muln (nreverse (cdr ni)) t)) + compl))) + (t (nreverse nr) (nreverse ni) nil))) + (nreverse (cdar sp)) + (nreverse (cddr sp))))) + (t (setq compl (cons sp compl))))) + (risplit (car l)))))) + +(defun risplit-expt (l) + ((lambda (pow $radexpand ris) ; Don't want 'simplifications' like + (cond ; Sqrt(-x) -> %i*sqrt(x) + ((eq (typep pow) 'fixnum) + ((lambda (sp) + (cond ((= pow -1) + ((lambda (a2+b2) + (cons (div (car sp) a2+b2) + (mul -1 (div (cdr sp) a2+b2)))) + (spabs sp))) + ((> (abs pow) $maxposex) + (cond ((=0 (cdr sp)) (cons (powers (car sp) pow) 0)) + (t ((lambda (abs^n natan) + (cons (mul abs^n + (take '(%cos) natan)) + (mul abs^n (take '(%sin) natan)))) + (powers (add (powers (car sp) 2) + (powers (cdr sp) 2)) + (*red pow 2)) + (mul pow (genatan (cdr sp) (car sp))))))) + ((> pow 0) (expanintexpt sp pow)) + (t ((lambda (abbas basspli) + (cons (div (car basspli) abbas) + (neg (div (cdr basspli) abbas)))) + (powers (spabs sp) (- pow)) + (expanintexpt sp (- pow)))))) + (risplit (cadr l)))) + ((and (ratnump pow) + (eq (typep (cadr pow)) 'fixnum) + (not (< (cadr pow) (- $maxnegex))) + (not (> (cadr pow) $maxposex)) + (prog2 (setq ris (risplit (cadr l))) + (or (= (caddr pow) 2) (=0 (cdr ris))))) + (cond ((=0 (cdr ris)) + (caseq (cond ((mnegp (car ris)) '$negative) + (implicit-real '$positive) + (t (asksign (car ris)))) + ($negative (risplit (mul2 (power -1 pow) (power (neg (car ris)) pow)))) + ($zero (cons (power 0 pow) 0)) + (t (cons (power (car ris) pow) 0)))) + (t ((lambda (abs2 n pos?) + ((lambda (abs) + (divcarcdr + (expanintexpt + (cons (power (add abs (car ris)) (1//2)) + (porm ((lambda (a b) (cond (a (not b)) (b t))) ;Xor + pos? (eq (asksign (cdr ris)) '$negative)) + (power (sub abs (car ris)) (1//2)))) + n) + (cond (pos? (power 2 (div n 2))) + (t (power (mul 2 abs2) (div n 2)))))) + (power abs2 (1//2)))) + (spabs ris) (abs (cadr pow)) (> (cadr pow) -1))))) + ((and (floatp (setq ris (cadr l))) (floatp pow)) + (risplit ((lambda ($numer) (exptrl ris pow)) t))) + (t ((lambda (sp aa) + ;;If all else fails, we use the trigonometric form. + (cond ((and (=0 (cdr sp)) (=0 (cdr aa))) (cons l 0)) + (t ((lambda (pre post) + (cons (mul pre (take '(%cos) post)) + (mul pre (take '(%sin) post)))) + (mul (powers '$%e (mul (cdr aa) (mul (cdr sp) -1))) + (powers (car aa) (car sp))) + (add (mul (cdr sp) (take '(%log) (car aa))) + (mul (car sp) (cdr aa))))))) + (risplit (caddr l)) (absarg1 (cadr l)))))) + (caddr l) nil nil)) + +(defun risplit-noun (l) + (cons (simplify (list '(%realpart) l)) (simplify (list '(%imagpart) l)))) + +(defun absarg1 (arg) + (let (arg1 ($keepfloat t)) + (cond ((or (free arg '$%i) + (free (setq arg1 (sratsimp arg)) '$%i)) + (if arg1 (setq arg arg1)) + (if implicit-real + (cons arg 0) + (unwind-protect + (prog2 (assume `(($notequal) ,arg 0)) + (absarg arg)) + (forget `(($notequal) ,arg 0))))) + (t (absarg arg))))) + +;;; Main function +;;; Takes an expression and returns the dotted pair +;;; ( . ). + +(defun risplit (l) + (let (($domain '$complex) ($m1pbranch t) $logarc op) + (cond + ((atom l) (cond ((eq l '$%i) (cons 0 1)) + ((decl-complexp l) (risplit-noun l)) + (t (cons l 0)))) + ((eq (caar l) 'rat) (cons l 0)) + ((eq (caar l) 'mplus) (risplit-mplus l)) + ((eq (caar l) 'mtimes) (risplit-times l)) + ((eq (caar l) 'mexpt) (risplit-expt l)) + ((eq (caar l) '%log) + (let ((aa (absarg1 (cadr l)))) + (rplaca aa (take '(%log) (car aa))))) + ((eq (caar l) 'bigfloat) (cons l 0)) ;All numbers are real. + ((and (memq (caar l) '(%integrate %derivative %laplace %sum)) + (freel (cddr l) '$%i)) + (let ((ris (risplit (cadr l)))) + (cons (simplify (list* (ncons (caar l)) (car ris) (cddr l))) + (simplify (list* (ncons (caar l)) (cdr ris) (cddr l)))))) + (((lambda (ass) +;;;This clause handles the very similar trigonometric and hyperbolic functions. +;;; It is driven by the table at the end of the lambda. + (and ass + ((lambda (ri) + (cond ((=0 (cdr ri)) ;Pure real case. + (cons (take (list (car ass)) (car ri)) 0)) + (t (cons (mul (take (list (car ass)) (car ri)) + (take (list (cadr ass)) (cdr ri))) + (negate-if (eq (caar l) '%cos) + (mul (take (list (caddr ass)) + (car ri)) + (take (list (cdddr ass)) + (cdr ri)))))))) + (risplit (cadr l))))) + (assq (caar l) + '((%sin %cosh %cos . %sinh) + (%cos %cosh %sin . %sinh) + (%sinh %cos %cosh . %sin) + (%cosh %cos %sinh . %sin))))) + ((memq (caar l) '(%tan %tanh)) + ((lambda (sp) +;;;The similar tan and tanh cases. + (cond ((=0 (cdr sp)) (cons l 0)) + (t + ((lambda (2rl 2im) + ((lambda (denom) + (cond ((eq (caar l) '%tan) + (cons (mul (take '(%sin) 2rl) denom) + (mul (take '(%sinh) 2im) denom))) + (t (cons (mul (take '(%sinh) 2rl) denom) + (mul (take '(%sin) 2im) denom))))) + (inv (cond ((eq (caar l) '%tan) + (add (take '(%cosh) 2im) (take '(%cos) 2rl))) + (t (add (take '(%cos) 2im) (take '(%cosh) 2rl))))))) + (mul (car sp) 2) + (mul (cdr sp) 2)) ))) + (risplit (cadr l)))) + ((and (memq (caar l) '(%atan %csc %sec %cot %csch %sech %coth)) + (=0 (cdr (risplit (cadr l))))) + (cons l 0)) + ((and (eq (caar l) '$atan2) (=0 (cdr (risplit (div (cadr l) (caddr l)))))) + (cons l 0)) + ((or (arcp (caar l)) (eq (caar l) '$atan2)) + (let ((ans (risplit ((lambda ($logarc) (ssimplifya l)) t)))) + (cond ((eq (caar l) '$atan2) + (setq ans (cons (sratsimp (car ans)) (sratsimp (cdr ans)))))) + (cond ((and (free l '$%i) (=0 (cdr ans))) (cons l 0)) (t ans)))) + ((eq (caar l) '%plog) + ; (princ '|Warning: Principal value not guaranteed for Plog in Rectform/ + ;|) + (risplit (cons '(%log) (cdr l)))) + ((memq (caar l) '(%realpart %imagpart mabs)) (cons l 0)) + ((eq (caar l) '%erf) + (let ((ris (risplit (cadr l))) orig cc) + (setq orig (simplify (list '(%erf) (add (car ris) (mul '$%i (cdr ris)))))) + (setq cc (simplify (list '(%erf) (sub (car ris) (mul '$%i (cdr ris)))))) + (cons (div (add orig cc) 2) (div (sub orig cc) (mul 2 '$%i))))) +;;; ^ All the above are guaranteed pure real. +;;; The handling of lists and matrices below has to be thought through. + ((eq (caar l) 'mlist) (dsrl l)) + ((eq (caar l) '$matrix) + (dot--ri (mapcar 'dsrl (cdr l)) '($matrix simp))) + ((memq (caar l) '(mlessp mleqp mgreaterp mgeqp)) + (let ((ris1 (risplit (cadr l))) (ris2 (risplit (caddr l)))) + (cons (simplify (list (ncons (caar l)) (car ris1) (car ris2))) + (simplify (list (ncons (caar l)) (cdr ris1) (cdr ris2)))))) +;;;The Coversinemyfoot clause covers functions which can be converted +;;; to functions known by risplit, such as the more useless trigonometrics. + (((lambda (foot) (and foot (risplit foot))) + (coversinemyfoot l))) +;;; A MAJOR ASSUMPTION: +;;; All random functions are pure real, regardless of argument. +;;; This is evidently assumed by some of the integration functions. +;;; Perhaps the best compromise is to return 'realpart/'imagpart +;;; under the control of a switch set by the integrators. First +;;; all such dependencies must be found in the integ + ((and rp-polylogp (mqapplyp l) (eq (subfunname l) '$li)) (cons l 0)) + ((prog2 (setq op (if (eq (caar l) 'mqapply) (caaadr l) (caar l))) + (decl-complexp op)) + (risplit-noun l)) + ((and (eq (caar l) '%product) (not (free (cadr l) '$%i))) + (risplit-noun l)) + (t (cons l 0))))) + +(defun coversinemyfoot (l) + (prog (recip) + (cond ((not (memq (caar l) '(%csc %sec %cot %csch %sech %coth)))) + ((null (setq recip (get (caar l) 'recip)))) + (t (return (div 1 (cons (list recip) (cdr l)))))))) + +(defun powers (c d) + (cond ((=1 d) c) + ((equal d 0) 1) ;equal to preclude 0^(pdl 0)->0: + ((=0 c) 0) ; see comment before =0. + ((=1 c) 1) + (t (power c d)))) + +(defun spabs (sp) (add (powers (car sp) 2) (powers (cdr sp) 2))) + +(progn (setq negp* '(nil nil t t) + negp* (nconc negp* negp*)) + 0) + +(defun divcarcdr (a b) (cons (div (car a) b) (div (cdr a) b))) + +(declare (notype (expanintexpt notype fixnum))) + +;Expand bas^n, where bas is ( . ) + +(defun expanintexpt (bas n) + (cond ((= n 1) bas) + (t (do ((rp (car bas)) + (ip (cdr bas)) + (c 1 (quotient (times c ex) i)) + (ex n (1- ex)) (i 1 (1+ i)) + (rori t (not rori)) (negp negp* (cdr negp)) + (rpt nil) (ipt nil)) + ((< ex 0) (cons (addn rpt t) (addn ipt t))) + (declare (fixnum ex i)) + (set-either rpt ipt + rori + (cons (negate-if (car negp) + (mul c + (powers rp ex) + (powers ip (1- i)))) + (cond (rori rpt) (t ipt)))))))) + + + +;;; Subtract out multiples of 2*%pi with a minimum of consing. +;;; Attempts to reduce to interval (-pi,pi]. + +(defun 2pistrip (exp) + (cond ((atom exp) exp) + ((eq (caar exp) 'mtimes) + (cond ((and (mnump (cadr exp)) + (eq (caddr exp) '$%pi) + (null (cdddr exp))) + (cond ((fixp (cadr exp)) ;5*%pi + (mul (abs (remainder (cadr exp) 2)) '$%pi)) + ;Neither 0 nor 1 appears as a coef + ((eq 'rat (caaadr exp)) ;5/2*%pi + (mul (list* '(rat simp) + (sub1 (remainder (add1 (cadadr exp)) + (times 2 (caddadr exp)))) + (cddadr exp)) + '$%pi)) + (t exp))) + (t exp))) + ((eq (caar exp) 'mplus) + ((lambda (res) + (cond ((eq res (cdr exp)) exp) (t (addn res t)))) + (2pirec (cdr exp)))) + (t exp))) + +(defun 2pirec (fm) ;Takes a list of exprs + (cond ((null (cdr fm)) ;If monad, just return. + ((lambda (2pf) + (cond ((eq 2pf (car fm)) fm) + ((=0 2pf) nil) + (t (list 2pf)))) + (2pistrip (car fm)))) + (t ((lambda (2pfma 2pfmd) + (cond ((or (null 2pfmd) (=0 2pfmd)) 2pfma) + ((and (eq 2pfmd (cdr fm)) (eq 2pfma (car fm))) fm) + (t (cons 2pfma 2pfmd)))) + (2pistrip (car fm)) (2pirec (cdr fm)))))) + +;;; Rectify into polar form; Arguments similar to risplit + +(defun argnum (n) (cond ((minusp n) (simplify '$%pi)) (t 0))) + +(defun absarg (l) + (setq l ($expand l)) + (cond ((atom l) + (cond ((eq l '$%i) + (cons 1 (simplify '((mtimes) ((rat simp) 1 2) $%pi)))) + ((numberp l) + (cons (abs l) (argnum l))) + ((memq l '($%e $%pi)) (cons l 0)) + (absflag (cons (take '(mabs) l) 0)) + (t ((lambda (gs) + (cond ((eq gs '$positive) (cons l 0)) + ((eq gs '$zero) (cons 0 0)) + ((eq gs '$negative) + (cons (neg l) (simplify '$%pi))) + (t (cons (take '(mabs) l) 0)))) + (cond ((eq rischp l) '$positive) (t (asksign l))))))) + ((memq (caar l) '(rat bigfloat)) + (cons (list (car l) (abs (cadr l)) (caddr l)) + (argnum (cadr l)))) + ((eq (caar l) 'mtimes) + (do ((n (cdr l) (cdr n)) + (abars) + (argl () (cons (cdr abars) argl)) + (absl () (rplacd abars absl))) + (()) + (cond ((not n) + (return (cons (muln absl t) + (2pistrip (addn argl t)))))) + (setq abars (absarg (car n))))) + ((eq (caar l) 'mexpt) + (let ((aa (absarg (cadr l))) + (sp (risplit (caddr l))) + ($radexpand nil)) + (cons (mul (powers (car aa) (car sp)) + (powers '$%e (neg (mul (cdr aa) (cdr sp))))) + (add (mul (cdr aa) (car sp)) + (mul (cdr sp) (take '(%log) (car aa))))))) + ((and (memq (caar l) '(%tan %tanh)) + (not (=0 (cdr (risplit (cadr l)))))) + ((lambda (sp) + ((lambda (2frst 2scnd) + (cond ((eq (caar l) '%tanh) + (psetq 2frst 2scnd 2scnd 2frst))) + (cons ((lambda (cosh cos) + (root (div (add cosh (neg cos)) + (add cosh cos)) + 2)) + (take '(%cosh) 2frst) + (take '(%cos) 2scnd)) + (take '(%atan) + (cond ((eq (caar l) '%tan) + (div (take '(%sinh) 2frst) + (take '(%sin) 2scnd))) + (t (div (take '(%sin) 2frst) + (take '(%sinh) 2scnd))))))) + (mul (cdr sp) 2) + (mul (car sp) 2))) + (risplit (cadr l)))) + ((specrepp l) (absarg (specdisrep l))) + (((lambda (foot) + (and foot (not (=0 (cdr (risplit (cadr l))))) (absarg foot))) + (coversinemyfoot l))) + (t (let ((ris (trisplit l))) + (xcons +;;; Arguments must be in this order so that the side-effect of the Atan2, +;;; that is, determining the Asksign of the argument, can happen before +;;; Take Mabs does its Sign. Blame JPG for noticing this lossage. + (if absflag 0 (genatan (cdr ris) (car ris))) + (cond ((equal (car ris) 0) (absarg-mabs (cdr ris))) + ((equal (cdr ris) 0) (absarg-mabs (car ris))) + (t (powers ($expand (add (powers (car ris) 2) + (powers (cdr ris) 2)) + 1 0) + (half))))))))) + +(defun genatan (num den) + (let ((arg (take '($atan2) num den))) + (if (or generate-atan2 (free arg '$atan2)) + arg + (take '(%atan) (m// num den))))) + +(defun absarg-mabs (l) + (if (eq (csign l) t) + (if (memq (caar l) '(mabs %cabs)) l (list '(%cabs simp) l)) + (take '(mabs) l))) diff --git a/src/maxdoc/dcl.autold b/src/maxdoc/dcl.autold new file mode 100755 index 00000000..59cac212 --- /dev/null +++ b/src/maxdoc/dcl.autold @@ -0,0 +1,312 @@ + +;;; -*- Mode: Lisp; Package: Macsyma-II; -*- +;;; Macsyma Autoload Declarations +;;; Created by KMP at 11/17/80 3:16:46 + +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) RATLAP FASL) 'AUTOLOAD))) + '(CMOD CPLUS CTIMES CEXPT CRECIP CFACTOR)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) ROMBRG FASL) 'AUTOLOAD))) + '($ROMBERG_SUBR $ROMBERG)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) NUMAPL FASL) 'AUTOLOAD))) + '(FMAPPLY MACSYMACALLP SUBRCALL$P SUBRCALLP)) +(DEFPROP $FASMAK ((DSK MACSYM) FASMAK FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X 'NIL 'AUTOLOAD))) + '($PLOTRESET $PLOTINIT $KILLPLOTS $LOADPLOTS $SAVEPLOTS $NAMEPLOT + $OLDNAMEPLOT $REPLOT4 $REPLOT $LABEL $GRAPH3D $GRAPH2 $PARAMPLOT2 + $CONTOURPLOT2 $PLOT3D $PLOT2)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X 'NIL 'AUTOLOAD))) + '($RENAMEFILE $FILELENGTH $FILELIST $QLISTFILES $LISTFILES $PRINTFILE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) OUTEX FASL) 'AUTOLOAD))) + '($MAP_OVER_INDEX_FILE $READ_NTH_OBJECT + $NUMBER_OF_OBJECTS_IN_INDEX_FILE OUTEX-HOOK-EXP $OPEN_INDEX_FILE + $MAKE_INDEX_FILE)) +(DEFPROP SOLVEQUARTIC NIL AUTOLOAD) +(DEFPROP $SUBLIS ((DSK MACSYM) SUBLIS FASL) AUTOLOAD) +(DEFPROP $GETCHARN ((DSK MACSYM) CHAR FASL) AUTOLOAD) +(DEFPROP SUBSTITUTE NIL AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) BUILDQ FASL) 'AUTOLOAD))) + '(MBUILDQ-SUBST $BUILDQ)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) INMIS FASL) 'AUTOLOAD))) + '($RESET $LISTOFVARS $UNKNOWN)) +(DEFPROP $OPTIONS ((DSK MACSYM) OPTION FASL) AUTOLOAD) +(DEFPROP $PRIMER ((DSK MACSYM) PRIMER FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) SCS FASL) 'AUTOLOAD))) + '($FACOUT $DISTRIB $SCSIMP)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) METER FASL) 'AUTOLOAD))) + '($TIME $RESETCLOCK $PRINTCLOCK $UNCLOCK $CLOCK)) +(DEFPROP $OPTIMIZE ((DSK MACSYM) OPTIM FASL) AUTOLOAD) +(DEFPROP $ZEROEQUIV ((DSK MACSYM) ZERO FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) POIS2 FASL) 'AUTOLOAD))) + '($POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS + $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP + $POISSUBST)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) POIS3 FASL) 'AUTOLOAD))) + '($POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS + $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP + $POISSUBST)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) TLIMIT FASL) 'AUTOLOAD))) + '($TLDEFINT $TLIMIT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) LINNEW FASL) 'AUTOLOAD))) + '($TMINVERSE $TMLIN $TMLINSOLVE $TMNEWDET)) +(DEFPROP $EZGCD ((DSK MACSYM) EZGCD FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) NUMTH FASL) 'AUTOLOAD))) + '($GCFACTOR $JACOBI $TOTIENT $PRIME $DIVSUM)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X 'NIL 'AUTOLOAD))) + '($SUBLIST $MAKELIST)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MAXOUT) PLOT FASL) 'AUTOLOAD))) + '($GRAPH $PLOT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) NEWDET FASL) 'AUTOLOAD))) + '($PERMANENT $NEWDET)) +(DEFPROP $PADE ((DSK MACSYM) PADE FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) NISIMP FASL) 'AUTOLOAD))) + '($LETSIMP $LETRULES $REMLET $LET)) +(DEFPROP $ALLROOTS ((DSK MACSYM) CPOLY FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) SUMCON FASL) 'AUTOLOAD))) + '($NICEINDICES $BASHINDICES $INTOSUM $SUMCONTRACT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) FORTRA FASL) 'AUTOLOAD))) + '($FORTMX $FORTRAN)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) NALGFA FASL) 'AUTOLOAD))) + '($ALGNORM $SPLITFIELD $PFACTORALG $ALGTRACE $DISCR $BDISCR $ALGFAC)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) GRIND FASL) 'AUTOLOAD))) + '(MSTRING $GRIND)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) MTREE FASL) 'AUTOLOAD))) + '($APPLY_NOUNS MTREE-SUBST)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) MATCOM FASL) 'AUTOLOAD))) + '($DEFRULE $TELLSIMPAFTER $TELLSIMP $DEFMATCH $MATCHDECLARE)) +(DEFPROP DIMENSION-SUPERSCRIPT NIL AUTOLOAD) +(DEFPROP $LOGCONTRACT ((DSK MAXOUT) LOGCON FASL) AUTOLOAD) +(DEFPROP $TRIGREDUCE ((DSK MACSYM) TRGRED FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) RPART FASL) 'AUTOLOAD))) + '(TRISPLIT CABS $CARG $CABS $POLARFORM $RECTFORM $IMAGPART $REALPART)) +(DEFPROP $NTERMS ((DSK MAXOUT) NTERMS FASL) AUTOLOAD) +(DEFPROP $COMBINE NIL AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) LOGARC FASL) 'AUTOLOAD))) + '(LOGARC $LOGARC)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) MATRUN FASL) 'AUTOLOAD))) + '(PART* PART+ $REMRULE $APPLYB2 $APPLY2 $APPLYB1 $APPLY1 $DISPRULE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) SERIES FASL) 'AUTOLOAD))) + '($ABSCONVERGE $CONVERGE $POWERSERIES)) +(DEFPROP $APROPOS ((DSK MACSYM) APROPO FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X 'NIL 'AUTOLOAD))) + '(GET-OUT GET-FLIST)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) DSKFN FASL) 'AUTOLOAD))) + '($RESTORE $REMFILE $FASSAVE $STORE $SAVE $UNSTORE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) CSIMP FASL) 'AUTOLOAD))) + '($LHS $RHS $PARTITION $DEMOIVRE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X 'NIL 'AUTOLOAD))) + '($SUBSETP $ELEMENTOF $ELEMENTP $CARDINAL $MAPSET $PREDSET $ELEMENTS + $EMPTYP $UNIVERSE $MAKE_UNIVERSE $SETDIFF $SYMDIFF $INTERSECTION + $UNION $ORDINAL ${)) +(DEFPROP $RESIDUE ((DSK MACSYM) RESIDU FASL) AUTOLOAD) +(DEFPROP $ALGSYS ((DSK MACSYM) ALGSYS FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) MATRIX FASL) 'AUTOLOAD))) + '($TRANSPOSE $SETELMX $ROW $MINOR $COL $TRIANGULARIZE $RANK $ECHELON + $INVERTMX $DIAGMATRIX $IDENT $EMATRIX $DETERMINANT $CHARPOLY $MATRIXP + $AUGCOEFMATRIX $COEFMATRIX $SUBMATRIX)) +(DEFPROP *MERROR ((DSK MACSYM) MERROR FASL) AUTOLOAD) +(DEFPROP $MOD NIL AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) NFORMA FASL) 'AUTOLOAD))) + '(NFORMAT-ALL NFORMAT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) GRAM FASL) 'AUTOLOAD))) + '(DEFINE-SYMBOL RBP LBP ASSOL CPUT A-ATOM)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) COMPAR FASL) 'AUTOLOAD))) + '(RGRP $FEATUREP LIKE $SIGN $ASKSIGN $COMPARE FORGET MLEARN LEARN + ASSUME MEVALP IS $KILLCONTEXT $NEWCONTEXT $MIN $MAX $FACTS + $DEACTIVATE $ACTIVATE $CONTEXT MOR MAND MNOT $FORGET $ASSUME $IS + $SUPCONTEXT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) TRIGI FASL) 'AUTOLOAD))) + '(ACSCH ASECH ACOTH ATANH ASINH ACOSH SECH CSCH COTH TANH COSH SINH + ACSC ASEC ACOT ATAN1 ACOS ASIN CSC SEC COT TAN MMINUSP MZEROP + EXPONENTIALIZE $EXPONENTIALIZE ARCP TRIGP SQ-SUMSQ SQRTX^2-1 + SQRT1+X^2 SQRT1-X^2)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) DB FASL) 'AUTOLOAD))) + '(FETCH KILL UNTRUE FACT TRUE* KINDP FACTP TRUEP CONTEXT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) MLISP FASL) 'AUTOLOAD))) + '($BINOMIAL $GAMMA $ACSCH $ASECH $ACOTH $ATANH $ACOSH $ASINH $ACSC + $ASEC $ACOT $ATAN $ACOS $ASIN $CSCH $SECH $COTH $TANH $COSH $SINH + $CSC $SEC $COT $TAN $COS $SIN $LOG $SQRT DSKRAT MFILEP AUTOLDCHK + BIGFLOATM* ADD2LNC RAT $EXP MRETURN OPTIONP $FUNMAKE MAPPLY1 MOPP1 + MOPP ARRSTORE MGETL MREMPROP MPUTPROP MGET REMALIAS1 REMRULE + REMARRELEM REMPROPCHK REMOVE1 $PUT $REM $GET FUNCER $MAPATOM MMAPEV + NUMERSET MSETCHK MSETERR $SUBVARP MQUOTEP MSETQP MEVALATOMS MSET + MUNBIND MBIND MARGS MOP MEVAL2 MEVAL1 MEVAL MAPPLY $ALLBUT $MATRIX + OUTERMAP1 FMAPL1 DSKSETQ $SUBVAR MGO MPROG MDOIN MDO MCOND $DISPFUN + $APPLY MDEFINE $DEFINE $ARRAY MDEFPROP $REMVALUE $REMARRAY + $REMFUNCTION $REMOVE $DECLARE $QPUT $OUTERMAP $FULLMAPL $MATRIXMAP + $FULLMAP $MAPLIST $MAP MQUOTE $EV MSETQ $LOCAL)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) COMM FASL) 'AUTOLOAD))) + '($LOPOW $HIPOW COEFF $FLOAT $ENTIER $FIX $DENOM $NUM $SYMBOLP $ATOM + $LENGTH $REVERSE $ARGS $LAST $FIRST FORMAT1 ATOMCHK $MEMBER $ENDCONS + $CONS $LISTP LISTERCHK GETOPR GETOP $DISPTERMS MEMALIKE $TRUNC + REMSIMP DELSIMP NTHELEM UNION* SUBSTITUTEL NOTLOREQ ATVARSCHK SDIFF + $DEL RECUR-APPLY SUBST0 SUBSTITUTE $COEFF $DELETE $REST $APPEND + $INPART $PART $DISPFORM $DISP $LDISP $DIFF $DEPENDS $SUBSTITUTE + $SUBSTINPART $SUBSTPART $DISPLAY $LDISPLAY $GRADEF $DEPENDENCIES)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) OPERS FASL) 'AUTOLOAD))) + '(SIMPLIFY MORP PORM ROOT NCPOWER POWER* POWER NCMULN NCMUL2 DIV* DIV + MULN MUL3 MUL2* MUL2 SUB* SUB NEG ADDN ADD2* ADD2)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) UTILS FASL) 'AUTOLOAD))) + '(LOG2 ASSQR FIRSTN NXTTOLAST RECONC AMONGL AMONG XOR ANDMAPCAR ORMAPC + ANDMAPC MAP2C)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) ASUM FASL) 'AUTOLOAD))) + '($GENFACT $SUM $DEFTAYLOR)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) ERMSGM FASL) 'AUTOLOAD))) + '(CHECK-OUT-OF-CORE-STRING ALLOCATE-MESSAGE-INDEX)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) MFORMT FASL) 'AUTOLOAD))) + '(DISPLAF *MFORMAT)) +(DEFPROP $DESCRIBE ((DSK MACSYM) DESCRI FASL) AUTOLOAD) +(DEFPROP $BFLOAT ((DSK MACSYM) FLOAT FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) ASKP FASL) 'AUTOLOAD))) + '(ASK-INTEGER $ASKINTEGER)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) RESULT FASL) 'AUTOLOAD))) + '($BEZOUT $DISCRIMINANT $RESULTANT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) POLYRZ FASL) 'AUTOLOAD))) + '($NROOTS $REALROOTS)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) LAPLAC FASL) 'AUTOLOAD))) + '($ILT $LAPLACE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) SYNEX FASL) 'AUTOLOAD))) + '($NOFIX $MATCHFIX $NARY $INFIX $POSTFIX $PREFIX)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) MMACRO FASL) 'AUTOLOAD))) + '(SIMPMDEFMACRO (MMACROEXPANDED MACRO) MMACRO-APPLY $MACROEXPAND1 + $MACROEXPAND MDEFMACRO)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) TRANSS FASL) 'AUTOLOAD))) + '($TRANSLATE $TRANSLATE_FILE $COMPFILE)) +(DEFPROP $POLYDECOMP NIL AUTOLOAD) +(DEFPROP $RISCH ((DSK MACSYM) RISCH FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) DISPLA FASL) 'AUTOLOAD))) + '(CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO DIMENSION-SUPERSCRIPT + DIMENSION-NOFIX DIMENSION-POSTFIX DIMENSION-NARY DIMENSION-INFIX + DIMENSION-PREFIX MAKESTRING DIMENSION-ATOM DISPLA)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) SUPRV FASL) 'AUTOLOAD))) + '($DSKGC $PAGEPAUSE $FILEDEFAULTS $DDT $LOGOUT $QUIT $TO_LISP $THROW + $UUO $%TH $POISLIM $FPPREC DOLLARIFY-NAME $VERBIFY $NOUNIFY PRINL + ERLIST1 ERREXP NONVARCHK NONSYMCHK FEXPRCHK ASCII-NUMBERP ALPHABETP + ERRBREAK $DEBUGMODE RULEOF REMVALUE REMLABELS KILL1 BATCH1 FILEPRINT + CARFILE MTRUENAME TRUEFNAME LOADFILE $SET_FILEDEFAULTS FILENAMEL + MFBOUNDP DOLLARIFY FIND0 LOAD-FUNCTION FIND-FUNCTION $BOTHCASES + $BREAK $ERROR $RANDOM $READONLY $READ $PRINT $ALLOC $SSTATUS $STATUS + $DELFILE $CLOSEFILE $APPENDFILE $WRITEFILE $TIME $CATCH $ERRCATCH + $LABELS $STRINGOUT $STRING $ALIAS $PLAYBACK $TOBREAK $KILL $DEMO + $BATCH $BATCON $SETUP_AUTOLOAD $LOADFILE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) NRAT4 FASL) 'AUTOLOAD))) + '($RADCAN FREEOF ARGSFREEOF $BOTHCOEF $RATSUBST $FREEOF $RATCOEF)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X 'NIL 'AUTOLOAD))) + '($CLEARSCREEN $PAUSE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) LIMIT FASL) 'AUTOLOAD))) + '($LDEFINT $LIMIT)) +(DEFPROP $TRIGEXPAND NIL AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) RAT3B FASL) 'AUTOLOAD))) + '(RATQUOTIENT RATREDUCE RATPLUS RATEXPT RATTIMES RATMINUS RATFACT + RATDIF RATABS RATDERIVATIVE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) RAT3C FASL) 'AUTOLOAD))) + '(PDEGREE $PRIMEP PGCD1 PQUOTIENTCHK)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) RAT3D FASL) 'AUTOLOAD))) + '(PABS $NTHROOT $INRT $ISQRT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) RAT3A FASL) 'AUTOLOAD))) + '(PTIMES PQUOTIENT PMOD PMINUSP PMINUS PDERIVATIVE PDIFFERENCE PPLUS)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) RAT3E FASL) 'AUTOLOAD))) + '($RATDISREP RATIONALIZE RATF $RATEXPAND $GFACTOR $SQFR $TOTALDISREP + $SHOWRATVARS $PRINTVARLIST $RATDENOM $RATNUMER POINTERGP $CONTENT + $GCD $REMAINDER $QUOTIENT $DIVIDE $MOD FACTOR $FACTOR $RATSIMP $RAT + $FULLRATSIMP $RATVARS $TELLRAT)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) SIMP FASL) 'AUTOLOAD))) + '(SIMPARGS1 BPROG SIMPNRT ALIKE ALIKE1 SIMPMQAPPLY $ORDERGREATP + $ORDERLESSP SIMPMATRIX SIMPEXPT EXPTRL SIMPSIGNUM SIMPDERIV INFSIMP + SIMPMDEF SIMPLAMBDA SIMPEXP SIMPBIGFLOAT SIMPINTEG SIMP-LIMIT + SIMPTIMES SIMPABS SIMPQUOT SIMPSQRT SIMPLN SIMPLUS TIMESK ADDK + SIMPARGS SSIMPLIFYA EQTEST SIMPLIFYA FREEARGS FREE CONSTFUN + $NONSCALARP $SCALARP $CONSTANTP $NUMFACTOR SUBFUNARGS SUBFUNSUBS + SUBFUNNAME SUBFUNMAKE SUBFUNMAKES SUBARGCHECK WNA-ERR TWOARGCHK + ONEARGCHK TWOARGCHECK ONEARGCHECK $POLYSIGN SPECDISREP SPECREPP $RATP + $RATNUMP $FLOATNUMP $EVENP $ODDP $INTEGERP $NUMBERP SIMPCHECK + SRATSIMP RATDISREP MQAPPLYP MNEGP MLOGP MNCEXPTP MNCTIMESP MEXPTP + MTIMESP MPLUSP RATNUMP EVEN MNUMP $BFLOATP MINUS1P1 ZEROP1 ONEP1 ONEP + $INTEGRATE $EXPAND $MULTTHRU)) +(DEFPROP $PFET NIL AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) TRMODE FASL) 'AUTOLOAD))) + '(CHEKVALUE $MODEDECLARE $MODE_IDENTITY $DEFINE_VARIABLE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) HAYAT FASL) 'AUTOLOAD))) + '($TAYLORINFO $TAYLOR)) +(DEFPROP DSKRAT NIL AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X 'NIL 'AUTOLOAD))) + '($GETCHAR $CONCAT)) +(DEFPROP $XTHRU NIL AUTOLOAD) +(DEFPROP $MOD NIL AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) SOLVE FASL) 'AUTOLOAD))) + '($LINSOLVE $SOLVE)) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) ACALL FASL) 'AUTOLOAD))) + '(MAPPLY-TR INSURE-ARRAY-PROPS $ARRAYSETAPPLY $ARRAYAPPLY + DISPLAY-FOR-TR MARRAYSET MARRAYREF MFUNCALL)) +(DEFPROP $TR_WARNINGS_GET ((DSK MACSYM) FCALL FASL) AUTOLOAD) +(MAPC (FUNCTION (LAMBDA (X) + (PUTPROP X '((DSK MACSYM) TRANSL FASL) 'AUTOLOAD))) + '(TRANSLATE-MACEXPR-TOPLEVEL TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION)) \ No newline at end of file diff --git a/src/maxdoc/dcl.fctns b/src/maxdoc/dcl.fctns new file mode 100644 index 00000000..521651c1 --- /dev/null +++ b/src/maxdoc/dcl.fctns @@ -0,0 +1,887 @@ +;; -*- Mode: Lisp; Package: Macsyma -*- +;; Declaration file for external functions known throughout Macsyma. +;; This file was generated by DEFINE version NIL. + +;; Declarations for RAT;RATLAP >, inserted manually 11/10/80 by CWH. +(DECLARE (COMMENT RATLAP)) +(DECLARE (*EXPR CMOD CPLUS CTIMES CEXPT CRECIP CFACTOR)) + +;; Declarations for MAXSRC;FASMAK 2, compiled 6/19/80 2:08 by GJC. +(DECLARE (COMMENT FASMAK)) +(DECLARE (*FEXPR $FASMAK)) + +;; Declarations for RAB;PSOLVE 19, compiled 7/25/80 0:42 by CWH. +(DECLARE (COMMENT PSOLVE)) +(DECLARE (*EXPR SOLVEQUARTIC)) + +;; Declarations for MAXSRC;CHAR 2, compiled 8/11/80 15:55 by GJC. +(DECLARE (COMMENT CHAR)) +(DECLARE (*EXPR $GETCHARN)) + +;; Declarations for JPG;PLOT 63, compiled 9/3/80 2:04 by JPG. +(DECLARE (COMMENT PLOT)) +(DECLARE (*FEXPR $GRAPH $PLOT)) + +;; Declarations for MAXSRC;MTREE 1, compiled 9/11/80 20:14 by GJC. +(DECLARE (COMMENT MTREE)) +(DECLARE (*EXPR $APPLY_NOUNS MTREE-SUBST)) + +;; Declarations for JPG;DISP1 1, compiled 9/14/80 12:42 by JPG. +(DECLARE (COMMENT DISP1)) +(DECLARE (*EXPR DIMENSION-SUPERSCRIPT)) + +;; Declarations for JPG;AC 1, compiled 10/14/80 5:58 by JPG. +(DECLARE (COMMENT AC)) +(DECLARE (*EXPR $COMBINE)) + +;; Declarations for MAXSRC;MESRUN 9, compiled 10/23/80 3:47 by GJC. +(DECLARE (COMMENT MESRUN)) +(DECLARE (*EXPR GET-OUT GET-FLIST)) + +;; Declarations for MAXSRC;SETS 10, compiled 10/28/80 23:37 by GJC. +(DECLARE (COMMENT SETS)) +(DECLARE (*EXPR $SUBSETP $ELEMENTOF $ELEMENTP $CARDINAL $MAPSET $PREDSET + $ELEMENTS $EMPTYP $UNIVERSE $MAKE_UNIVERSE)) +(DECLARE (*LEXPR $SETDIFF $SYMDIFF $INTERSECTION $UNION $ORDINAL ${)) + +;; Declarations for RZ;COMBIN 139, compiled 11/8/80 3:11 by JPG. +(DECLARE (COMMENT COMBIN)) +(DECLARE (*EXPR $POLYDECOMP)) + +;; Declarations for RAB;OUTMIS 289, compiled 11/10/80 6:19 by JPG. +(DECLARE (COMMENT OUTMIS)) +(DECLARE (*EXPR $CLEARSCREEN)) +(DECLARE (*LEXPR $PAUSE)) + +;; Declarations for MRG;TRIGO 326, compiled 11/10/80 15:48 by JPG. +(DECLARE (COMMENT TRIGO)) +(DECLARE (*EXPR $TRIGEXPAND)) + +;; Declarations for PAULW;CSIMP2 46, compiled 11/14/80 4:53 by JPG. +(DECLARE (COMMENT CSIMP2)) +(DECLARE (*EXPR $XTHRU)) + +;; Declarations for MAXSRC;FCALL 36, compiled 11/15/80 19:08 by KMP. +(DECLARE (COMMENT FCALL)) +(DECLARE (*EXPR $TR_WARNINGS_GET)) + +;; Declarations for RAT;RATOUT 62, compiled 11/18/80 17:09 by BMT. +(DECLARE (COMMENT RATOUT)) +(DECLARE (*EXPR $PFET)) + +;; Declarations for DAS;MSTUFF 18, compiled 11/20/80 4:26 by JPG0. +(DECLARE (COMMENT MSTUFF)) +(DECLARE (*EXPR $SUBLIST)) +(DECLARE (*FEXPR $MAKELIST)) + +;; Declarations for SHARE;FILEOP 18, compiled 11/26/80 3:00 by JPG. +(DECLARE (COMMENT FILEOP)) +(DECLARE (*FEXPR $RENAMEFILE $FILELENGTH $FILELIST $QLISTFILES $LISTFILES + $PRINTFILE)) + +;; Declarations for RAT;RESULT 20, compiled 12/9/80 21:41 by BMT. +(DECLARE (COMMENT RESULT)) +(DECLARE (*EXPR $BEZOUT $DISCRIMINANT $RESULTANT)) + +;; Declarations for ELLEN;OPTION 87, compiled 12/11/80 6:40 by JPG. +(DECLARE (COMMENT OPTION)) +(DECLARE (*FEXPR $OPTIONS)) + +;; Declarations for MAXSRC;NUMAPL 9, compiled 1/12/81 19:20 by GJC. +(DECLARE (COMMENT NUMAPL)) +(DECLARE (*EXPR MACSYMACALLP SUBRCALL$P SUBRCALLP)) +(DECLARE (*LEXPR FMAPPLY)) + +;; Declarations for JPG;F293 9, compiled 1/13/81 4:32 by JPG. +(DECLARE (COMMENT F293)) +(DECLARE (*EXPR DEFINE-SYMBOL)) + +;; Declarations for MAXSRC;OUTEX1 30 (OUTEX split), compiled 1/30/81 23:12 by GJC. +(DECLARE (COMMENT OUTEX1)) +(DECLARE (*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE)) + +;; Declarations for MAXSRC;OUTEX2 30 (OUTEX split), compiled 1/30/81 23:13 by GJC. +(DECLARE (COMMENT OUTEX2)) +(DECLARE (*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT + $NUMBER_OF_OBJECTS_IN_INDEX_FILE $OPEN_INDEX_FILE)) + +;; Declarations for MAXSRC;OUTEX 36, compiled 2/6/81 0:16 by GJC. +(DECLARE (COMMENT OUTEX)) +(DECLARE (*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE)) + +;; Declarations for MAXSRC;OUTEY 36 (OUTEX split), compiled 2/6/81 0:17 by GJC. +(DECLARE (COMMENT OUTEY)) +(DECLARE (*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $INDEX_FILE_DIM + $OPEN_INDEX_FILE)) + +;; Declarations for JPG;F294 20, compiled 2/8/81 8:02 by JPG. +(DECLARE (COMMENT F294)) +(DECLARE (*EXPR MMINUSP*)) + +;; Declarations for JPG;GRAPH2 65 (PLOT split), compiled 2/12/81 6:49 by JPG. +(DECLARE (COMMENT GRAPH2)) +(DECLARE (*FEXPR $MULTIGRAPH $PARAMPLOT)) + +;; Declarations for JPG;GRAPH 65 (PLOT split), compiled 2/12/81 6:49 by JPG. +(DECLARE (COMMENT GRAPH)) +(DECLARE (*FEXPR $GRAPH $PLOT)) + +;; Declarations for MAXSRC;MTAGS 9, compiled 2/17/81 19:33 by GJC. +(DECLARE (COMMENT MTAGS)) +(DECLARE (*EXPR $TAG_FILE_INSERT)) + +;; Declarations for ELLEN;PRIMER 223, compiled 3/2/81 6:15 by JPG. +(DECLARE (COMMENT PRIMER)) +(DECLARE (*FEXPR $PRIMER)) + +;; Declarations for MAXSRC;SUSPEN 13, compiled 3/15/81 23:01 by GJC. +(DECLARE (COMMENT SUSPEN)) +(DECLARE (*LEXPR $SUSPEND)) + +;; Declarations for RZ;PRODCT 144 (COMBIN split), compiled 4/9/81 7:50 by JPG. +(DECLARE (COMMENT PRODCT)) +(DECLARE (*FEXPR $PRODUCT)) + +;; Declarations for JPG;F296 41, compiled 4/29/81 7:02 by JPG. +(DECLARE (COMMENT F296)) +(DECLARE (*EXPR *MERROR-1)) + +;; Declarations for MAXSRC;DESCRI 51, compiled 4/30/81 6:42 by JPG. +(DECLARE (COMMENT DESCRI)) +(DECLARE (*EXPR MDESCRIBE)) +(DECLARE (*FEXPR $DESCRIBE)) + +;; Declarations for MAXSRC;TRMODE 63, compiled 5/5/81 6:24 by JPG. +(DECLARE (COMMENT TRMODE)) +(DECLARE (*EXPR FLUIDIZE ASS-EQ-SET ASSIGN-MODE-CHECK)) +(DECLARE (*LEXPR CHEKVALUE ASS-EQ-REF)) + +;; Declarations for MEM;RES 30, compiled 6/9/81 16:48 by MEM. +(DECLARE (COMMENT RES)) +(DECLARE (*EXPR $ISIMPTEST $RSIMPTEST $ITEFFA $RTEFFA $TEFFS $IRES $RRES $NUPP + $NUP $NU)) + +;; Declarations for TRANSL;TRDEBG 8, compiled 6/19/81 5:15 by JPG. +(DECLARE (COMMENT TRDEBG)) +(DECLARE (*EXPR $DEBUG)) +(DECLARE (*LEXPR $LISPDEBUGMODE $DEBUGPRINTMODE)) + +;; Declarations for RAT;MATCOM 94, compiled 6/21/81 10:46 by JPG. +(DECLARE (COMMENT MATCOM)) +(DECLARE (*FEXPR $DEFRULE $TELLSIMPAFTER $TELLSIMP $DEFMATCH $MATCHDECLARE)) + +;; Declarations for JPG;F297 16, compiled 6/22/81 7:18 by JPG. +(DECLARE (COMMENT F297)) +(DECLARE (*EXPR NEVERSET)) + +;; Declarations for TRANSL;TRANSL 1145, compiled 6/26/81 18:44 by GJC. +(DECLARE (COMMENT TRANSL)) +(DECLARE (*EXPR TRANSLATE-MACEXPR-TOPLEVEL + TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION)) + +;; Declarations for MAXSRC;EXAMPL 56 (DESCRI split), compiled 7/1/81 1:54 by ELLEN. +(DECLARE (COMMENT EXAMPL)) +(DECLARE (*FEXPR $HELP)) + +;; Declarations for JPG;MAPF 47 (COMM2 split), compiled 7/2/81 3:18 by JPG. +(DECLARE (COMMENT MAPF)) +(DECLARE (*FEXPR $SCANMAP)) + +;; Declarations for MAXSRC;SYNEX 9, compiled 7/3/81 9:03 by JPG. +(DECLARE (COMMENT SYNEX)) +(DECLARE (*LEXPR $NOFIX $MATCHFIX $NARY $INFIX $POSTFIX $PREFIX)) + +;; Declarations for MAXSRC;PROPFN 305 (OUTMIS split), compiled 7/6/81 5:21 by JPG. +(DECLARE (COMMENT PROPFN)) +(DECLARE (*FEXPR $PRINTPROPS $PROPVARS $PROPERTIES)) + +;; Declarations for ZZ;APROPO 28, compiled 7/9/81 5:19 by JPG. +(DECLARE (COMMENT APROPO)) +(DECLARE (*FEXPR $APROPOS)) + +;; Declarations for MAXSRC;NDIFFQ 5, compiled 7/14/81 23:23 by GJC. +(DECLARE (COMMENT NDIFFQ)) +(DECLARE (*EXPR $MAP_FLOAT_ARRAY $INIT_FLOAT_ARRAY)) + +;; Declarations for TRANSL;TRPROP 1, compiled 7/15/81 1:48 by GJC. +(DECLARE (COMMENT TRPROP)) +(DECLARE (*EXPR META-FSET META-MPUTPROP META-PUTPROP META-ADD2LNC)) + +;; Declarations for MAXSRC;DOVER 1, compiled 8/7/81 23:36 by GJC. +(DECLARE (COMMENT DOVER)) +(DECLARE (*LEXPR $DOVER_FILE $DOVARD_FILE)) + +;; Declarations for MAXSRC;ERMSGM 11, compiled 8/18/81 6:27 by JPG. +(DECLARE (COMMENT ERMSGM)) +(DECLARE (*EXPR CHECK-OUT-OF-CORE-STRING ALLOCATE-MESSAGE-INDEX)) + +;; Declarations for MAXDEV;ATST 33, compiled 8/22/81 10:04 by JPG. +(DECLARE (COMMENT ATST)) +(DECLARE (*EXPR $SPECINT)) + +;; Declarations for JPG;F298 13, compiled 9/9/81 4:14 by JPG. +(DECLARE (COMMENT F298)) +(DECLARE (*EXPR $ERRORMSG RATCOEFF)) + +;; Declarations for TRANSL;MCOMPI 145, compiled 9/21/81 10:49 by GJC. +(DECLARE (COMMENT MCOMPI)) +(DECLARE (*LEXPR $COMPILE_LISP_FILE)) + +;; Declarations for JPG;NF299 33, compiled 12/31/81 16:17 by JPG. +(DECLARE (COMMENT NF299)) +(DECLARE (*EXPR DECL-COMPLEXP)) + +;; Declarations for JPG;F299 33, compiled 12/31/81 16:26 by JPG. +(DECLARE (COMMENT F299)) +(DECLARE (*EXPR DECL-COMPLEXP)) + +;; Declarations for TRANSL;TRANSS 79, compiled 1/22/82 6:51 by JPG. +(DECLARE (COMMENT TRANSS)) +(DECLARE (*LEXPR $TRANSLATE_FILE)) + +;; Declarations for MAXSRC;NUMER 17, compiled 2/12/82 16:13 by JPG. +(DECLARE (COMMENT NUMER)) +(DECLARE (*EXPR MAKE-TRAMP$)) +(DECLARE (*LEXPR GET-ARRAY)) + +;; Declarations for MAXSRC;DESCR 68 (DESCRI split), compiled 3/19/82 7:07 by JPG. +(DECLARE (COMMENT DESCR)) +(DECLARE (*EXPR MDESCRIBE)) + +;; Declarations for TRANSL;ACALL 66, compiled 4/3/82 14:52 by GJC. +(DECLARE (COMMENT ACALL)) +(DECLARE (*EXPR MAKE-ALAMBDA APPLICATION-OPERATOR MAYBE-BOOLE-CHECK + IS-BOOLE-CHECK ASSIGN-CHECK MAPPLY-TR INSURE-ARRAY-PROPS + $ARRAYSETAPPLY $ARRAYAPPLY INTERVAL-ERROR)) +(DECLARE (*LEXPR MAPLIST_TR DISPLAY-FOR-TR MARRAYSET MARRAYREF MFUNCALL)) + +;; Declarations for JPG;BOPTIM 5, compiled 4/27/82 4:46 by JPG. +(DECLARE (COMMENT BOPTIM)) +(DECLARE (*EXPR $OPTIMIZE)) + +;; Declarations for JPG;AOPTIM 14, compiled 5/5/82 6:47 by JPG. +(DECLARE (COMMENT AOPTIM)) +(DECLARE (*EXPR $COLLAPSE $OPTIMIZE)) + +;; Declarations for JPG;ADSKFN 9, compiled 5/10/82 4:53 by JPG0. +(DECLARE (COMMENT ADSKFN)) +(DECLARE (*EXPR I-$STORE I-$UNSTORE)) + +;; Declarations for JPG;F302 12, compiled 10/23/82 0:58 by JPG. +(DECLARE (COMMENT F302)) +(DECLARE (*LEXPR $KILLCONTEXT)) + +;; Declarations for MAXSRC;MTRACE 42, compiled 10/28/82 7:02 by JPG. +(DECLARE (COMMENT MTRACE)) +(DECLARE (*EXPR $UNTRACE_IT $TRACE_IT)) + +;; Declarations for JM;RISCH 436, compiled 11/16/82 6:35 by JPG. +(DECLARE (COMMENT RISCH)) +(DECLARE (*EXPR $RISCH)) + +;; Declarations for RAT;LESFAC 148, compiled 12/15/82 3:41 by JPG0. +(DECLARE (COMMENT LESFAC)) +(DECLARE (*EXPR LOWDEG)) + +;; Declarations for MAXSRC;AR 15, compiled 1/13/83 2:01 by JPG. +(DECLARE (COMMENT AR)) +(DECLARE (*EXPR ARRSTORE-EXTEND MEVAL1-EXTEND $ARRAY_DIMENSION_N + $ARRAY_NUMBER_OF_DIMENSIONS DIMENSION-ARRAY-OBJECT)) +(DECLARE (*LEXPR $MAKE_ARRAY)) + +;; Declarations for JPG;F303 2, compiled 1/31/83 1:27 by JPG. +(DECLARE (COMMENT F303)) +(DECLARE (*EXPR $BOTHCOEF)) + +;; Declarations for RAT;POIS2 74, compiled 2/4/83 4:15 by JPG. +(DECLARE (COMMENT POIS2)) +(DECLARE (*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS + $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP)) +(DECLARE (*LEXPR $POISSUBST)) + +;; Declarations for RAT;POIS3 66, compiled 2/4/83 4:18 by JPG. +(DECLARE (COMMENT POIS3)) +(DECLARE (*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS + $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP)) +(DECLARE (*LEXPR $POISSUBST)) + +;; Declarations for TENSOR;ITENSR 119, compiled 2/25/83 5:38 by JPG. +(DECLARE (COMMENT ITENSR)) +(DECLARE (*EXPR $CHANGENAME $INDICES2 $COMPONENTS $INDEXED $REMCOMPS $FLUSHND + $INDICES $LC $SHOW $KDELTA $UNDIFF $CONTRACT $CURVATURE $CHR2 + $CHR1 $METRIC $DUMMY)) +(DECLARE (*LEXPR $REMCOORD $COORD $ENTERTENSOR $RENAME $FLUSHD $FLUSH $LORENTZ + $COVDIFF $DEFCON)) + +;; Declarations for ELL;HYPGEO 10, compiled 4/2/83 5:27 by JPG. +(DECLARE (COMMENT HYPGEO)) +(DECLARE (*EXPR $SPECINT)) + +;; Declarations for MRG;DISPLA 777, compiled 5/25/83 3:46 by JPG0. +(DECLARE (COMMENT DISPLA)) +(DECLARE (*EXPR CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO + DIMENSION-SUPERSCRIPT DIMENSION-NOFIX DIMENSION-POSTFIX + DIMENSION-NARY DIMENSION-INFIX DIMENSION-PREFIX MAKESTRING + DIMENSION-STRING DIMENSION-ATOM DISPLA)) + +;; Declarations for MRG;GRAM 488, compiled 5/25/83 3:51 by JPG0. +(DECLARE (COMMENT GRAM)) +(DECLARE (*EXPR DEFINE-SYMBOL RBP LBP)) + +;; Declarations for RAT;EZGCD 262, compiled 6/14/83 4:54 by JPG. +(DECLARE (COMMENT EZGCD)) +(DECLARE (*LEXPR $EZGCD)) + +;; Declarations for ELL;HYP 98, compiled 6/28/83 9:30 by JPG. +(DECLARE (COMMENT HYP)) +(DECLARE (*EXPR HGFSIMP-EXEC $HGFRED)) + +;; Declarations for CFFK;TEKPLT 171, compiled 7/15/83 15:00 by CFFK. +(DECLARE (COMMENT TEKPLT)) +(DECLARE (*EXPR $GMARK $GVPRINT $GHPRINT $GTERPRI $EXITGRAPH $ENTERGRAPH + $CLEAR $DRAWSYMBOL3 $LINE3 $VECTOR3 $POINT3 $SETPOINT3 $SIZE + $SCREENSIZE1 $SCREENSIZE $DEFINESYMBOL $DRAWSYMBOL $LINE + $VECTOR $POPDASH $PUSHDASH $CHANGEDASH $DEFINEDASH $POINT + $SETPOINT)) + +;; Declarations for RZ;SUM 166 (COMBIN split), compiled 12/17/83 10:43 by JPG. +(DECLARE (COMMENT SUM)) +(DECLARE (*EXPR SIMPSUM2)) + +;; Declarations for CFFK;APLOT2 300, compiled 2/25/84 12:24 by JPG. +(DECLARE (COMMENT APLOT2)) +(DECLARE (*EXPR $PLOTRESET $PLOTINIT)) + +;; Declarations for LPH;FORTRN 70, compiled 4/12/84 18:08 by JPG. +(DECLARE (COMMENT FORTRN)) +(DECLARE (*LEXPR $FORTMX)) + +;; Declarations for JPG;F304 41, compiled 7/23/85 14:28 by JPG. +(DECLARE (COMMENT F304)) +(DECLARE (*EXPR SUBSTITUTE)) + +;; Declarations for MRG;NFORMA 15, compiled 1/28/18 8:47 by EJS. +(DECLARE (COMMENT NFORMA)) +(DECLARE (*EXPR NFORMAT-ALL NFORMAT)) + +;; Declarations for MRG;COMPAR 857, compiled 1/28/18 8:53 by EJS. +(DECLARE (COMMENT COMPAR)) +(DECLARE (*EXPR DECLAREKIND RGRP $FEATUREP SIGN MNQP MGQP MGRP MEQP LIKE $SIGN + CSIGN ASKSIGN-P-OR-N $ASKSIGN MAXIMIN MINIMUM MAXIMUM $COMPARE + RESTORE-FACTS FORGET LEARN ASSUME PRED-REVERSE PRE-ERR MEVALP2 + MEVALP IS $KILLCONTEXT $NEWCONTEXT)) +(DECLARE (*LEXPR $MIN $MAX $FACTS $DEACTIVATE $ACTIVATE $CONTEXT)) + +;; Declarations for MRG;TRIGI 343, compiled 1/28/18 8:53 by EJS. +(DECLARE (COMMENT TRIGI)) +(DECLARE (*EXPR ACSCH ASECH ACOTH ATANH ASINH ACOSH SECH CSCH COTH TANH COSH + SINH ACSC ASEC ACOT ATAN1 ACOS ASIN CSC SEC COT TAN MMINUSP* + MMINUSP EXPONENTIALIZE $EXPONENTIALIZE RREMAINDER RTIMES + RDIFFERENCE RPLUS SIMP-%ATAN SIMP-%SEC SIMP-%CSC SIMP-%COT + SIMP-%TAN SIMP-%COS SIMP-%SIN ARCP TRIGP SQ-SUMSQ SQRTX^2-1 + SQRT1+X^2 SQRT1-X^2)) + +;; Declarations for MRG;DB 1145, compiled 1/28/18 9:50 by EJS. +(DECLARE (COMMENT DB)) +(DECLARE (*EXPR KILLC CONTEXTMARK KCNTXT CNTXT KILLFRAME REMOV UNKIND)) +(DECLARE (*LEXPR CONTEXT DEACTIVATE ACTIVATE)) + +;; Declarations for MRG;GRIND 150, compiled 1/28/18 9:50 by EJS. +(DECLARE (COMMENT GRIND)) +(DECLARE (*EXPR MSTRING)) + +;; Declarations for JPG;MLISP 613, compiled 1/28/18 9:52 by EJS. +(DECLARE (COMMENT MLISP)) +(DECLARE (*EXPR $BINOMIAL $GAMMA $ACSCH $ASECH $ACOTH $ATANH $ACOSH $ASINH + $ACSC $ASEC $ACOT $ATAN $ACOS $ASIN $CSCH $SECH $COTH $TANH + $COSH $SINH $CSC $SEC $COT $TAN $COS $SIN $LOG |''MAKE-FUN| + DSKRAT MFILEP BIGFLOATM* ADD2LNC $SQRT $EXP RAT MRETURN + OPTIONP MCONS-OP-ARGS $FUNMAKE MOPP1 MOPP MSPECFUNP ARRSTORE + MGETL MREMPROP MPUTPROP MGET REMALIAS1 REMRULE REMARRELEM + I-$REMVALUE REMPROPCHK REMOVE1 I-$REMOVE $PUT $REM $GET FUNCER + $MAPATOM MMAPEV NEVERSET NUMERSET MSETCHK MSETERR $SUBVARP + MQUOTEP MSETQP MEVALATOMS MSET MUNBIND MBIND MARGS MOP MEVAL2 + MEVAL1 MEVAL MEVALN MAPPLY)) +(DECLARE (*LEXPR $ALLBUT $MATRIX OUTERMAP1 FMAPL1 MCALL)) +(DECLARE (*FEXPR DSKSETQ MDEFPROP)) + +;; Declarations for JPG;SUPRV 619, compiled 1/28/18 11:29 by EJS. +(DECLARE (COMMENT SUPRV)) +(DECLARE (*EXPR MACHERRFUN IOLFUN TTYRETFUN TTYINTFUN TTYINTFUNSETUP $DSKGC + I-$ALLOC $PAGEPAUSE MORE-FUN MTERPRI MFILE-OUT FILEPRINT + FILESTRIP $DDT $LOGOUT $QUIT $TO_LISP COMPUTIME TIMEORG $THROW + $UUO GETLABCHARN GETLABELS* GETLABELS $%TH $POISLIM $FPPREC + CASIFY-EXPLODEN STRMEVAL MAKSTRING DOLLARIFY-NAME AMPERCHK + $VERBIFY $NOUNIFY FULLSTRIP1 FULLSTRIP STRIPDOLLAR REMALIAS + ALIAS RETRIEVE PRINL NONVARCHK NONSYMCHK FEXPRCHECK ERRBREAK + $DEBUGMODE RULEOF REMVALUE REMLABELS KILL1 BATCH1 CARFILE + MTRUENAME TRUEFNAME LOADFILE FILENAMEL MFBOUNDP DOLLARIFY + LOAD-FILE FIND0 LOAD-FUNCTION FIND-FUNCTION REPRINT RUBOUT* + FORMFEED $BOTHCASES TYI* ADDLABEL MEXPLODEN PRINTLABEL + MAKELABEL MEVAL*)) +(DECLARE (*LEXPR $FILEDEFAULTS $BREAK $RANDOM $READONLY $READ $PRINT)) + +;; Declarations for JPG;COMM 395, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT COMM)) +(DECLARE (*EXPR $LOPOW $HIPOW COEFF $FLOAT $ENTIER $FIX $DENOM $NUM $SYMBOLP + $ATOM $LENGTH $REVERSE $ARGS $LAST $FIRST FORMAT1 ATOMCHK + $MEMBER $ENDCONS $CONS $LISTP LISTERCHK GETOPR GETOP MPART + PART1 $DISPTERMS ELABEL $TRUNC REMSIMP DELSIMP NTHELEM UNION* + SUBSTITUTEL NOTLOREQ ATVARSCHK SDIFF $DEL I-$DEPENDENCIES + RECUR-APPLY SUBST0 SUBSTITUTE)) +(DECLARE (*LEXPR $COEFF $DELETE $REST $APPEND $INPART $PART $DISPFORM $DISP + $LDISP $DIFF $DEPENDS $SUBSTITUTE)) + +;; Declarations for JPG;DSKFN 169, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT DSKFN)) +(DECLARE (*EXPR I-$STORE I-$UNSTORE)) + +;; Declarations for PAULW;CSIMP 299, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT CSIMP)) +(DECLARE (*EXPR $LHS $RHS $PARTITION $DEMOIVRE)) + +;; Declarations for PAULW;MAT 286, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT MAT)) +(DECLARE (*EXPR DISPLINE MAKE-PARAM)) + +;; Declarations for PAULW;MATRIX 320, compiled 1/28/18 11:39 by EJS. +(DECLARE (COMMENT MATRIX)) +(DECLARE (*EXPR $TRANSPOSE $SETELMX $ROW $MINOR)) +(DECLARE (*LEXPR $SUBMATRIX)) + +;; Declarations for RAT;FACTOR 472, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT FACTOR)) +(DECLARE (*EXPR TESTDIVIDE CFACTORW)) + +;; Declarations for RAT;RAT3A 258, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3A)) +(DECLARE (*EXPR PTIMES PQUOTIENT PMOD PMINUS PMINUSP PDERIVATIVE PDIFFERENCE + PPLUS POINTERGP)) + +;; Declarations for RAT;RAT3B 95, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3B)) +(DECLARE (*EXPR RATQUOTIENT RATPLUS RATEXPT RATTIMES RATREDUCE RATMINUS + RATFACT RATDIF RATDERIVATIVE)) + +;; Declarations for RAT;RAT3C 302, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3C)) +(DECLARE (*EXPR PDEGREE $PRIMEP PGCD1 PQUOTIENTCHK)) + +;; Declarations for RAT;RAT3D 264, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3D)) +(DECLARE (*EXPR PABS $NTHROOT $INRT $ISQRT)) + +;; Declarations for RAT;RAT3E 546, compiled 1/28/18 11:50 by EJS. +(DECLARE (COMMENT RAT3E)) +(DECLARE (*EXPR $RATDISREP $RATEXPAND RATIONALIZE RATF RATREP* RATREP RATSETUP + $GFACTOR $SQFR $TOTALDISREP $SHOWRATVARS $PRINTVARLIST + $RATDENOM $RATNUMER)) +(DECLARE (*LEXPR $CONTENT $GCD $REMAINDER $QUOTIENT $DIVIDE $MOD FACTOR + $FACTOR $RATSIMP $RAT $FULLRATSIMP $RATVARS $TELLRAT + $UNTELLRAT)) + +;; Declarations for RAT;NRAT4 265, compiled 1/28/18 11:50 by EJS. +(DECLARE (COMMENT NRAT4)) +(DECLARE (*EXPR $RADCAN FREEOF ARGSFREEOF $BOTHCOEF $RATSUBST RATCOEFF)) +(DECLARE (*LEXPR $FREEOF $RATCOEF)) + +;; Declarations for MAXSRC;OPERS 75, compiled 1/28/18 11:51 by EJS. +(DECLARE (COMMENT OPERS)) +(DECLARE (*EXPR SIMPLIFY MORP PORM ROOT NCPOWER POWER* POWER NCMULN NCMUL2 + DIV* DIV MULN MUL3 MUL2* MUL2 SUB* SUB NEG ADDN ADD2* ADD2)) + +;; Declarations for MAXSRC;UTILS 26, compiled 1/28/18 11:51 by EJS. +(DECLARE (COMMENT UTILS)) +(DECLARE (*EXPR ASCII-NUMBERP ALPHABETP CPUT A-ATOM DOT2L FSET LOG2 ASSQR + FIRSTN RECONC AMONGL AMONG XOR ANDMAPCAR ORMAPC ANDMAPC MAP2C)) +(DECLARE (*LEXPR CONCAT *MAKE-LIST)) + +;; Declarations for MAXSRC;MUTILS 11, compiled 1/28/18 11:51 by EJS. +(DECLARE (COMMENT MUTILS)) +(DECLARE (*EXPR MEMALIKE ASSOLIKE ASSOL)) + +;; Declarations for JM;SIMP 834, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT SIMP)) +(DECLARE (*EXPR NTHKDR *KAR SIMPARGS1 KDR KAR MATCHERR BPROG RATDENOMINATOR + RATNUMERATOR SIMPNRT EXPAND1 ALIKE ALIKE1 GREAT DECL-REALP + DECL-COMPLEXP SIMPMQAPPLY $ORDERGREATP $ORDERLESSP SIMPMATRIX + SIMPEXPT EXPTRL SIMPSIGNUM SIGNUM1 SIMPDERIV INFSIMP SIMPMDEF + SIMPLAMBDA SIMPEXP SIMPBIGFLOAT SIMPINTEG SIMP-LIMIT SIMPTIMES + SIMPABS SIMPQUOT SIMPSQRT SIMPLN SIMPLUS FPCOFRAT TIMESK ADDK + SIMPARGS SSIMPLIFYA RESIMPLIFY EQTEST SIMPLIFYA FREEARGS FREEL + FREE ISINOP CONSTFUN MXORLISTP MEQUALP MBAGP $NONSCALARP + $SCALARP $CONSTANTP $NUMFACTOR SUBFUNARGS SUBFUNSUBS + SUBFUNNAME SUBFUNMAKE SUBFUNMAKES SUBARGCHECK IMPROPER-ARG-ERR + WNA-ERR TWOARGCHECK ONEARGCHECK $POLYSIGN SPECDISREP SPECREPP + SPECREPCHECK $RATP $RATNUMP $FLOATNUMP $EVENP $ODDP $INTEGERP + $NUMBERP MRATCHECK SIMPCHECK SRATSIMP RATDISREP MQAPPLYP MNEGP + MMMINUSP MLOGP MNCEXPTP MNCTIMESP MEXPTP MTIMESP MPLUSP + RATNUMP EVEN MNUMP $BFLOATP ZEROP1 ONEP1 ONEP)) +(DECLARE (*LEXPR $INTEGRATE $EXPAND $MULTTHRU)) + +;; Declarations for MAXSRC;INMIS 98, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT INMIS)) +(DECLARE (*EXPR $RESET $LISTOFVARS $UNKNOWN)) + +;; Declarations for RZ;ASUM 271, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT ASUM)) +(DECLARE (*EXPR TOTAL-NARY RASSOCIATIVE LASSOCIATIVE NARY1 ANTISYM + COMMUTATIVE1 ODDFUN EVENFUN DO%SUM DOSUM SIMPSUM SIMPGFACT + SIMPFACT)) +(DECLARE (*LEXPR $GENFACT)) + +;; Declarations for MAXSRC;MERROR 47, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT MERROR)) +(DECLARE (*EXPR *ERRRJF-1 *MERROR-5 *MERROR-4 *MERROR-3 *MERROR-2 *MERROR-1 + FSTRINGC READ-ONLY-ASSIGN $ERRORMSG)) +(DECLARE (*LEXPR ERRRJF MERROR $ERROR)) + +;; Declarations for MAXSRC;MFORMT 27, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT MFORMT)) +(DECLARE (*EXPR MTELL5 MTELL4 MTELL3 MTELL2 MTELL1 *MFORMAT-5 *MFORMAT-4 + *MFORMAT-3 *MFORMAT-2 DISPLAF)) +(DECLARE (*LEXPR MTELL MFORMAT)) + +;; Declarations for MRG;FORTRA 64, compiled 1/28/18 11:53 by EJS. +(DECLARE (COMMENT FORTRA)) +(DECLARE (*LEXPR $FORTMX)) + +;; Declarations for MRG;SCS 60, compiled 1/28/18 11:56 by EJS. +(DECLARE (COMMENT SCS)) +(DECLARE (*EXPR $FACOUT $DISTRIB)) +(DECLARE (*LEXPR $SCSIMP)) + +;; Declarations for MRG;OPTIM 14, compiled 1/28/18 11:56 by EJS. +(DECLARE (COMMENT OPTIM)) +(DECLARE (*EXPR $COLLAPSE $OPTIMIZE)) + +;; Declarations for JM;SININT 140, compiled 1/28/18 11:56 by EJS. +(DECLARE (COMMENT SININT)) +(DECLARE (*EXPR RATINT)) + +;; Declarations for JM;ZERO 23, compiled 1/28/18 11:57 by EJS. +(DECLARE (COMMENT ZERO)) +(DECLARE (*EXPR $ZEROEQUIV)) + +;; Declarations for RAT;MATRUN 80, compiled 1/28/18 11:57 by EJS. +(DECLARE (COMMENT MATRUN)) +(DECLARE (*EXPR APPLY2HACK APPLY2 APPLY1HACK APPLY1 PART* PART+ FINDBASE + FINDEXPON FINDFUN FINDBE $REMRULE)) + +;; Declarations for RAT;FLOAT 321, compiled 1/28/18 12:06 by EJS. +(DECLARE (COMMENT FLOAT)) +(DECLARE (*EXPR FPENTIER *FPATAN ATANBIGFLOAT RATBIGFLOAT ADDBIGFLOAT $BFLOAT + FP2FLO)) + +;; Declarations for RAT;SOLVE 401, compiled 1/28/18 12:09 by EJS. +(DECLARE (COMMENT SOLVE)) +(DECLARE (*EXPR $LINSOLVE)) +(DECLARE (*LEXPR $SOLVE)) + +;; Declarations for JIM;TLIMIT 47, compiled 1/28/18 21:24 by EJS. +(DECLARE (COMMENT TLIMIT)) +(DECLARE (*EXPR $TLDEFINT)) +(DECLARE (*LEXPR $TLIMIT)) + +;; Declarations for JIM;LIMIT 273, compiled 1/28/18 21:24 by EJS. +(DECLARE (COMMENT LIMIT)) +(DECLARE (*EXPR $LDEFINT)) +(DECLARE (*LEXPR $LIMIT)) + +;; Declarations for JIM;ASKP 85, compiled 1/28/18 21:24 by EJS. +(DECLARE (COMMENT ASKP)) +(DECLARE (*EXPR ASK-INTEGER)) +(DECLARE (*LEXPR $ASKINTEGER)) + +;; Declarations for PAULW;RESIDU 105, compiled 1/28/18 21:25 by EJS. +(DECLARE (COMMENT RESIDU)) +(DECLARE (*EXPR $RESIDUE)) + +;; Declarations for PAULW;LINNEW 27, compiled 1/28/18 21:28 by EJS. +(DECLARE (COMMENT LINNEW)) +(DECLARE (*EXPR $TMINVERSE $TMLIN)) +(DECLARE (*LEXPR $TMLINSOLVE $TMNEWDET)) + +;; Declarations for MACRAK;RPART 263, compiled 1/28/18 21:34 by EJS. +(DECLARE (COMMENT RPART)) +(DECLARE (*EXPR TRISPLIT CABS $CARG $CABS $POLARFORM $RECTFORM $IMAGPART + $REALPART)) + +;; Declarations for MACRAK;LOGARC 27, compiled 1/28/18 21:35 by EJS. +(DECLARE (COMMENT LOGARC)) +(DECLARE (*EXPR LOGARC $LOGARC)) + +;; Declarations for RZ;SERIES 133, compiled 1/28/18 21:35 by EJS. +(DECLARE (COMMENT SERIES)) +(DECLARE (*EXPR $POWERSERIES)) + +;; Declarations for RZ;NUMTH 47, compiled 1/28/18 21:35 by EJS. +(DECLARE (COMMENT NUMTH)) +(DECLARE (*EXPR $GCFACTOR $JACOBI $TOTIENT $PRIME)) +(DECLARE (*LEXPR $DIVSUM)) + +;; Declarations for RAT;HAYAT 386, compiled 1/28/18 21:37 by EJS. +(DECLARE (COMMENT HAYAT)) +(DECLARE (*EXPR $TAYLORINFO)) +(DECLARE (*LEXPR $TAYLOR)) + +;; Declarations for RZ;TRGRED 88, compiled 1/28/18 21:37 by EJS. +(DECLARE (COMMENT TRGRED)) +(DECLARE (*LEXPR $TRIGREDUCE)) + +;; Declarations for RAT;NEWDET 12, compiled 1/28/18 21:37 by EJS. +(DECLARE (COMMENT NEWDET)) +(DECLARE (*LEXPR $PERMANENT $NEWDET)) + +;; Declarations for RAT;POLYRZ 93, compiled 1/28/18 21:37 by EJS. +(DECLARE (COMMENT POLYRZ)) +(DECLARE (*LEXPR $NROOTS $REALROOTS)) + +;; Declarations for RAT;ALGSYS 1, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT ALGSYS)) +(DECLARE (*EXPR MYCABS $ALGSYS)) + +;; Declarations for RAT;NALGFA 67, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT NALGFA)) +(DECLARE (*EXPR $ALGNORM $SPLITFIELD $PFACTORALG $ALGTRACE)) +(DECLARE (*LEXPR $BDISCR $ALGFAC)) + +;; Declarations for MAXSRC;LAPLAC 202, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT LAPLAC)) +(DECLARE (*EXPR $ILT $LAPLACE)) + +;; Declarations for CFFK;CPOLY 64, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT CPOLY)) +(DECLARE (*EXPR $ALLROOTS)) + +;; Declarations for RAT;PADE 42, compiled 1/28/18 21:42 by EJS. +(DECLARE (COMMENT PADE)) +(DECLARE (*EXPR $PADE)) + +;; Declarations for MAXSRC;SUMCON 18, compiled 1/28/18 21:42 by EJS. +(DECLARE (COMMENT SUMCON)) +(DECLARE (*EXPR $NICEINDICES $BASHINDICES $INTOSUM $SUMCONTRACT)) + +;; Declarations for MAXSRC;SUBLIS 11, compiled 1/28/18 21:46 by EJS. +(DECLARE (COMMENT SUBLIS)) +(DECLARE (*EXPR $SUBLIS)) + +;; Declarations for REH;MMACRO 50, compiled 1/28/18 21:47 by EJS. +(DECLARE (COMMENT MMACRO)) +(DECLARE (*EXPR SIMPMDEFMACRO MMACRO-APPLY)) + +;; Declarations for REH;BUILDQ 9, compiled 1/28/18 21:47 by EJS. +(DECLARE (COMMENT BUILDQ)) +(DECLARE (*EXPR MBUILDQ-SUBST)) + +;; Declarations for JPG;DIFF2 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT DIFF2)) +(DECLARE (*EXPR STOTALDIFF DIFFNCEXPT DIFFLAPLACE DIFFSUM DIFFINT)) + +;; Declarations for JPG;AT 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT AT)) +(DECLARE (*EXPR $AT $ATVALUE)) + +;; Declarations for JPG;LOGCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT LOGCON)) +(DECLARE (*EXPR $LOGCONTRACT)) + +;; Declarations for JPG;NTERMS 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT NTERMS)) +(DECLARE (*EXPR $NTERMS)) + +;; Declarations for JPG;ARITHF 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT ARITHF)) +(DECLARE (*EXPR $FIBTOPHI)) + +;; Declarations for JPG;DERIVD 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT DERIVD)) +(DECLARE (*EXPR $DERIVDEGREE)) + +;; Declarations for JPG;BOX 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT BOX)) +(DECLARE (*EXPR BOX)) +(DECLARE (*LEXPR $REMBOX $BOX $LPART $DPART)) + +;; Declarations for JPG;GENMAT 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT GENMAT)) +(DECLARE (*EXPR $COPYLIST $COPYMATRIX)) +(DECLARE (*LEXPR $GENMATRIX)) + +;; Declarations for JPG;ADDROW 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT ADDROW)) +(DECLARE (*LEXPR $ADDCOL $ADDROW)) + +;; Declarations for JPG;ARRAYF 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT ARRAYF)) +(DECLARE (*EXPR $ARRAYMAKE)) + +;; Declarations for JPG;ALIAS 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT ALIAS)) +(DECLARE (*EXPR $UNORDER)) + +;; Declarations for JPG;CONCAT 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT CONCAT)) +(DECLARE (*EXPR $GETCHAR)) +(DECLARE (*LEXPR $CONCAT)) + +;; Declarations for JPG;TTYINI 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT TTYINI)) +(DECLARE (*EXPR $TTY_INIT)) + +;; Declarations for PAULW;PLOG 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT PLOG)) +(DECLARE (*EXPR SIMPPLOG)) + +;; Declarations for PAULW;BINOML 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT BINOML)) +(DECLARE (*EXPR BINOCOMP SIMPBINOCOEF)) + +;; Declarations for PAULW;GAMMA 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT GAMMA)) +(DECLARE (*EXPR SIMPGAMMA SIMPBETA)) + +;; Declarations for PAULW;ERF 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT ERF)) +(DECLARE (*EXPR ERF SIMPERF)) + +;; Declarations for PAULW;EMATRI 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT EMATRIX)) +(DECLARE (*EXPR $EMATRIX $ZEROMATRIX)) + +;; Declarations for PAULW;COEFM 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT COEFM)) +(DECLARE (*EXPR $AUGCOEFMATRIX $COEFMATRIX)) + +;; Declarations for PAULW;ENTERM 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT ENTERM)) +(DECLARE (*EXPR $ENTERMATRIX)) + +;; Declarations for PAULW;XTHRU 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT XTHRU)) +(DECLARE (*EXPR $XTHRU)) + +;; Declarations for RAT;SCUBIC 19 (PSOLVE split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT SCUBIC)) +(DECLARE (*EXPR SOLVECUBIC)) + +;; Declarations for RAT;SQUART 19 (PSOLVE split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT SQUART)) +(DECLARE (*EXPR SOLVEQUARTIC)) + +;; Declarations for MAXSRC;STATUS 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT STATUS)) +(DECLARE (*EXPR $TIMEDATE $WHO)) + +;; Declarations for MAXSRC;ISOLAT 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT ISOLAT)) +(DECLARE (*EXPR $REVEAL $PICKAPART $ISOLATE)) + +;; Declarations for MAXSRC;CHANGV 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT CHANGV)) +(DECLARE (*EXPR $CHANGEVAR)) + +;; Declarations for MAXSRC;FACSUM 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT FACSUM)) +(DECLARE (*EXPR $GFACTORSUM $FACTORSUM)) + +;; Declarations for MAXSRC;COMBF 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT COMBF)) +(DECLARE (*EXPR $COMBINE)) + +;; Declarations for MAXSRC;FACOUT 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT FACOUT)) +(DECLARE (*LEXPR $FACTOROUT)) + +;; Declarations for MAXSRC;SCREEN 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT SCREEN)) +(DECLARE (*EXPR $CLEARSCREEN)) +(DECLARE (*LEXPR $PAUSE)) + +;; Declarations for RZ;MINFCT 152 (COMBIN split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT MINFCT)) +(DECLARE (*EXPR $FACTCOMB $MINFACTORIAL $MAKEGAMMA $MAKEFACT)) + +;; Declarations for RZ;EULBRN 152 (COMBIN split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT EULBRN)) +(DECLARE (*EXPR $BERNPOLY SIMPBERN $BERN SIMPEULER $EULER)) + +;; Declarations for RZ;ZETA 152 (COMBIN split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT ZETA)) +(DECLARE (*EXPR $FIB $ZETA)) + +;; Declarations for RZ;CFFUN 152 (COMBIN split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT CFFUN)) +(DECLARE (*EXPR $CFEXPAND $QUNIT $CFDISREP)) + +;; Declarations for RZ;TAYRAT 152 (COMBIN split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT TAYRAT)) +(DECLARE (*EXPR $TAYTORAT)) + +;; Declarations for RZ;DECOMP 152 (COMBIN split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT DECOMP)) +(DECLARE (*EXPR $POLYDECOMP)) + +;; Declarations for MRG;HYPER 330 (TRIGO split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT HYPER)) +(DECLARE (*EXPR SIMP-%SECH SIMP-%CSCH SIMP-%COTH SIMP-%TANH SIMP-%COSH + SIMP-%SINH)) + +;; Declarations for MRG;ATRIG 330 (TRIGO split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT ATRIG)) +(DECLARE (*EXPR SIMP-%ASEC SIMP-%ACSC SIMP-%ACOT SIMP-%ACOS SIMP-%ASIN)) + +;; Declarations for MRG;AHYPER 330 (TRIGO split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT AHYPER)) +(DECLARE (*EXPR SIMP-%ASECH SIMP-%ACSCH SIMP-%ACOTH SIMP-%ATANH SIMP-%ACOSH + SIMP-%ASINH)) + +;; Declarations for MRG;TRIGEX 330 (TRIGO split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT TRIGEX)) +(DECLARE (*EXPR TRIGEXPAND $TRIGEXPAND)) + +;; Declarations for RAT;FASTT 64 (RATOUT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT FASTT)) +(DECLARE (*EXPR $FASTTIMES)) + +;; Declarations for RAT;RATWT 64 (RATOUT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT RATWT)) +(DECLARE (*LEXPR $RATWEIGHT)) + +;; Declarations for RAT;HORNER 64 (RATOUT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT HORNER)) +(DECLARE (*LEXPR $HORNER)) + +;; Declarations for RAT;PFRAC 64 (RATOUT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT PFRAC)) +(DECLARE (*EXPR $PARTFRAC)) + +;; Declarations for RAT;RATDIF 64 (RATOUT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT RATDIF)) +(DECLARE (*EXPR $RATDIFF)) + +;; Declarations for RAT;PFET 64 (RATOUT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT PFET)) +(DECLARE (*EXPR $PFET)) + +;; Declarations for RAT;MRESUL 30 (RESULT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT MRESUL)) +(DECLARE (*EXPR RESULTANT $RESULTANT $POLY_DISCRIMINANT)) + +;; Declarations for RAT;BEZOUT 30 (RESULT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT BEZOUT)) +(DECLARE (*EXPR $BEZOUT)) + +;; Declarations for DAS;MSORT 21 (MSTUFF split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT MSORT)) +(DECLARE (*LEXPR $SORT)) + +;; Declarations for DAS;MAKEL 21 (MSTUFF split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT MAKEL)) +(DECLARE (*EXPR $SUBLIST)) + +;; Declarations for MAXSRC;MLOAD 121, compiled 1/30/18 22:44 by EJS. +(DECLARE (COMMENT MLOAD)) +(DECLARE (*EXPR MFILENAME-ONLYP $FILE_TYPE $LOAD $BATCHLOAD CALL-BATCH1 + OPEN-IN-DSK OPEN-OUT-DSK LOAD-AND-TELL $LISTP_CHECK)) +(DECLARE (*LEXPR $FILENAME_MERGE $FILE_SEARCH)) diff --git a/src/maxdoc/dcl.fexpr b/src/maxdoc/dcl.fexpr new file mode 100755 index 00000000..f15fea86 --- /dev/null +++ b/src/maxdoc/dcl.fexpr @@ -0,0 +1,37 @@ +; *FEXPR declarations are fake, actually these are +; all DEFMSPEC's and this information is used only +; by the Macsyma->Lisp translator. -gjc + +(*FEXPR + $TRACE_OPTIONS $DEFINE_VARIABLE $FULLMAPL $PRIMER MCOND + $DEMO $LETSIMP $GRADEF $MAKEATOMIC $DEPENDENCIES + $LDISPLAY $APPENDFILE $STORE $COMPFILE $OUTERMAP + $PROPVARS $QPUT $APPLYB2 $MAIL $FASSAVE + $REMARRAY $BATCON $EXAMPLE $GRAPH2 $OPTIONS + $APPLYB1 $LOADFILE $HELP $REPLOT4 $MATRIXMAP + $TIMER $NAMEPLOT $LOADPLOTS $SUBSTPART $ORDERLESS + MDOIN $PRINTFILE $DESCRIBE $COMPILE $DELFILE + $TELLSIMPAFTER $CATCH $DISPRULE $APPLY $ALARMCLOCK + $SSTATUS $BATCH $PRINTPROPS $MACROEXPAND $LET + $CONTOURPLOT2 $DEFTAYLOR $DEFMATCH MOR $DECLARE + $STRING $INTERPOLATE $ALIAS $TOBREAK $EVAL_WHEN + $MACROEXPAND1 $LABELS $UNTRACE $ASSUME $WRITEFILE + MPROG $EV $UNTIMER $REMCON $SUBSTINPART + $TELLSIMP MQUOTE $CF $REMOVE $CLOSEFILE + $APROPOS $PARAMPLOT $ORDERGREAT MNOT $RENAMEFILE + $MAKELIST $APPLY2 $IS $PARAMPLOT2 $NUMERVAL + $HARDCOPY $MATCHDECLARE $MAP $LOCAL $TIME + $NAMEFILE $APPLY1 $SUBVAR $DISPLAY $SEND + $BUILDQ $DEFINE $FILELIST $ARRAYINFO $MODE_IDENTITY + $FILELENGTH $MAPLIST $RESTORE $FUNDEF $ALLOC + $ERRCATCH $SAVEPLOTS MGO $LETRULES $FORTRAN + $LABEL MPROGN $REMFILE $SCANMAP MDO + $TRANSLATE $ARRAY $LISTFILES $ROMBERG $FORGET + $PLAYBACK $BUG $DEFRULE MSPEC-HOOK $TRACE + MAND $REMLET $STRINGOUT $REMFUNCTION $SAVE + $UNSTORE $MODEDECLARE $TIMER_INFO $STATUS $PROPERTIES + MSETQ $PLOT3D $GRAPH $PLOT $QLISTFILES + $SETUP_AUTOLOAD $SUPCONTEXT $KILL $PLOTMODE $GRIND + $GRAPH3D $PLOT2 $SUM MLOCAL $REMVALUE + $PRODUCT $DISPFUN MDEFINE $REPLOT $FULLMAP + $KILLPLOTS $MULTIGRAPH MDEFMACRO) \ No newline at end of file diff --git a/src/maxdoc/dcl.lispm b/src/maxdoc/dcl.lispm new file mode 100755 index 00000000..ca210952 --- /dev/null +++ b/src/maxdoc/dcl.lispm @@ -0,0 +1,296 @@ + +(DEFPROP DCL "12//7//81 0:57:08" VERSION) +(*EXPR CMOD CPLUS CTIMES CEXPT CRECIP CFACTOR) +(*FEXPR $FASMAK) +(*EXPR SOLVEQUARTIC) +(*EXPR $GETCHARN) +(*EXPR $FACOUT $DISTRIB) +(*LEXPR $SCSIMP) +(*FEXPR $GRAPH $PLOT) +(*EXPR $APPLY_NOUNS MTREE-SUBST) +(*EXPR DIMENSION-SUPERSCRIPT) +(*EXPR $COMBINE) +(*EXPR LOGARC $LOGARC) +(*EXPR GET-OUT GET-FLIST) +(*EXPR $SUBSETP $ELEMENTOF $ELEMENTP $CARDINAL $MAPSET $PREDSET $ELEMENTS $EMPTYP $UNIVERSE $MAKE_UNIVERSE) +(*LEXPR $SETDIFF $SYMDIFF $INTERSECTION $UNION $ORDINAL ${) +(*LEXPR $NROOTS $REALROOTS) +(*EXPR $POLYDECOMP) +(*EXPR $CLEARSCREEN) +(*LEXPR $PAUSE) +(*EXPR $TRIGEXPAND) +(*EXPR $XTHRU) +(*EXPR $TR_WARNINGS_GET) +(*EXPR $PFET) +(*EXPR $SUBLIST) +(*FEXPR $MAKELIST) +(*FEXPR $RENAMEFILE $FILELENGTH $FILELIST $QLISTFILES $LISTFILES $PRINTFILE) +(*EXPR $TLDEFINT) +(*LEXPR $TLIMIT) +(*EXPR $BEZOUT $DISCRIMINANT $RESULTANT) +(*FEXPR $OPTIONS) +(*EXPR MBUILDQ-SUBST) +(*FEXPR $BUILDQ) +(*EXPR MACSYMACALLP SUBRCALL$P SUBRCALLP) +(*LEXPR FMAPPLY) +(*EXPR DEFINE-SYMBOL) +(*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE) +(*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $NUMBER_OF_OBJECTS_IN_INDEX_FILE $OPEN_INDEX_FILE) +(*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE) +(*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $INDEX_FILE_DIM $OPEN_INDEX_FILE) +(*EXPR MMINUSP*) +(*EXPR LOWDEG) +(*EXPR $ZEROEQUIV) +(*EXPR SIMP-%SECH SIMP-%CSCH SIMP-%COTH SIMP-%TANH SIMP-%COSH SIMP-%SINH) +(*EXPR SIMP-%ASEC SIMP-%ACSC SIMP-%ACOT SIMP-%ACOS SIMP-%ASIN) +(*EXPR SIMP-%ASECH SIMP-%ACSCH SIMP-%ACOTH SIMP-%ATANH SIMP-%ACOSH SIMP-%ASINH) +(*EXPR TRIGEXPAND $TRIGEXPAND) +(*FEXPR $MULTIGRAPH $PARAMPLOT) +(*FEXPR $GRAPH $PLOT) +(*EXPR $TAG_FILE_INSERT) +(*FEXPR $PRIMER) +(*EXPR $SUBLIS) +(*LEXPR $SUSPEND) +(*EXPR ACSCH ASECH ACOTH ATANH ASINH ACOSH SECH CSCH COTH TANH COSH SINH ACSC ASEC ACOT ATAN1 ACOS ASIN CSC SEC COT TAN MMINUSP* MMINUSP EXPONENTIALIZE $EXPONENTIALIZE RREMAINDER RTIMES RDIFFERENCE RPLUS SIMP-%ATAN SIMP-%SEC SIMP-%CSC SIMP-%COT SIMP-%TAN SIMP-%COS SIMP-%SIN ARCP TRIGP SQ-SUMSQ SQRTX^2-1 SQRT1+X^2 SQRT1-X^2) +(*FEXPR $PRODUCT) +(*EXPR $LHS $RHS $PARTITION $DEMOIVRE) +(*EXPR *MERROR-1) +(*EXPR PTIMES PQUOTIENT PMOD PMINUS PMINUSP PDERIVATIVE PDIFFERENCE PPLUS POINTERGP) +(*EXPR MDESCRIBE) +(*FEXPR $DESCRIBE) +(*EXPR $TMINVERSE $TMLIN) +(*LEXPR $TMLINSOLVE $TMNEWDET) +(*LEXPR $PERMANENT $NEWDET) +(*EXPR $ALGNORM $SPLITFIELD $PFACTORALG $ALGTRACE) +(*LEXPR $BDISCR $ALGFAC) +(*EXPR FLUIDIZE ASS-EQ-SET ASSIGN-MODE-CHECK) +(*LEXPR CHEKVALUE ASS-EQ-REF) +(*LEXPR $TRANSLATE_FILE) +(*EXPR RATQUOTIENT RATPLUS RATEXPT RATTIMES RATREDUCE RATMINUS RATFACT RATDIF RATDERIVATIVE) +(*EXPR TRISPLIT CABS $CARG $CABS $POLARFORM $RECTFORM $IMAGPART $REALPART) +(*EXPR APPLY2HACK APPLY2 APPLY1HACK APPLY1 PART* PART+ FINDBASE FINDEXPON FINDFUN FINDBE $REMRULE) +(*FEXPR $APPLYB2 $APPLY2 $APPLYB1 $APPLY1 $DISPRULE) +(*EXPR $UNTRACE_IT $TRACE_IT) +(*EXPR $RESET $LISTOFVARS $UNKNOWN) +(*EXPR MAKE-TRAMP$) +(*LEXPR GET-ARRAY) +(*EXPR $ISIMPTEST $RSIMPTEST $ITEFFA $RTEFFA $TEFFS $IRES $RRES $NUPP $NUP $NU) +(*EXPR $DEBUG) +(*LEXPR $LISPDEBUGMODE $DEBUGPRINTMODE) +(*LEXPR $SORT) +(*EXPR $SUBLIST) +(*FEXPR $MAKELIST) +(*FEXPR $DEFRULE $TELLSIMPAFTER $TELLSIMP $DEFMATCH $MATCHDECLARE) +(*EXPR NEVERSET) +(*EXPR DEFINE-SYMBOL RBP LBP) +(*EXPR TOTAL-NARY RASSOCIATIVE LASSOCIATIVE NARY1 ANTISYM COMMUTATIVE1 ODDFUN EVENFUN DO%SUM DOSUM SIMPSUM SIMPGFACT SIMPFACT) +(*LEXPR $GENFACT) +(*FEXPR $SUM $DEFTAYLOR) +(*EXPR TRANSLATE-MACEXPR-TOPLEVEL TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION) +(*EXPR MTELL5 MTELL4 MTELL3 MTELL2 MTELL1 DISPLAF *MFORMAT-5 *MFORMAT-4 *MFORMAT-3 *MFORMAT-2) +(*LEXPR MTELL MFORMAT) +(*EXPR TESTDIVIDE CFACTORW) +(*LEXPR $TRIGREDUCE) +(*EXPR PDEGREE $PRIMEP PGCD1 PQUOTIENTCHK) +(*EXPR $RATDISREP $RATEXPAND RATIONALIZE RATF RATREP* RATREP $GFACTOR $SQFR $TOTALDISREP $SHOWRATVARS $PRINTVARLIST $RATDENOM $RATNUMER) +(*LEXPR $CONTENT $GCD $REMAINDER $QUOTIENT $DIVIDE $MOD FACTOR $FACTOR $RATSIMP $RAT $FULLRATSIMP $RATVARS $TELLRAT $UNTELLRAT) +(*EXPR MEMALIKE ASSOLIKE ASSOL) +(*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP) +(*LEXPR $POISSUBST) +(*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP) +(*LEXPR $POISSUBST) +(*EXPR $ILT $LAPLACE) +(*EXPR $FASTTIMES) +(*LEXPR $RATWEIGHT) +(*LEXPR $HORNER) +(*EXPR $PARTFRAC) +(*EXPR $RATDIFF) +(*EXPR $PFET) +(*EXPR $RESULTANT $DISCRIMINANT) +(*EXPR $BEZOUT) +(*EXPR $PADE) +(*FEXPR $HELP) +(*FEXPR $SCANMAP) +(*LEXPR $NOFIX $MATCHFIX $NARY $INFIX $POSTFIX $PREFIX) +(*FEXPR $PRINTPROPS $PROPVARS $PROPERTIES) +(*EXPR DISPLINE MAKE-PARAM) +(*EXPR PABS $NTHROOT $INRT $ISQRT) +(*EXPR SIMPPLOG) +(*EXPR BINOCOMP SIMPBINOCOEF) +(*EXPR SIMPGAMMA SIMPBETA) +(*EXPR ERF SIMPERF) +(*EXPR $EMATRIX $ZEROMATRIX) +(*EXPR $AUGCOEFMATRIX $COEFMATRIX) +(*EXPR $ENTERMATRIX) +(*EXPR $XTHRU) +(*FEXPR $APROPOS) +(*EXPR $MAP_FLOAT_ARRAY $INIT_FLOAT_ARRAY) +(*EXPR ASCII-NUMBERP ALPHABETP CPUT A-ATOM DOT2L FSET LOG2 ASSQR FIRSTN RECONC AMONGL AMONG XOR ANDMAPCAR ORMAPC ANDMAPC MAP2C) +(*LEXPR CONCAT *MAKE-LIST) +(*EXPR META-FSET META-MPUTPROP META-PUTPROP META-ADD2LNC) +(*EXPR $CHANGENAME $INDICES2 $COMPONENTS $INDEXED $REMCOMPS $FLUSHND $INDICES $LC $SHOW $KDELTA $UNDIFF $CONTRACT $RIEMANN $CHR2 $CHR1 $METRIC $DUMMY) +(*LEXPR $REMCOORD $COORD $ENTERTENSOR $RENAME $FLUSHD $FLUSH $LORENTZ $COVDIFF $DEFCON) +(*FEXPR $REMCON $DISPCON) +(*LEXPR $FORTMX) +(*LEXPR $DOVER_FILE $DOVARD_FILE) +(*EXPR $PLOTRESET $PLOTINIT) +(*EXPR KILLC CONTEXTMARK KCNTXT CNTXT KILLFRAME REMOV UNKIND KILL UNTRUE DOUTERN DINTERN DINTERNP REMF ADDF DATUM PAR KIND FACT TRUE* KINDP ISP FALSEP TRUEP CLEAR VISIBLEP UNMRK MARKP MARK) +(*LEXPR CONTEXT DEACTIVATE ACTIVATE) +(*EXPR CHECK-OUT-OF-CORE-STRING ALLOCATE-MESSAGE-INDEX) +(*EXPR $SPECINT $LAPINT) +(*EXPR $GCFACTOR $JACOBI $TOTIENT $PRIME) +(*LEXPR $DIVSUM) +(*EXPR SIMPMDEFMACRO MMACRO-APPLY) +(*EXPR HGFSIMP-EXEC $HGFRED) +(*EXPR $SPECINT) +(*EXPR $LDEFINT) +(*LEXPR $LIMIT) +(*EXPR $ERRORMSG RATCOEFF) +(*EXPR STOTALDIFF DIFFNCEXPT DIFFLAPLACE DIFFSUM DIFFINT) +(*EXPR $AT $ATVALUE) +(*EXPR $LOGCONTRACT) +(*EXPR $NTERMS) +(*EXPR $FIBTOPHI) +(*EXPR $DERIVDEGREE) +(*EXPR BOX) +(*LEXPR $REMBOX $BOX $LPART $DPART) +(*EXPR $COPYLIST $COPYMATRIX) +(*LEXPR $GENMATRIX) +(*LEXPR $ADDCOL $ADDROW) +(*EXPR $ARRAYMAKE) +(*EXPR $UNORDER) +(*EXPR $GETCHAR) +(*LEXPR $CONCAT) +(*EXPR CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO DIMENSION-SUPERSCRIPT DIMENSION-NOFIX DIMENSION-POSTFIX DIMENSION-NARY DIMENSION-INFIX DIMENSION-PREFIX MAKESTRING DIMENSION-STRING DIMENSION-ATOM DISPLA) +(*EXPR NFORMAT-ALL NFORMAT) +(*EXPR MSTRING) +(*EXPR $LOPOW $HIPOW COEFF $FLOAT $ENTIER $FIX $DENOM $NUM $SYMBOLP $ATOM $LENGTH $REVERSE $ARGS $LAST $FIRST FORMAT1 ATOMCHK $MEMBER $ENDCONS $CONS $LISTP LISTERCHK GETOPR GETOP MPART PART1 $DISPTERMS ELABEL $TRUNC REMSIMP DELSIMP NTHELEM UNION* SUBSTITUTEL NOTLOREQ ATVARSCHK SDIFF $DEL I-$DEPENDENCIES RECUR-APPLY SUBST0 SUBSTITUTE) +(*LEXPR $COEFF $DELETE $REST $APPEND $INPART $PART $DISPFORM $DISP $LDISP $DIFF $DEPENDS $SUBSTITUTE) +(*EXPR $TRANSPOSE $SETELMX $ROW $MINOR $COL $TRIANGULARIZE $RANK ONEN $ECHELON $INVERTMX $DIAGMATRIX $IDENT $DETERMINANT $CHARPOLY $MATRIXP) +(*LEXPR $SUBMATRIX) +(*EXPR $RADCAN FREEOF ARGSFREEOF $BOTHCOEF $RATSUBST RATCOEFF) +(*LEXPR $FREEOF $RATCOEF) +(*EXPR SIMPLIFY MORP PORM ROOT NCPOWER POWER* POWER NCMULN NCMUL2 DIV* DIV MULN MUL3 MUL2* MUL2 SUB* SUB NEG ADDN ADD2* ADD2) +(*EXPR NTHKDR *KAR SIMPARGS1 KDR KAR MATCHERR BPROG RATDENOMINATOR RATNUMERATOR SIMPNRT EXPAND1 ALIKE ALIKE1 GREAT SIMPMQAPPLY $ORDERGREATP $ORDERLESSP SIMPMATRIX SIMPEXPT EXPTRL SIMPSIGNUM SIGNUM1 SIMPDERIV INFSIMP SIMPMDEF SIMPLAMBDA SIMPEXP SIMPBIGFLOAT SIMPINTEG SIMP-LIMIT SIMPTIMES SIMPABS SIMPQUOT SIMPSQRT SIMPLN SIMPLUS FPCOFRAT TIMESK ADDK SIMPARGS SSIMPLIFYA EQTEST SIMPLIFYA FREEARGS FREEL FREE ISINOP CONSTFUN MXORLISTP MEQUALP MBAGP $NONSCALARP $SCALARP $CONSTANTP $NUMFACTOR SUBFUNARGS SUBFUNSUBS SUBFUNNAME SUBFUNMAKE SUBFUNMAKES SUBARGCHECK IMPROPER-ARG-ERR WNA-ERR TWOARGCHECK ONEARGCHECK $POLYSIGN SPECDISREP SPECREPP $RATP $RATNUMP $FLOATNUMP $EVENP $ODDP $INTEGERP $NUMBERP MRATCHECK SIMPCHECK SRATSIMP RATDISREP MQAPPLYP MNEGP MMMINUSP MLOGP MNCEXPTP MNCTIMESP MEXPTP MTIMESP MPLUSP RATNUMP EVEN MNUMP $BFLOATP ZEROP1 ONEP1 ONEP) +(*LEXPR $INTEGRATE $EXPAND $MULTTHRU) +(*FEXPR RETLIST MATCOEF) +(*EXPR $POWERSERIES) +(*EXPR MYCABS $ALGSYS) +(*EXPR MFILENAME-ONLYP $FILE_TYPE $LOAD $BATCHLOAD CALL-BATCH1 OPEN-IN-DSK OPEN-OUT-DSK LOAD-AND-TELL $LISTP_CHECK) +(*LEXPR $FILENAME_MERGE $FILE_SEARCH) +(*EXPR I-$STORE I-$UNSTORE) +(*EXPR RATINT) +(*EXPR $OPTIMIZE) +(*EXPR ARRSTORE-EXTEND MEVAL1-EXTEND $ARRAY_DIMENSION_N $ARRAY_NUMBER_OF_DIMENSIONS DIMENSION-ARRAY-OBJECT) +(*LEXPR $MAKE_ARRAY) +(*LEXPR $COMPILE_LISP_FILE) +(*EXPR $TIMEDATE $WHO) +(*EXPR $REVEAL $PICKAPART $ISOLATE) +(*EXPR $CHANGEVAR) +(*EXPR $GFACTORSUM $FACTORSUM) +(*EXPR $COMBINE) +(*LEXPR $FACTOROUT) +(*EXPR $CLEARSCREEN) +(*LEXPR $PAUSE) +(*EXPR $FACTCOMB $MINFACTORIAL $MAKEGAMMA $MAKEFACT) +(*EXPR $BERNPOLY SIMPBERN $BERN SIMPEULER $EULER) +(*EXPR $FIB $ZETA) +(*EXPR $CFEXPAND $QUNIT $CFDISREP) +(*EXPR $TAYTORAT) +(*EXPR $POLYDECOMP) +(*EXPR $LINSOLVE) +(*LEXPR $SOLVE) +(*LEXPR $EZGCD) +(*EXPR $NICEINDICES $BASHINDICES $INTOSUM $SUMCONTRACT) +(*EXPR APPLICATION-OPERATOR IS-BOOLE-CHECK ASSIGN-CHECK MAPPLY-TR INSURE-ARRAY-PROPS $ARRAYSETAPPLY $ARRAYAPPLY INTERVAL-ERROR) +(*LEXPR DISPLAY-FOR-TR MARRAYSET MARRAYREF MFUNCALL) +(*EXPR $TAYLORINFO) +(*LEXPR $TAYLOR) +(*EXPR $RISCH) +(*EXPR $SCALARP) +(*EXPR $RESIDUE) +(*EXPR DECLAREKIND RGRP $FEATUREP SIGN MNQP MGQP MGRP MEQP LIKE $SIGN ASKSIGN-P-OR-N $ASKSIGN MAXIMIN MINIMUM MAXIMUM $COMPARE RESTORE-FACTS FORGET LEARN ASSUME PRED-REVERSE PRE-ERR MEVALP2 MEVALP IS $KILLCONTEXT $NEWCONTEXT) +(*LEXPR $MIN $MAX $FACTS $DEACTIVATE $ACTIVATE $CONTEXT) +(*EXPR $GMARK $GVPRINT $GHPRINT $GTERPRI $EXITGRAPH $ENTERGRAPH $CLEAR $DRAWSYMBOL3 $LINE3 $VECTOR3 $POINT3 $SETPOINT3 $SIZE $SCREENSIZE1 $SCREENSIZE $DEFINESYMBOL $DRAWSYMBOL $LINE $VECTOR $POPDASH $PUSHDASH $CHANGEDASH $DEFINEDASH $POINT $SETPOINT) +(*EXPR MACHERRFUN IOLFUN TTYRETFUN TTYINTFUN TTYINTFUNSETUP $DSKGC I-$ALLOC $PAGEPAUSE MORE-FUN MTERPRI MFILE-OUT FILEPRINT FILESTRIP $DDT $LOGOUT $QUIT $TO_LISP COMPUTIME TIMEORG $THROW $UUO GETLABCHARN GETLABELS* GETLABELS $%TH $POISLIM $FPPREC CASIFY-EXPLODEN STRMEVAL MAKSTRING DOLLARIFY-NAME AMPERCHK $VERBIFY $NOUNIFY FULLSTRIP1 FULLSTRIP STRIPDOLLAR REMALIAS ALIAS RETRIEVE PRINL NONVARCHK NONSYMCHK FEXPRCHECK ERRBREAK $DEBUGMODE RULEOF REMVALUE REMLABELS KILL1 BATCH1 CARFILE MTRUENAME TRUEFNAME LOADFILE FILENAMEL MFBOUNDP DOLLARIFY LOAD-FILE FIND0 LOAD-FUNCTION FIND-FUNCTION REPRINT RUBOUT* FORMFEED $BOTHCASES TYI* ADDLABEL MEXPLODEN PRINTLABEL MAKELABEL MEVAL*) +(*LEXPR $FILEDEFAULTS $BREAK $RANDOM $READONLY $READ $PRINT) +(*EXPR MDESCRIBE) +(*EXPR ASK-INTEGER) +(*LEXPR $ASKINTEGER) +(*EXPR *ERRRJF-1 *MERROR-5 *MERROR-4 *MERROR-3 *MERROR-2 *MERROR-1 FSTRINGC READ-ONLY-ASSIGN $ERRORMSG) +(*LEXPR ERRRJF MERROR $ERROR) +(*EXPR FPENTIER *FPATAN ATANBIGFLOAT RATBIGFLOAT ADDBIGFLOAT $BFLOAT FP2FLO) +(*EXPR $ALLROOTS) +(*EXPR $BINOMIAL $GAMMA $ACSCH $ASECH $ACOTH $ATANH $ACOSH $ASINH $ACSC $ASEC $ACOT $ATAN $ACOS $ASIN $CSCH $SECH $COTH $TANH $COSH $SINH $CSC $SEC $COT $TAN $COS $SIN $LOG |''MAKE-FUN| DSKRAT MFILEP BIGFLOATM* ADD2LNC $SQRT $EXP RAT MRETURN OPTIONP MCONS-OP-ARGS $FUNMAKE MOPP1 MOPP ARRSTORE MGETL MREMPROP MPUTPROP MGET REMALIAS1 REMRULE REMARRELEM I-$REMVALUE REMPROPCHK REMOVE1 I-$REMOVE $PUT $REM $GET FUNCER $MAPATOM MMAPEV NEVERSET NUMERSET MSETCHK MSETERR $SUBVARP MQUOTEP MSETQP MEVALATOMS MSET MUNBIND MBIND MARGS MOP MEVAL2 MEVAL1 MEVAL MEVALN MAPPLY) +(*LEXPR $ALLBUT $MATRIX OUTERMAP1 FMAPL1 MCALL) +(*FEXPR DSKSETQ MDEFPROP) +(SPECIAL $USER_MESFILE DUMPING USER-MESFILE MASTER-MESFILE) +(SPECIAL $UNIVERSE $DISPLAYSET) +(SPECIAL $TR_WARN_BAD_FUNCTION_CALLS) +(SPECIAL $RESULTANT) +(SPECIAL $ROMBERGIT_USED $ROMBERGABS $ROMBERGTOL $ROMBERGMIN $ROMBERGIT) +(FIXNUM $ROMBERGIT_USED $ROMBERGMIN $ROMBERGIT) +(FLONUM $ROMBERGABS $ROMBERGTOL) +(SPECIAL $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE) +(FIXNUM $TRACE_MAX_INDENT $TRACE_MAX_INDENT) +(SPECIAL $TR_FLOAT_CAN_BRANCH_COMPLEX) +(SPECIAL $SUBLIS_APPLY_LAMBDA) +(SPECIAL $SUSPEND) +(SPECIAL -SQRT3//2 SQRT3//2 -SQRT2//2 SQRT2//2 %PI//2 %PI//4 -1//2 1//2 $HALFANGLES $LOGARC $EXPONENTIALIZE $TRIGSIGN $TRIGEXPANDTIMES $TRIGEXPANDPLUS $TRIGEXPAND $TRIGINVERSES $%IARGS $%PIARGS) +(SPECIAL $GAMMALIM $SUMSPLITFACT HALF%PI3 %PI2 HALF%PI FOURTH%PI %P%I) +(SPECIAL ERRRJFFLAG HMODULUS MODULUS) +(SPECIAL $POINTBOUND) +(SPECIAL $MODE_CHECK_ERRORP $MODE_CHECK_WARNP $MODE_CHECKP) +(SPECIAL $TR_GEN_TAGS $TR_STATE_VARS $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED $COMPGRIND TRANSL-FILE $TR_WINDY $TR_FILE_TTY_MESSAGESP $TR_OUTPUT_FILE_DEFAULT *TRANSL-FILE-DEBUG*) +(SPECIAL $RATALGDENOM $RATWTLVL) +(SPECIAL GENERATE-ATAN2 IMPLICIT-REAL) +(SPECIAL $MAXAPPLYHEIGHT $MAXAPPLYDEPTH) +(SPECIAL $TIMER_DEVALUE $TIMER $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE_SAFETY $TRACE) +(FIXNUM $TRACE_MAX_INDENT) +(SPECIAL $LISTCONSTVARS) +(SPECIAL TRAMP3$ TRAMP2$ TRAMP1$) +(SPECIAL $PARSEWINDOW) +(FIXNUM $PARSEWINDOW) +(SPECIAL $PRODHACK $SUMHACK $SIMPSUM $ZEROBERN $GENINDEX $GENSUMNUM $CAUCHYSUM) +(SPECIAL $TR_BOUND_FUNCTION_APPLYP $TR_OPTIMIZE_MAX_LOOP *$ANY-MODES* *TR-WARN-BREAK* $TR_PREDICATE_BRAIN_DAMAGE $TR_NUMER $TR_ARRAY_AS_REF $TR_FUNCTION_CALL_DEFAULT *WARNED-MODE-VARS* *WARNED-FEXPRS* *WARNED-UN-DECLARED-VARS* $TR_WARN_UNDEFINED_VARIABLE $TR_WARN_MODE $TR_WARN_FEXPR $TR_WARN_MEVAL $TR_WARN_UNDECLARED TR-UNIQUE TR-ABORT *TRANSL-DEBUG* *TRANSL-BACKTRACE* TRANSLATE-TIME-EVALABLES SPECIALS ASSIGNS NEED-PROG? RETURN-MODE RETURNS INSIDE-MPROG TR-PROGRET FEXPRS EXPRS LEXPRS ARRAYS LOCAL TSTACK $SPECIAL $TRANSCOMPILE $TR_SEMICOMPILE $TRANSBIND) +(SPECIAL $NEWFAC $NALGFAC SMALLPRIMES ALPHA MM* MPLC* MINPOLY* *MX* *MIN* GAUSS) +(SPECIAL *ALPHA BIGPRIMES $GCD *GCDL*) +(SPECIAL $RATDENOMDIVIDE $RATEXPAND $RATEPSILON $RATPRINT FR-FACTOR ADN* INRATSIMP TELLRATLIST $FACEXPAND $RATVARS $ALGEBRAIC $RATFAC $RATWEIGHTS $NOREPEAT $DONTFACTOR $FACTORFLAG $KEEPFLOAT *RATWEIGHTS *FNEWVARSW VARLIST GENPAIRS GENVAR) +(SPECIAL $RESULTANT) +(SPECIAL $LINSOLVE_PARAMS $%RNUM $BACKSUBST $SPARSE $GLOBALSOLVE) +(SPECIAL $HOMOG_HACK $SAVEFACTORS $BERLEFACT $INTFACLIM LOW* ALGFAC* *IRREDS) +(SPECIAL $BETA_ARGS_SUM_TO_INTEGER) +(SPECIAL META-PROP-L META-PROP-P) +(SPECIAL $FORTFLOAT $FORTINDENT $FORTSPACES) +(FIXNUM $FORTINDENT) +(SPECIAL $MAXPRIME) +(SPECIAL $MACROEXPANSION) +(SPECIAL PRESERVE-DIRECTION LIMIT-ANSWERS SIMPLIMPLUS-PROBLEMS RD* INFINITESIMALS REAL-INFINITIES INFINITIES) +(SPECIAL $SUPERLOGCON $LOGCONCOEFFP) +(SPECIAL $ROOTSCONMODE) +(SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR $BOXCHAR DISPLAYP STRINGDISP $FPTRUNC $NOUNDISP $DERIVABBREV $LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP $CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY) +(SPECIAL $NEGSUMDISPFLAG $SQRTDISPFLAG $EXPTDISPFLAG $%EDISPFLAG $PFEFORMAT $POWERDISP) +(SPECIAL $VECT_CROSS) +(SPECIAL $MATRIX_ELEMENT_TRANSPOSE $MATRIX_ELEMENT_ADD $MATRIX_ELEMENT_MULT $RATMX) +(SPECIAL DERIVSIMP ERRORSW DOSIMP $MAXNEGEX $MAXPOSEX $EXPON $EXPOP $MX0SIMP $DOMXTIMES $DOMXPLUS $DOMXEXPT $DOSCMXPLUS $NUMER_PBRANCH $SUMEXPAND $SIMP $NUMER $NEGDISTRIB $FLOAT) +(FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP) +(SPECIAL ALGNOTEXACT $ALGEXACT REALONLYRATNUM $REALONLY $%RNUM_LIST) +(SPECIAL $FILE_TYPES $FILE_SEARCH *IN-MACSYMA-INDEXER* *IN-TRANSLATE-FILE* *IN-$BATCHLOAD*) +(SPECIAL $LET_RULE_PACKAGES $CURRENT_LET_RULE_PACKAGE $DEFAULT_LET_RULE_PACKAGE $LETRAT $LETVARSIMP) +(SPECIAL $INTEGRATION_CONSTANT_COUNTER) +(SPECIAL $OPTIMPREFIX) +(SPECIAL $TO_CALL_LISP_COMPILER) +(SPECIAL $ISOLATE_WRT_TIMES $EXPTISOLATE) +(SPECIAL $SOLVERADCAN $SOLVETRIGWARN $SOLVENULLWARN $SOLVEFACTORS $SOLVEEXPLICIT $SOLVEDECOMPOSES $SAVEFACTORS $PROGRAMMODE $SOLVE_INCONSISTENT_ERROR $LINSOLVEWARN $MULTIPLICITIES $BREAKUP) +(SPECIAL $TAYLOR_LOGEXPAND $TAYLOR_TRUNCATE_POLYNOMIALS $MAXTAYORDER) +(SPECIAL $ERFFLAG $LIFLAG) +(SPECIAL LIMITP $ASKEXP $SIGNBFLOAT $PREDERROR SIGN-IMAG-ERRP $ACTIVECONTEXTS $CONTEXTS $CONTEXT) +(SPECIAL $SHOWTIME $FILE_STRING_PRINT $CHANGE_FILEDEFAULTS ALIASLIST $MOREWAIT $TTYINTFUN $TTYINTNUM USER-TIMESOFAR CASEP $DIREC $LINENUM $LINECHAR $OUTCHAR $INCHAR $%) +(FIXNUM $LINENUM) +(SPECIAL DEFINTDEBUG) +(SPECIAL $ERROR_SYMS $ERROR_SIZE $ERROR) +(SPECIAL BIGFLOAT%PI BIGFLOAT%E BFMHALF BFHALF BIGFLOATONE BIGFLOATZERO $FPPREC $FPPRINTPREC $BFTRUNC $BFTORAT $FLOAT2BF) +(FIXNUM $FPPRINTPREC) +(SPECIAL $ASSUMESCALAR $DOTIDENT $SCALARMATRIXP $DOMXNCTIMES $DOSCMXOPS $DOMXMXOPS $DOALLMXOPS $DOTASSOC $DOTEXPTSIMP $DOTDISTRIB $DOTSCRULES $DOT1SIMP $DOT0NSCSIMP $DOT0SIMP $DOTCONSTRULES) +(SPECIAL $FLOATOPTIONS $FLOATWIDTH $FLOATPREC $FLOATFRAC $FLOATINT $FLOATFORMAT) +(SPECIAL $SETCHECK MUNBINDP) \ No newline at end of file diff --git a/src/maxdoc/dcl.load b/src/maxdoc/dcl.load new file mode 100755 index 00000000..fcfdefa3 --- /dev/null +++ b/src/maxdoc/dcl.load @@ -0,0 +1,303 @@ + +(DEFPROP DCL "5//29//82 8:19:42" VERSION) +(*EXPR CMOD CPLUS CTIMES CEXPT CRECIP CFACTOR) +(*FEXPR $FASMAK) +(*EXPR SOLVEQUARTIC) +(*EXPR $GETCHARN) +(*EXPR $FACOUT $DISTRIB) +(*LEXPR $SCSIMP) +(*FEXPR $GRAPH $PLOT) +(*EXPR $APPLY_NOUNS MTREE-SUBST) +(*EXPR DIMENSION-SUPERSCRIPT) +(*EXPR $COMBINE) +(*EXPR GET-OUT GET-FLIST) +(*EXPR $SUBSETP $ELEMENTOF $ELEMENTP $CARDINAL $MAPSET $PREDSET $ELEMENTS $EMPTYP $UNIVERSE $MAKE_UNIVERSE) +(*LEXPR $SETDIFF $SYMDIFF $INTERSECTION $UNION $ORDINAL ${) +(*LEXPR $NROOTS $REALROOTS) +(*EXPR $POLYDECOMP) +(*EXPR $CLEARSCREEN) +(*LEXPR $PAUSE) +(*EXPR $TRIGEXPAND) +(*EXPR $XTHRU) +(*EXPR $TR_WARNINGS_GET) +(*EXPR $PFET) +(*EXPR $SUBLIST) +(*FEXPR $MAKELIST) +(*FEXPR $RENAMEFILE $FILELENGTH $FILELIST $QLISTFILES $LISTFILES $PRINTFILE) +(*EXPR $TLDEFINT) +(*LEXPR $TLIMIT) +(*EXPR $BEZOUT $DISCRIMINANT $RESULTANT) +(*FEXPR $OPTIONS) +(*EXPR MBUILDQ-SUBST) +(*FEXPR $BUILDQ) +(*EXPR MACSYMACALLP SUBRCALL$P SUBRCALLP) +(*LEXPR FMAPPLY) +(*EXPR DEFINE-SYMBOL) +(*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE) +(*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $NUMBER_OF_OBJECTS_IN_INDEX_FILE $OPEN_INDEX_FILE) +(*EXPR OUTEX-HOOK-EXP $MAKE_INDEX_FILE) +(*EXPR $MAP_OVER_INDEX_FILE $READ_NTH_OBJECT $INDEX_FILE_DIM $OPEN_INDEX_FILE) +(*EXPR MMINUSP*) +(*EXPR LOWDEG) +(*EXPR SIMP-%SECH SIMP-%CSCH SIMP-%COTH SIMP-%TANH SIMP-%COSH SIMP-%SINH) +(*EXPR SIMP-%ASEC SIMP-%ACSC SIMP-%ACOT SIMP-%ACOS SIMP-%ASIN) +(*EXPR SIMP-%ASECH SIMP-%ACSCH SIMP-%ACOTH SIMP-%ATANH SIMP-%ACOSH SIMP-%ASINH) +(*EXPR TRIGEXPAND $TRIGEXPAND) +(*FEXPR $MULTIGRAPH $PARAMPLOT) +(*FEXPR $GRAPH $PLOT) +(*EXPR $TAG_FILE_INSERT) +(*FEXPR $PRIMER) +(*LEXPR $SUSPEND) +(*FEXPR $PRODUCT) +(*EXPR $LHS $RHS $PARTITION $DEMOIVRE) +(*EXPR *MERROR-1) +(*EXPR MDESCRIBE) +(*FEXPR $DESCRIBE) +(*EXPR $TMINVERSE $TMLIN) +(*LEXPR $TMLINSOLVE $TMNEWDET) +(*LEXPR $PERMANENT $NEWDET) +(*EXPR $ALGNORM $SPLITFIELD $PFACTORALG $ALGTRACE) +(*LEXPR $BDISCR $ALGFAC) +(*EXPR FLUIDIZE ASS-EQ-SET ASSIGN-MODE-CHECK) +(*LEXPR CHEKVALUE ASS-EQ-REF) +(*EXPR RATQUOTIENT RATPLUS RATEXPT RATTIMES RATREDUCE RATMINUS RATFACT RATDIF RATDERIVATIVE) +(*EXPR $UNTRACE_IT $TRACE_IT) +(*EXPR $ISIMPTEST $RSIMPTEST $ITEFFA $RTEFFA $TEFFS $IRES $RRES $NUPP $NUP $NU) +(*EXPR $DEBUG) +(*LEXPR $LISPDEBUGMODE $DEBUGPRINTMODE) +(*LEXPR $SORT) +(*EXPR $SUBLIST) +(*FEXPR $MAKELIST) +(*FEXPR $DEFRULE $TELLSIMPAFTER $TELLSIMP $DEFMATCH $MATCHDECLARE) +(*EXPR NEVERSET) +(*EXPR TRANSLATE-MACEXPR-TOPLEVEL TRANSLATE-AND-EVAL-MACSYMA-EXPRESSION) +(*LEXPR $TRIGREDUCE) +(*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP) +(*LEXPR $POISSUBST) +(*EXPR $POISINT $POISSQUARE $POISEXPT $POISTIMES $POISDIFF $PRINTPOIS $OUTOFPOIS $POISCTIMES $INTOPOIS $POISMAP $POISPLUS $POISSIMP) +(*LEXPR $POISSUBST) +(*EXPR $ILT $LAPLACE) +(*EXPR $PADE) +(*FEXPR $HELP) +(*FEXPR $SCANMAP) +(*LEXPR $NOFIX $MATCHFIX $NARY $INFIX $POSTFIX $PREFIX) +(*FEXPR $PRINTPROPS $PROPVARS $PROPERTIES) +(*EXPR DISPLINE MAKE-PARAM) +(*EXPR SIMPPLOG) +(*EXPR BINOCOMP SIMPBINOCOEF) +(*EXPR SIMPGAMMA SIMPBETA) +(*EXPR ERF SIMPERF) +(*EXPR $EMATRIX $ZEROMATRIX) +(*EXPR $AUGCOEFMATRIX $COEFMATRIX) +(*EXPR $ENTERMATRIX) +(*EXPR $XTHRU) +(*FEXPR $APROPOS) +(*EXPR $MAP_FLOAT_ARRAY $INIT_FLOAT_ARRAY) +(*EXPR ASCII-NUMBERP ALPHABETP CPUT A-ATOM DOT2L FSET LOG2 ASSQR FIRSTN RECONC AMONGL AMONG XOR ANDMAPCAR ORMAPC ANDMAPC MAP2C) +(*LEXPR CONCAT *MAKE-LIST) +(*EXPR META-FSET META-MPUTPROP META-PUTPROP META-ADD2LNC) +(*LEXPR $FORTMX) +(*LEXPR $DOVER_FILE $DOVARD_FILE) +(*EXPR CHECK-OUT-OF-CORE-STRING ALLOCATE-MESSAGE-INDEX) +(*EXPR $SPECINT $LAPINT) +(*EXPR $GCFACTOR $JACOBI $TOTIENT $PRIME) +(*LEXPR $DIVSUM) +(*EXPR SIMPMDEFMACRO MMACRO-APPLY) +(*EXPR HGFSIMP-EXEC $HGFRED) +(*EXPR $SPECINT) +(*EXPR $ERRORMSG RATCOEFF) +(*EXPR $RADCAN FREEOF ARGSFREEOF $BOTHCOEF $RATSUBST RATCOEFF) +(*LEXPR $FREEOF $RATCOEF) +(*EXPR SIMPLIFY MORP PORM ROOT NCPOWER POWER* POWER NCMULN NCMUL2 DIV* DIV MULN MUL3 MUL2* MUL2 SUB* SUB NEG ADDN ADD2* ADD2) +(*EXPR $POWERSERIES) +(*EXPR RATINT) +(*EXPR ARRSTORE-EXTEND MEVAL1-EXTEND $ARRAY_DIMENSION_N $ARRAY_NUMBER_OF_DIMENSIONS DIMENSION-ARRAY-OBJECT) +(*LEXPR $MAKE_ARRAY) +(*LEXPR $COMPILE_LISP_FILE) +(*LEXPR $EZGCD) +(*EXPR $NICEINDICES $BASHINDICES $INTOSUM $SUMCONTRACT) +(*EXPR $TAYLORINFO) +(*LEXPR $TAYLOR) +(*EXPR $RISCH) +(*EXPR $RESIDUE) +(*EXPR ASK-INTEGER) +(*LEXPR $ASKINTEGER) +(*EXPR $ALLROOTS) +(*EXPR LOGARC $LOGARC) +(*EXPR CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO DIMENSION-SUPERSCRIPT DIMENSION-NOFIX DIMENSION-POSTFIX DIMENSION-NARY DIMENSION-INFIX DIMENSION-PREFIX MAKESTRING DIMENSION-STRING DIMENSION-ATOM DISPLA) +(*EXPR $LOPOW $HIPOW COEFF $FLOAT $ENTIER $FIX $DENOM $NUM $SYMBOLP $ATOM $LENGTH $REVERSE $ARGS $LAST $FIRST FORMAT1 ATOMCHK $MEMBER $ENDCONS $CONS $LISTP LISTERCHK GETOPR GETOP MPART PART1 $DISPTERMS ELABEL $TRUNC REMSIMP DELSIMP NTHELEM UNION* SUBSTITUTEL NOTLOREQ ATVARSCHK SDIFF $DEL I-$DEPENDENCIES RECUR-APPLY SUBST0 SUBSTITUTE) +(*LEXPR $COEFF $DELETE $REST $APPEND $INPART $PART $DISPFORM $DISP $LDISP $DIFF $DEPENDS $SUBSTITUTE) +(*EXPR DECLAREKIND RGRP $FEATUREP SIGN MNQP MGQP MGRP MEQP LIKE $SIGN CSIGN ASKSIGN-P-OR-N $ASKSIGN MAXIMIN MINIMUM MAXIMUM $COMPARE RESTORE-FACTS FORGET LEARN ASSUME PRED-REVERSE PRE-ERR MEVALP2 MEVALP IS $KILLCONTEXT $NEWCONTEXT) +(*LEXPR $MIN $MAX $FACTS $DEACTIVATE $ACTIVATE $CONTEXT) +(*EXPR NTHKDR *KAR SIMPARGS1 KDR KAR MATCHERR BPROG RATDENOMINATOR RATNUMERATOR SIMPNRT EXPAND1 ALIKE ALIKE1 GREAT DECL-REALP DECL-COMPLEXP SIMPMQAPPLY $ORDERGREATP $ORDERLESSP SIMPMATRIX SIMPEXPT EXPTRL SIMPSIGNUM SIGNUM1 SIMPDERIV INFSIMP SIMPMDEF SIMPLAMBDA SIMPEXP SIMPBIGFLOAT SIMPINTEG SIMP-LIMIT SIMPTIMES SIMPABS SIMPQUOT SIMPSQRT SIMPLN SIMPLUS FPCOFRAT TIMESK ADDK SIMPARGS SSIMPLIFYA EQTEST SIMPLIFYA FREEARGS FREEL FREE ISINOP CONSTFUN MXORLISTP MEQUALP MBAGP $NONSCALARP $SCALARP $CONSTANTP $NUMFACTOR SUBFUNARGS SUBFUNSUBS SUBFUNNAME SUBFUNMAKE SUBFUNMAKES SUBARGCHECK IMPROPER-ARG-ERR WNA-ERR TWOARGCHECK ONEARGCHECK $POLYSIGN SPECDISREP SPECREPP SPECREPCHECK $RATP $RATNUMP $FLOATNUMP $EVENP $ODDP $INTEGERP $NUMBERP MRATCHECK SIMPCHECK SRATSIMP RATDISREP MQAPPLYP MNEGP MMMINUSP MLOGP MNCEXPTP MNCTIMESP MEXPTP MTIMESP MPLUSP RATNUMP EVEN MNUMP $BFLOATP ZEROP1 ONEP1 ONEP) +(*LEXPR $INTEGRATE $EXPAND $MULTTHRU) +(*EXPR NFORMAT-ALL NFORMAT) +(*EXPR DEFINE-SYMBOL RBP LBP) +(*EXPR ACSCH ASECH ACOTH ATANH ASINH ACOSH SECH CSCH COTH TANH COSH SINH ACSC ASEC ACOT ATAN1 ACOS ASIN CSC SEC COT TAN MMINUSP* MMINUSP EXPONENTIALIZE $EXPONENTIALIZE RREMAINDER RTIMES RDIFFERENCE RPLUS SIMP-%ATAN SIMP-%SEC SIMP-%CSC SIMP-%COT SIMP-%TAN SIMP-%COS SIMP-%SIN ARCP TRIGP SQ-SUMSQ SQRTX^2-1 SQRT1+X^2 SQRT1-X^2) +(*EXPR KILLC CONTEXTMARK KCNTXT CNTXT KILLFRAME REMOV UNKIND KILL UNTRUE DOUTERN DINTERN DINTERNP REMF ADDF DATUM PAR KIND FACT TRUE* KINDP ISP FALSEP TRUEP CLEAR VISIBLEP UNMRK MARKP MARK) +(*LEXPR CONTEXT DEACTIVATE ACTIVATE) +(*EXPR MSTRING) +(*EXPR PTIMES PQUOTIENT PMOD PMINUS PMINUSP PDERIVATIVE PDIFFERENCE PPLUS POINTERGP) +(*EXPR PDEGREE $PRIMEP PGCD1 PQUOTIENTCHK) +(*EXPR PABS $NTHROOT $INRT $ISQRT) +(*EXPR MEMALIKE ASSOLIKE ASSOL) +(*EXPR MFILENAME-ONLYP $FILE_TYPE $LOAD $BATCHLOAD CALL-BATCH1 OPEN-IN-DSK OPEN-OUT-DSK LOAD-AND-TELL $LISTP_CHECK) +(*LEXPR $FILENAME_MERGE $FILE_SEARCH) +(*EXPR $RESET $LISTOFVARS $UNKNOWN) +(*EXPR TOTAL-NARY RASSOCIATIVE LASSOCIATIVE NARY1 ANTISYM COMMUTATIVE1 ODDFUN EVENFUN DO%SUM DOSUM SIMPSUM SIMPGFACT SIMPFACT) +(*LEXPR $GENFACT) +(*EXPR *ERRRJF-1 *MERROR-5 *MERROR-4 *MERROR-3 *MERROR-2 *MERROR-1 FSTRINGC READ-ONLY-ASSIGN $ERRORMSG) +(*LEXPR ERRRJF MERROR $ERROR) +(*EXPR MYCABS $ALGSYS) +(*EXPR DECL-COMPLEXP) +(*EXPR DECL-COMPLEXP) +(*EXPR TESTDIVIDE CFACTORW) +(*EXPR FPENTIER *FPATAN ATANBIGFLOAT RATBIGFLOAT ADDBIGFLOAT $BFLOAT FP2FLO) +(*LEXPR $TRANSLATE_FILE) +(*EXPR $ZEROEQUIV) +(*EXPR $SUBLIS) +(*EXPR $PLOTRESET $PLOTINIT) +(*EXPR MAKE-TRAMP$) +(*LEXPR GET-ARRAY) +(*EXPR $TIMEDATE $WHO) +(*EXPR $REVEAL $PICKAPART $ISOLATE) +(*EXPR $CHANGEVAR) +(*EXPR $GFACTORSUM $FACTORSUM) +(*EXPR $COMBINE) +(*LEXPR $FACTOROUT) +(*EXPR $CLEARSCREEN) +(*LEXPR $PAUSE) +(*EXPR $CHANGENAME $INDICES2 $COMPONENTS $INDEXED $REMCOMPS $FLUSHND $INDICES $LC $SHOW $KDELTA $UNDIFF $CONTRACT $CURVATURE $CHR2 $CHR1 $METRIC $DUMMY) +(*LEXPR $REMCOORD $COORD $ENTERTENSOR $RENAME $FLUSHD $FLUSH $LORENTZ $COVDIFF $DEFCON) +(*EXPR $RESULTANT $POLY_DISCRIMINANT) +(*EXPR $BEZOUT) +(*EXPR $LDEFINT) +(*LEXPR $LIMIT) +(*EXPR MDESCRIBE) +(*EXPR $GMARK $GVPRINT $GHPRINT $GTERPRI $EXITGRAPH $ENTERGRAPH $CLEAR $DRAWSYMBOL3 $LINE3 $VECTOR3 $POINT3 $SETPOINT3 $SIZE $SCREENSIZE1 $SCREENSIZE $DEFINESYMBOL $DRAWSYMBOL $LINE $VECTOR $POPDASH $PUSHDASH $CHANGEDASH $DEFINEDASH $POINT $SETPOINT) +(*EXPR MAKE-ALAMBDA APPLICATION-OPERATOR MAYBE-BOOLE-CHECK IS-BOOLE-CHECK ASSIGN-CHECK MAPPLY-TR INSURE-ARRAY-PROPS $ARRAYSETAPPLY $ARRAYAPPLY INTERVAL-ERROR) +(*LEXPR MAPLIST_TR DISPLAY-FOR-TR MARRAYSET MARRAYREF MFUNCALL) +(*EXPR $RATDISREP $RATEXPAND RATIONALIZE RATF RATREP* RATREP RATSETUP $GFACTOR $SQFR $TOTALDISREP $SHOWRATVARS $PRINTVARLIST $RATDENOM $RATNUMER) +(*LEXPR $CONTENT $GCD $REMAINDER $QUOTIENT $DIVIDE $MOD FACTOR $FACTOR $RATSIMP $RAT $FULLRATSIMP $RATVARS $TELLRAT $UNTELLRAT) +(*EXPR $FASTTIMES) +(*LEXPR $RATWEIGHT) +(*LEXPR $HORNER) +(*EXPR $PARTFRAC) +(*EXPR $RATDIFF) +(*EXPR $PFET) +(*EXPR $LINSOLVE) +(*LEXPR $SOLVE) +(*EXPR MACHERRFUN IOLFUN TTYRETFUN TTYINTFUN TTYINTFUNSETUP $DSKGC I-$ALLOC $PAGEPAUSE MORE-FUN MTERPRI MFILE-OUT FILEPRINT FILESTRIP $DDT $LOGOUT $QUIT $TO_LISP COMPUTIME TIMEORG $THROW $UUO GETLABCHARN GETLABELS* GETLABELS $%TH $POISLIM $FPPREC CASIFY-EXPLODEN STRMEVAL MAKSTRING DOLLARIFY-NAME AMPERCHK $VERBIFY $NOUNIFY FULLSTRIP1 FULLSTRIP STRIPDOLLAR REMALIAS ALIAS RETRIEVE PRINL NONVARCHK NONSYMCHK FEXPRCHECK ERRBREAK $DEBUGMODE RULEOF REMVALUE REMLABELS KILL1 BATCH1 CARFILE MTRUENAME TRUEFNAME LOADFILE FILENAMEL MFBOUNDP DOLLARIFY LOAD-FILE FIND0 LOAD-FUNCTION FIND-FUNCTION REPRINT RUBOUT* FORMFEED $BOTHCASES TYI* ADDLABEL MEXPLODEN PRINTLABEL MAKELABEL MEVAL*) +(*LEXPR $FILEDEFAULTS $BREAK $RANDOM $READONLY $READ $PRINT) +(*EXPR $OPTIMIZE) +(*EXPR TRISPLIT CABS $CARG $CABS $POLARFORM $RECTFORM $IMAGPART $REALPART) +(*EXPR $BINOMIAL $GAMMA $ACSCH $ASECH $ACOTH $ATANH $ACOSH $ASINH $ACSC $ASEC $ACOT $ATAN $ACOS $ASIN $CSCH $SECH $COTH $TANH $COSH $SINH $CSC $SEC $COT $TAN $COS $SIN $LOG |''MAKE-FUN| DSKRAT MFILEP BIGFLOATM* ADD2LNC $SQRT $EXP RAT MRETURN OPTIONP MCONS-OP-ARGS $FUNMAKE MOPP1 MOPP MSPECFUNP ARRSTORE MGETL MREMPROP MPUTPROP MGET REMALIAS1 REMRULE REMARRELEM I-$REMVALUE REMPROPCHK REMOVE1 I-$REMOVE $PUT $REM $GET FUNCER $MAPATOM MMAPEV NEVERSET NUMERSET MSETCHK MSETERR $SUBVARP MQUOTEP MSETQP MEVALATOMS MSET MUNBIND MBIND MARGS MOP MEVAL2 MEVAL1 MEVAL MEVALN MAPPLY) +(*LEXPR $ALLBUT $MATRIX OUTERMAP1 FMAPL1 MCALL) +(*FEXPR DSKSETQ MDEFPROP) +(*EXPR $COLLAPSE $OPTIMIZE) +(*EXPR $FACTCOMB $MINFACTORIAL $MAKEGAMMA $MAKEFACT) +(*EXPR $BERNPOLY SIMPBERN $BERN SIMPEULER $EULER) +(*EXPR $FIB $ZETA) +(*EXPR $CFEXPAND $QUNIT $CFDISREP) +(*EXPR $TAYTORAT) +(*EXPR $POLYDECOMP) +(*EXPR I-$STORE I-$UNSTORE) +(*EXPR APPLY2HACK APPLY2 APPLY1HACK APPLY1 PART* PART+ FINDBASE FINDEXPON FINDFUN FINDBE $REMRULE) +(*EXPR STOTALDIFF DIFFNCEXPT DIFFLAPLACE DIFFSUM DIFFINT) +(*EXPR $AT $ATVALUE) +(*EXPR $LOGCONTRACT) +(*EXPR $NTERMS) +(*EXPR $FIBTOPHI) +(*EXPR $DERIVDEGREE) +(*EXPR BOX) +(*LEXPR $REMBOX $BOX $LPART $DPART) +(*EXPR $COPYLIST $COPYMATRIX) +(*LEXPR $GENMATRIX) +(*LEXPR $ADDCOL $ADDROW) +(*EXPR $ARRAYMAKE) +(*EXPR $UNORDER) +(*EXPR $GETCHAR) +(*LEXPR $CONCAT) +(*EXPR $TTY_INIT) +(*EXPR $TRANSPOSE $SETELMX $ROW $MINOR $COL $TRIANGULARIZE $RANK POWERX BBSORT ONEN $ECHELON $INVERTMX $DIAGMATRIX $IDENT $DETERMINANT $CHARPOLY $MATRIXP) +(*LEXPR $SUBMATRIX) +(*EXPR CG-IMAGE-TYO-N CG-TYO-N CG-IMAGE-TYO CG-TYO DIMENSION-SUPERSCRIPT DIMENSION-NOFIX DIMENSION-POSTFIX DIMENSION-NARY DIMENSION-INFIX DIMENSION-PREFIX MAKESTRING DIMENSION-STRING DIMENSION-ATOM DISPLA) +(*EXPR I-$STORE I-$UNSTORE) +(*EXPR MTELL5 MTELL4 MTELL3 MTELL2 MTELL1 *MFORMAT-5 *MFORMAT-4 *MFORMAT-3 *MFORMAT-2 DISPLAF) +(*LEXPR MTELL MFORMAT) +(*EXPR $COLLAPSE $OPTIMIZE) +(SPECIAL $USER_MESFILE DUMPING USER-MESFILE MASTER-MESFILE) +(SPECIAL $UNIVERSE $DISPLAYSET) +(SPECIAL $TR_WARN_BAD_FUNCTION_CALLS) +(SPECIAL $RESULTANT) +(SPECIAL $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE) +(FIXNUM $TRACE_MAX_INDENT $TRACE_MAX_INDENT) +(SPECIAL $TR_FLOAT_CAN_BRANCH_COMPLEX) +(SPECIAL $SUSPEND) +(SPECIAL $GAMMALIM $SUMSPLITFACT HALF%PI3 %PI2 HALF%PI FOURTH%PI %P%I) +(SPECIAL $MODE_CHECK_ERRORP $MODE_CHECK_WARNP $MODE_CHECKP) +(SPECIAL $RATALGDENOM $RATWTLVL) +(SPECIAL $TIMER_DEVALUE $TIMER $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE_SAFETY $TRACE) +(FIXNUM $TRACE_MAX_INDENT) +(SPECIAL $TR_BOUND_FUNCTION_APPLYP $TR_OPTIMIZE_MAX_LOOP *$ANY-MODES* *TR-WARN-BREAK* $TR_PREDICATE_BRAIN_DAMAGE $TR_NUMER $TR_ARRAY_AS_REF $TR_FUNCTION_CALL_DEFAULT *WARNED-MODE-VARS* *WARNED-FEXPRS* *WARNED-UN-DECLARED-VARS* $TR_WARN_UNDEFINED_VARIABLE $TR_WARN_MODE $TR_WARN_FEXPR $TR_WARN_MEVAL $TR_WARN_UNDECLARED TR-UNIQUE TR-ABORT *TRANSL-DEBUG* *TRANSL-BACKTRACE* TRANSLATE-TIME-EVALABLES SPECIALS ASSIGNS NEED-PROG? RETURN-MODE RETURNS INSIDE-MPROG TR-PROGRET FEXPRS EXPRS LEXPRS ARRAYS LOCAL TSTACK $SPECIAL $TRANSCOMPILE $TR_SEMICOMPILE $TRANSBIND) +(SPECIAL $LINSOLVE_PARAMS $%RNUM $BACKSUBST $SPARSE $GLOBALSOLVE) +(SPECIAL $BETA_ARGS_SUM_TO_INTEGER) +(SPECIAL META-PROP-L META-PROP-P) +(SPECIAL $FORTFLOAT $FORTINDENT $FORTSPACES) +(FIXNUM $FORTINDENT) +(SPECIAL $MAXPRIME) +(SPECIAL $MACROEXPANSION) +(SPECIAL $TO_CALL_LISP_COMPILER) +(SPECIAL $TAYLOR_LOGEXPAND $TAYLOR_TRUNCATE_POLYNOMIALS $MAXTAYORDER) +(SPECIAL $ERFFLAG $LIFLAG) +(SPECIAL DEFINTDEBUG) +(SPECIAL $FLOATOPTIONS $FLOATWIDTH $FLOATPREC $FLOATFRAC $FLOATINT $FLOATFORMAT) +(SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR $BOXCHAR DISPLAYP STRINGDISP $FPTRUNC $NOUNDISP $DERIVABBREV $LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP $CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY) +(SPECIAL $VECT_CROSS) +(SPECIAL LIMITP $ASKEXP $SIGNBFLOAT $PREDERROR SIGN-IMAG-ERRP $ACTIVECONTEXTS $CONTEXTS $CONTEXT) +(SPECIAL DERIVSIMP ERRORSW DOSIMP $MAXNEGEX $MAXPOSEX $EXPON $EXPOP $MX0SIMP $DOMXTIMES $DOMXPLUS $DOMXEXPT $DOSCMXPLUS $NUMER_PBRANCH $SUMEXPAND $SIMP $NUMER $NEGDISTRIB $FLOAT) +(FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP) +(SPECIAL $NEGSUMDISPFLAG $SQRTDISPFLAG $EXPTDISPFLAG $%EDISPFLAG $PFEFORMAT $POWERDISP) +(SPECIAL $PARSEWINDOW) +(FIXNUM $PARSEWINDOW) +(SPECIAL -SQRT3//2 SQRT3//2 -SQRT2//2 SQRT2//2 %PI//2 %PI//4 -1//2 1//2 $HALFANGLES $LOGARC $EXPONENTIALIZE $TRIGSIGN $TRIGEXPANDTIMES $TRIGEXPANDPLUS $TRIGEXPAND $TRIGINVERSES $%IARGS $%PIARGS) +(SPECIAL ERRRJFFLAG HMODULUS MODULUS) +(SPECIAL *ALPHA BIGPRIMES $GCD *GCDL*) +(SPECIAL $HOMOG_HACK $SAVEFACTORS $BERLEFACT $INTFACLIM LOW* ALGFAC* *IRREDS) +(SPECIAL $FILE_TYPES $FILE_SEARCH *IN-MACSYMA-INDEXER* *IN-TRANSLATE-FILE* *IN-$BATCHLOAD*) +(SPECIAL $LISTCONSTVARS) +(SPECIAL $PRODHACK $SUMHACK $SIMPSUM $ZEROBERN $GENINDEX $GENSUMNUM $CAUCHYSUM) +(SPECIAL $POINTBOUND) +(SPECIAL $ERROR_SYMS $ERROR_SIZE $ERRORMSG $ERROR) +(SPECIAL ALGNOTEXACT $ALGEXACT REALONLYRATNUM $REALONLY $%RNUM_LIST) +(SPECIAL $NEWFAC $NALGFAC SMALLPRIMES ALPHA MM* MPLC* MINPOLY* *MX* *MIN* GAUSS) +(SPECIAL BIGFLOAT%PI BIGFLOAT%E BFMHALF BFHALF BIGFLOATONE BIGFLOATZERO $FPPREC $FPPRINTPREC $BFTRUNC $BFTORAT $FLOAT2BF) +(FIXNUM $FPPRINTPREC) +(SPECIAL $TR_GEN_TAGS $TR_STATE_VARS $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED $COMPGRIND TRANSL-FILE $TR_WINDY $TR_FILE_TTY_MESSAGESP $TR_OUTPUT_FILE_DEFAULT *TRANSL-FILE-DEBUG*) +(SPECIAL $SUBLIS_APPLY_LAMBDA) +(SPECIAL $ROMBERGIT_USED $ROMBERGABS $ROMBERGTOL $ROMBERGMIN $ROMBERGIT) +(FIXNUM $ROMBERGIT_USED $ROMBERGMIN $ROMBERGIT) +(FLONUM $ROMBERGABS $ROMBERGTOL) +(SPECIAL $QUANC8_RELERR $QUANC8_ABSERR $QUANC8_ERREST $QUANC8_FLAG) +(SPECIAL TRAMP3$ TRAMP2$ TRAMP1$) +(SPECIAL $ISOLATE_WRT_TIMES $EXPTISOLATE) +(SPECIAL $LET_RULE_PACKAGES $CURRENT_LET_RULE_PACKAGE $DEFAULT_LET_RULE_PACKAGE $LETRAT $LETVARSIMP) +(SPECIAL $RESULTANT) +(SPECIAL PRESERVE-DIRECTION LIMIT-ANSWERS SIMPLIMPLUS-PROBLEMS RD* INFINITESIMALS REAL-INFINITIES INFINITIES) +(SPECIAL $RATDENOMDIVIDE $RATEXPAND $RATEPSILON $RATPRINT FR-FACTOR ADN* INRATSIMP TELLRATLIST $FACEXPAND $RATVARS $ALGEBRAIC $RATFAC $RATWEIGHTS $NOREPEAT $DONTFACTOR $FACTORFLAG $KEEPFLOAT FACTORRESIMP *RATWEIGHTS *FNEWVARSW VARLIST GENPAIRS GENVAR) +(SPECIAL $SOLVERADCAN $SOLVETRIGWARN $SOLVENULLWARN $SOLVEFACTORS $SOLVEEXPLICIT $SOLVEDECOMPOSES $PROGRAMMODE $SOLVE_INCONSISTENT_ERROR $LINSOLVEWARN $MULTIPLICITIES $BREAKUP) +(SPECIAL $INTEGRATION_CONSTANT_COUNTER) +(SPECIAL $SHOWTIME $FILE_STRING_PRINT $CHANGE_FILEDEFAULTS ALIASLIST $MOREWAIT $TTYINTFUN $TTYINTNUM USER-TIMESOFAR CASEP $DIREC $LINENUM $LINECHAR $OUTCHAR $INCHAR $%) +(FIXNUM $LINENUM) +(SPECIAL $OPTIMPREFIX) +(SPECIAL GENERATE-ATAN2 IMPLICIT-REAL) +(SPECIAL $SETCHECK MUNBINDP) +(SPECIAL $OPTIMWARN $OPTIMPREFIX) +(SPECIAL $MAXAPPLYHEIGHT $MAXAPPLYDEPTH) +(SPECIAL $SUPERLOGCON $LOGCONCOEFFP) +(SPECIAL $ROOTSCONMODE) +(SPECIAL $ASSUMESCALAR $DOTIDENT $SCALARMATRIXP $DOMXNCTIMES $DOSCMXOPS $DOMXMXOPS $DOALLMXOPS $DOTASSOC $DOTEXPTSIMP $DOTDISTRIB $DOTSCRULES $DOT1SIMP $DOT0NSCSIMP $DOT0SIMP $DOTCONSTRULES) +(SPECIAL $MATRIX_ELEMENT_TRANSPOSE $MATRIX_ELEMENT_ADD $MATRIX_ELEMENT_MULT $RATMX TOP* $DETOUT *RANK*) +(SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR $BOXCHAR DISPLAYP STRINGDISP $NOUNDISP $DERIVABBREV $LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP $CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY) +(SPECIAL $OPTIMWARN $OPTIMPREFIX) +(*FEXPR $TRACE_OPTIONS $DEFINE_VARIABLE $FULLMAPL $PRIMER MCOND $DEMO $LETSIMP $GRADEF $MAKEATOMIC $DEPENDENCIES $LDISPLAY $APPENDFILE $STORE $COMPFILE $OUTERMAP $PROPVARS $QPUT $APPLYB2 $MAIL $FASSAVE $REMARRAY $BATCON $EXAMPLE $GRAPH2 $OPTIONS $APPLYB1 $LOADFILE $HELP $REPLOT4 $MATRIXMAP $TIMER $NAMEPLOT $LOADPLOTS $SUBSTPART $ORDERLESS MDOIN $PRINTFILE $DESCRIBE $COMPILE $DELFILE $TELLSIMPAFTER $CATCH $DISPRULE $APPLY $ALARMCLOCK $SSTATUS $BATCH $PRINTPROPS $MACROEXPAND $LET $CONTOURPLOT2 $DEFTAYLOR $DEFMATCH MOR $DECLARE $STRING $INTERPOLATE $ALIAS $TOBREAK $EVAL_WHEN $MACROEXPAND1 $LABELS $UNTRACE $ASSUME $WRITEFILE MPROG $EV $UNTIMER $REMCON $SUBSTINPART $TELLSIMP MQUOTE $CF $REMOVE $CLOSEFILE $APROPOS $PARAMPLOT $ORDERGREAT MNOT $RENAMEFILE $MAKELIST $APPLY2 $IS $PARAMPLOT2 $NUMERVAL $HARDCOPY $MATCHDECLARE $MAP $LOCAL $TIME $NAMEFILE $APPLY1 $SUBVAR $DISPLAY $SEND $BUILDQ $DEFINE $FILELIST $ARRAYINFO $MODE_IDENTITY $FILELENGTH $MAPLIST $RESTORE $FUNDEF $ALLOC $ERRCATCH $SAVEPLOTS MGO $LETRULES $FORTRAN $LABEL MPROGN $REMFILE $SCANMAP MDO $TRANSLATE $ARRAY $LISTFILES $ROMBERG $FORGET $PLAYBACK $BUG $DEFRULE MSPEC-HOOK $TRACE MAND $REMLET $STRINGOUT $REMFUNCTION $SAVE $UNSTORE $MODEDECLARE $TIMER_INFO $STATUS $PROPERTIES MSETQ $PLOT3D $GRAPH $PLOT $QLISTFILES $SETUP_AUTOLOAD $SUPCONTEXT $KILL $PLOTMODE $GRIND $GRAPH3D $PLOT2 $SUM MLOCAL $REMVALUE $PRODUCT $DISPFUN MDEFINE $REPLOT $FULLMAP $KILLPLOTS $MULTIGRAPH MDEFMACRO) \ No newline at end of file diff --git a/src/maxdoc/dcl.multix b/src/maxdoc/dcl.multix new file mode 100755 index 00000000..fcdd88a4 --- /dev/null +++ b/src/maxdoc/dcl.multix @@ -0,0 +1,276 @@ + +(defprop dcl (date= (81. 4. 4.) daytime= (0. 14. 29.)) version) +(*expr cmod cplus ctimes cexpt crecip cfactor) +(*fexpr $fasmak) +(*expr solvequartic) +(*expr $getcharn) +(*expr $facout $distrib) +(*lexpr $scsimp) +(*expr $optimize) +(*expr $poisint $poissquare $poisexpt $poistimes $poisdiff $printpois $outofpois $poisctimes $intopois $poismap $poisplus $poissimp) +(*lexpr $poissubst) +(*expr $poisint $poissquare $poisexpt $poistimes $poisdiff $printpois $outofpois $poisctimes $intopois $poismap $poisplus $poissimp) +(*lexpr $poissubst) +(*fexpr $graph $plot) +(*lexpr $permanent $newdet) +(*fexpr $letsimp $letrules $remlet $let) +(*expr $niceindices $bashindices $intosum $sumcontract) +(*lexpr $fortmx) +(*fexpr $fortran) +(*expr $apply_nouns mtree-subst) +(*fexpr $defrule $tellsimpafter $tellsimp $defmatch $matchdeclare) +(*expr dimension-superscript) +(*lexpr $trigreduce) +(*expr $combine) +(*expr logarc $logarc) +(*expr $absconverge $converge $powerseries) +(*fexpr $apropos) +(*expr get-out get-flist) +(*expr $subsetp $elementof $elementp $cardinal $mapset $predset $elements $emptyp $universe $make_universe) +(*lexpr $setdiff $symdiff $intersection $union $ordinal ${) +(*expr simplify morp porm root ncpower power* power ncmuln ncmul2 div* div muln mul3 mul2* mul2 sub* sub neg addn add2* add2) +(*expr ask-integer) +(*lexpr $askinteger) +(*lexpr $nroots $realroots) +(*lexpr $nofix $matchfix $nary $infix $postfix $prefix) +(*expr simpmdefmacro (mmacroexpanded macro) mmacro-apply) +(*fexpr $macroexpand1 $macroexpand mdefmacro) +(*expr $polydecomp) +(*expr $clearscreen) +(*lexpr $pause) +(*expr $trigexpand) +(*expr $xthru) +(*expr $tr_warnings_get) +(*expr $pfet) +(*expr $sublist) +(*fexpr $makelist) +(*fexpr $renamefile $filelength $filelist $qlistfiles $listfiles $printfile) +(*expr $radcan freeof argsfreeof $bothcoef $ratsubst) +(*lexpr $freeof $ratcoef) +(*expr check-out-of-core-string allocate-message-index) +(*expr $tldefint) +(*lexpr $tlimit) +(*expr mapply-tr insure-array-props $arraysetapply $arrayapply interval-error) +(*lexpr display-for-tr marrayset marrayref mfuncall) +(*expr $bezout $discriminant $resultant) +(*expr $reset $listofvars $unknown) +(*fexpr $options) +(*fexpr $time $resetclock $printclock $unclock $clock) +(*expr $pade) +(*expr mbuildq-subst) +(*fexpr $buildq) +(*expr macsymacallp subrcall$p subrcallp) +(*lexpr fmapply) +(*expr define-symbol) +(*expr $debug) +(*lexpr $lispdebugmode $debugprintmode) +(*expr $factcomb $minfactorial $makegamma $makefact) +(*expr $bernpoly $bern $euler) +(*expr $fib $zeta) +(*expr $cfexpand $qunit $cfdisrep) +(*fexpr $cf) +(*fexpr $product) +(*expr $taytorat) +(*expr $polydecomp) +(*expr nformat-all nformat) +(*expr mdescribe) +(*fexpr $describe) +(*expr make-param) +(*expr $lhs $rhs $partition $demoivre) +(*expr $transpose $setelmx $row $minor $col $triangularize $rank onen $echelon $invertmx $diagmatrix $ident $determinant $charpoly $matrixp) +(*lexpr $submatrix) +(*expr $linsolve) +(*lexpr $solve) +(*expr $tminverse $tmlin) +(*lexpr $tmlinsolve $tmnewdet) +(*lexpr $sort) +(*expr $sublist) +(*fexpr $makelist) +(*expr apply2hack apply2 apply1hack apply1 part* part+ findbase findexpon findfun findbe $remrule) +(*fexpr $applyb2 $apply2 $applyb1 $apply1 $disprule) +(*expr outex-hook-exp $make_index_file) +(*expr $map_over_index_file $read_nth_object $number_of_objects_in_index_file $open_index_file) +(*expr $residue) +(*expr $ilt $laplace) +(*expr ratint) +(*expr outex-hook-exp $make_index_file) +(*expr $map_over_index_file $read_nth_object $index_file_dim $open_index_file) +(*expr mminusp*) +(*expr define-symbol rbp lbp) +(*expr rgrp $featurep like $sign asksign-p-or-n $asksign maximin minimum maximum $compare forget learn assume mevalp is $killcontext $newcontext) +(*lexpr $min $max $facts $deactivate $activate $context) +(*fexpr mor mand mnot $forget $assume $is $supcontext) +(*expr lowdeg) +(*expr pabs $nthroot $inrt $isqrt) +(*expr rassociative lassociative nary1 antisym commutative1 oddfun evenfun do%sum dosum simpsum simpgfact simpfact) +(*lexpr $genfact) +(*fexpr $sum $deftaylor) +(*expr $zeroequiv) +(*expr displaf) +(*lexpr *mformat) +(*expr fpentier *fpatan atanbigfloat ratbigfloat addbigfloat $bfloat fp2flo) +(*lexpr $ezgcd) +(*expr $taylorinfo) +(*lexpr $taylor) +(*expr $algsys) +(*expr $allroots) +(*expr $algnorm $splitfield $pfactoralg $algtrace) +(*lexpr $bdiscr $algfac) +(*expr simp-%sech simp-%csch simp-%coth simp-%tanh simp-%cosh simp-%sinh) +(*expr simp-%asec simp-%acsc simp-%acot simp-%acos simp-%asin) +(*expr simp-%asech simp-%acsch simp-%acoth simp-%atanh simp-%acosh simp-%asinh) +(*expr trigexpand $trigexpand) +(*expr $gcfactor $jacobi $totient $prime) +(*lexpr $divsum) +(*expr acsch asech acoth atanh asinh acosh sech csch coth tanh cosh sinh acsc asec acot atan1 acos asin csc sec cot tan mminusp* mminusp exponentialize $exponentialize rremainder rtimes rdifference rplus simp-%atan simp-%sec simp-%csc simp-%cot simp-%tan simp-%cos simp-%sin arcp trigp sq-sumsq sqrtx^2-1 sqrt1+x^2 sqrt1-x^2) +(*expr simpplog) +(*expr simpbinocoef) +(*expr simpgamma simpbeta) +(*expr erf simperf) +(*expr $ematrix $zeromatrix) +(*expr $augcoefmatrix $coefmatrix) +(*expr $entermatrix) +(*expr $xthru) +(*fexpr $multigraph $paramplot) +(*fexpr $graph $plot) +(*expr $gmark $gvprint $ghprint $gterpri $exitgraph $entergraph $clear $drawsymbol3 $line3 $vector3 $point3 $setpoint3 $size $screensize1 $screensize $definesymbol $drawsymbol $line $vector $popdash $pushdash $changedash $definedash $point $setpoint) +(*expr $batchload open-in-dsk open-out-dsk mstringp) +(*expr $tag_file_insert) +(*expr translate-macexpr-toplevel translate-and-eval-macsyma-expression) +(*expr ascii-numberp alphabetp cput a-atom log2 assqr firstn reconc amongl among xor andmapcar ormapc andmapc map2c) +(*lexpr concat *make-list) +(*expr trisplit cabs $carg $cabs $polarform $rectform $imagpart $realpart) +(*expr $timedate $who) +(*fexpr $alarmclock $send $mail $bug) +(*expr $reveal $pickapart $isolate) +(*fexpr $printprops $propvars $properties) +(*expr $changevar) +(*expr $gfactorsum $factorsum) +(*expr $combine) +(*lexpr $factorout) +(*expr $clearscreen) +(*lexpr $pause) +(*lexpr $translate_file) +(*expr $ldefint) +(*lexpr $limit) +(*expr testdivide cfactorw) +(*expr ptimes pquotient pmod pminus pminusp pderivative pdifference pplus pointergp) +(*expr ratquotient ratplus ratexpt rattimes ratreduce ratminus ratfact ratdif ratderivative) +(*expr pdegree $primep pgcd1 pquotientchk) +(*expr nthkdr *kar simpargs1 kdr kar matcherr bprog ratdenominator ratnumerator simpnrt alike alike1 great simpmqapply $ordergreatp $orderlessp simpmatrix simpexpt exptrl simpsignum signum1 simpderiv infsimp simpmdef simplambda simpexp simpbigfloat simpinteg simp-limit simptimes simpabs simpquot simpsqrt simpln simplus fpcofrat timesk addk simpargs ssimplifya eqtest simplifya freeargs freel free isinop constfun mxorlistp mequalp mbagp $nonscalarp $scalarp $constantp $numfactor subfunargs subfunsubs subfunname subfunmake subfunmakes subargcheck improper-arg-err wna-err twoargchk oneargchk twoargcheck oneargcheck $polysign specdisrep specrepp $ratp $ratnump $floatnump $evenp $oddp $integerp $numberp mratcheck simpcheck sratsimp ratdisrep mqapplyp mnegp mlogp mncexptp mnctimesp mexptp mtimesp mplusp ratnump even mnump $bfloatp zerop1 onep1 onep) +(*lexpr $integrate $expand $multthru) +(*fexpr retlist matcoef) +(*expr fstringc *errrjf read-only-assign $errormsg) +(*lexpr *merror) +(*fexpr $primer) +(*expr $sublis) +(*expr $plotreset $plotinit) +(*fexpr $killplots $loadplots $saveplots $nameplot $replot4 $replot $label $graph3d $graph2 $paramplot2 $contourplot2 $plot3d $plot2) +(*expr $binomial $gamma $acsch $asech $acoth $atanh $acosh $asinh $acsc $asec $acot $atan $acos $asin $csch $sech $coth $tanh $cosh $sinh $csc $sec $cot $tan $cos $sin $log $sqrt $exp dskrat mfilep autoldchk bigfloatm* add2lnc rat mreturn optionp mcons-op-args $funmake mapplyt mopp1 mopp arrstore mgetl mremprop mputprop mget remalias1 remrule remarrelem rempropchk remove1 $put $rem $get funcer $mapatom mmapev numerset msetchk mseterr $subvarp mquotep msetqp mevalatoms mset munbind mbind margs mop meval2 meval1 meval mevaln mapply) +(*lexpr $allbut $matrix outermap1 fmapl1 mcall) +(*fexpr dsksetq $subvar mgo mprog mdoin mdo mcond $dispfun $apply mdefine $define $array mdefprop $remvalue $remarray $remfunction $remove $declare $qput $outermap $fullmapl $matrixmap $fullmap $maplist $map mquote $ev msetq $local mprogn) +(*expr $untrace_it $trace_it) +(*expr killc contextmark kcntxt cntxt killframe remov unkind kill untrue doutern dintern dinternp remf addf datum par kind fact true* kindp factp isp falsep truep clear visiblep unmrk markp mark) +(*lexpr context deactivate activate) +(*fexpr deframe) +(*lexpr $suspend) +(*expr $lopow $hipow coeff $float $entier $fix $denom $num $symbolp $atom $length $reverse $args $last $first format1 atomchk $member $endcons $cons $listp listerchk getopr getop mpart part1 $dispterms $trunc remsimp delsimp nthelem union* substitutel notloreq atvarschk sdiff $del recur-apply subst0 substitute) +(*lexpr $coeff $delete $rest $append $inpart $part $dispform $disp $ldisp $diff $depends $substitute) +(*fexpr $substinpart $substpart $display $ldisplay $gradef $dependencies) +(*expr stotaldiff diffncexpt difflaplace diffsum diffint) +(*expr $at $atvalue) +(*expr $logcontract) +(*expr $nterms) +(*expr $fibtophi) +(*fexpr $numerval) +(*expr $derivdegree) +(*expr box) +(*lexpr $rembox $box $lpart $dpart) +(*fexpr $scanmap) +(*expr $copylist $copymatrix) +(*lexpr $genmatrix) +(*lexpr $addcol $addrow) +(*expr $arraymake) +(*fexpr $arrayinfo) +(*expr $unorder) +(*fexpr $orderless $ordergreat $makeatomic) +(*expr $getchar) +(*lexpr $concat) +(*expr $ratdisrep $ratexpand rationalize ratf $gfactor $sqfr $totaldisrep $showratvars $printvarlist $ratdenom $ratnumer) +(*lexpr $content $gcd $remainder $quotient $divide $mod factor $factor $ratsimp $rat $fullratsimp $ratvars $tellrat $untellrat) +(*fexpr $restore $remfile $fassave $store $save $unstore) +(*expr ass-eq-set assign-mode-check) +(*lexpr chekvalue ass-eq-ref) +(*expr $resultant $discriminant) +(*expr $bezout) +(*expr macherrfun iolfun ttyretfun ttyintfun ttyintfunsetup $dskgc $pagepause mfile-out fileprint filestrip $ddt $logout $quit $to_lisp computime timeorg $throw $uuo getlabcharn getlabels* getlabels $%th $poislim $fpprec casify-exploden strmeval makstring dollarify-name amperchk $verbify $nounify fullstrip1 fullstrip stripdollar remalias retrieve prinl erlist1 errexp nonvarchk nonsymchk fexprchk errbreak $debugmode ruleof remvalue remlabels kill1 batch1 carfile mtruename truefname loadfile filenamel mfboundp dollarify find0 load-function find-function reprint rubout* formfeed $bothcases tyi* addlabel mexploden printlabel makelabel meval*) +(*lexpr $filedefaults $break $error $random $readonly $read $print) +(*fexpr $alloc $sstatus $status $delfile $closefile $appendfile $writefile $time $catch $errcatch $labels $stringout $string $alias $playback $tobreak $kill $demo $batch $batcon $setup_autoload $loadfile) +(*expr memalike assolike assol) +(*expr cg-image-tyo-n cg-tyo-n cg-image-tyo cg-tyo dimension-superscript dimension-nofix dimension-postfix dimension-nary dimension-infix dimension-prefix makestring dimension-string dimension-atom displa) +(*expr sign) +(*expr mstring) +(*fexpr $grind) +(*expr $risch) +(*lexpr $compile_lisp_file) +(special $fortfloat $fortindent $fortspaces) +(fixnum $fortindent) +(special $user_mesfile dumping user-mesfile master-mesfile) +(special $universe $displayset) +(special $macroexpansion) +(special $tr_warn_bad_function_calls) +(special $assumescalar $dotident $scalarmatrixp $domxnctimes $doscmxops $domxmxops $doallmxops $dotassoc $dotexptsimp $dotdistrib $dotscrules $dot1simp $dot0nscsimp $dot0simp $dotconstrules) +(special $resultant) +(special $listconstvars) +(special $rombergit_used $rombergabs $rombergtol $rombergmin $rombergit) +(fixnum $rombergit_used $rombergmin $rombergit) +(flonum $rombergabs $rombergtol) +(special $negsumdispflag $sqrtdispflag $exptdispflag $%edispflag $pfeformat $powerdisp) +(special $linsolve_params $%rnum $backsubst $sparse $globalsolve) +(special $gammalim $sumsplitfact half%pi3 %pi2 half%pi fourth%pi %p%i) +(special $matrix_element_transpose $matrix_element_add $matrix_element_mult $ratmx) +(special $pointbound) +(special $solveradcan $solvetrigwarn $solvenullwarn $solvefactors $solveexplicit $solvedecomposes $savefactors $programmode $solve_inconsistent_error $linsolvewarn $multiplicities $breakup) +(special $trace_max_indent $trace_break_arg $trace) +(fixnum $trace_max_indent $trace_max_indent) +(special $maxapplyheight $maxapplydepth) +(special $parsewindow) +(fixnum $parsewindow) +(special limitp $askexp $signbfloat $prederror $activecontexts $contexts $context) +(special $homog_hack $savefactors $berlefact $intfaclim low* algfac* *irreds) +(special $prodhack $sumhack $simpsum $zerobern $genindex $gensumnum $cauchysum) +(special bigfloat%pi bigfloat%e bfmhalf bfhalf bigfloatone bigfloatzero $fpprec $fpprintprec $bftrunc $bftorat $float2bf) +(fixnum $fpprintprec) +(special $taylor_logexpand) +(special $algexact $realonly $%rnum_list) +(special -sqrt3//2 sqrt3//2 -sqrt2//2 sqrt2//2 %pi//2 %pi//4 -1//2 1//2 $halfangles $logarc $exponentialize $trigsign $trigexpandtimes $trigexpandplus $trigexpand $triginverses $%iargs $%piargs) +(special $tr_float_can_branch_complex) +(special *in-macsyma-indexer* *in-translate-file*) +(special $tr_optimize_max_loop *$any-modes* *tr-warn-break* *in-translate-file* *in-translate* *in-compfile* *in-compile* $tr_numer $tr_array_as_ref $tr_function_call_default *warned-mode-vars* *warned-fexprs* *warned-un-declared-vars* $tr_warn_undefined_variable $tr_warn_mode $tr_warn_fexpr $tr_warn_meval $tr_warn_undeclared tr-unique tr-abort *transl-traced* *transl-debug* *transl-backtrace* translate-time-evalables declares specials assigns need-prog? return-mode returns inside-mprog tr-progret fexprs lexprs arrays local tstack $special $transcompile $tr_semicompile $transbind) +(special $integration_constant_counter) +(special generate-atan2 implicit-real) +(special $tr_gen_tags $tr_true_name_of_file_being_translated $compgrind transl-file $tr_windy $tr_file_tty_messagesp $tr_output_file_default *transl-file-debug*) +(special preserve-direction limit-answers simplimplus-problems rd* infinitesimals real-infinities infinities) +(special $newfac $nalgfac smallprimes alpha mm* mplc* minpoly* *mx* *min* gauss) +(special errrjfflag hmodulus modulus) +(special $ratalgdenom $ratwtlvl) +(special *alpha bigprimes $gcd *gcdl*) +(special derivsimp errorsw dosimp $maxnegex $maxposex $expon $expop $mx0simp $domxtimes $domxplus $domxexpt $doscmxplus $simp $numer $negdistrib $float) +(fixnum $maxnegex $maxposex $expon $expop) +(special $error) +(special $sublis_apply_lambda) +(special munbindp) +(special $trace_max_indent $trace_break_arg $trace_safety $trace) +(fixnum $trace_max_indent $trace_max_indent $trace_max_indent) +(special $suspend) +(special $vect_cross) +(special $superlogcon $logconcoeffp) +(special $rootsconmode) +(special $ratdenomdivide $ratexpand $ratepsilon $ratprint fr-factor adn* inratsimp tellratlist $facexpand $ratvars $algebraic $ratfac $ratweights $norepeat $dontfactor $factorflag $keepfloat *ratweights *fnewvarsw varlist genpairs genvar) +(special $mode_check_errorp $mode_check_warnp $mode_checkp) +(special $resultant) +(special $showtime $file_string_print $change_filedefaults aliaslist $morewait $ttyintfun $ttyintnum casep $linenum $linechar $outchar $inchar) +(fixnum $linenum) +(special $display_format_internal $rmxchar $lmxchar $absboxchar $boxchar displayp stringdisp $fptrunc $noundisp $derivabbrev $linedisp $lispdisp $display2d $leftjust $stardisp $cursordisp line-graphics-tty character-graphics-tty) +(special $erfflag $liflag) +(special $to_call_lisp_compiler) \ No newline at end of file diff --git a/src/maxdoc/dcl.vars b/src/maxdoc/dcl.vars new file mode 100644 index 00000000..89f5d861 --- /dev/null +++ b/src/maxdoc/dcl.vars @@ -0,0 +1,341 @@ +;; -*- Mode: Lisp; Package: Macsyma -*- +;; Declaration file for global variables known throughout Macsyma. +;; This file was generated by DEFINE version NIL. + +;; Declarations for MAXSRC;MESRUN 9, compiled 10/23/80 3:47 by GJC. +(DECLARE (COMMENT MESRUN)) +(DECLARE (SPECIAL $USER_MESFILE DUMPING USER-MESFILE MASTER-MESFILE)) + +;; Declarations for MAXSRC;SETS 10, compiled 10/28/80 23:37 by GJC. +(DECLARE (COMMENT SETS)) +(DECLARE (SPECIAL $UNIVERSE $DISPLAYSET)) + +;; Declarations for MAXSRC;FCALL 36, compiled 11/15/80 19:08 by KMP. +(DECLARE (COMMENT FCALL)) +(DECLARE (SPECIAL $TR_WARN_BAD_FUNCTION_CALLS)) + +;; Declarations for RAT;RESULT 20, compiled 12/9/80 21:40 by BMT. +(DECLARE (COMMENT RESULT)) +(DECLARE (SPECIAL $RESULTANT)) + +;; Declarations for MAXSRC;NTRACE 24, compiled 1/22/81 1:13 by GJC. +(DECLARE (COMMENT NTRACE)) +(DECLARE (SPECIAL $TRACE_MAX_INDENT $TRACE_BREAK_ARG $TRACE)) +(DECLARE (FIXNUM $TRACE_MAX_INDENT $TRACE_MAX_INDENT)) + +;; Declarations for MAXSRC;TRANSF 9, compiled 2/17/81 19:27 by GJC. +(DECLARE (COMMENT TRANSF)) +(DECLARE (SPECIAL $TR_FLOAT_CAN_BRANCH_COMPLEX)) + +;; Declarations for MAXSRC;SUSPEN 13, compiled 3/15/81 23:01 by GJC. +(DECLARE (COMMENT SUSPEN)) +(DECLARE (SPECIAL $SUSPEND)) + +;; Declarations for MAXSRC;TRMODE 63, compiled 5/5/81 6:24 by JPG. +(DECLARE (COMMENT TRMODE)) +(DECLARE (SPECIAL $MODE_CHECK_ERRORP $MODE_CHECK_WARNP $MODE_CHECKP)) + +;; Declarations for TRANSL;TRANSL 1145, compiled 6/26/81 18:44 by GJC. +(DECLARE (COMMENT TRANSL)) +(DECLARE (SPECIAL $TR_BOUND_FUNCTION_APPLYP $TR_OPTIMIZE_MAX_LOOP *$ANY-MODES* + *TR-WARN-BREAK* $TR_PREDICATE_BRAIN_DAMAGE $TR_NUMER + $TR_ARRAY_AS_REF $TR_FUNCTION_CALL_DEFAULT + *WARNED-MODE-VARS* *WARNED-FEXPRS* *WARNED-UN-DECLARED-VARS* + $TR_WARN_UNDEFINED_VARIABLE $TR_WARN_MODE $TR_WARN_FEXPR + $TR_WARN_MEVAL $TR_WARN_UNDECLARED TR-UNIQUE TR-ABORT + *TRANSL-DEBUG* *TRANSL-BACKTRACE* TRANSLATE-TIME-EVALABLES + SPECIALS ASSIGNS NEED-PROG? RETURN-MODE RETURNS INSIDE-MPROG + TR-PROGRET FEXPRS EXPRS LEXPRS ARRAYS LOCAL TSTACK $SPECIAL + $TRANSCOMPILE $TR_SEMICOMPILE $TRANSBIND)) + +;; Declarations for TRANSL;TRPROP 1, compiled 7/15/81 1:48 by GJC. +(DECLARE (COMMENT TRPROP)) +(DECLARE (SPECIAL META-PROP-L META-PROP-P)) + +;; Declarations for TRANSL;MCOMPI 145, compiled 9/21/81 10:48 by GJC. +(DECLARE (COMMENT MCOMPI)) +(DECLARE (SPECIAL $TO_CALL_LISP_COMPILER)) + +;; Declarations for SHARE;FORMAT 13, compiled 12/3/81 2:30 by JPG. +(DECLARE (COMMENT FORMAT)) +(DECLARE (SPECIAL $FLOATOPTIONS $FLOATWIDTH $FLOATPREC $FLOATFRAC $FLOATINT + $FLOATFORMAT)) + +;; Declarations for RP;DISPHK 764, compiled 12/12/81 9:57 by JPG. +(DECLARE (COMMENT DISPHK)) +(DECLARE (SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR + $BOXCHAR DISPLAYP STRINGDISP $FPTRUNC $NOUNDISP $DERIVABBREV + $LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP + $CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY)) + +;; Declarations for TRANSL;TRANSS 79, compiled 1/22/82 6:51 by JPG. +(DECLARE (COMMENT TRANSS)) +(DECLARE (SPECIAL $TR_GEN_TAGS $TR_STATE_VARS + $TR_TRUE_NAME_OF_FILE_BEING_TRANSLATED $COMPGRIND + TRANSL-FILE $TR_WINDY $TR_FILE_TTY_MESSAGESP + $TR_OUTPUT_FILE_DEFAULT *TRANSL-FILE-DEBUG*)) + +;; Declarations for MAXSRC;ROMBRG 43, compiled 2/12/82 5:17 by JPG. +(DECLARE (COMMENT ROMBRG)) +(DECLARE (SPECIAL $ROMBERGIT_USED $ROMBERGABS $ROMBERGTOL $ROMBERGMIN + $ROMBERGIT)) +(DECLARE (FIXNUM $ROMBERGIT_USED $ROMBERGMIN $ROMBERGIT)) +(DECLARE (FLONUM $ROMBERGABS $ROMBERGTOL)) + +;; Declarations for MAXSRC;NUMER 17, compiled 2/12/82 16:12 by JPG. +(DECLARE (COMMENT NUMER)) +(DECLARE (SPECIAL TRAMP3$ TRAMP2$ TRAMP1$)) + +;; Declarations for JPG;BOPTIM 5, compiled 4/27/82 4:45 by JPG. +(DECLARE (COMMENT BOPTIM)) +(DECLARE (SPECIAL $OPTIMPREFIX)) + +;; Declarations for JPG;AOPTIM 14, compiled 5/5/82 6:47 by JPG. +(DECLARE (COMMENT AOPTIM)) +(DECLARE (SPECIAL $OPTIMWARN $OPTIMPREFIX)) + +;; Declarations for MAXSRC;MTRACE 42, compiled 10/28/82 7:02 by JPG. +(DECLARE (COMMENT MTRACE)) +(DECLARE (SPECIAL $TIMER_DEVALUE $TIMER $TRACE_MAX_INDENT $TRACE_BREAK_ARG + $TRACE_SAFETY $TRACE)) +(DECLARE (FIXNUM $TRACE_MAX_INDENT)) + +;; Declarations for JM;RISCH 436, compiled 11/16/82 6:35 by JPG. +(DECLARE (COMMENT RISCH)) +(DECLARE (SPECIAL $ERFFLAG $LIFLAG)) + +;; Declarations for MRG;DISPLA 777, compiled 5/25/83 3:46 by JPG0. +(DECLARE (COMMENT DISPLA)) +(DECLARE (SPECIAL $DISPLAY_FORMAT_INTERNAL $RMXCHAR $LMXCHAR $ABSBOXCHAR + $BOXCHAR DISPLAYP STRINGDISP $NOUNDISP $DERIVABBREV + $LINEDISP $LISPDISP $DISPLAY2D $LEFTJUST $STARDISP + $CURSORDISP LINE-GRAPHICS-TTY CHARACTER-GRAPHICS-TTY)) + +;; Declarations for MRG;GRAM 488, compiled 5/25/83 3:51 by JPG0. +(DECLARE (COMMENT GRAM)) +(DECLARE (SPECIAL $PARSEWINDOW)) +(DECLARE (FIXNUM $PARSEWINDOW)) + +;; Declarations for GZ;GROB 174, compiled 7/6/83 2:24 by JPG0. +(DECLARE (COMMENT GROB)) +(DECLARE (SPECIAL $GROBNER_FUNCTIONS $GROBNER_GENVAR_INDEX + $GROBNER_GENVAR_PREFIX $GROBNER_TOT_ORDER + $GROBNER_COEF_DIVIDE $GROBNER_TOT_REDUCE $GROBNER_PRIMITIVE + $GROBNER_RAT $GROBNER_TRACE)) +(DECLARE (FIXNUM $GROBNER_GENVAR_INDEX)) + +;; Declarations for LPH;QQ 2, compiled 8/31/83 20:41 by LPH. +(DECLARE (COMMENT QQ)) +(DECLARE (SPECIAL $QUANC8_RELERR $QUANC8_ABSERR $QUANC8_ERREST $QUANC8_FLAG)) + +;; Declarations for LPH;FORTRN 70, compiled 4/12/84 18:08 by JPG. +(DECLARE (COMMENT FORTRN)) +(DECLARE (SPECIAL $FORTINDENT $FORTSPACES $FORTNUM)) +(DECLARE (FIXNUM $FORTINDENT)) + +;; Declarations for JPG;NDIFF 8, compiled 2/1/86 23:46 by JPG. +(DECLARE (COMMENT NDIFF)) +(DECLARE (SPECIAL $NEWDIFF)) + +;; Declarations for MRG;NFORMA 15, compiled 1/28/18 8:47 by EJS. +(DECLARE (COMMENT NFORMA)) +(DECLARE (SPECIAL $NEGSUMDISPFLAG $SQRTDISPFLAG $EXPTDISPFLAG $%EDISPFLAG + $PFEFORMAT $POWERDISP)) + +;; Declarations for MRG;COMPAR 857, compiled 1/28/18 8:53 by EJS. +(DECLARE (COMMENT COMPAR)) +(DECLARE (SPECIAL $ASSUME_POS_PRED $ASSUME_POS LIMITP $ASKEXP $SIGNBFLOAT + $PREDERROR SIGN-IMAG-ERRP $ACTIVECONTEXTS $CONTEXTS $CONTEXT)) + +;; Declarations for MRG;TRIGI 343, compiled 1/28/18 8:53 by EJS. +(DECLARE (COMMENT TRIGI)) +(DECLARE (SPECIAL -SQRT3//2 SQRT3//2 -SQRT2//2 SQRT2//2 %PI//2 %PI//4 -1//2 + 1//2 $HALFANGLES $LOGARC $EXPONENTIALIZE $TRIGSIGN + $TRIGEXPANDTIMES $TRIGEXPANDPLUS $TRIGEXPAND $TRIGINVERSES + $%IARGS $%PIARGS)) + +;; Declarations for JPG;MLISP 613, compiled 1/28/18 9:52 by EJS. +(DECLARE (COMMENT MLISP)) +(DECLARE (SPECIAL $SETCHECK MUNBINDP)) + +;; Declarations for JPG;SUPRV 619, compiled 1/28/18 11:29 by EJS. +(DECLARE (COMMENT SUPRV)) +(DECLARE (SPECIAL $SHOWTIME $FILE_STRING_PRINT $CHANGE_FILEDEFAULTS ALIASLIST + $MOREWAIT $TTYINTFUN $TTYINTNUM USER-TIMESOFAR CASEP $DIREC + $LINENUM $LINECHAR $OUTCHAR $INCHAR $%)) +(DECLARE (FIXNUM $LINENUM)) + +;; Declarations for JPG;COMM 395, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT COMM)) +(DECLARE (SPECIAL $VECT_CROSS)) + +;; Declarations for PAULW;CSIMP 299, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT CSIMP)) +(DECLARE (SPECIAL $GAMMALIM $SUMSPLITFACT HALF%PI3 %PI2 HALF%PI FOURTH%PI %P%I)) + +;; Declarations for PAULW;MAT 286, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT MAT)) +(DECLARE (SPECIAL $LINSOLVE_PARAMS $%RNUM $BACKSUBST $SPARSE $GLOBALSOLVE)) + +;; Declarations for RAT;FACTOR 472, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT FACTOR)) +(DECLARE (SPECIAL $NEWFAC $NALGFAC SMALLPRIMES ALPHA MM* MPLC* MINPOLY* *MX* + *MIN* GAUSS)) + +;; Declarations for RAT;RAT3A 258, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3A)) +(DECLARE (SPECIAL ERRRJFFLAG HMODULUS MODULUS)) + +;; Declarations for RAT;RAT3B 95, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3B)) +(DECLARE (SPECIAL $RATALGDENOM $RATWTLVL)) + +;; Declarations for RAT;RAT3C 302, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3C)) +(DECLARE (SPECIAL *ALPHA BIGPRIMES $GCD *GCDL*)) + +;; Declarations for RAT;RAT3D 264, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3D)) +(DECLARE (SPECIAL $HOMOG_HACK $SAVEFACTORS $BERLEFACT $INTFACLIM LOW* ALGFAC* + *IRREDS)) + +;; Declarations for RAT;RAT3E 546, compiled 1/28/18 11:50 by EJS. +(DECLARE (COMMENT RAT3E)) +(DECLARE (SPECIAL $RATDENOMDIVIDE $RATEXPAND $RATEPSILON $RATPRINT FR-FACTOR + ADN* INRATSIMP TELLRATLIST $FACEXPAND $RATVARS $ALGEBRAIC + $RATFAC $RATWEIGHTS $NOREPEAT $DONTFACTOR $FACTORFLAG + $KEEPFLOAT FACTORRESIMP *RATWEIGHTS *FNEWVARSW VARLIST + GENPAIRS GENVAR)) + +;; Declarations for JM;SIMP 834, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT SIMP)) +(DECLARE (SPECIAL DERIVSIMP ERRORSW DOSIMP $MAXNEGEX $MAXPOSEX $EXPON $EXPOP + $MX0SIMP $DOMXTIMES $DOMXPLUS $DOMXEXPT $DOSCMXPLUS + $NUMER_PBRANCH $SUMEXPAND $SIMP $NUMER $NEGDISTRIB $FLOAT)) +(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP)) + +;; Declarations for MAXSRC;INMIS 98, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT INMIS)) +(DECLARE (SPECIAL $LISTCONSTVARS)) +(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP)) + +;; Declarations for RZ;ASUM 271, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT ASUM)) +(DECLARE (SPECIAL $PRODHACK $SUMHACK $SIMPSUM $ZEROBERN $GENINDEX $GENSUMNUM + $CAUCHYSUM)) +(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP)) + +;; Declarations for RAT;SPGCD 110, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT SPGCD)) +(DECLARE (SPECIAL $POINTBOUND)) +(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP)) + +;; Declarations for MAXSRC;MERROR 47, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT MERROR)) +(DECLARE (SPECIAL $ERROR_SYMS $ERROR_SIZE $ERRORMSG $ERROR)) +(DECLARE (FIXNUM $MAXNEGEX $MAXPOSEX $EXPON $EXPOP)) + +;; Declarations for MRG;FORTRA 64, compiled 1/28/18 11:53 by EJS. +(DECLARE (COMMENT FORTRA)) +(DECLARE (SPECIAL $FORTFLOAT $FORTINDENT $FORTSPACES)) +(DECLARE (FIXNUM $FORTINDENT)) + +;; Declarations for MRG;OPTIM 14, compiled 1/28/18 11:56 by EJS. +(DECLARE (COMMENT OPTIM)) +(DECLARE (SPECIAL $OPTIMWARN $OPTIMPREFIX)) + +;; Declarations for JM;SIN 200, compiled 1/28/18 11:56 by EJS. +(DECLARE (COMMENT SIN)) +(DECLARE (SPECIAL $INTEGRATION_CONSTANT_COUNTER)) + +;; Declarations for RAT;MATRUN 80, compiled 1/28/18 11:57 by EJS. +(DECLARE (COMMENT MATRUN)) +(DECLARE (SPECIAL $MAXAPPLYHEIGHT $MAXAPPLYDEPTH)) + +;; Declarations for RAT;FLOAT 321, compiled 1/28/18 12:06 by EJS. +(DECLARE (COMMENT FLOAT)) +(DECLARE (SPECIAL BIGFLOAT%PI BIGFLOAT%E BFMHALF BFHALF BIGFLOATONE + BIGFLOATZERO $FPPREC $FPPRINTPREC $BFTRUNC $BFTORAT + $FLOAT2BF)) +(DECLARE (FIXNUM $FPPRINTPREC)) + +;; Declarations for RAT;SOLVE 401, compiled 1/28/18 12:09 by EJS. +(DECLARE (COMMENT SOLVE)) +(DECLARE (SPECIAL $SOLVERADCAN $SOLVETRIGWARN $SOLVENULLWARN $SOLVEFACTORS + $SOLVEEXPLICIT $SOLVEDECOMPOSES $PROGRAMMODE + $SOLVE_INCONSISTENT_ERROR $LINSOLVEWARN $MULTIPLICITIES + $BREAKUP)) + +;; Declarations for MAXSRC;MDOT 94, compiled 1/28/18 12:09 by EJS. +(DECLARE (COMMENT MDOT)) +(DECLARE (SPECIAL $ASSUMESCALAR $DOTIDENT $SCALARMATRIXP $DOMXNCTIMES + $DOSCMXOPS $DOMXMXOPS $DOALLMXOPS $DOTASSOC $DOTEXPTSIMP + $DOTDISTRIB $DOTSCRULES $DOT1SIMP $DOT0NSCSIMP $DOT0SIMP + $DOTCONSTRULES)) + +;; Declarations for JIM;LIMIT 273, compiled 1/28/18 21:24 by EJS. +(DECLARE (COMMENT LIMIT)) +(DECLARE (SPECIAL PRESERVE-DIRECTION LIMIT-ANSWERS SIMPLIMPLUS-PROBLEMS RD* + INFINITESIMALS REAL-INFINITIES INFINITIES)) + +;; Declarations for PAULW;DEFINT 658, compiled 1/28/18 21:24 by EJS. +(DECLARE (COMMENT DEFINT)) +(DECLARE (SPECIAL DEFINTDEBUG)) + +;; Declarations for MACRAK;RPART 263, compiled 1/28/18 21:34 by EJS. +(DECLARE (COMMENT RPART)) +(DECLARE (SPECIAL GENERATE-ATAN2 IMPLICIT-REAL)) + +;; Declarations for RZ;NUMTH 47, compiled 1/28/18 21:35 by EJS. +(DECLARE (COMMENT NUMTH)) +(DECLARE (SPECIAL $MAXPRIME)) + +;; Declarations for RAT;HAYAT 386, compiled 1/28/18 21:37 by EJS. +(DECLARE (COMMENT HAYAT)) +(DECLARE (SPECIAL $TAYLOR_LOGEXPAND $TAYLOR_TRUNCATE_POLYNOMIALS $MAXTAYORDER)) + +;; Declarations for RAT;ALGSYS 1, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT ALGSYS)) +(DECLARE (SPECIAL ALGNOTEXACT $ALGEXACT REALONLYRATNUM $REALONLY $%RNUM_LIST)) + +;; Declarations for RAT;NISIMP 81, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT NISIMP)) +(DECLARE (SPECIAL $LET_RULE_PACKAGES $CURRENT_LET_RULE_PACKAGE + $DEFAULT_LET_RULE_PACKAGE $LETRAT $LETVARSIMP)) + +;; Declarations for MAXSRC;SUBLIS 11, compiled 1/28/18 21:46 by EJS. +(DECLARE (COMMENT SUBLIS)) +(DECLARE (SPECIAL $SUBLIS_APPLY_LAMBDA)) + +;; Declarations for REH;MMACRO 50, compiled 1/28/18 21:47 by EJS. +(DECLARE (COMMENT MMACRO)) +(DECLARE (SPECIAL $MACROEXPANSION)) + +;; Declarations for JPG;LOGCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT LOGCON)) +(DECLARE (SPECIAL $SUPERLOGCON $LOGCONCOEFFP)) + +;; Declarations for JPG;RTCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT RTCON)) +(DECLARE (SPECIAL $ROOTSCONMODE)) + +;; Declarations for PAULW;GAMMA 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT GAMMA)) +(DECLARE (SPECIAL $BETA_ARGS_SUM_TO_INTEGER)) + +;; Declarations for RAT;SCUBIC 19 (PSOLVE split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT SCUBIC)) +(DECLARE (SPECIAL FLAG4)) + +;; Declarations for MAXSRC;ISOLAT 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT ISOLAT)) +(DECLARE (SPECIAL $ISOLATE_WRT_TIMES $EXPTISOLATE)) + +;; Declarations for RAT;MRESUL 30 (RESULT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT MRESUL)) +(DECLARE (SPECIAL $RESULTANT)) + +;; Declarations for MAXSRC;MLOAD 121, compiled 1/30/18 22:44 by EJS. +(DECLARE (COMMENT MLOAD)) +(DECLARE (SPECIAL $FILE_TYPES $FILE_SEARCH *IN-MACSYMA-INDEXER* + *IN-TRANSLATE-FILE* *IN-$BATCHLOAD*)) diff --git a/src/maxdoc/files.72 b/src/maxdoc/files.72 new file mode 100755 index 00000000..c0355282 --- /dev/null +++ b/src/maxdoc/files.72 @@ -0,0 +1,483 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Table of files comprising the Macsyma system. +;; This is the root in the tree of all macsyma documentation and system +;; organization. Therefore if any change is made to any of the +;; Macsyma source files, this table should be updated and mail sent +;; to Macsyma-Implementors. Macsyma implementors should familiarize +;; themselves with the various compilation, indexing, and documentation +;; features which depend on the information contained herein. +;; -GJC 2:52pm Monday, 3 November 1980 + +;; The MAXTUL directory contains the programs which manipulate these +;; data. In general they output data to the MAXDOC directory. + +(EVAL-WHEN (COMPILE EVAL LOAD) + (OR (GET 'DEFMFILE 'VERSION) + ;; which see for documentation of the structure. + (LOAD '((MAXTUL) DEFILE)))) + +(INIT-MACSYMA-SOURCE-FILES) +(HERALD MACSYMA-SOURCE-FILES) + +;; Extensions to lisp. + +;; Tools. + +;; macro packages. + +(DEFMFILE LIBMAX LMMAC + SYSTEMS-FOR '(PDP10 FRANZ) + GLOBAL-COMPILE T + MACRO-COMPILE T) + +(DEFMFILE LIBMAX DEFINE + SYSTEMS-FOR '(PDP10) + GLOBAL-COMPILE T) + +(DEFMFILE LIBMAX ERMSGC + ;; out-of-core format strings. + GLOBAL-COMPILE T) + +(DEFMFILE LIBMAX MAXMAC + GLOBAL-COMPILE T + MACRO-COMPILE T) + +(DEFMFILE LIBMAX MFORMA + GLOBAL-COMPILE T + MACRO-COMPILE T) + +(DEFMFILE LIBMAX MOPERS + GLOBAL-COMPILE T) + +(DEFMFILE LIBMAX MRGMAC + SELECTIVE-COMPILE T) + +(DEFMFILE LIBMAX STRMAC + SELECTIVE-COMPILE T) + +(DEFMFILE LIBMAX META + GLOBAL-COMPILE T) + +(DEFMFILE LIBMAX OPSHIN + MACRO-COMPILE T) + +(DEFMFILE LIBMAX TRANSQ + SELECTIVE-COMPILE T) + +(DEFMFILE LIBMAX TRANSM + SELECTIVE-COMPILE T) + +(DEFMFILE LIBMAX MDEFUN + ;; for translated code. + SELECTIVE-COMPILE T) + +(DEFMFILE LIBMAX TPRELU + SELECTIVE-COMPILE T) + +(DEFMFILE LIBMAX NUMERM + ;; for numerical code man. + SELECTIVE-COMPILE T) + +(DEFMFILE LIBMAX LMRUN + SYSTEMS-NOT-FOR '(FRANZ NIL LISPM) + SELECTIVE-COMPILE '?) + +(DEFMFILE EMAXIM EDMAC + ;; macsyma expression display editor. + SELECTIVE-COMPILE T) + +;; runtime packages. + + +(DEFMFILE ELL HYP + UNFASL-DIR 'ELL + FASL-DIR 'ELL) + +(DEFMFILE ELL HYPGEO + UNFASL-DIR 'ELL + FASL-DIR 'ELL) + +(DEFMFILE SHARE APLOT2 + FASL-DIR 'SHARE + UNFASL-DIR 'MUNFAS) + +(DEFMFILE SHARE TEKPLT + FASL-DIR 'SHARE + UNFASL-DIR 'MUNFAS) + +(DEFMFILE SHARE IFFUN + FASL-DIR 'SHARE + UNFASL-DIR 'MUNFAS) + +(DEFMFILE SHARE PRINT + FASL-DIR 'SHARE + UNFASL-DIR 'MUNFAS) + +(DEFMFILE SHARE PLOT3D + FASL-DIR 'SHARE + UNFASL-DIR 'MUNFAS) + +(DEFMFILE CFFK CPOLY) + +(DEFMFILE RZ MACROS + SELECTIVE-COMPILE T) + +(DEFMFILE RZ ASUM + IN-CORE 270.) + +(DEFMFILE RZ SERIES) + +(DEFMFILE RZ NUMTH) + +(DEFMFILE RZ SCHATC) + +(DEFMFILE RZ TRGRED) + +(DEFMFILE RZ COMBIN + SPLIT '(minfct eulbrn zeta cffun sum + prodct tayrat decomp)) + +(DEFMFILE JPG SUPRV + IN-CORE 60.) + +(DEFMFILE JPG COMM + IN-CORE 50.) + +(DEFMFILE JPG COMM2 + SPLIT '(DIFF2 AT LOGCON RTCON NTERMS + ATAN2 ARITHF DERIVD BOX + MAPF GENMAT ADDROW ARRAYF + ALIAS CONCAT TTYINI)) + +(DEFMFILE JPG DSKFN + IN-CORE 310.) + +(DEFMFILE JPG MLISP + IN-CORE 40.) + +(DEFMFILE JPG MEDIT + SYSTEMS-NOT-FOR '(LISPM NIL) + IN-CORE 300.) + +(DEFMFILE JPG ODE2 + LANGUAGE 'MACSYMA) + +(DEFMFILE JPG PLOT + SYSTEMS-FOR '(PDP10) + SPLIT '(GRAPH2 GRAPH)) + +(DEFMFILE MRG DB + IN-CORE 190.) + +(DEFMFILE MRG DISPLA + IN-CORE 20.) + +(DEFMFILE MRG FORTRA) + +(DEFMFILE MRG GRAM + SYSTEMS-NOT-FOR '(LISPM NIL) + IN-CORE 10.) + +(DEFMFILE MRG GRIND + IN-CORE 320.) + +(DEFMFILE MRG COMPAR + IN-CORE 200.) + +(DEFMFILE MRG NFORMA + IN-CORE 30.) + +(DEFMFILE MRG OPTIM) + +(DEFMFILE MRG SCS) + +(DEFMFILE MRG TRIGI + IN-CORE 260.) + +(DEFMFILE MRG TRIGO + SPLIT '( HYPER ATRIG AHYPER TRIGEX)) + +(DEFMFILE PAULW CSIMP + IN-CORE 240.) + +(DEFMFILE PAULW MAT + IN-CORE 230.) + +(DEFMFILE PAULW MATRIX + IN-CORE 220.) + +(DEFMFILE RAT ALGSYS) + +(DEFMFILE RAT FACTOR + IN-CORE 100.) + +(DEFMFILE RAT MHAYAT + SELECTIVE-COMPILE T) + +(DEFMFILE RAT RAT3A + IN-CORE 110.) + +(DEFMFILE RAT RAT3B + IN-CORE 120.) + +(DEFMFILE RAT RAT3C + IN-CORE 150.) + +(DEFMFILE RAT RAT3D + IN-CORE 130.) + +(DEFMFILE RAT RAT3E + IN-CORE 140.) + +(DEFMFILE RAT RATLAP + SYSTEMS-FOR '(PDP10) + LANGUAGE 'MIDAS + IN-CORE 90.) + +(DEFMFILE RAT RATMAC + SELECTIVE-COMPILE T) + +(DEFMFILE RAT NRAT4 + IN-CORE 210.) + +(DEFMFILE RAT EZGCD) + +(DEFMFILE RAT LESFAC + IN-CORE 160.) + +(DEFMFILE RAT SPGCD + IN-CORE 290.) + +(DEFMFILE RAT SOLVE) + +(DEFMFILE RAT HOMOG) + +(DEFMFILE RAT PADE) + +(DEFMFILE RAT MATRUN) + +(DEFMFILE RAT MATCOM) + +(DEFMFILE RAT POIS2) + +(DEFMFILE RAT POIS3) + +(DEFMFILE RAT RATPOI) + +(DEFMFILE RAT FLOAT) + +(DEFMFILE RAT RESULT + SPLIT '(MRESUL SUBRES REDRES MODRES BEZOUT )) + +(DEFMFILE RAT UFACT) + +(DEFMFILE RAT HAYAT) + +(DEFMFILE RAT POLYRZ) + +(DEFMFILE RAT NALGFA) + +(DEFMFILE RAT NEWDET) + +(DEFMFILE RAT NISIMP) + +(DEFMFILE RAT RATOUT + SPLIT '(MODGCD KRONEC FASTT RATWT HORNER PFRAC + RATDIF PFET )) + +(DEFMFILE JM SIMP + IN-CORE 70.) + +(DEFMFILE JM SININT) + +(DEFMFILE JM SIN) + +(DEFMFILE JM RISCH) + +(DEFMFILE JM ZERO) + + +(DEFMFILE MAXSRC INMIS + IN-CORE 180.) + +(DEFMFILE MAXSRC LAPLAC) + +(DEFMFILE RAT PSOLVE + SPLIT '(SCUBIC SQUART)) + +(DEFMFILE MAXSRC OUTMIS + SPLIT '( STATUS ISOLAT PROPFN CHANGV FACSUM COMBF FACOUT SCREEN)) + +(DEFMFILE MAXSRC MTRACE + ;; new trace package. + ) + +;; Terminal support +(DEFMFILE MAXSRC ARDS + SYSTEMS-NOT-FOR '(FRANZ)) + +(DEFMFILE MAXSRC VT100 + SYSTEMS-NOT-FOR '(FRANZ)) + +(DEFMFILE MAXSRC H19 + SYSTEMS-NOT-FOR '(FRANZ)) + +;; for suspending the macsyma session/environment +(DEFMFILE MAXSRC SUSPEN + SYSTEMS-FOR '(PDP10)) + +;; Other stuff. + +(DEFMFILE MAXSRC OPERS + IN-CORE 80.) + +(DEFMFILE MAXSRC OPS) + +(DEFMFILE MAXSRC SUBLIS) + +(DEFMFILE MAXSRC SETS + FASL-DIR 'SHARE + ;; macsyma extended data types not fully supported. + UNFASL-DIR 'MAXOUT) + +(DEFMFILE MAXSRC AR) ;; Array objects. + +(DEFMFILE MAXSRC MTREE) + +(DEFMFILE MAXSRC CHAR) + +(DEFMFILE MAXSRC DOVER) + +;; The transl package. +(DEFMFILE TRANSL TRDUMP + FASL-DIR 'MAXDMP + UNFASL-DIR 'MUNFAS) +(DEFMFILE TRANSL TRHOOK) ; used to implement translator modularity on the PDP-10. +(DEFMFILE TRANSL TRUTIL) ; Utilties. +(DEFMFILE TRANSL TRANSS) ; The system and user hacking part of transl. +(DEFMFILE TRANSL TRANSL) ; Toplevel expression translate and basic special forms. +(DEFMFILE TRANSL TRANS1) ; Translation properties by general grouping. +(DEFMFILE TRANSL TRANS2) ; ITS filenames don't allow more detail, see TRANSL > +(DEFMFILE TRANSL TRANS3) +(DEFMFILE TRANSL TRANS4) +(DEFMFILE TRANSL TRANS5) +(DEFMFILE TRANSL TRANSF) +(DEFMFILE TRANSL TROPER) +(DEFMFILE TRANSL TRPRED) ; predicates. +(DEFMFILE TRANSL TRPROP) ; META-PROPERTIES. +(DEFMFILE TRANSL TRMODE) ; User MODEDECLARE definitions. +(DEFMFILE TRANSL TRDATA) ; DATA on built-in functions. +(DEFMFILE TRANSL ACALL) ; RUNTIME support for translated code. +(DEFMFILE TRANSL FCALL) ; FSUBRs for the interpreter. (See TRANSQ). +(DEFMFILE TRANSL EVALW) ; User utility EVAL_WHEN. +(DEFMFILE TRANSL MCOMPI) ; User interface to lisp compiler. +(DEFMFILE TRANSL LJOB + ;; Inferior JOB hacking, (so we can call lisp compiler). + SYSTEMS-FOR '(ITS)) +(DEFMFILE TRANSL TRDEBG) ; For debugging translated code. +(DEFMFILE TRANSL MTAGS) ; generates macsyma-user TAGS while translating. + +;; Numerical stuff. +(DEFMFILE MAXSRC ROMBRG) +(DEFMFILE MAXSRC INTPOL) +(DEFMFILE MAXSRC NUMER) ;; numerical support hacks. +(DEFMFILE MAXSRC NDIFFQ + FASL-DIR 'SHARE2) + +;; Macsyma file handling stuff. Advanced user I/O +(DEFMFILE MAXSRC MLOAD IN-CORE 65.) +(DEFMFILE MAXSRC OUTEX + SPLIT '(outex OUTEY)) + +;; error handler. +(DEFMFILE MAXSRC MERROR IN-CORE 50.) +(DEFMFILE MAXSRC MFORMT IN-CORE 50.) +;; out of core strings. +(DEFMFILE MAXSRC ERMSGM IN-CORE 1. ; the first thing loaded! + SYSTEMS-FOR '(PDP10)) + +(DEFMFILE MAXSRC LDISP) +(DEFMFILE MAXSRC MDOT) +(DEFMFILE MAXSRC SUMCON) +(DEFMFILE MAXSRC SYNEX + SYSTEMS-NOT-FOR '(NIL LISPM)) +(DEFMFILE MAXSRC RUNTIM + SYSTEMS-FOR '(PDP10) + IN-CORE 280.) +(DEFMFILE MAXSRC UTILS + IN-CORE 250.) +(DEFMFILE MAXSRC MUTILS + IN-CORE 5.) + +(DEFMFILE ELLEN OPTION) +(DEFMFILE ELLEN PRIMER) + +(DEFMFILE MAXSRC DESCRI + SPLIT '( DESCR EXAMPL) + SYSTEMS-NOT-FOR '(FRANZ LISPM NIL)) +(DEFMFILE RLB FASDMP + SYSTEMS-NOT-FOR '(FRANZ LISPM MULTICS NIL)) + +(DEFMFILE MAXSRC IRINTE) + +(DEFMFILE JIM ASKP) +(DEFMFILE JIM LIMIT) +(DEFMFILE JIM TLIMIT) + +(DEFMFILE PAULW RESIDU) +(DEFMFILE PAULW DEFINT) +(DEFMFILE PAULW SPRDET) +(DEFMFILE PAULW NEWINV) +(DEFMFILE PAULW LINNEW) +(DEFMFILE PAULW EEZ) +(DEFMFILE PAULW NEWFAC) +(DEFMFILE PAULW ALGFAC) +(DEFMFILE PAULW CSIMP2 + SPLIT '( PLOG BINOML GAMMA ERF EMATRIX COEFM ENTERM xthru XRTOUT + )) + +(DEFMFILE MACRAK LOGARC) +(DEFMFILE MACRAK RPART) + +(DEFMFILE ZZ APROPO + SYSTEMS-NOT-FOR '(FRANZ LISPM NIL)) + +(DEFMFILE TENSOR ITENSR) +(DEFMFILE TENSOR CANTEN) +(DEFMFILE TENSOR GENER) +(DEFMFILE TENSOR SYMTRY) + +(DEFMFILE SHARE FILEOP + SYSTEMS-FOR '(PDP10) + FASL-DIR 'SHARE) + +(DEFMFILE ALJABR RESET + SYSTEMS-NOT-FOR '(FRANZ)) + +(DEFMFILE DAS MSTUFF + SPLIT '( MSORT MAKEL)) + +(DEFMFILE WGD SPECFN + SPLIT '( plylog plygam)) + +(DEFMFILE REH MMACRO) +(DEFMFILE REH BUILDQ) + + +;;; macsyma expression display editor. + +(DEFMFILE EMAXIM EDCTL + FASL-DIR 'EMAXIM) +(DEFMFILE EMAXIM EDEXP + FASL-DIR 'EMAXIM) +(DEFMFILE EMAXIM EDBUF + FASL-DIR 'EMAXIM) +(DEFMFILE EMAXIM EDITS + SYSTEMS-FOR '(ITS) + FASL-DIR 'EMAXIM) +(DEFMFILE EMAXIM EDLM + SYSTEMS-FOR '(LISPM)) + \ No newline at end of file diff --git a/src/maxdoc/init.norese b/src/maxdoc/init.norese new file mode 100644 index 00000000..5240530d --- /dev/null +++ b/src/maxdoc/init.norese @@ -0,0 +1,21 @@ +;; -*- Mode: Lisp; Package: Macsyma -*- +;; This is the initialization file for variables which cannot be reset. +;; This file was generated by DEFINE version NIL. + +;; Initializations for MRG;COMPAR 857, compiled 1/28/18 8:53 by EJS. +(DECLARE (COMMENT COMPAR)) +(SETQ $CONTEXT (QUOTE $INITIAL) $CONTEXTS (QUOTE ((MLIST) $INITIAL $GLOBAL)) + $ACTIVECONTEXTS (QUOTE ((MLIST)))) + +;; Initializations for JPG;SUPRV 619, compiled 1/28/18 11:29 by EJS. +(DECLARE (COMMENT SUPRV)) +(SETQ $% (QUOTE $%) $LINENUM 1. $DIREC (QUOTE JRMU) $MOREWAIT NIL) + +;; Initializations for RAT;FLOAT 321, compiled 1/28/18 12:06 by EJS. +(DECLARE (COMMENT FLOAT)) +(SETQ BIGFLOATZERO (QUOTE ((BIGFLOAT SIMP 56.) 0. 0.)) + BIGFLOATONE (QUOTE ((BIGFLOAT SIMP 56.) 36028797018963968. 1.))) + +;; Initializations for RAT;ALGSYS 1, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT ALGSYS)) +(SETQ REALONLYRATNUM NIL ALGNOTEXACT NIL) diff --git a/src/maxdoc/init.reset b/src/maxdoc/init.reset new file mode 100644 index 00000000..cca170b7 --- /dev/null +++ b/src/maxdoc/init.reset @@ -0,0 +1,175 @@ +;; -*- Mode: Lisp; Package: Macsyma -*- +;; This is the initialization file for variables which can be reset. +;; This file was generated by DEFINE version NIL. + +;; Initializations for MRG;NFORMA 15, compiled 1/28/18 8:47 by EJS. +(DECLARE (COMMENT NFORMA)) +(SETQ $POWERDISP NIL $PFEFORMAT NIL $%EDISPFLAG NIL $EXPTDISPFLAG T + $SQRTDISPFLAG T $NEGSUMDISPFLAG T) + +;; Initializations for MRG;COMPAR 857, compiled 1/28/18 8:53 by EJS. +(DECLARE (COMMENT COMPAR)) +(SETQ $PREDERROR T $SIGNBFLOAT T $ASSUME_POS NIL $ASSUME_POS_PRED NIL) + +;; Initializations for MRG;TRIGI 343, compiled 1/28/18 8:53 by EJS. +(DECLARE (COMMENT TRIGI)) +(SETQ $%PIARGS T $%IARGS T $TRIGINVERSES (QUOTE $ALL) $TRIGEXPAND NIL + $TRIGEXPANDPLUS T $TRIGEXPANDTIMES T $TRIGSIGN T $EXPONENTIALIZE NIL + $LOGARC NIL $HALFANGLES NIL) + +;; Initializations for JPG;MLISP 613, compiled 1/28/18 9:52 by EJS. +(DECLARE (COMMENT MLISP)) +(SETQ $SETCHECK NIL) + +;; Initializations for JPG;SUPRV 619, compiled 1/28/18 11:29 by EJS. +(DECLARE (COMMENT SUPRV)) +(SETQ $INCHAR (QUOTE $C) $OUTCHAR (QUOTE $D) $LINECHAR (QUOTE $E) + $TTYINTNUM 21. $TTYINTFUN NIL $CHANGE_FILEDEFAULTS T + $FILE_STRING_PRINT NIL $SHOWTIME NIL) + +;; Initializations for JPG;COMM 395, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT COMM)) +(SETQ $VECT_CROSS NIL) + +;; Initializations for PAULW;CSIMP 299, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT CSIMP)) +(SETQ $SUMSPLITFACT T $GAMMALIM 1000000.) + +;; Initializations for PAULW;MAT 286, compiled 1/28/18 11:38 by EJS. +(DECLARE (COMMENT MAT)) +(SETQ $GLOBALSOLVE NIL $SPARSE NIL $BACKSUBST T $%RNUM 0. $LINSOLVE_PARAMS T) + +;; Initializations for RAT;FACTOR 472, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT FACTOR)) +(SETQ $NALGFAC T $NEWFAC NIL) + +;; Initializations for RAT;RAT3B 95, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3B)) +(SETQ $RATWTLVL NIL $RATALGDENOM T) + +;; Initializations for RAT;RAT3C 302, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3C)) +(SETQ $GCD (CAR *GCDL*)) + +;; Initializations for RAT;RAT3D 264, compiled 1/28/18 11:49 by EJS. +(DECLARE (COMMENT RAT3D)) +(SETQ $INTFACLIM 1000. $BERLEFACT T $SAVEFACTORS NIL $HOMOG_HACK NIL) + +;; Initializations for RAT;RAT3E 546, compiled 1/28/18 11:50 by EJS. +(DECLARE (COMMENT RAT3E)) +(SETQ $KEEPFLOAT NIL $FACTORFLAG NIL $DONTFACTOR (QUOTE ((MLIST))) $NOREPEAT T + $RATWEIGHTS (QUOTE ((MLIST SIMP))) $RATFAC NIL $ALGEBRAIC NIL + $RATVARS (QUOTE ((MLIST SIMP))) $FACEXPAND T $RATPRINT T + $RATEPSILON 2.0E-8 $RATEXPAND NIL $RATDENOMDIVIDE T) + +;; Initializations for JM;SIMP 834, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT SIMP)) +(SETQ $FLOAT NIL $NEGDISTRIB T $NUMER NIL $SIMP T $SUMEXPAND NIL + $NUMER_PBRANCH NIL $DOSCMXPLUS NIL $DOMXEXPT T $DOMXPLUS NIL + $DOMXTIMES NIL $MX0SIMP T $EXPOP 0. $EXPON 0. $MAXPOSEX 1000. + $MAXNEGEX 1000.) + +;; Initializations for MAXSRC;INMIS 98, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT INMIS)) +(SETQ $LISTCONSTVARS NIL) + +;; Initializations for RZ;ASUM 271, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT ASUM)) +(SETQ $CAUCHYSUM NIL $GENSUMNUM 0. $GENINDEX (QUOTE $I) $ZEROBERN T + $SIMPSUM NIL $SUMHACK NIL $PRODHACK NIL) + +;; Initializations for RAT;SPGCD 110, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT SPGCD)) +(SETQ $POINTBOUND *ALPHA) + +;; Initializations for MAXSRC;MERROR 47, compiled 1/28/18 11:52 by EJS. +(DECLARE (COMMENT MERROR)) +(SETQ $ERROR (QUOTE ((MLIST SIMP) |&No error.|)) $ERRORMSG (QUOTE T) + $ERROR_SIZE 10. $ERROR_SYMS (QUOTE ((MLIST) $ERREXP1 $ERREXP2 $ERREXP3))) + +;; Initializations for MRG;FORTRA 64, compiled 1/28/18 11:53 by EJS. +(DECLARE (COMMENT FORTRA)) +(SETQ $FORTSPACES NIL $FORTINDENT 0. $FORTFLOAT NIL) + +;; Initializations for MRG;OPTIM 14, compiled 1/28/18 11:56 by EJS. +(DECLARE (COMMENT OPTIM)) +(SETQ $OPTIMPREFIX (QUOTE $%) $OPTIMWARN T) + +;; Initializations for JM;SIN 200, compiled 1/28/18 11:56 by EJS. +(DECLARE (COMMENT SIN)) +(SETQ $INTEGRATION_CONSTANT_COUNTER 0.) + +;; Initializations for RAT;MATRUN 80, compiled 1/28/18 11:57 by EJS. +(DECLARE (COMMENT MATRUN)) +(SETQ $MAXAPPLYDEPTH 10000. $MAXAPPLYHEIGHT 10000.) + +;; Initializations for RAT;FLOAT 321, compiled 1/28/18 12:06 by EJS. +(DECLARE (COMMENT FLOAT)) +(SETQ $FLOAT2BF NIL $BFTORAT NIL $BFTRUNC T $FPPRINTPREC 0. $FPPREC 16.) + +;; Initializations for RAT;SOLVE 401, compiled 1/28/18 12:09 by EJS. +(DECLARE (COMMENT SOLVE)) +(SETQ $BREAKUP T $MULTIPLICITIES (QUOTE $NOT_SET_YET) $LINSOLVEWARN T + $SOLVE_INCONSISTENT_ERROR T $PROGRAMMODE T $SOLVEDECOMPOSES T + $SOLVEEXPLICIT NIL $SOLVEFACTORS T $SOLVENULLWARN T $SOLVETRIGWARN T + $SOLVERADCAN NIL) + +;; Initializations for MAXSRC;MDOT 94, compiled 1/28/18 12:09 by EJS. +(DECLARE (COMMENT MDOT)) +(SETQ $DOTCONSTRULES T $DOT0SIMP T $DOT0NSCSIMP T $DOT1SIMP T $DOTSCRULES NIL + $DOTDISTRIB NIL $DOTEXPTSIMP T $DOTASSOC T $DOALLMXOPS T $DOMXMXOPS T + $DOSCMXOPS NIL $DOMXNCTIMES NIL $SCALARMATRIXP T $DOTIDENT 1. + $ASSUMESCALAR T) + +;; Initializations for RZ;NUMTH 47, compiled 1/28/18 21:35 by EJS. +(DECLARE (COMMENT NUMTH)) +(SETQ $MAXPRIME 489318.) + +;; Initializations for RAT;HAYAT 386, compiled 1/28/18 21:37 by EJS. +(DECLARE (COMMENT HAYAT)) +(SETQ $MAXTAYORDER T $TAYLOR_TRUNCATE_POLYNOMIALS T $TAYLOR_LOGEXPAND T) + +;; Initializations for RAT;ALGSYS 1, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT ALGSYS)) +(SETQ $%RNUM_LIST (QUOTE ((MLIST))) $REALONLY NIL $ALGEXACT NIL) + +;; Initializations for RAT;NISIMP 81, compiled 1/28/18 21:41 by EJS. +(DECLARE (COMMENT NISIMP)) +(SETQ $LETVARSIMP NIL $LETRAT NIL + $DEFAULT_LET_RULE_PACKAGE (QUOTE $DEFAULT_LET_RULE_PACKAGE) + $CURRENT_LET_RULE_PACKAGE (QUOTE $DEFAULT_LET_RULE_PACKAGE) + $LET_RULE_PACKAGES (QUOTE ((MLIST) $DEFAULT_LET_RULE_PACKAGE))) + +;; Initializations for MAXSRC;SUBLIS 11, compiled 1/28/18 21:46 by EJS. +(DECLARE (COMMENT SUBLIS)) +(SETQ $SUBLIS_APPLY_LAMBDA T) + +;; Initializations for REH;MMACRO 50, compiled 1/28/18 21:47 by EJS. +(DECLARE (COMMENT MMACRO)) +(SETQ $MACROEXPANSION NIL) + +;; Initializations for JPG;LOGCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT LOGCON)) +(SETQ $LOGCONCOEFFP NIL $SUPERLOGCON T) + +;; Initializations for JPG;RTCON 56 (COMM2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT RTCON)) +(SETQ $ROOTSCONMODE T) + +;; Initializations for PAULW;GAMMA 63 (CSIMP2 split), compiled 1/28/18 21:50 by EJS. +(DECLARE (COMMENT GAMMA)) +(SETQ $BETA_ARGS_SUM_TO_INTEGER NIL) + +;; Initializations for MAXSRC;ISOLAT 309 (OUTMIS split), compiled 1/28/18 22:02 by EJS. +(DECLARE (COMMENT ISOLAT)) +(SETQ $EXPTISOLATE NIL $ISOLATE_WRT_TIMES NIL) + +;; Initializations for RAT;MRESUL 30 (RESULT split), compiled 1/28/18 22:03 by EJS. +(DECLARE (COMMENT MRESUL)) +(SETQ $RESULTANT (QUOTE $SUBRES)) + +;; Initializations for MAXSRC;MLOAD 121, compiled 1/30/18 22:44 by EJS. +(DECLARE (COMMENT MLOAD)) +(SETQ + $FILE_SEARCH (LIST* (QUOTE (MLIST)) (MAPCAR (FUNCTION TO-MACSYMA-NAMESTRING) (QUOTE ("DSK:SHARE;" "DSK:SHARE1;" "DSK:SHARE2;" "DSK:SHAREM;")))) + $FILE_TYPES (LIST* (QUOTE (MLIST)) (MAPCAR (FUNCTION TO-MACSYMA-NAMESTRING) (QUOTE ("* FASL" "* TRLISP" "* LISP" "* >"))))) diff --git a/src/maxdoc/mcldat.34 b/src/maxdoc/mcldat.34 new file mode 100755 index 00000000..972d4355 --- /dev/null +++ b/src/maxdoc/mcldat.34 @@ -0,0 +1,1212 @@ +; Compiler source file database. +; Sunday, July 24, 1983 1:58am +(SETQ MACSYMA-FILE-NAMES NIL) +(PUSH 'EDLM MACSYMA-FILE-NAMES) +(DEFPROP EDLM EMAXIM DIR) +(DEFPROP EDLM 4/ GENPREFIX) +(DEFPROP EDLM MUNFAS UNFASL-DIR) +(DEFPROP EDLM MACSYM FASL-DIR) +(DEFPROP EDLM MAXERR ERRMSG-DIR) +(DEFPROP EDLM NIL IN-CORE) +(PUSH 'EDITS MACSYMA-FILE-NAMES) +(DEFPROP EDITS EMAXIM DIR) +(DEFPROP EDITS 3/ GENPREFIX) +(DEFPROP EDITS MUNFAS UNFASL-DIR) +(DEFPROP EDITS EMAXIM FASL-DIR) +(DEFPROP EDITS MAXERR ERRMSG-DIR) +(DEFPROP EDITS NIL IN-CORE) +(PUSH 'EDBUF MACSYMA-FILE-NAMES) +(DEFPROP EDBUF EMAXIM DIR) +(DEFPROP EDBUF 2/ GENPREFIX) +(DEFPROP EDBUF MUNFAS UNFASL-DIR) +(DEFPROP EDBUF EMAXIM FASL-DIR) +(DEFPROP EDBUF MAXERR ERRMSG-DIR) +(DEFPROP EDBUF NIL IN-CORE) +(PUSH 'EDEXP MACSYMA-FILE-NAMES) +(DEFPROP EDEXP EMAXIM DIR) +(DEFPROP EDEXP 1/ GENPREFIX) +(DEFPROP EDEXP MUNFAS UNFASL-DIR) +(DEFPROP EDEXP EMAXIM FASL-DIR) +(DEFPROP EDEXP MAXERR ERRMSG-DIR) +(DEFPROP EDEXP NIL IN-CORE) +(PUSH 'EDCTL MACSYMA-FILE-NAMES) +(DEFPROP EDCTL EMAXIM DIR) +(DEFPROP EDCTL 0/ GENPREFIX) +(DEFPROP EDCTL MUNFAS UNFASL-DIR) +(DEFPROP EDCTL EMAXIM FASL-DIR) +(DEFPROP EDCTL MAXERR ERRMSG-DIR) +(DEFPROP EDCTL NIL IN-CORE) +(PUSH 'BUILDQ MACSYMA-FILE-NAMES) +(DEFPROP BUILDQ REH DIR) +(DEFPROP BUILDQ /// GENPREFIX) +(DEFPROP BUILDQ MUNFAS UNFASL-DIR) +(DEFPROP BUILDQ MACSYM FASL-DIR) +(DEFPROP BUILDQ MAXERR ERRMSG-DIR) +(DEFPROP BUILDQ NIL IN-CORE) +(PUSH 'MMACRO MACSYMA-FILE-NAMES) +(DEFPROP MMACRO REH DIR) +(DEFPROP MMACRO |.| GENPREFIX) +(DEFPROP MMACRO MUNFAS UNFASL-DIR) +(DEFPROP MMACRO MACSYM FASL-DIR) +(DEFPROP MMACRO MAXERR ERRMSG-DIR) +(DEFPROP MMACRO NIL IN-CORE) +(PUSH 'SPECFN MACSYMA-FILE-NAMES) +(DEFPROP SPECFN WGD DIR) +(DEFPROP SPECFN -/ GENPREFIX) +(DEFPROP SPECFN MAXOUT UNFASL-DIR) +(DEFPROP SPECFN MAXOUT FASL-DIR) +(DEFPROP SPECFN MAXERR ERRMSG-DIR) +(DEFPROP SPECFN NIL IN-CORE) +(PUSH 'MSTUFF MACSYMA-FILE-NAMES) +(DEFPROP MSTUFF DAS DIR) +(DEFPROP MSTUFF |,| GENPREFIX) +(DEFPROP MSTUFF MAXOUT UNFASL-DIR) +(DEFPROP MSTUFF MAXOUT FASL-DIR) +(DEFPROP MSTUFF MAXERR ERRMSG-DIR) +(DEFPROP MSTUFF NIL IN-CORE) +(PUSH 'RESET MACSYMA-FILE-NAMES) +(DEFPROP RESET ALJABR DIR) +(DEFPROP RESET +/ GENPREFIX) +(DEFPROP RESET MUNFAS UNFASL-DIR) +(DEFPROP RESET MACSYM FASL-DIR) +(DEFPROP RESET MAXERR ERRMSG-DIR) +(DEFPROP RESET NIL IN-CORE) +(PUSH 'FILEOP MACSYMA-FILE-NAMES) +(DEFPROP FILEOP SHARE DIR) +(DEFPROP FILEOP */ GENPREFIX) +(DEFPROP FILEOP MUNFAS UNFASL-DIR) +(DEFPROP FILEOP SHARE FASL-DIR) +(DEFPROP FILEOP MAXERR ERRMSG-DIR) +(DEFPROP FILEOP NIL IN-CORE) +(PUSH 'SYMTRY MACSYMA-FILE-NAMES) +(DEFPROP SYMTRY TENSOR DIR) +(DEFPROP SYMTRY |)| GENPREFIX) +(DEFPROP SYMTRY MUNFAS UNFASL-DIR) +(DEFPROP SYMTRY MACSYM FASL-DIR) +(DEFPROP SYMTRY MAXERR ERRMSG-DIR) +(DEFPROP SYMTRY NIL IN-CORE) +(PUSH 'GENER MACSYMA-FILE-NAMES) +(DEFPROP GENER TENSOR DIR) +(DEFPROP GENER |(| GENPREFIX) +(DEFPROP GENER MUNFAS UNFASL-DIR) +(DEFPROP GENER MACSYM FASL-DIR) +(DEFPROP GENER MAXERR ERRMSG-DIR) +(DEFPROP GENER NIL IN-CORE) +(PUSH 'CANTEN MACSYMA-FILE-NAMES) +(DEFPROP CANTEN TENSOR DIR) +(DEFPROP CANTEN |'| GENPREFIX) +(DEFPROP CANTEN MUNFAS UNFASL-DIR) +(DEFPROP CANTEN MACSYM FASL-DIR) +(DEFPROP CANTEN MAXERR ERRMSG-DIR) +(DEFPROP CANTEN NIL IN-CORE) +(PUSH 'ITENSR MACSYMA-FILE-NAMES) +(DEFPROP ITENSR TENSOR DIR) +(DEFPROP ITENSR &/ GENPREFIX) +(DEFPROP ITENSR MUNFAS UNFASL-DIR) +(DEFPROP ITENSR MACSYM FASL-DIR) +(DEFPROP ITENSR MAXERR ERRMSG-DIR) +(DEFPROP ITENSR NIL IN-CORE) +(PUSH 'APROPO MACSYMA-FILE-NAMES) +(DEFPROP APROPO ZZ DIR) +(DEFPROP APROPO %/ GENPREFIX) +(DEFPROP APROPO MUNFAS UNFASL-DIR) +(DEFPROP APROPO MACSYM FASL-DIR) +(DEFPROP APROPO MAXERR ERRMSG-DIR) +(DEFPROP APROPO NIL IN-CORE) +(PUSH 'RPART MACSYMA-FILE-NAMES) +(DEFPROP RPART MACRAK DIR) +(DEFPROP RPART $/ GENPREFIX) +(DEFPROP RPART MUNFAS UNFASL-DIR) +(DEFPROP RPART MACSYM FASL-DIR) +(DEFPROP RPART MAXERR ERRMSG-DIR) +(DEFPROP RPART NIL IN-CORE) +(PUSH 'LOGARC MACSYMA-FILE-NAMES) +(DEFPROP LOGARC MACRAK DIR) +(DEFPROP LOGARC |#| GENPREFIX) +(DEFPROP LOGARC MUNFAS UNFASL-DIR) +(DEFPROP LOGARC MACSYM FASL-DIR) +(DEFPROP LOGARC MAXERR ERRMSG-DIR) +(DEFPROP LOGARC NIL IN-CORE) +(PUSH 'CSIMP2 MACSYMA-FILE-NAMES) +(DEFPROP CSIMP2 PAULW DIR) +(DEFPROP CSIMP2 |"| GENPREFIX) +(DEFPROP CSIMP2 MAXOUT UNFASL-DIR) +(DEFPROP CSIMP2 MAXOUT FASL-DIR) +(DEFPROP CSIMP2 MAXERR ERRMSG-DIR) +(DEFPROP CSIMP2 NIL IN-CORE) +(PUSH 'ALGFAC MACSYMA-FILE-NAMES) +(DEFPROP ALGFAC PAULW DIR) +(DEFPROP ALGFAC !/ GENPREFIX) +(DEFPROP ALGFAC MUNFAS UNFASL-DIR) +(DEFPROP ALGFAC MACSYM FASL-DIR) +(DEFPROP ALGFAC MAXERR ERRMSG-DIR) +(DEFPROP ALGFAC NIL IN-CORE) +(PUSH 'NEWFAC MACSYMA-FILE-NAMES) +(DEFPROP NEWFAC PAULW DIR) +(DEFPROP NEWFAC | | GENPREFIX) +(DEFPROP NEWFAC MUNFAS UNFASL-DIR) +(DEFPROP NEWFAC MACSYM FASL-DIR) +(DEFPROP NEWFAC MAXERR ERRMSG-DIR) +(DEFPROP NEWFAC NIL IN-CORE) +(PUSH 'EEZ MACSYMA-FILE-NAMES) +(DEFPROP EEZ PAULW DIR) +(DEFPROP EEZ || GENPREFIX) +(DEFPROP EEZ MUNFAS UNFASL-DIR) +(DEFPROP EEZ MACSYM FASL-DIR) +(DEFPROP EEZ MAXERR ERRMSG-DIR) +(DEFPROP EEZ NIL IN-CORE) +(PUSH 'LINNEW MACSYMA-FILE-NAMES) +(DEFPROP LINNEW PAULW DIR) +(DEFPROP LINNEW || GENPREFIX) +(DEFPROP LINNEW MUNFAS UNFASL-DIR) +(DEFPROP LINNEW MACSYM FASL-DIR) +(DEFPROP LINNEW MAXERR ERRMSG-DIR) +(DEFPROP LINNEW NIL IN-CORE) +(PUSH 'NEWINV MACSYMA-FILE-NAMES) +(DEFPROP NEWINV PAULW DIR) +(DEFPROP NEWINV || GENPREFIX) +(DEFPROP NEWINV MUNFAS UNFASL-DIR) +(DEFPROP NEWINV MACSYM FASL-DIR) +(DEFPROP NEWINV MAXERR ERRMSG-DIR) +(DEFPROP NEWINV NIL IN-CORE) +(PUSH 'SPRDET MACSYMA-FILE-NAMES) +(DEFPROP SPRDET PAULW DIR) +(DEFPROP SPRDET || GENPREFIX) +(DEFPROP SPRDET MUNFAS UNFASL-DIR) +(DEFPROP SPRDET MACSYM FASL-DIR) +(DEFPROP SPRDET MAXERR ERRMSG-DIR) +(DEFPROP SPRDET NIL IN-CORE) +(PUSH 'DEFINT MACSYMA-FILE-NAMES) +(DEFPROP DEFINT PAULW DIR) +(DEFPROP DEFINT / GENPREFIX) +(DEFPROP DEFINT MUNFAS UNFASL-DIR) +(DEFPROP DEFINT MACSYM FASL-DIR) +(DEFPROP DEFINT MAXERR ERRMSG-DIR) +(DEFPROP DEFINT NIL IN-CORE) +(PUSH 'RESIDU MACSYMA-FILE-NAMES) +(DEFPROP RESIDU PAULW DIR) +(DEFPROP RESIDU || GENPREFIX) +(DEFPROP RESIDU MUNFAS UNFASL-DIR) +(DEFPROP RESIDU MACSYM FASL-DIR) +(DEFPROP RESIDU MAXERR ERRMSG-DIR) +(DEFPROP RESIDU NIL IN-CORE) +(PUSH 'TLIMIT MACSYMA-FILE-NAMES) +(DEFPROP TLIMIT JIM DIR) +(DEFPROP TLIMIT || GENPREFIX) +(DEFPROP TLIMIT MUNFAS UNFASL-DIR) +(DEFPROP TLIMIT MACSYM FASL-DIR) +(DEFPROP TLIMIT MAXERR ERRMSG-DIR) +(DEFPROP TLIMIT NIL IN-CORE) +(PUSH 'LIMIT MACSYMA-FILE-NAMES) +(DEFPROP LIMIT JIM DIR) +(DEFPROP LIMIT || GENPREFIX) +(DEFPROP LIMIT MUNFAS UNFASL-DIR) +(DEFPROP LIMIT MACSYM FASL-DIR) +(DEFPROP LIMIT MAXERR ERRMSG-DIR) +(DEFPROP LIMIT NIL IN-CORE) +(PUSH 'ASKP MACSYMA-FILE-NAMES) +(DEFPROP ASKP JIM DIR) +(DEFPROP ASKP || GENPREFIX) +(DEFPROP ASKP MUNFAS UNFASL-DIR) +(DEFPROP ASKP MACSYM FASL-DIR) +(DEFPROP ASKP MAXERR ERRMSG-DIR) +(DEFPROP ASKP NIL IN-CORE) +(PUSH 'IRINTE MACSYMA-FILE-NAMES) +(DEFPROP IRINTE MAXSRC DIR) +(DEFPROP IRINTE || GENPREFIX) +(DEFPROP IRINTE MUNFAS UNFASL-DIR) +(DEFPROP IRINTE MACSYM FASL-DIR) +(DEFPROP IRINTE MAXERR ERRMSG-DIR) +(DEFPROP IRINTE NIL IN-CORE) +(PUSH 'FASDMP MACSYMA-FILE-NAMES) +(DEFPROP FASDMP RLB DIR) +(DEFPROP FASDMP || GENPREFIX) +(DEFPROP FASDMP MUNFAS UNFASL-DIR) +(DEFPROP FASDMP MACSYM FASL-DIR) +(DEFPROP FASDMP MAXERR ERRMSG-DIR) +(DEFPROP FASDMP NIL IN-CORE) +(PUSH 'DESCRI MACSYMA-FILE-NAMES) +(DEFPROP DESCRI MAXSRC DIR) +(DEFPROP DESCRI || GENPREFIX) +(DEFPROP DESCRI MAXOUT UNFASL-DIR) +(DEFPROP DESCRI MAXOUT FASL-DIR) +(DEFPROP DESCRI MAXERR ERRMSG-DIR) +(DEFPROP DESCRI NIL IN-CORE) +(PUSH 'PRIMER MACSYMA-FILE-NAMES) +(DEFPROP PRIMER ELLEN DIR) +(DEFPROP PRIMER || GENPREFIX) +(DEFPROP PRIMER MUNFAS UNFASL-DIR) +(DEFPROP PRIMER MACSYM FASL-DIR) +(DEFPROP PRIMER MAXERR ERRMSG-DIR) +(DEFPROP PRIMER NIL IN-CORE) +(PUSH 'OPTION MACSYMA-FILE-NAMES) +(DEFPROP OPTION ELLEN DIR) +(DEFPROP OPTION || GENPREFIX) +(DEFPROP OPTION MUNFAS UNFASL-DIR) +(DEFPROP OPTION MACSYM FASL-DIR) +(DEFPROP OPTION MAXERR ERRMSG-DIR) +(DEFPROP OPTION NIL IN-CORE) +(PUSH 'MUTILS MACSYMA-FILE-NAMES) +(DEFPROP MUTILS MAXSRC DIR) +(DEFPROP MUTILS || GENPREFIX) +(DEFPROP MUTILS MUNFAS UNFASL-DIR) +(DEFPROP MUTILS MAXDMP FASL-DIR) +(DEFPROP MUTILS MAXERR ERRMSG-DIR) +(DEFPROP MUTILS 5. IN-CORE) +(PUSH 'UTILS MACSYMA-FILE-NAMES) +(DEFPROP UTILS MAXSRC DIR) +(DEFPROP UTILS || GENPREFIX) +(DEFPROP UTILS MUNFAS UNFASL-DIR) +(DEFPROP UTILS MAXDMP FASL-DIR) +(DEFPROP UTILS MAXERR ERRMSG-DIR) +(DEFPROP UTILS 250. IN-CORE) +(PUSH 'RUNTIM MACSYMA-FILE-NAMES) +(DEFPROP RUNTIM MAXSRC DIR) +(DEFPROP RUNTIM || GENPREFIX) +(DEFPROP RUNTIM MUNFAS UNFASL-DIR) +(DEFPROP RUNTIM MAXDMP FASL-DIR) +(DEFPROP RUNTIM MAXERR ERRMSG-DIR) +(DEFPROP RUNTIM 280. IN-CORE) +(PUSH 'SYNEX MACSYMA-FILE-NAMES) +(DEFPROP SYNEX MAXSRC DIR) +(DEFPROP SYNEX || GENPREFIX) +(DEFPROP SYNEX MUNFAS UNFASL-DIR) +(DEFPROP SYNEX MACSYM FASL-DIR) +(DEFPROP SYNEX MAXERR ERRMSG-DIR) +(DEFPROP SYNEX NIL IN-CORE) +(PUSH 'SUMCON MACSYMA-FILE-NAMES) +(DEFPROP SUMCON MAXSRC DIR) +(DEFPROP SUMCON |/ +| GENPREFIX) +(DEFPROP SUMCON MUNFAS UNFASL-DIR) +(DEFPROP SUMCON MACSYM FASL-DIR) +(DEFPROP SUMCON MAXERR ERRMSG-DIR) +(DEFPROP SUMCON NIL IN-CORE) +(PUSH 'MDOT MACSYMA-FILE-NAMES) +(DEFPROP MDOT MAXSRC DIR) +(DEFPROP MDOT | | GENPREFIX) +(DEFPROP MDOT MUNFAS UNFASL-DIR) +(DEFPROP MDOT MACSYM FASL-DIR) +(DEFPROP MDOT MAXERR ERRMSG-DIR) +(DEFPROP MDOT NIL IN-CORE) +(PUSH 'LDISP MACSYMA-FILE-NAMES) +(DEFPROP LDISP MAXSRC DIR) +(DEFPROP LDISP | | GENPREFIX) +(DEFPROP LDISP MUNFAS UNFASL-DIR) +(DEFPROP LDISP MACSYM FASL-DIR) +(DEFPROP LDISP MAXERR ERRMSG-DIR) +(DEFPROP LDISP NIL IN-CORE) +(PUSH 'ERMSGM MACSYMA-FILE-NAMES) +(DEFPROP ERMSGM MAXSRC DIR) +(DEFPROP ERMSGM | | GENPREFIX) +(DEFPROP ERMSGM MUNFAS UNFASL-DIR) +(DEFPROP ERMSGM MAXDMP FASL-DIR) +(DEFPROP ERMSGM MAXERR ERRMSG-DIR) +(DEFPROP ERMSGM 1. IN-CORE) +(PUSH 'MFORMT MACSYMA-FILE-NAMES) +(DEFPROP MFORMT MAXSRC DIR) +(DEFPROP MFORMT | | GENPREFIX) +(DEFPROP MFORMT MUNFAS UNFASL-DIR) +(DEFPROP MFORMT MAXDMP FASL-DIR) +(DEFPROP MFORMT MAXERR ERRMSG-DIR) +(DEFPROP MFORMT 50. IN-CORE) +(PUSH 'MERROR MACSYMA-FILE-NAMES) +(DEFPROP MERROR MAXSRC DIR) +(DEFPROP MERROR / GENPREFIX) +(DEFPROP MERROR MUNFAS UNFASL-DIR) +(DEFPROP MERROR MAXDMP FASL-DIR) +(DEFPROP MERROR MAXERR ERRMSG-DIR) +(DEFPROP MERROR 50. IN-CORE) +(PUSH 'OUTEX MACSYMA-FILE-NAMES) +(DEFPROP OUTEX MAXSRC DIR) +(DEFPROP OUTEX || GENPREFIX) +(DEFPROP OUTEX MAXOUT UNFASL-DIR) +(DEFPROP OUTEX MAXOUT FASL-DIR) +(DEFPROP OUTEX MAXERR ERRMSG-DIR) +(DEFPROP OUTEX NIL IN-CORE) +(PUSH 'MLOAD MACSYMA-FILE-NAMES) +(DEFPROP MLOAD MAXSRC DIR) +(DEFPROP MLOAD || GENPREFIX) +(DEFPROP MLOAD MUNFAS UNFASL-DIR) +(DEFPROP MLOAD MAXDMP FASL-DIR) +(DEFPROP MLOAD MAXERR ERRMSG-DIR) +(DEFPROP MLOAD 65. IN-CORE) +(PUSH 'NDIFFQ MACSYMA-FILE-NAMES) +(DEFPROP NDIFFQ MAXSRC DIR) +(DEFPROP NDIFFQ || GENPREFIX) +(DEFPROP NDIFFQ MUNFAS UNFASL-DIR) +(DEFPROP NDIFFQ SHARE2 FASL-DIR) +(DEFPROP NDIFFQ MAXERR ERRMSG-DIR) +(DEFPROP NDIFFQ NIL IN-CORE) +(PUSH 'NUMER MACSYMA-FILE-NAMES) +(DEFPROP NUMER MAXSRC DIR) +(DEFPROP NUMER || GENPREFIX) +(DEFPROP NUMER MUNFAS UNFASL-DIR) +(DEFPROP NUMER MACSYM FASL-DIR) +(DEFPROP NUMER MAXERR ERRMSG-DIR) +(DEFPROP NUMER NIL IN-CORE) +(PUSH 'INTPOL MACSYMA-FILE-NAMES) +(DEFPROP INTPOL MAXSRC DIR) +(DEFPROP INTPOL || GENPREFIX) +(DEFPROP INTPOL MUNFAS UNFASL-DIR) +(DEFPROP INTPOL MACSYM FASL-DIR) +(DEFPROP INTPOL MAXERR ERRMSG-DIR) +(DEFPROP INTPOL NIL IN-CORE) +(PUSH 'ROMBRG MACSYMA-FILE-NAMES) +(DEFPROP ROMBRG MAXSRC DIR) +(DEFPROP ROMBRG || GENPREFIX) +(DEFPROP ROMBRG MUNFAS UNFASL-DIR) +(DEFPROP ROMBRG MACSYM FASL-DIR) +(DEFPROP ROMBRG MAXERR ERRMSG-DIR) +(DEFPROP ROMBRG NIL IN-CORE) +(PUSH 'MTAGS MACSYMA-FILE-NAMES) +(DEFPROP MTAGS TRANSL DIR) +(DEFPROP MTAGS || GENPREFIX) +(DEFPROP MTAGS MUNFAS UNFASL-DIR) +(DEFPROP MTAGS MACSYM FASL-DIR) +(DEFPROP MTAGS MAXERR ERRMSG-DIR) +(DEFPROP MTAGS NIL IN-CORE) +(PUSH 'TRDEBG MACSYMA-FILE-NAMES) +(DEFPROP TRDEBG TRANSL DIR) +(DEFPROP TRDEBG || GENPREFIX) +(DEFPROP TRDEBG MUNFAS UNFASL-DIR) +(DEFPROP TRDEBG MACSYM FASL-DIR) +(DEFPROP TRDEBG MAXERR ERRMSG-DIR) +(DEFPROP TRDEBG NIL IN-CORE) +(PUSH 'LJOB MACSYMA-FILE-NAMES) +(DEFPROP LJOB TRANSL DIR) +(DEFPROP LJOB |ï| GENPREFIX) +(DEFPROP LJOB MUNFAS UNFASL-DIR) +(DEFPROP LJOB MACSYM FASL-DIR) +(DEFPROP LJOB MAXERR ERRMSG-DIR) +(DEFPROP LJOB NIL IN-CORE) +(PUSH 'MCOMPI MACSYMA-FILE-NAMES) +(DEFPROP MCOMPI TRANSL DIR) +(DEFPROP MCOMPI ~ GENPREFIX) +(DEFPROP MCOMPI MUNFAS UNFASL-DIR) +(DEFPROP MCOMPI MACSYM FASL-DIR) +(DEFPROP MCOMPI MAXERR ERRMSG-DIR) +(DEFPROP MCOMPI NIL IN-CORE) +(PUSH 'EVALW MACSYMA-FILE-NAMES) +(DEFPROP EVALW TRANSL DIR) +(DEFPROP EVALW } GENPREFIX) +(DEFPROP EVALW MUNFAS UNFASL-DIR) +(DEFPROP EVALW MACSYM FASL-DIR) +(DEFPROP EVALW MAXERR ERRMSG-DIR) +(DEFPROP EVALW NIL IN-CORE) +(PUSH 'FCALL MACSYMA-FILE-NAMES) +(DEFPROP FCALL TRANSL DIR) +(DEFPROP FCALL /| GENPREFIX) +(DEFPROP FCALL MUNFAS UNFASL-DIR) +(DEFPROP FCALL MACSYM FASL-DIR) +(DEFPROP FCALL MAXERR ERRMSG-DIR) +(DEFPROP FCALL NIL IN-CORE) +(PUSH 'ACALL MACSYMA-FILE-NAMES) +(DEFPROP ACALL TRANSL DIR) +(DEFPROP ACALL { GENPREFIX) +(DEFPROP ACALL MUNFAS UNFASL-DIR) +(DEFPROP ACALL MACSYM FASL-DIR) +(DEFPROP ACALL MAXERR ERRMSG-DIR) +(DEFPROP ACALL NIL IN-CORE) +(PUSH 'TRDATA MACSYMA-FILE-NAMES) +(DEFPROP TRDATA TRANSL DIR) +(DEFPROP TRDATA /z GENPREFIX) +(DEFPROP TRDATA MUNFAS UNFASL-DIR) +(DEFPROP TRDATA MACSYM FASL-DIR) +(DEFPROP TRDATA MAXERR ERRMSG-DIR) +(DEFPROP TRDATA NIL IN-CORE) +(PUSH 'TRMODE MACSYMA-FILE-NAMES) +(DEFPROP TRMODE TRANSL DIR) +(DEFPROP TRMODE /y GENPREFIX) +(DEFPROP TRMODE MUNFAS UNFASL-DIR) +(DEFPROP TRMODE MACSYM FASL-DIR) +(DEFPROP TRMODE MAXERR ERRMSG-DIR) +(DEFPROP TRMODE NIL IN-CORE) +(PUSH 'TRPROP MACSYMA-FILE-NAMES) +(DEFPROP TRPROP TRANSL DIR) +(DEFPROP TRPROP /x GENPREFIX) +(DEFPROP TRPROP MUNFAS UNFASL-DIR) +(DEFPROP TRPROP MACSYM FASL-DIR) +(DEFPROP TRPROP MAXERR ERRMSG-DIR) +(DEFPROP TRPROP NIL IN-CORE) +(PUSH 'TRPRED MACSYMA-FILE-NAMES) +(DEFPROP TRPRED TRANSL DIR) +(DEFPROP TRPRED /w GENPREFIX) +(DEFPROP TRPRED MUNFAS UNFASL-DIR) +(DEFPROP TRPRED MACSYM FASL-DIR) +(DEFPROP TRPRED MAXERR ERRMSG-DIR) +(DEFPROP TRPRED NIL IN-CORE) +(PUSH 'TROPER MACSYMA-FILE-NAMES) +(DEFPROP TROPER TRANSL DIR) +(DEFPROP TROPER /v GENPREFIX) +(DEFPROP TROPER MUNFAS UNFASL-DIR) +(DEFPROP TROPER MACSYM FASL-DIR) +(DEFPROP TROPER MAXERR ERRMSG-DIR) +(DEFPROP TROPER NIL IN-CORE) +(PUSH 'TRANSF MACSYMA-FILE-NAMES) +(DEFPROP TRANSF TRANSL DIR) +(DEFPROP TRANSF /u GENPREFIX) +(DEFPROP TRANSF MUNFAS UNFASL-DIR) +(DEFPROP TRANSF MACSYM FASL-DIR) +(DEFPROP TRANSF MAXERR ERRMSG-DIR) +(DEFPROP TRANSF NIL IN-CORE) +(PUSH 'TRANS5 MACSYMA-FILE-NAMES) +(DEFPROP TRANS5 TRANSL DIR) +(DEFPROP TRANS5 /t GENPREFIX) +(DEFPROP TRANS5 MUNFAS UNFASL-DIR) +(DEFPROP TRANS5 MACSYM FASL-DIR) +(DEFPROP TRANS5 MAXERR ERRMSG-DIR) +(DEFPROP TRANS5 NIL IN-CORE) +(PUSH 'TRANS4 MACSYMA-FILE-NAMES) +(DEFPROP TRANS4 TRANSL DIR) +(DEFPROP TRANS4 /s GENPREFIX) +(DEFPROP TRANS4 MUNFAS UNFASL-DIR) +(DEFPROP TRANS4 MACSYM FASL-DIR) +(DEFPROP TRANS4 MAXERR ERRMSG-DIR) +(DEFPROP TRANS4 NIL IN-CORE) +(PUSH 'TRANS3 MACSYMA-FILE-NAMES) +(DEFPROP TRANS3 TRANSL DIR) +(DEFPROP TRANS3 /r GENPREFIX) +(DEFPROP TRANS3 MUNFAS UNFASL-DIR) +(DEFPROP TRANS3 MACSYM FASL-DIR) +(DEFPROP TRANS3 MAXERR ERRMSG-DIR) +(DEFPROP TRANS3 NIL IN-CORE) +(PUSH 'TRANS2 MACSYMA-FILE-NAMES) +(DEFPROP TRANS2 TRANSL DIR) +(DEFPROP TRANS2 /q GENPREFIX) +(DEFPROP TRANS2 MUNFAS UNFASL-DIR) +(DEFPROP TRANS2 MACSYM FASL-DIR) +(DEFPROP TRANS2 MAXERR ERRMSG-DIR) +(DEFPROP TRANS2 NIL IN-CORE) +(PUSH 'TRANS1 MACSYMA-FILE-NAMES) +(DEFPROP TRANS1 TRANSL DIR) +(DEFPROP TRANS1 /p GENPREFIX) +(DEFPROP TRANS1 MUNFAS UNFASL-DIR) +(DEFPROP TRANS1 MACSYM FASL-DIR) +(DEFPROP TRANS1 MAXERR ERRMSG-DIR) +(DEFPROP TRANS1 NIL IN-CORE) +(PUSH 'TRANSL MACSYMA-FILE-NAMES) +(DEFPROP TRANSL TRANSL DIR) +(DEFPROP TRANSL /o GENPREFIX) +(DEFPROP TRANSL MUNFAS UNFASL-DIR) +(DEFPROP TRANSL MACSYM FASL-DIR) +(DEFPROP TRANSL MAXERR ERRMSG-DIR) +(DEFPROP TRANSL NIL IN-CORE) +(PUSH 'TRANSS MACSYMA-FILE-NAMES) +(DEFPROP TRANSS TRANSL DIR) +(DEFPROP TRANSS /n GENPREFIX) +(DEFPROP TRANSS MUNFAS UNFASL-DIR) +(DEFPROP TRANSS MACSYM FASL-DIR) +(DEFPROP TRANSS MAXERR ERRMSG-DIR) +(DEFPROP TRANSS NIL IN-CORE) +(PUSH 'TRUTIL MACSYMA-FILE-NAMES) +(DEFPROP TRUTIL TRANSL DIR) +(DEFPROP TRUTIL /m GENPREFIX) +(DEFPROP TRUTIL MUNFAS UNFASL-DIR) +(DEFPROP TRUTIL MACSYM FASL-DIR) +(DEFPROP TRUTIL MAXERR ERRMSG-DIR) +(DEFPROP TRUTIL NIL IN-CORE) +(PUSH 'TRHOOK MACSYMA-FILE-NAMES) +(DEFPROP TRHOOK TRANSL DIR) +(DEFPROP TRHOOK /l GENPREFIX) +(DEFPROP TRHOOK MUNFAS UNFASL-DIR) +(DEFPROP TRHOOK MACSYM FASL-DIR) +(DEFPROP TRHOOK MAXERR ERRMSG-DIR) +(DEFPROP TRHOOK NIL IN-CORE) +(PUSH 'TRDUMP MACSYMA-FILE-NAMES) +(DEFPROP TRDUMP TRANSL DIR) +(DEFPROP TRDUMP /k GENPREFIX) +(DEFPROP TRDUMP MUNFAS UNFASL-DIR) +(DEFPROP TRDUMP MAXDMP FASL-DIR) +(DEFPROP TRDUMP MAXERR ERRMSG-DIR) +(DEFPROP TRDUMP NIL IN-CORE) +(PUSH 'DOVER MACSYMA-FILE-NAMES) +(DEFPROP DOVER MAXSRC DIR) +(DEFPROP DOVER /j GENPREFIX) +(DEFPROP DOVER MUNFAS UNFASL-DIR) +(DEFPROP DOVER MACSYM FASL-DIR) +(DEFPROP DOVER MAXERR ERRMSG-DIR) +(DEFPROP DOVER NIL IN-CORE) +(PUSH 'CHAR MACSYMA-FILE-NAMES) +(DEFPROP CHAR MAXSRC DIR) +(DEFPROP CHAR /i GENPREFIX) +(DEFPROP CHAR MUNFAS UNFASL-DIR) +(DEFPROP CHAR MACSYM FASL-DIR) +(DEFPROP CHAR MAXERR ERRMSG-DIR) +(DEFPROP CHAR NIL IN-CORE) +(PUSH 'MTREE MACSYMA-FILE-NAMES) +(DEFPROP MTREE MAXSRC DIR) +(DEFPROP MTREE /h GENPREFIX) +(DEFPROP MTREE MUNFAS UNFASL-DIR) +(DEFPROP MTREE MACSYM FASL-DIR) +(DEFPROP MTREE MAXERR ERRMSG-DIR) +(DEFPROP MTREE NIL IN-CORE) +(PUSH 'AR MACSYMA-FILE-NAMES) +(DEFPROP AR MAXSRC DIR) +(DEFPROP AR /g GENPREFIX) +(DEFPROP AR MUNFAS UNFASL-DIR) +(DEFPROP AR MACSYM FASL-DIR) +(DEFPROP AR MAXERR ERRMSG-DIR) +(DEFPROP AR NIL IN-CORE) +(PUSH 'SETS MACSYMA-FILE-NAMES) +(DEFPROP SETS MAXSRC DIR) +(DEFPROP SETS /f GENPREFIX) +(DEFPROP SETS MAXOUT UNFASL-DIR) +(DEFPROP SETS SHARE FASL-DIR) +(DEFPROP SETS MAXERR ERRMSG-DIR) +(DEFPROP SETS NIL IN-CORE) +(PUSH 'SUBLIS MACSYMA-FILE-NAMES) +(DEFPROP SUBLIS MAXSRC DIR) +(DEFPROP SUBLIS /e GENPREFIX) +(DEFPROP SUBLIS MUNFAS UNFASL-DIR) +(DEFPROP SUBLIS MACSYM FASL-DIR) +(DEFPROP SUBLIS MAXERR ERRMSG-DIR) +(DEFPROP SUBLIS NIL IN-CORE) +(PUSH 'OPS MACSYMA-FILE-NAMES) +(DEFPROP OPS MAXSRC DIR) +(DEFPROP OPS /d GENPREFIX) +(DEFPROP OPS MUNFAS UNFASL-DIR) +(DEFPROP OPS MACSYM FASL-DIR) +(DEFPROP OPS MAXERR ERRMSG-DIR) +(DEFPROP OPS NIL IN-CORE) +(PUSH 'OPERS MACSYMA-FILE-NAMES) +(DEFPROP OPERS MAXSRC DIR) +(DEFPROP OPERS /c GENPREFIX) +(DEFPROP OPERS MUNFAS UNFASL-DIR) +(DEFPROP OPERS MAXDMP FASL-DIR) +(DEFPROP OPERS MAXERR ERRMSG-DIR) +(DEFPROP OPERS 80. IN-CORE) +(PUSH 'SUSPEN MACSYMA-FILE-NAMES) +(DEFPROP SUSPEN MAXSRC DIR) +(DEFPROP SUSPEN /b GENPREFIX) +(DEFPROP SUSPEN MUNFAS UNFASL-DIR) +(DEFPROP SUSPEN MACSYM FASL-DIR) +(DEFPROP SUSPEN MAXERR ERRMSG-DIR) +(DEFPROP SUSPEN NIL IN-CORE) +(PUSH 'H19 MACSYMA-FILE-NAMES) +(DEFPROP H19 MAXSRC DIR) +(DEFPROP H19 /a GENPREFIX) +(DEFPROP H19 MUNFAS UNFASL-DIR) +(DEFPROP H19 MACSYM FASL-DIR) +(DEFPROP H19 MAXERR ERRMSG-DIR) +(DEFPROP H19 NIL IN-CORE) +(PUSH 'VT100 MACSYMA-FILE-NAMES) +(DEFPROP VT100 MAXSRC DIR) +(DEFPROP VT100 /` GENPREFIX) +(DEFPROP VT100 MUNFAS UNFASL-DIR) +(DEFPROP VT100 MACSYM FASL-DIR) +(DEFPROP VT100 MAXERR ERRMSG-DIR) +(DEFPROP VT100 NIL IN-CORE) +(PUSH 'ARDS MACSYMA-FILE-NAMES) +(DEFPROP ARDS MAXSRC DIR) +(DEFPROP ARDS _ GENPREFIX) +(DEFPROP ARDS MUNFAS UNFASL-DIR) +(DEFPROP ARDS MACSYM FASL-DIR) +(DEFPROP ARDS MAXERR ERRMSG-DIR) +(DEFPROP ARDS NIL IN-CORE) +(PUSH 'MTRACE MACSYMA-FILE-NAMES) +(DEFPROP MTRACE MAXSRC DIR) +(DEFPROP MTRACE ^ GENPREFIX) +(DEFPROP MTRACE MUNFAS UNFASL-DIR) +(DEFPROP MTRACE MACSYM FASL-DIR) +(DEFPROP MTRACE MAXERR ERRMSG-DIR) +(DEFPROP MTRACE NIL IN-CORE) +(PUSH 'OUTMIS MACSYMA-FILE-NAMES) +(DEFPROP OUTMIS MAXSRC DIR) +(DEFPROP OUTMIS ] GENPREFIX) +(DEFPROP OUTMIS MAXOUT UNFASL-DIR) +(DEFPROP OUTMIS MAXOUT FASL-DIR) +(DEFPROP OUTMIS MAXERR ERRMSG-DIR) +(DEFPROP OUTMIS NIL IN-CORE) +(PUSH 'PSOLVE MACSYMA-FILE-NAMES) +(DEFPROP PSOLVE RAT DIR) +(DEFPROP PSOLVE \ GENPREFIX) +(DEFPROP PSOLVE MAXOUT UNFASL-DIR) +(DEFPROP PSOLVE MAXOUT FASL-DIR) +(DEFPROP PSOLVE MAXERR ERRMSG-DIR) +(DEFPROP PSOLVE NIL IN-CORE) +(PUSH 'LAPLAC MACSYMA-FILE-NAMES) +(DEFPROP LAPLAC MAXSRC DIR) +(DEFPROP LAPLAC [ GENPREFIX) +(DEFPROP LAPLAC MUNFAS UNFASL-DIR) +(DEFPROP LAPLAC MACSYM FASL-DIR) +(DEFPROP LAPLAC MAXERR ERRMSG-DIR) +(DEFPROP LAPLAC NIL IN-CORE) +(PUSH 'INMIS MACSYMA-FILE-NAMES) +(DEFPROP INMIS MAXSRC DIR) +(DEFPROP INMIS Z GENPREFIX) +(DEFPROP INMIS MUNFAS UNFASL-DIR) +(DEFPROP INMIS MAXDMP FASL-DIR) +(DEFPROP INMIS MAXERR ERRMSG-DIR) +(DEFPROP INMIS 180. IN-CORE) +(PUSH 'ZERO MACSYMA-FILE-NAMES) +(DEFPROP ZERO JM DIR) +(DEFPROP ZERO Y GENPREFIX) +(DEFPROP ZERO MUNFAS UNFASL-DIR) +(DEFPROP ZERO MACSYM FASL-DIR) +(DEFPROP ZERO MAXERR ERRMSG-DIR) +(DEFPROP ZERO NIL IN-CORE) +(PUSH 'RISCH MACSYMA-FILE-NAMES) +(DEFPROP RISCH JM DIR) +(DEFPROP RISCH X GENPREFIX) +(DEFPROP RISCH MUNFAS UNFASL-DIR) +(DEFPROP RISCH MACSYM FASL-DIR) +(DEFPROP RISCH MAXERR ERRMSG-DIR) +(DEFPROP RISCH NIL IN-CORE) +(PUSH 'SIN MACSYMA-FILE-NAMES) +(DEFPROP SIN JM DIR) +(DEFPROP SIN W GENPREFIX) +(DEFPROP SIN MUNFAS UNFASL-DIR) +(DEFPROP SIN MACSYM FASL-DIR) +(DEFPROP SIN MAXERR ERRMSG-DIR) +(DEFPROP SIN NIL IN-CORE) +(PUSH 'SININT MACSYMA-FILE-NAMES) +(DEFPROP SININT JM DIR) +(DEFPROP SININT V GENPREFIX) +(DEFPROP SININT MUNFAS UNFASL-DIR) +(DEFPROP SININT MACSYM FASL-DIR) +(DEFPROP SININT MAXERR ERRMSG-DIR) +(DEFPROP SININT NIL IN-CORE) +(PUSH 'SIMP MACSYMA-FILE-NAMES) +(DEFPROP SIMP JM DIR) +(DEFPROP SIMP U GENPREFIX) +(DEFPROP SIMP MUNFAS UNFASL-DIR) +(DEFPROP SIMP MAXDMP FASL-DIR) +(DEFPROP SIMP MAXERR ERRMSG-DIR) +(DEFPROP SIMP 70. IN-CORE) +(PUSH 'RATOUT MACSYMA-FILE-NAMES) +(DEFPROP RATOUT RAT DIR) +(DEFPROP RATOUT T GENPREFIX) +(DEFPROP RATOUT MAXOUT UNFASL-DIR) +(DEFPROP RATOUT MAXOUT FASL-DIR) +(DEFPROP RATOUT MAXERR ERRMSG-DIR) +(DEFPROP RATOUT NIL IN-CORE) +(PUSH 'NISIMP MACSYMA-FILE-NAMES) +(DEFPROP NISIMP RAT DIR) +(DEFPROP NISIMP S GENPREFIX) +(DEFPROP NISIMP MUNFAS UNFASL-DIR) +(DEFPROP NISIMP MACSYM FASL-DIR) +(DEFPROP NISIMP MAXERR ERRMSG-DIR) +(DEFPROP NISIMP NIL IN-CORE) +(PUSH 'NEWDET MACSYMA-FILE-NAMES) +(DEFPROP NEWDET RAT DIR) +(DEFPROP NEWDET R GENPREFIX) +(DEFPROP NEWDET MUNFAS UNFASL-DIR) +(DEFPROP NEWDET MACSYM FASL-DIR) +(DEFPROP NEWDET MAXERR ERRMSG-DIR) +(DEFPROP NEWDET NIL IN-CORE) +(PUSH 'NALGFA MACSYMA-FILE-NAMES) +(DEFPROP NALGFA RAT DIR) +(DEFPROP NALGFA Q GENPREFIX) +(DEFPROP NALGFA MUNFAS UNFASL-DIR) +(DEFPROP NALGFA MACSYM FASL-DIR) +(DEFPROP NALGFA MAXERR ERRMSG-DIR) +(DEFPROP NALGFA NIL IN-CORE) +(PUSH 'POLYRZ MACSYMA-FILE-NAMES) +(DEFPROP POLYRZ RAT DIR) +(DEFPROP POLYRZ P GENPREFIX) +(DEFPROP POLYRZ MUNFAS UNFASL-DIR) +(DEFPROP POLYRZ MACSYM FASL-DIR) +(DEFPROP POLYRZ MAXERR ERRMSG-DIR) +(DEFPROP POLYRZ NIL IN-CORE) +(PUSH 'HAYAT MACSYMA-FILE-NAMES) +(DEFPROP HAYAT RAT DIR) +(DEFPROP HAYAT O GENPREFIX) +(DEFPROP HAYAT MUNFAS UNFASL-DIR) +(DEFPROP HAYAT MACSYM FASL-DIR) +(DEFPROP HAYAT MAXERR ERRMSG-DIR) +(DEFPROP HAYAT NIL IN-CORE) +(PUSH 'UFACT MACSYMA-FILE-NAMES) +(DEFPROP UFACT RAT DIR) +(DEFPROP UFACT N GENPREFIX) +(DEFPROP UFACT MUNFAS UNFASL-DIR) +(DEFPROP UFACT MACSYM FASL-DIR) +(DEFPROP UFACT MAXERR ERRMSG-DIR) +(DEFPROP UFACT NIL IN-CORE) +(PUSH 'RESULT MACSYMA-FILE-NAMES) +(DEFPROP RESULT RAT DIR) +(DEFPROP RESULT M GENPREFIX) +(DEFPROP RESULT MAXOUT UNFASL-DIR) +(DEFPROP RESULT MAXOUT FASL-DIR) +(DEFPROP RESULT MAXERR ERRMSG-DIR) +(DEFPROP RESULT NIL IN-CORE) +(PUSH 'FLOAT MACSYMA-FILE-NAMES) +(DEFPROP FLOAT RAT DIR) +(DEFPROP FLOAT L GENPREFIX) +(DEFPROP FLOAT MUNFAS UNFASL-DIR) +(DEFPROP FLOAT MACSYM FASL-DIR) +(DEFPROP FLOAT MAXERR ERRMSG-DIR) +(DEFPROP FLOAT NIL IN-CORE) +(PUSH 'RATPOI MACSYMA-FILE-NAMES) +(DEFPROP RATPOI RAT DIR) +(DEFPROP RATPOI K GENPREFIX) +(DEFPROP RATPOI MUNFAS UNFASL-DIR) +(DEFPROP RATPOI MACSYM FASL-DIR) +(DEFPROP RATPOI MAXERR ERRMSG-DIR) +(DEFPROP RATPOI NIL IN-CORE) +(PUSH 'POIS3 MACSYMA-FILE-NAMES) +(DEFPROP POIS3 RAT DIR) +(DEFPROP POIS3 J GENPREFIX) +(DEFPROP POIS3 MUNFAS UNFASL-DIR) +(DEFPROP POIS3 MACSYM FASL-DIR) +(DEFPROP POIS3 MAXERR ERRMSG-DIR) +(DEFPROP POIS3 NIL IN-CORE) +(PUSH 'POIS2 MACSYMA-FILE-NAMES) +(DEFPROP POIS2 RAT DIR) +(DEFPROP POIS2 I GENPREFIX) +(DEFPROP POIS2 MUNFAS UNFASL-DIR) +(DEFPROP POIS2 MACSYM FASL-DIR) +(DEFPROP POIS2 MAXERR ERRMSG-DIR) +(DEFPROP POIS2 NIL IN-CORE) +(PUSH 'MATCOM MACSYMA-FILE-NAMES) +(DEFPROP MATCOM RAT DIR) +(DEFPROP MATCOM H GENPREFIX) +(DEFPROP MATCOM MUNFAS UNFASL-DIR) +(DEFPROP MATCOM MACSYM FASL-DIR) +(DEFPROP MATCOM MAXERR ERRMSG-DIR) +(DEFPROP MATCOM NIL IN-CORE) +(PUSH 'MATRUN MACSYMA-FILE-NAMES) +(DEFPROP MATRUN RAT DIR) +(DEFPROP MATRUN G GENPREFIX) +(DEFPROP MATRUN MUNFAS UNFASL-DIR) +(DEFPROP MATRUN MACSYM FASL-DIR) +(DEFPROP MATRUN MAXERR ERRMSG-DIR) +(DEFPROP MATRUN NIL IN-CORE) +(PUSH 'PADE MACSYMA-FILE-NAMES) +(DEFPROP PADE RAT DIR) +(DEFPROP PADE F GENPREFIX) +(DEFPROP PADE MUNFAS UNFASL-DIR) +(DEFPROP PADE MACSYM FASL-DIR) +(DEFPROP PADE MAXERR ERRMSG-DIR) +(DEFPROP PADE NIL IN-CORE) +(PUSH 'HOMOG MACSYMA-FILE-NAMES) +(DEFPROP HOMOG RAT DIR) +(DEFPROP HOMOG E GENPREFIX) +(DEFPROP HOMOG MUNFAS UNFASL-DIR) +(DEFPROP HOMOG MACSYM FASL-DIR) +(DEFPROP HOMOG MAXERR ERRMSG-DIR) +(DEFPROP HOMOG NIL IN-CORE) +(PUSH 'SOLVE MACSYMA-FILE-NAMES) +(DEFPROP SOLVE RAT DIR) +(DEFPROP SOLVE D GENPREFIX) +(DEFPROP SOLVE MUNFAS UNFASL-DIR) +(DEFPROP SOLVE MACSYM FASL-DIR) +(DEFPROP SOLVE MAXERR ERRMSG-DIR) +(DEFPROP SOLVE NIL IN-CORE) +(PUSH 'SPGCD MACSYMA-FILE-NAMES) +(DEFPROP SPGCD RAT DIR) +(DEFPROP SPGCD C GENPREFIX) +(DEFPROP SPGCD MUNFAS UNFASL-DIR) +(DEFPROP SPGCD MAXDMP FASL-DIR) +(DEFPROP SPGCD MAXERR ERRMSG-DIR) +(DEFPROP SPGCD 290. IN-CORE) +(PUSH 'LESFAC MACSYMA-FILE-NAMES) +(DEFPROP LESFAC RAT DIR) +(DEFPROP LESFAC B GENPREFIX) +(DEFPROP LESFAC MUNFAS UNFASL-DIR) +(DEFPROP LESFAC MAXDMP FASL-DIR) +(DEFPROP LESFAC MAXERR ERRMSG-DIR) +(DEFPROP LESFAC 160. IN-CORE) +(PUSH 'EZGCD MACSYMA-FILE-NAMES) +(DEFPROP EZGCD RAT DIR) +(DEFPROP EZGCD A GENPREFIX) +(DEFPROP EZGCD MUNFAS UNFASL-DIR) +(DEFPROP EZGCD MACSYM FASL-DIR) +(DEFPROP EZGCD MAXERR ERRMSG-DIR) +(DEFPROP EZGCD NIL IN-CORE) +(PUSH 'NRAT4 MACSYMA-FILE-NAMES) +(DEFPROP NRAT4 RAT DIR) +(DEFPROP NRAT4 @ GENPREFIX) +(DEFPROP NRAT4 MUNFAS UNFASL-DIR) +(DEFPROP NRAT4 MAXDMP FASL-DIR) +(DEFPROP NRAT4 MAXERR ERRMSG-DIR) +(DEFPROP NRAT4 210. IN-CORE) +(PUSH 'RATMAC MACSYMA-FILE-NAMES) +(DEFPROP RATMAC RAT DIR) +(DEFPROP RATMAC ? GENPREFIX) +(DEFPROP RATMAC T MACRO-FILE) +(PUSH 'RATLAP MACSYMA-FILE-NAMES) +(DEFPROP RATLAP RAT DIR) +(DEFPROP RATLAP > GENPREFIX) +(DEFPROP RATLAP MUNFAS UNFASL-DIR) +(DEFPROP RATLAP MAXDMP FASL-DIR) +(DEFPROP RATLAP MAXERR ERRMSG-DIR) +(DEFPROP RATLAP 90. IN-CORE) +(PUSH 'RAT3E MACSYMA-FILE-NAMES) +(DEFPROP RAT3E RAT DIR) +(DEFPROP RAT3E = GENPREFIX) +(DEFPROP RAT3E MUNFAS UNFASL-DIR) +(DEFPROP RAT3E MAXDMP FASL-DIR) +(DEFPROP RAT3E MAXERR ERRMSG-DIR) +(DEFPROP RAT3E 140. IN-CORE) +(PUSH 'RAT3D MACSYMA-FILE-NAMES) +(DEFPROP RAT3D RAT DIR) +(DEFPROP RAT3D < GENPREFIX) +(DEFPROP RAT3D MUNFAS UNFASL-DIR) +(DEFPROP RAT3D MAXDMP FASL-DIR) +(DEFPROP RAT3D MAXERR ERRMSG-DIR) +(DEFPROP RAT3D 130. IN-CORE) +(PUSH 'RAT3C MACSYMA-FILE-NAMES) +(DEFPROP RAT3C RAT DIR) +(DEFPROP RAT3C /; GENPREFIX) +(DEFPROP RAT3C MUNFAS UNFASL-DIR) +(DEFPROP RAT3C MAXDMP FASL-DIR) +(DEFPROP RAT3C MAXERR ERRMSG-DIR) +(DEFPROP RAT3C 150. IN-CORE) +(PUSH 'RAT3B MACSYMA-FILE-NAMES) +(DEFPROP RAT3B RAT DIR) +(DEFPROP RAT3B : GENPREFIX) +(DEFPROP RAT3B MUNFAS UNFASL-DIR) +(DEFPROP RAT3B MAXDMP FASL-DIR) +(DEFPROP RAT3B MAXERR ERRMSG-DIR) +(DEFPROP RAT3B 120. IN-CORE) +(PUSH 'RAT3A MACSYMA-FILE-NAMES) +(DEFPROP RAT3A RAT DIR) +(DEFPROP RAT3A 9 GENPREFIX) +(DEFPROP RAT3A MUNFAS UNFASL-DIR) +(DEFPROP RAT3A MAXDMP FASL-DIR) +(DEFPROP RAT3A MAXERR ERRMSG-DIR) +(DEFPROP RAT3A 110. IN-CORE) +(PUSH 'MHAYAT MACSYMA-FILE-NAMES) +(DEFPROP MHAYAT RAT DIR) +(DEFPROP MHAYAT 8 GENPREFIX) +(DEFPROP MHAYAT T MACRO-FILE) +(PUSH 'FACTOR MACSYMA-FILE-NAMES) +(DEFPROP FACTOR RAT DIR) +(DEFPROP FACTOR 7 GENPREFIX) +(DEFPROP FACTOR MUNFAS UNFASL-DIR) +(DEFPROP FACTOR MAXDMP FASL-DIR) +(DEFPROP FACTOR MAXERR ERRMSG-DIR) +(DEFPROP FACTOR 100. IN-CORE) +(PUSH 'ALGSYS MACSYMA-FILE-NAMES) +(DEFPROP ALGSYS RAT DIR) +(DEFPROP ALGSYS 6 GENPREFIX) +(DEFPROP ALGSYS MUNFAS UNFASL-DIR) +(DEFPROP ALGSYS MACSYM FASL-DIR) +(DEFPROP ALGSYS MAXERR ERRMSG-DIR) +(DEFPROP ALGSYS NIL IN-CORE) +(PUSH 'MATRIX MACSYMA-FILE-NAMES) +(DEFPROP MATRIX PAULW DIR) +(DEFPROP MATRIX 5 GENPREFIX) +(DEFPROP MATRIX MUNFAS UNFASL-DIR) +(DEFPROP MATRIX MAXDMP FASL-DIR) +(DEFPROP MATRIX MAXERR ERRMSG-DIR) +(DEFPROP MATRIX 220. IN-CORE) +(PUSH 'MAT MACSYMA-FILE-NAMES) +(DEFPROP MAT PAULW DIR) +(DEFPROP MAT 4 GENPREFIX) +(DEFPROP MAT MUNFAS UNFASL-DIR) +(DEFPROP MAT MAXDMP FASL-DIR) +(DEFPROP MAT MAXERR ERRMSG-DIR) +(DEFPROP MAT 230. IN-CORE) +(PUSH 'CSIMP MACSYMA-FILE-NAMES) +(DEFPROP CSIMP PAULW DIR) +(DEFPROP CSIMP 3 GENPREFIX) +(DEFPROP CSIMP MUNFAS UNFASL-DIR) +(DEFPROP CSIMP MAXDMP FASL-DIR) +(DEFPROP CSIMP MAXERR ERRMSG-DIR) +(DEFPROP CSIMP 240. IN-CORE) +(PUSH 'TRIGO MACSYMA-FILE-NAMES) +(DEFPROP TRIGO MRG DIR) +(DEFPROP TRIGO 2 GENPREFIX) +(DEFPROP TRIGO MAXOUT UNFASL-DIR) +(DEFPROP TRIGO MAXOUT FASL-DIR) +(DEFPROP TRIGO MAXERR ERRMSG-DIR) +(DEFPROP TRIGO NIL IN-CORE) +(PUSH 'TRIGI MACSYMA-FILE-NAMES) +(DEFPROP TRIGI MRG DIR) +(DEFPROP TRIGI 1 GENPREFIX) +(DEFPROP TRIGI MUNFAS UNFASL-DIR) +(DEFPROP TRIGI MAXDMP FASL-DIR) +(DEFPROP TRIGI MAXERR ERRMSG-DIR) +(DEFPROP TRIGI 260. IN-CORE) +(PUSH 'SCS MACSYMA-FILE-NAMES) +(DEFPROP SCS MRG DIR) +(DEFPROP SCS 0 GENPREFIX) +(DEFPROP SCS MUNFAS UNFASL-DIR) +(DEFPROP SCS MACSYM FASL-DIR) +(DEFPROP SCS MAXERR ERRMSG-DIR) +(DEFPROP SCS NIL IN-CORE) +(PUSH 'OPTIM MACSYMA-FILE-NAMES) +(DEFPROP OPTIM MRG DIR) +(DEFPROP OPTIM // GENPREFIX) +(DEFPROP OPTIM MUNFAS UNFASL-DIR) +(DEFPROP OPTIM MACSYM FASL-DIR) +(DEFPROP OPTIM MAXERR ERRMSG-DIR) +(DEFPROP OPTIM NIL IN-CORE) +(PUSH 'NFORMA MACSYMA-FILE-NAMES) +(DEFPROP NFORMA MRG DIR) +(DEFPROP NFORMA |.| GENPREFIX) +(DEFPROP NFORMA MUNFAS UNFASL-DIR) +(DEFPROP NFORMA MAXDMP FASL-DIR) +(DEFPROP NFORMA MAXERR ERRMSG-DIR) +(DEFPROP NFORMA 30. IN-CORE) +(PUSH 'COMPAR MACSYMA-FILE-NAMES) +(DEFPROP COMPAR MRG DIR) +(DEFPROP COMPAR - GENPREFIX) +(DEFPROP COMPAR MUNFAS UNFASL-DIR) +(DEFPROP COMPAR MAXDMP FASL-DIR) +(DEFPROP COMPAR MAXERR ERRMSG-DIR) +(DEFPROP COMPAR 200. IN-CORE) +(PUSH 'GRIND MACSYMA-FILE-NAMES) +(DEFPROP GRIND MRG DIR) +(DEFPROP GRIND /, GENPREFIX) +(DEFPROP GRIND MUNFAS UNFASL-DIR) +(DEFPROP GRIND MAXDMP FASL-DIR) +(DEFPROP GRIND MAXERR ERRMSG-DIR) +(DEFPROP GRIND 320. IN-CORE) +(PUSH 'GRAM MACSYMA-FILE-NAMES) +(DEFPROP GRAM MRG DIR) +(DEFPROP GRAM + GENPREFIX) +(DEFPROP GRAM MUNFAS UNFASL-DIR) +(DEFPROP GRAM MAXDMP FASL-DIR) +(DEFPROP GRAM MAXERR ERRMSG-DIR) +(DEFPROP GRAM 10. IN-CORE) +(PUSH 'FORTRA MACSYMA-FILE-NAMES) +(DEFPROP FORTRA MRG DIR) +(DEFPROP FORTRA * GENPREFIX) +(DEFPROP FORTRA MUNFAS UNFASL-DIR) +(DEFPROP FORTRA MACSYM FASL-DIR) +(DEFPROP FORTRA MAXERR ERRMSG-DIR) +(DEFPROP FORTRA NIL IN-CORE) +(PUSH 'DISPLA MACSYMA-FILE-NAMES) +(DEFPROP DISPLA MRG DIR) +(DEFPROP DISPLA |)| GENPREFIX) +(DEFPROP DISPLA MUNFAS UNFASL-DIR) +(DEFPROP DISPLA MAXDMP FASL-DIR) +(DEFPROP DISPLA MAXERR ERRMSG-DIR) +(DEFPROP DISPLA 20. IN-CORE) +(PUSH 'DB MACSYMA-FILE-NAMES) +(DEFPROP DB MRG DIR) +(DEFPROP DB |(| GENPREFIX) +(DEFPROP DB MUNFAS UNFASL-DIR) +(DEFPROP DB MAXDMP FASL-DIR) +(DEFPROP DB MAXERR ERRMSG-DIR) +(DEFPROP DB 190. IN-CORE) +(PUSH 'PLOT MACSYMA-FILE-NAMES) +(DEFPROP PLOT JPG DIR) +(DEFPROP PLOT /' GENPREFIX) +(DEFPROP PLOT MAXOUT UNFASL-DIR) +(DEFPROP PLOT MAXOUT FASL-DIR) +(DEFPROP PLOT MAXERR ERRMSG-DIR) +(DEFPROP PLOT NIL IN-CORE) +(PUSH 'ODE2 MACSYMA-FILE-NAMES) +(DEFPROP ODE2 JPG DIR) +(DEFPROP ODE2 & GENPREFIX) +(DEFPROP ODE2 MUNFAS UNFASL-DIR) +(DEFPROP ODE2 MACSYM FASL-DIR) +(DEFPROP ODE2 MAXERR ERRMSG-DIR) +(DEFPROP ODE2 NIL IN-CORE) +(PUSH 'MEDIT MACSYMA-FILE-NAMES) +(DEFPROP MEDIT JPG DIR) +(DEFPROP MEDIT % GENPREFIX) +(DEFPROP MEDIT MUNFAS UNFASL-DIR) +(DEFPROP MEDIT MAXDMP FASL-DIR) +(DEFPROP MEDIT MAXERR ERRMSG-DIR) +(DEFPROP MEDIT 300. IN-CORE) +(PUSH 'MLISP MACSYMA-FILE-NAMES) +(DEFPROP MLISP JPG DIR) +(DEFPROP MLISP $ GENPREFIX) +(DEFPROP MLISP MUNFAS UNFASL-DIR) +(DEFPROP MLISP MAXDMP FASL-DIR) +(DEFPROP MLISP MAXERR ERRMSG-DIR) +(DEFPROP MLISP 40. IN-CORE) +(PUSH 'DSKFN MACSYMA-FILE-NAMES) +(DEFPROP DSKFN JPG DIR) +(DEFPROP DSKFN /# GENPREFIX) +(DEFPROP DSKFN MUNFAS UNFASL-DIR) +(DEFPROP DSKFN MAXDMP FASL-DIR) +(DEFPROP DSKFN MAXERR ERRMSG-DIR) +(DEFPROP DSKFN 310. IN-CORE) +(PUSH 'COMM2 MACSYMA-FILE-NAMES) +(DEFPROP COMM2 JPG DIR) +(DEFPROP COMM2 /" GENPREFIX) +(DEFPROP COMM2 MAXOUT UNFASL-DIR) +(DEFPROP COMM2 MAXOUT FASL-DIR) +(DEFPROP COMM2 MAXERR ERRMSG-DIR) +(DEFPROP COMM2 NIL IN-CORE) +(PUSH 'COMM MACSYMA-FILE-NAMES) +(DEFPROP COMM JPG DIR) +(DEFPROP COMM ! GENPREFIX) +(DEFPROP COMM MUNFAS UNFASL-DIR) +(DEFPROP COMM MAXDMP FASL-DIR) +(DEFPROP COMM MAXERR ERRMSG-DIR) +(DEFPROP COMM 50. IN-CORE) +(PUSH 'SUPRV MACSYMA-FILE-NAMES) +(DEFPROP SUPRV JPG DIR) +(DEFPROP SUPRV | | GENPREFIX) +(DEFPROP SUPRV MUNFAS UNFASL-DIR) +(DEFPROP SUPRV MAXDMP FASL-DIR) +(DEFPROP SUPRV MAXERR ERRMSG-DIR) +(DEFPROP SUPRV 60. IN-CORE) +(PUSH 'COMBIN MACSYMA-FILE-NAMES) +(DEFPROP COMBIN RZ DIR) +(DEFPROP COMBIN / GENPREFIX) +(DEFPROP COMBIN MAXOUT UNFASL-DIR) +(DEFPROP COMBIN MAXOUT FASL-DIR) +(DEFPROP COMBIN MAXERR ERRMSG-DIR) +(DEFPROP COMBIN NIL IN-CORE) +(PUSH 'TRGRED MACSYMA-FILE-NAMES) +(DEFPROP TRGRED RZ DIR) +(DEFPROP TRGRED / GENPREFIX) +(DEFPROP TRGRED MUNFAS UNFASL-DIR) +(DEFPROP TRGRED MACSYM FASL-DIR) +(DEFPROP TRGRED MAXERR ERRMSG-DIR) +(DEFPROP TRGRED NIL IN-CORE) +(PUSH 'SCHATC MACSYMA-FILE-NAMES) +(DEFPROP SCHATC RZ DIR) +(DEFPROP SCHATC / GENPREFIX) +(DEFPROP SCHATC MUNFAS UNFASL-DIR) +(DEFPROP SCHATC MACSYM FASL-DIR) +(DEFPROP SCHATC MAXERR ERRMSG-DIR) +(DEFPROP SCHATC NIL IN-CORE) +(PUSH 'NUMTH MACSYMA-FILE-NAMES) +(DEFPROP NUMTH RZ DIR) +(DEFPROP NUMTH / GENPREFIX) +(DEFPROP NUMTH MUNFAS UNFASL-DIR) +(DEFPROP NUMTH MACSYM FASL-DIR) +(DEFPROP NUMTH MAXERR ERRMSG-DIR) +(DEFPROP NUMTH NIL IN-CORE) +(PUSH 'SERIES MACSYMA-FILE-NAMES) +(DEFPROP SERIES RZ DIR) +(DEFPROP SERIES  GENPREFIX) +(DEFPROP SERIES MUNFAS UNFASL-DIR) +(DEFPROP SERIES MACSYM FASL-DIR) +(DEFPROP SERIES MAXERR ERRMSG-DIR) +(DEFPROP SERIES NIL IN-CORE) +(PUSH 'ASUM MACSYMA-FILE-NAMES) +(DEFPROP ASUM RZ DIR) +(DEFPROP ASUM / GENPREFIX) +(DEFPROP ASUM MUNFAS UNFASL-DIR) +(DEFPROP ASUM MAXDMP FASL-DIR) +(DEFPROP ASUM MAXERR ERRMSG-DIR) +(DEFPROP ASUM 270. IN-CORE) +(PUSH 'MACROS MACSYMA-FILE-NAMES) +(DEFPROP MACROS RZ DIR) +(DEFPROP MACROS / GENPREFIX) +(DEFPROP MACROS T MACRO-FILE) +(PUSH 'CPOLY MACSYMA-FILE-NAMES) +(DEFPROP CPOLY CFFK DIR) +(DEFPROP CPOLY / GENPREFIX) +(DEFPROP CPOLY MUNFAS UNFASL-DIR) +(DEFPROP CPOLY MACSYM FASL-DIR) +(DEFPROP CPOLY MAXERR ERRMSG-DIR) +(DEFPROP CPOLY NIL IN-CORE) +(PUSH 'PLOT3D MACSYMA-FILE-NAMES) +(DEFPROP PLOT3D SHARE DIR) +(DEFPROP PLOT3D / GENPREFIX) +(DEFPROP PLOT3D MUNFAS UNFASL-DIR) +(DEFPROP PLOT3D SHARE FASL-DIR) +(DEFPROP PLOT3D MAXERR ERRMSG-DIR) +(DEFPROP PLOT3D NIL IN-CORE) +(PUSH 'PRINT MACSYMA-FILE-NAMES) +(DEFPROP PRINT SHARE DIR) +(DEFPROP PRINT / GENPREFIX) +(DEFPROP PRINT MUNFAS UNFASL-DIR) +(DEFPROP PRINT SHARE FASL-DIR) +(DEFPROP PRINT MAXERR ERRMSG-DIR) +(DEFPROP PRINT NIL IN-CORE) +(PUSH 'IFFUN MACSYMA-FILE-NAMES) +(DEFPROP IFFUN SHARE DIR) +(DEFPROP IFFUN / GENPREFIX) +(DEFPROP IFFUN MUNFAS UNFASL-DIR) +(DEFPROP IFFUN SHARE FASL-DIR) +(DEFPROP IFFUN MAXERR ERRMSG-DIR) +(DEFPROP IFFUN NIL IN-CORE) +(PUSH 'TEKPLT MACSYMA-FILE-NAMES) +(DEFPROP TEKPLT SHARE DIR) +(DEFPROP TEKPLT / GENPREFIX) +(DEFPROP TEKPLT MUNFAS UNFASL-DIR) +(DEFPROP TEKPLT SHARE FASL-DIR) +(DEFPROP TEKPLT MAXERR ERRMSG-DIR) +(DEFPROP TEKPLT NIL IN-CORE) +(PUSH 'APLOT2 MACSYMA-FILE-NAMES) +(DEFPROP APLOT2 SHARE DIR) +(DEFPROP APLOT2 || GENPREFIX) +(DEFPROP APLOT2 MUNFAS UNFASL-DIR) +(DEFPROP APLOT2 SHARE FASL-DIR) +(DEFPROP APLOT2 MAXERR ERRMSG-DIR) +(DEFPROP APLOT2 NIL IN-CORE) +(PUSH 'HYPGEO MACSYMA-FILE-NAMES) +(DEFPROP HYPGEO ELL DIR) +(DEFPROP HYPGEO / GENPREFIX) +(DEFPROP HYPGEO ELL UNFASL-DIR) +(DEFPROP HYPGEO ELL FASL-DIR) +(DEFPROP HYPGEO MAXERR ERRMSG-DIR) +(DEFPROP HYPGEO NIL IN-CORE) +(PUSH 'HYP MACSYMA-FILE-NAMES) +(DEFPROP HYP ELL DIR) +(DEFPROP HYP || GENPREFIX) +(DEFPROP HYP ELL UNFASL-DIR) +(DEFPROP HYP ELL FASL-DIR) +(DEFPROP HYP MAXERR ERRMSG-DIR) +(DEFPROP HYP NIL IN-CORE) +(PUSH 'EDMAC MACSYMA-FILE-NAMES) +(DEFPROP EDMAC EMAXIM DIR) +(DEFPROP EDMAC / GENPREFIX) +(DEFPROP EDMAC T MACRO-FILE) +(PUSH 'LMRUN MACSYMA-FILE-NAMES) +(DEFPROP LMRUN LIBMAX DIR) +(DEFPROP LMRUN / GENPREFIX) +(DEFPROP LMRUN T MACRO-FILE) +(PUSH 'NUMERM MACSYMA-FILE-NAMES) +(DEFPROP NUMERM LIBMAX DIR) +(DEFPROP NUMERM / GENPREFIX) +(DEFPROP NUMERM T MACRO-FILE) +(PUSH 'TPRELU MACSYMA-FILE-NAMES) +(DEFPROP TPRELU LIBMAX DIR) +(DEFPROP TPRELU |/ +| GENPREFIX) +(DEFPROP TPRELU T MACRO-FILE) +(PUSH 'MDEFUN MACSYMA-FILE-NAMES) +(DEFPROP MDEFUN LIBMAX DIR) +(DEFPROP MDEFUN / GENPREFIX) +(DEFPROP MDEFUN T MACRO-FILE) +(PUSH 'TRANSM MACSYMA-FILE-NAMES) +(DEFPROP TRANSM LIBMAX DIR) +(DEFPROP TRANSM / GENPREFIX) +(DEFPROP TRANSM T MACRO-FILE) +(PUSH 'TRANSQ MACSYMA-FILE-NAMES) +(DEFPROP TRANSQ LIBMAX DIR) +(DEFPROP TRANSQ / GENPREFIX) +(DEFPROP TRANSQ T MACRO-FILE) +(PUSH 'OPSHIN MACSYMA-FILE-NAMES) +(DEFPROP OPSHIN LIBMAX DIR) +(DEFPROP OPSHIN | | GENPREFIX) +(DEFPROP OPSHIN T MACRO-FILE) +(PUSH 'META MACSYMA-FILE-NAMES) +(DEFPROP META LIBMAX DIR) +(DEFPROP META  GENPREFIX) +(DEFPROP META T MACRO-FILE) +(PUSH 'STRMAC MACSYMA-FILE-NAMES) +(DEFPROP STRMAC LIBMAX DIR) +(DEFPROP STRMAC / GENPREFIX) +(DEFPROP STRMAC T MACRO-FILE) +(PUSH 'MRGMAC MACSYMA-FILE-NAMES) +(DEFPROP MRGMAC LIBMAX DIR) +(DEFPROP MRGMAC / GENPREFIX) +(DEFPROP MRGMAC T MACRO-FILE) +(PUSH 'MOPERS MACSYMA-FILE-NAMES) +(DEFPROP MOPERS LIBMAX DIR) +(DEFPROP MOPERS / GENPREFIX) +(DEFPROP MOPERS T MACRO-FILE) +(PUSH 'MFORMA MACSYMA-FILE-NAMES) +(DEFPROP MFORMA LIBMAX DIR) +(DEFPROP MFORMA / GENPREFIX) +(DEFPROP MFORMA T MACRO-FILE) +(PUSH 'MAXMAC MACSYMA-FILE-NAMES) +(DEFPROP MAXMAC LIBMAX DIR) +(DEFPROP MAXMAC / GENPREFIX) +(DEFPROP MAXMAC T MACRO-FILE) +(PUSH 'ERMSGC MACSYMA-FILE-NAMES) +(DEFPROP ERMSGC LIBMAX DIR) +(DEFPROP ERMSGC / GENPREFIX) +(DEFPROP ERMSGC T MACRO-FILE) +(PUSH 'DEFINE MACSYMA-FILE-NAMES) +(DEFPROP DEFINE LIBMAX DIR) +(DEFPROP DEFINE / GENPREFIX) +(DEFPROP DEFINE T MACRO-FILE) +(PUSH 'LMMAC MACSYMA-FILE-NAMES) +(DEFPROP LMMAC LIBMAX DIR) +(DEFPROP LMMAC  GENPREFIX) +(DEFPROP LMMAC T MACRO-FILE) diff --git a/src/maxdoc/tdcl.10 b/src/maxdoc/tdcl.10 new file mode 100755 index 00000000..f2bfd3d5 --- /dev/null +++ b/src/maxdoc/tdcl.10 @@ -0,0 +1,120 @@ +;;;-*-lisp-*- +;;; loaded at compile time by translated macsyma code. +#-Multics +(herald tdcl) +#+Multics +(defprop tdcl t version) + +;;; here are some important frobs which have not been taken care +;;; of by defmfun and defmvar. the macsyma switches are especially +;;; problematical, since various declare and setq's are spread throughout +;;; mlisp, suprv, and simp, and are not possible to fix via a tags query +;;; replace as i did with defun=>defmfun. +;;; -gjc 4:04pm saturday, 15 november 1980 + +(*lexpr mcall add* mul* $part map1 fmapl1 scanmap1 + $error marrayref marrayset + mfuncall) + +(*expr meval meval1 power simplify div munlocal mset mapply getopr + mbind munbind add2lnc addn muln add2* mul2* part1 mapply-tr + minimum maximum atan2 fmap1) + +(flonum (atan2 flonum flonum) + ;;($cosh flonum) no longer flonum due to mrg lossage (or some other asshole). + ;;($sinh flonum) there are no flonum entries to these functions, + ;; nice extra make-work for the transl maintainer. + ) + +;;; special variables for $ fsubr compatibility package in trans1 > + +(special maplp fmaplvl mcatch bindlist loclist errcatch lisperrprint) +(*expr errlfun1 is) + +;;; random fsubrs, for some reason defmfun is not working, so here +;;; is a list generated by a transl documentor program. + +(*fexpr + + +$alias $alloc $appendfile $apply +$apropos $array $arrayinfo $assume +$batch $batchload $batcon $catch +$clock $closefile $compfile $contourplot2 +$declare $define $define_variable $defmatch +$defrule $deftaylor $delfile $demo +$dependencies $describe $diskfree $diskuse +$dispfun $display $disprule $dumparrays +$errcatch $ev $fassave $filelength +$filelist $forget $fortran $fulldiskuse +$fullmap $fullmapl $gradef $graph +$graph2 $graph3d $grind $hardcopy +$is $kill $labels $ldisplay +$let $letsimp $listfiles $loadarrays +$loadfile $loadplots $local $macroexpand +$macroexpand1 $makeatomic $map +$maplist $matchdeclare $matrixmap $modedeclare +$mode_identity $multigraph $namefile $nameplot +$numerval $open_index_file $options $ordergreat +$orderless $outermap $paramplot $paramplot2 +$playback $plot $plot2 $plot3d +$plotmode $primer $printclock $printdiskuse +$printfile $printprops $properties $propvars +$qlistfiles $qput $rearray $remarray +$remfile $remfunction $remove $remvalue +$renamefile $replot $replot4 $resetclock +$restore $save $saveplots $scanmap +$setup_autoload $sstatus $status $store +$string $stringout $substinpart $substpart +$subvar $sum $supcontext $tellsimp +$tellsimpafter $time $tobreak $translate +$tstring $unclock $unstore +$writefile mand matcoef +mcond mdefine mdefprop mdo +mdoin mgo mlocal mnot +mor mprog mprogn mquote +msetq ) + + +;;; list of special variables, gotten by +;;; (let ((l nil)) +;;; (mapatoms #'(lambda (x) (and (boundp x) (= (getcharn x 1) #/$) (push x l)))) +;;; l) + + +(special $%edispflag $%emode $%enumer $%e_to_numlog $%iargs $%piargs $%rnum $abconvtest + $absboxchar $activecontexts $advise $algdelta $algebraic $algepsilon $algexact + $aliases $arrays $backsubst $backtrace $batchkill $batcount $berlefact $bftorat + $bftrunc $bothcases $boxchar $breakup $cauchysum $cflength $change_filedefaults + $combineflag $compgrind $context $contexts $cursor $cursordisp $debugmode $demoivre + $dependencies $derivabbrev $derivsubst $detout $device $dispflag $display2d + $disptime $domain $domxexpt $domxplus $domxtimes $dontfactor $doscmxplus $dskall + $dskgc $dskuse $dynamalloc $erfflag $error $errorfun $expon $exponentialize $expop + $exptdispflag $exptisolate $exptsubst $facexpand $factlim $factorflag $false + $features $filename $filenum $filesize $float $float2bf $fpprec $fpprintprec + $fptrunc $fullflag $functions $gammalim $gcd $genindex $gensumnum $globalsolve + $gradefs $grind $grindswitch $halfangles $inchar $infeval $inflag $infolists + $intanalysis $intfaclim $invertflag $keepfloat $labels $lasttime $leftjust + $lhospitallim $liflag $limitdomain $limsubst $linechar $linedisp $linenum + $linsolvewarn $lispdisp $listarith $listconstvars $lmxchar $loadprint $logabs + $logarc $logexpand $lognegint $lognumer $logsimp $m1pbranch $macroexpansion + $macros $maperror $mapprint $matrix_element_add $matrix_element_mult + $matrix_element_transpose $maxapplydepth $maxapplyheight $maxnegex $maxposex + $maxprime $maxtaydiff $maxtayorder $modresult $morewait $multiplicities $mx0simp + $myoptions $nalgfac $negdistrib $negsumdispflag $newfac $nointegrate $nolabels + $norepeat $noundisp $numer $off $on $opproperties $opsubst $optionset $outchar + $packagefile $pagepause $parsetime $parsewindow $partswitch $pfeformat $piece + $plotheight $plotundefined $pointbound $poislim $polyfactor $powerdisp $prederror + $prodhack $programmode $prompt $props $psexpand $radexpand $radsubstflag $ratalgdenom + $ratdenomdivide $ratepsilon $ratexpand $ratfac $ratmx $ratprint $ratsimpexpons + $ratvars $ratvarswitch $ratweights $ratwtlvl $realonly $refcheck $rmxchar + $rootsepsilon $rules $savedef $savefactors $setcheck $setcheckbreak $showtime + $signbfloat $simp $simpsum $singsolve $solvedecomposes $solveexplicit $solvefactors + $solvenullwarn $solveradcan $solvetrigwarn $solve_inconsistent_error $sparse + $special $sqrtdispflag $stardisp $storenum $strdisp $subnumsimp $subscrmap + $sumhack $sumsplitfact $taylordepth $tlimswitch $transbind $transcompile + $translate $transrun $trigexpand $trigexpandplus $trigexpandtimes $triginverses + $trigsign $true $tr_warn_fexpr $tr_warn_meval $ttyintfun $ttyintnum $uname $values + $verbose $version $weightlevels $wtlevel $zerobern $zeta%pi + ) + diff --git a/src/maxsrc/ar.17 b/src/maxsrc/ar.17 new file mode 100644 index 00000000..2929621d --- /dev/null +++ b/src/maxsrc/ar.17 @@ -0,0 +1,165 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module ar) + +(DECLARE (SPECIAL EVARRP MUNBOUND FLOUNBOUND FIXUNBOUND)) + +;;; This code needs to be checked carefully for the 3600. +(defstruct (mgenarray conc-name array) + aref + aset + type + NULL + GENERATOR + CONTENT) + +(DEFUN MARRAY-TYPE (X) + (OR (CDR (ASSQ (ARRAY-TYPE X) + '((FLONUM . $FLOAT) + (FIXNUM . $FIXNUM)))) + (MGENARRAY-TYPE X))) + +(DEFMFUN $MAKE_ARRAY (TYPE &REST DIML) + (LET ((LTYPE (ASSQ TYPE '(($FLOAT . FLONUM) ($FLONUM . FLONUM) + ($FIXNUM . FIXNUM))))) + (COND ((NOT LTYPE) + (COND ((EQ TYPE '$ANY) + (MAKE-MGENARRAY TYPE '$ANY + CONTENT (LEXPR-FUNCALL '*ARRAY NIL T DIML))) + ((EQ TYPE '$HASHED) + (LET ((KLUDGE (GENSYM))) + (OR (FIXP (CAR DIML)) + (MERROR "non-integer number of dimensions: ~M" + (CAR DIML))) + (INSURE-ARRAY-PROPS KLUDGE () (CAR DIML)) + (MAKE-MGENARRAY TYPE '$HASHED + CONTENT KLUDGE))) + ((EQ TYPE '$FUNCTIONAL) + ;; MAKE_ARRAY('FUNCTIONAL,LAMBDA(...),'ARRAY_TYPE,...) + (OR (> (LENGTH DIML) 1) + (MERROR "not enough arguments for functional array specification")) + (LET ((AR (APPLY #'$MAKE_ARRAY (CDR DIML))) + (THE-NULL)) + (CASEQ (MARRAY-TYPE AR) + (($FIXNUM) + (FILLARRAY AR (LIST (SETQ THE-NULL FIXUNBOUND)))) + (($FLOAT) + (FILLARRAY AR (LIST (SETQ THE-NULL FLOUNBOUND)))) + (($ANY) + (FILLARRAY (MGENARRAY-CONTENT AR) (LIST (SETQ THE-NULL MUNBOUND)))) + (T + ;; Nothing to do for hashed arrays. Is FUNCTIONAL here + ;; an error? + (SETQ THE-NULL 'NOTEXIST))) + (MAKE-MGENARRAY TYPE '$FUNCTIONAL + CONTENT AR + GENERATOR (CAR DIML) + NULL THE-NULL))) + ('ELSE + (MERROR "Array type of ~M is not recognized by MAKE_ARRAY" TYPE)))) + ('ELSE + (LEXPR-FUNCALL '*ARRAY NIL (CDR LTYPE) DIML))))) + +(DEFMFUN DIMENSION-ARRAY-OBJECT (FORM RESULT &AUX (MTYPE (MARRAY-TYPE FORM))) + (DIMENSION-STRING + (NCONC (EXPLODEN "{Array: ") + (CDR (EXPLODEN MTYPE)) + (EXPLODEN " ") + (EXPLODEN (MAKNUM FORM)) + (IF (MEMQ MTYPE '($FLOAT $FIXNUM $ANY)) + (NCONC (EXPLODEN "[") + (DO ((L (CDR (ARRAYDIMS (IF (MEMQ MTYPE '($FLOAT $FIXNUM)) + FORM + (MGENARRAY-CONTENT FORM)))) + (CDR L)) + (V NIL + (NCONC (NREVERSE (EXPLODEN (CAR L))) V))) + ((NULL L) (NREVERSE V)) + (IF V (PUSH #/, V))) + (EXPLODEN "]"))) + (EXPLODEN "}")) + RESULT)) + +(DEFUN MARRAY-CHECK (A) + (IF (EQ (TYPEP A) 'ARRAY) + (CASEQ (MARRAY-TYPE A) + (($FIXNUM $FLOAT) A) + (($ANY) (MGENARRAY-CONTENT A)) + (($HASHED $FUNCTIONAL) + ;; BUG: It does have a number of dimensions! Gosh. -GJC + (MERROR "Hashed array has no dimension info: ~M" A)) + (T + (MARRAY-TYPE-UNKNOWN A))) + (MERROR "Not an array: ~M" A))) + +(DEFMFUN $ARRAY_NUMBER_OF_DIMENSIONS (A) + (ARRAY-/#-DIMS (MARRAY-CHECK A))) + +(DEFMFUN $ARRAY_DIMENSION_N (N A) + (ARRAY-DIMENSION-N N (MARRAY-CHECK A))) + +(DEFUN MARRAY-TYPE-UNKNOWN (X) + (MERROR "BUG: Array of unhandled type: ~S" X)) + +(DEFUN MARRAYREF-GENSUB (ARRAY IND1 INDS) + (CASEQ (MARRAY-TYPE ARRAY) + ;; We are using a CASEQ on the TYPE instead of a FUNCALL, (or SUBRCALL) + ;; because we are losers. All this stuff uses too many functions from + ;; the "MLISP" modual, which are not really suitable for the kind of + ;; speed and simplicity we want anyway. Ah me. Also, passing the single + ;; unconsed index IND1 around is a dubious optimization, which causes + ;; extra consing in the case of hashed arrays. + (($HASHED) + (LEXPR-FUNCALL #'MARRAYREF (MGENARRAY-CONTENT ARRAY) IND1 INDS)) + (($FLOAT $FIXNUM) + (LEXPR-FUNCALL ARRAY IND1 INDS)) + (($ANY) + (LEXPR-FUNCALL (MGENARRAY-CONTENT ARRAY) IND1 INDS)) + (($FUNCTIONAL) + (LET ((VALUE (LET ((EVARRP T)) + ;; special variable changes behavior of hashed-array + ;; referencing functions in case of not finding an element. + (*CATCH 'EVARRP (MARRAYREF-GENSUB + (MGENARRAY-CONTENT ARRAY) IND1 INDS))))) + (IF (EQUAL VALUE (MGENARRAY-NULL ARRAY)) + (MARRAYSET-GENSUB (LEXPR-FUNCALL #'MFUNCALL + (MGENARRAY-GENERATOR ARRAY) + ;; the first argument we pass the + ;; function is a SELF variable. + ARRAY + ;; extra consing here! LEXPR madness. + IND1 + INDS) + (MGENARRAY-CONTENT ARRAY) IND1 INDS) + VALUE))) + (T + (MARRAY-TYPE-UNKNOWN ARRAY)))) + + +(DEFUN MARRAYSET-GENSUB (VAL ARRAY IND1 INDS) + (CASEQ (MARRAY-TYPE ARRAY) + (($HASHED) + (LEXPR-FUNCALL #'MARRAYSET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS)) + (($ANY) + #-3600(STORE (LEXPR-FUNCALL (MGENARRAY-CONTENT ARRAY) IND1 INDS) VAL) + #+3600(LEXPR-FUNCALL #'ASET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS)) + (($FLOAT $FIXNUM) + #-3600(STORE (LEXPR-FUNCALL ARRAY IND1 INDS) VAL) + #+3600(LEXPR-FUNCALL #'ASET VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS)) + (($FUNCTIONAL) + (MARRAYSET-GENSUB VAL (MGENARRAY-CONTENT ARRAY) IND1 INDS)) + (T + (MARRAY-TYPE-UNKNOWN ARRAY)))) + + +;; Extensions to MEVAL. + +(DEFMFUN MEVAL1-EXTEND (FORM) + (LET ((L (MEVALARGS (CDR FORM)))) + (MARRAYREF-GENSUB (CAAR FORM) (CAR L) (CDR L)))) + +(DEFMFUN ARRSTORE-EXTEND (A L R) + (MARRAYSET-GENSUB R A (CAR L) (CDR L))) + diff --git a/src/maxsrc/ards.11 b/src/maxsrc/ards.11 new file mode 100644 index 00000000..05c14175 --- /dev/null +++ b/src/maxsrc/ards.11 @@ -0,0 +1,145 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module ards) + +;; Package for drawing lines on terminals supporting the Advanced Remote +;; Display Station (ARDS) protocol. See .INFO.;ARDS > for a description of +;; this crock. The screen is addressed as -512. <= X, Y <= 511. Note that +;; drawing from (-511, 0) to (512, 0) on plasma consoles will work for some +;; random reason. Keep ibase set at 8 since Macsyma has it at 10. + +(EVAL-WHEN (EVAL COMPILE) (SETQ OLD-IBASE IBASE IBASE 8)) + +;; Read-time parameters. These aren't real TD codes. + +#.(SETQ %TDCHR #+ITS 234 #-ITS 34) +#.(SETQ %TDSET #+ITS 235 #-ITS 35) +#.(SETQ %TDLNG #+ITS 236 #-ITS 36) +#.(SETQ %TDSHR #+ITS 237 #-ITS 37) + +;; The ARDS-X and ARDS-Y variables are only valid when inside one of the +;; graphics modes. When entering a graphics mode, we always move the cursor to +;; where we want it without looking to see where it is already. This may want +;; to be fixed later. + +(DEFVAR ARDS-X) +(DEFVAR ARDS-Y) +(DEFVAR ARDS-STATE #.%TDCHR) + +;; I can think of few things less optimal. + +(DEFUN ARDS-SEND-X-Y (S X Y INVISIBLE DOTTED 4-CHARS &AUX (SIGN-X 0) (SIGN-Y 0)) + (DECLARE (FIXNUM X Y SIGN-X SIGN-Y)) + (SETQ SIGN-X (IF (< X 0) 1 0)) + (SETQ SIGN-Y (IF (< Y 0) 1 0)) + (SETQ X (ABS X) Y (ABS Y)) + (+TYO (+ (LSH (LOGAND X 37) 1) SIGN-X 100) S) + (IF 4-CHARS + (+TYO (+ (LOGAND (LSH X -5) 37) 100 (IF INVISIBLE 40 0)) S)) + (+TYO (+ (LSH (LOGAND Y 37) 1) SIGN-Y 100) S) + (IF 4-CHARS + (+TYO (+ (LOGAND (LSH Y -5) 37) 100 (IF DOTTED 40 0)) S))) + +(DEFUN ARDS-SET-POINT (S X Y) + (DECLARE (FIXNUM X Y)) + (COND ((AND (NOT (= ARDS-STATE #.%TDCHR)) + (= ARDS-X X) + (= ARDS-Y Y))) + (T (UNLESS (= ARDS-STATE #.%TDSET) + (+TYO #.%TDSET S) + (SETQ ARDS-STATE #.%TDSET)) + (SETQ ARDS-X X ARDS-Y Y) + (ARDS-SEND-X-Y S X Y NIL NIL T)))) + +;; Updates global state and figures out if we can draw a short vector. Even if +;; in long vector mode already, it still wins to go into short vector mode. If +;; only one short vector is drawn, we break even. + +(DEFUN ARDS-DRAW-VECTOR (S X Y INVISIBLE DOTTED) + (DECLARE (FIXNUM X Y)) + (PSETQ X (- X ARDS-X) ARDS-X X) + (PSETQ Y (- Y ARDS-Y) ARDS-Y Y) + (IF (AND (< (ABS X) 40) (< (ABS Y) 40) (NOT INVISIBLE) (NOT DOTTED)) + (ARDS-DRAW-SHORT-VECTOR S X Y) + (ARDS-DRAW-LONG-VECTOR S X Y INVISIBLE DOTTED))) + +(DEFUN ARDS-DRAW-SHORT-VECTOR (S X Y) + (DECLARE (FIXNUM X Y)) + (UNLESS (= ARDS-STATE #.%TDSHR) + (+TYO #.%TDSHR S) + (SETQ ARDS-STATE #.%TDSHR)) + (ARDS-SEND-X-Y S X Y NIL NIL NIL)) + +(DEFUN ARDS-DRAW-LONG-VECTOR (S X Y INVISIBLE DOTTED) + (DECLARE (FIXNUM X Y)) + (UNLESS (= ARDS-STATE #.%TDLNG) + (+TYO #.%TDLNG S) + (SETQ ARDS-STATE #.%TDLNG)) + (ARDS-SEND-X-Y S X Y INVISIBLE DOTTED T)) + +(DEFUN ARDS-EXIT-GRAPHICS (S) + (UNLESS (= ARDS-STATE #.%TDCHR) + (+TYO #.%TDCHR S) + (SETQ ARDS-STATE #.%TDCHR))) + +;; For convenience. If you are drawing a lot of lines, you +;; should call the procedures defined above. + +#+DEBUG +(DEFUN ARDS-DRAW-POINT (S X Y) + (ARDS-SET-POINT S X Y) + (ARDS-DRAW-VECTOR S X Y NIL NIL) + (ARDS-EXIT-GRAPHICS S)) + +(DEFUN ARDS-DRAW-LINE (S X1 Y1 X2 Y2) + (ARDS-SET-POINT S X1 Y1) + (ARDS-DRAW-VECTOR S X2 Y2 NIL NIL) + (ARDS-EXIT-GRAPHICS S)) + + +;; This file gets loaded when Macsyma is started up and it is determined +;; that an ARDS console is being used. Communication with Macsyma +;; is through the functions and specials defined after this point. +;; Everything above this point is independent of Macsyma. + +(DECLARE (SPECIAL DISPLAY-FILE)) + +;; These define the size of the character cell in pixels. + +(SETQ LG-CHARACTER-X 6.) +(SETQ LG-CHARACTER-Y 10.) +(SETQ LG-CHARACTER-X-2 (// LG-CHARACTER-X 2)) +(SETQ LG-CHARACTER-Y-2 (// LG-CHARACTER-Y 2)) + +;; Coordinate translation from 0 <= X, Y <= 511 to -512 <= X, Y <= 511. Also, +;; exchange directtion of Y coordinates. Normally, both constants below would +;; be 512., but there is a one pixel border around the edge of the Plasma TVs. + +(DEFMACRO LG-TRANSL-X (X) `(- (LSH ,X 1) 510.)) +(DEFMACRO LG-TRANSL-Y (Y) `(- 510. (LSH ,Y 1))) + +(DEFUN LG-DRAW-LINE (X1 Y1 X2 Y2) + (DECLARE (FIXNUM X1 Y1 X2 Y2)) + (LG-SET-POINT X1 Y1) + (LG-END-VECTOR X2 Y2)) + +(DEFUN LG-SET-POINT (X Y) + (ARDS-SET-POINT DISPLAY-FILE (LG-TRANSL-X X) (LG-TRANSL-Y Y))) + +(DEFUN LG-DRAW-VECTOR (X Y) + (ARDS-DRAW-VECTOR DISPLAY-FILE + (LG-TRANSL-X X) (LG-TRANSL-Y Y) NIL NIL)) + +(DEFUN LG-END-VECTOR (X Y) + (LG-DRAW-VECTOR X Y) + (ARDS-EXIT-GRAPHICS DISPLAY-FILE)) + +(EVAL-WHEN (EVAL COMPILE) (SETQ IBASE OLD-IBASE)) + +;; This should really be set in ALJABR;LOADER and not here, but we're not +;; always able to recognize the terminal type. So we want things to turn on +;; when the file is loaded by hand. + +(SETQ LINE-GRAPHICS-TTY T) diff --git a/src/maxsrc/char.2 b/src/maxsrc/char.2 new file mode 100644 index 00000000..2fc81e6b --- /dev/null +++ b/src/maxsrc/char.2 @@ -0,0 +1,33 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module char) + + +;;; hacks for character manipulation. + + +(DEFMFUN $GETCHARN (SYMBOL INDEX) + (OR (SYMBOLP SYMBOL) + (MERROR "First arg to GETCHARN: ~A, was not a symbol." + (implode (mstring symbol)))) + (OR (AND (FIXP INDEX) + (> INDEX 0)) + (MERROR "Second arg to GETCHARN: ~A, was not a positive fixnum." + (implode (mstring index)))) + ; what happens next is debateable. + ; one thing I don't want to do call mstring and take nthcdr. + ; what to returns depends on what you would see printed. + ; well, or read in. + ; the main use for this is to check symbol name conventions, + ; so $FOO and &FOO might be the same, same with %FOO I guess, + ; but FOO (i.e. ?FOO is different.) poo, all these things + ; depend on the setting of global switches. screw it. + (LET ((C1 (GETCHARN SYMBOL 1))) + (COND ((OR (= C1 #/$) (= C1 #/%) (= C1 #/&)) + (GETCHARN SYMBOL (1+ INDEX))) + ((= INDEX 1) #/?) + (T (GETCHARN SYMBOL (1- INDEX)))))) + + diff --git a/src/maxsrc/descri.58 b/src/maxsrc/descri.58 new file mode 100644 index 00000000..ea5f8d5e --- /dev/null +++ b/src/maxsrc/descri.58 @@ -0,0 +1,226 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1981 Massachusetts Institute of Technology ** + +(macsyma-module descri) + +(DECLARE (SPLITFILE DESCR)) + +;;; Updated for New-I/O by KMP, 5:31pm Tuesday, 8 August 1978 +;;; Updated for FILEPOSing by RLB, 20 December 1978 +;;; Updated for Multics by putting the index to the doc on the plist of the +;;; symbol being doc'ed by JIM 25 Oct. 1980. + +;;; This version will allow  (control-Q) to quote an & in the +;;; doc file. It first reads MANUAL;MACSYM BINDEX (prepared by doing +;;; :L MANUAL;MANDEX) to find out where in +;;; MANUAL;MACSYM DOC to look. It then reads the latter file +;;; for the entries found in the index. The entry is printed by TYI'ing +;;; chars to the next (non-quoted) "&" in the file. Elements which are +;;; not Macsyma keywords will not be searched for. Any elements which are +;;; not found will be noted explicitly. +;;; The format of the index file is found in comments in RLB;MANDEX . + +;;; This version runs most of the old $DESCRIBE (here named ODESCRIBE) +;;; as a fallback if the index info is out of date. + +(DEFMFUN $DESCRIBE FEXPR (NODES) + (DO ((N NODES (CDR N)) (L) (X)) + ((NULL N) (SETQ NODES (NREVERSE L))) + (SETQ X (CAR N)) + (COND ((SYMBOLP X) (PUSH (prepare-a-node x) L)) + (T (MTELL "~&Non-atomic arg being ignored: ~M" X) + ))) + (COND ((NULL NODES) (SETQ NODES (NCONS 'DESCRIBE)))) + (CURSORPOS 'A) + (LET ((L (LOCATE-INDEX-INFO NODES #+ITS'((DSK MAXOUT) MACSYM BINDEX) + #-ITS ())) + (F)) + (SETQ F (CAR L) L (CDR L)) + (COND ((NULL F) + (PRINC + "Description index is out of date, this may take a lot longer.") + (ODESCRIBE NODES)) + ('T (DO ((L L (CDR L))) ((NULL L) (CLOSE F)) + (COND ((ATOM (CAR L)) + (PRINC "No info for ") + (PRINC (fullstrip1 (CAR L))) (TERPRI)) + ((DO POS (CAR L) (CDR POS) (NULL POS) + (TERPRI) + (FILEPOS F (CAR POS)) + (DO C (TYI F -1) (TYI F -1) () + (CASEQ C + (#/ (TYO (TYI F))) + ((#/& -1) (RETURN 'T)) + (#o14 () ) ;^L + (T (TYO C))))))))))) + '$DONE) + +#-Multics +(DEFUN UPCASE-FULLSTRIP1 (X) + (IMPLODE + (MAP #'(LAMBDA (CHS) + (COND ((< (CAR CHS) #/a)) + ((> (CAR CHS) #/z)) + (T (RPLACA CHS (- (CAR CHS) + #.(- #/a #/A)))))) + (EXPLODEN (FULLSTRIP1 X))))) + +#-Multics +(DEFUN LH-BITS MACRO (FORM) `(BOOLE 1 #o777777 (LSH ,(CADR FORM) -18.))) +#-Multics +(DEFUN RH-BITS MACRO (FORM) `(BOOLE 1 #o777777 ,(CADR FORM))) + +#-Multics +(defun prepare-a-node (x) + (COND ((= (GETCHARN X 1) #/&) (UPCASE-FULLSTRIP1 X)) + (T (FULLSTRIP1 X)))) + +#+Multics +(defun prepare-a-node (x) + (setq x (downcase-it (fullstrip1 x)));For strings and to get the alias's. + (implode (cons #/$ (explode x)))) + +#+Multics +(defun downcase-it (x) + (IMPLODE + (MAP #'(LAMBDA (CHS) + (COND ((< (CAR CHS) #/A)) + ((> (CAR CHS) #/Z)) + (T (RPLACA CHS (+ (CAR CHS) + #.(- #/a #/A)))))) + (EXPLODEN X)))) + +;;;Return +;;; (open-file-obj-or-NIL . (list of (list of starting pos's) or losing-atom)) +#+Multics +(defun locate-index-info (nodes f) + f ;IGNORED + (cond ((not (get '$describe 'user-doc)) + (mtell "Loading DESCRIBE data-base, please be patient.~%") + (load-documentation-file manual-index))) + (setq nodes (sort (append nodes ()) 'alphalessp)) + (do ((l nodes (cdr l)) + (locations ())) + ((null l) (return (cons (open (find-documentation-file manual) + '(in ascii)) + locations))) + (let ((item-location (and (symbolp (car l)) + (get (car l) 'user-doc)))) + (push (if (not (null item-location)) + (ncons item-location) + (car l)) + locations)))) + +#-Multics +(DEFUN LOCATE-INDEX-INFO (NODES F) + (SETQ NODES (SORT (APPEND NODES ()) 'ALPHALESSP) F (OPEN F '(IN FIXNUM))) + (LET ((FILE (DO ((I (IN F) (1- I)) (L)) ;Grab file name + ((< I 1) (PNPUT (NREVERSE L) 7)) + (PUSH (IN F) L))) + (CDATE (IN F)) (FPINDEX (FILEPOS F))) + (DO ((L NODES (CDR L)) (PN) (1STCH 0) (NENT 0) (RET)) + ((NULL L)) + ;(DECLARE (FIXNUM NENT 1STCH)) + (SETQ 1STCH (GETCHARN (CAR L) 1) PN (PNGET (CAR L) 7)) + (FILEPOS F (+ FPINDEX 1STCH)) ;Pos to index-to-the-index + (SETQ NENT (IN F)) + (COND ((NOT (= 0 NENT)) + (FILEPOS F (RH-BITS NENT)) ;Pos to the entries + (SETQ NENT (LH-BITS NENT)) + (DO I 1 (1+ I) (> I NENT) ;Check all entries + (LET ((LPNAME (IN F)) (NSTARTS 0) (FOUND 'T)) + (SETQ NSTARTS (RH-BITS LPNAME) + LPNAME (LH-BITS LPNAME)) + ;;Read in LPNAME file entry pname words, + ;;comparing word-by-word with pname list of the + ;;symbol. Assume they all match (FOUND=T) unless + ;;(a) a mismatch is found + ;;(b) pname list of symbol ran out before LPNAME + ;; words were read from the file + ;;(c) any pname list words left when all words + ;; read from the file + (DO ((I 1 (1+ I)) (PN PN (CDR PN))) + ((> I LPNAME) ;Read pname of entry + (AND PN (SETQ FOUND ()))) + (COND ((NULL PN) (SETQ FOUND ()) (IN F)) + ((NOT (= (CAR PN) (IN F))) + (SETQ FOUND ())))) + ;;If we found the one, read in all the starts and + ;;return a list of them. If we didn't find it, we + ;;need too read in all the starts anyway (dumb + ;;filepos) but remember that simple DO returns nil. + (COND (FOUND (DO ((I 1 (1+ I)) (L)) + ((> I NSTARTS) + (SETQ RET (NREVERSE L))) + (PUSH (IN F) L))) + ((SETQ RET (DO I 1 (1+ I) (> I NSTARTS) + (IN F)))))) + (COND (RET (RPLACA L RET) (RETURN 'T))))))) + (CLOSE F) + (SETQ F (OPEN FILE '(IN ASCII))) + (COND ((NOT (= CDATE (CAR (SYSCALL 1 'RFDATE F)))) + (CLOSE F) (SETQ F ()))) + (CONS F NODES))) + +(DEFMFUN MDESCRIBE (X) (APPLY '$DESCRIBE (NCONS X))) + +;;;ODESCRIBE is mostly like the old $DESCRIBE, except the arg checking +;;; has already been done, and it is a SUBR. + +(DEFUN ODESCRIBE (NODES) + (TERPRI) + (COND ((NOT NODES) (ERROR "Nothing to describe!"))) + (CURSORPOS 'A) + (PRINC "Checking...") + (TERPRI) + (PROG (STREAM EOF) + (SETQ STREAM (OPEN '((DSK MAXOUT) MACSYM DOC) '(IN ASCII))) + (SETQ EOF (GENSYM)) + (*CATCH 'END-OF-FILE + (DO ((FORM (READ STREAM EOF) (READ STREAM EOF))) + ((OR (NULL NODES) (EQ FORM EOF))) + (COND ((MEMQ FORM NODES) + (SETQ NODES (DELETE FORM NODES)) + (CURSORPOS 'A) + (PRINC FORM) + (DO ((C (TYI STREAM -1.) (TYI STREAM -1.))) + ((= C 38.)) ; "&" = End of entry + (COND ((= C -1.) ; -1 = EOF + (*THROW 'END-OF-FILE T)) + ((= C 17.) ; "" = Quote + (SETQ C (TYI STREAM)) + (TYO C)) + ((NOT (MEMBER C '(3. 12.))) + (TYO C))))) + (T (DO ((C (TYI STREAM -1.) (TYI STREAM -1.))) + ((= C 38.)) + (COND ((= C -1.) + (*THROW 'END-OF-FILE T)) + ((= C 17.) + (SETQ C (TYI STREAM))))))))) + (CLOSE STREAM)) + (COND (NODES + (MTELL "Information missing: ~%~M" + (CONS '(MLIST) NODES)) + )) + '$DONE) + +(DEFMFUN $HELP FEXPR (X) X (MDESCRIBE '$HELP)) + +(DECLARE (SPLITFILE EXAMPL)) + +;In essence, example(func):=DEMO([manual,demo,dsk,demo],OFF,func,OFF); + +(DEFUN $example FEXPR (func) + (FEXPRCHK func '$example) + (NONSYMCHK (SETQ func (CAR func)) '$example) + (let (($change_filedefaults ())) + (batch1 `(#-Multics((MLIST) manual demo dsk demo) + #+Multics((mlist) ,(string-to-mstring + (string-append macsyma-dir + ">demo>manual.demo"))) + NIL ,func NIL) + t nil nil)) + '$done) + diff --git a/src/maxsrc/dover.3 b/src/maxsrc/dover.3 new file mode 100644 index 00000000..fc293410 --- /dev/null +++ b/src/maxsrc/dover.3 @@ -0,0 +1,62 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module dover) + +;;; to make it easy to queue plot files to the DOVER. + +(DEFMVAR $DOVARD_VIEWPORT '((MLIST) 1 7 1 7) + "[XMIN,XMAX,YMIN,YMAX] in inches on the paper") + +(DEFUN ($DOVARD_VIEWPORT ASSIGN) (IGNORE VALUE) + (IF ($LISTP VALUE) + (DO ((L (CDR VALUE) (CDR L)) + (J 0 (1+ J))) + ((= J 4) + (OR (NULL L) (MERROR "DOVARD_VIEWPORT list too long"))) + (AND (NULL L) (MERROR "DOVARD_VIEWPORT list too short")) + (OR (NUMBERP (CAR L)) + (MERROR "DOVARD_VIEWPORT list element non-numeric: ~M" (CAR L)))) + (MERROR "DOVARD_VIEWPORT must be a list"))) + +(defmfun $dovard_file (&optional (filename "dsk:.temp.;* .plot.") (output "* PRESS")) + (setq filename ($filename_merge filename (status uname))) + (IF (NOT (PROBEF FILENAME)) + (MERROR "File for input ~M does not exist" FILENAME)) + (setq output ($filename_merge output filename)) + (let ((dovard-command-filename (TO-MACSYMA-NAMESTRING (mergef "* DOVARD" filename))) + (dovard-output-filename OUTPUT) + (STREAM)) + (UNWIND-PROTECT + (PROGN (SETQ STREAM (OPEN (MERGEF "* _DOVARD" DOVARD-COMMAND-FILENAME) 'OUT)) + (MFORMAT STREAM + "DSK:MACSYM;.PLOT PRESS~%~A~%~A~%1~%~S,~S,~S,~S~%~%" + DOVARD-OUTPUT-FILENAME + FILENAME + (NTH 1 $DOVARD_VIEWPORT) + (NTH 2 $DOVARD_VIEWPORT) + (NTH 3 $DOVARD_VIEWPORT) + (NTH 4 $DOVARD_VIEWPORT) + ) + (RENAMEF STREAM DOVARD-COMMAND-FILENAME)) + (IF STREAM (CLOSE STREAM))) + (MTELL "~%Calling DOVARD program, reply Y to its question.~%") + (IF (PROBEF DOVARD-OUTPUT-FILENAME) (DELETEF DOVARD-OUTPUT-FILENAME)) + (CALL-JOB "DOVARD" (CONCAT "@" DOVARD-COMMAND-FILENAME)) + (IF (NOT (PROBEF DOVARD-OUTPUT-FILENAME)) + (MERROR "Output file ~M not created" DOVARD-OUTPUT-FILENAME) + `((MLIST) ,FILENAME ,DOVARD-OUTPUT-FILENAME)))) + +(DEFMFUN $DOVER_FILE (&OPTIONAL (FILENAME "")) + (SETQ FILENAME ($FILENAME_MERGE FILENAME "DSK:.TEMP.;* PRESS" (STATUS UNAME))) + (IF (NOT (PROBEF FILENAME)) + (MERROR "File for input ~M does not exist" FILENAME)) + (CALL-JOB "DOVER" FILENAME) + FILENAME) + +(DEFUN CALL-JOB (JOB JCL) + (VALRET (CONCAT ": At DDT LEVEL:" + JOB " " JCL + "î:JOB " (STATUS JNAME) + "î:CONTINUE "))) diff --git a/src/maxsrc/ermsgm.12 b/src/maxsrc/ermsgm.12 new file mode 100644 index 00000000..d5240918 --- /dev/null +++ b/src/maxsrc/ermsgm.12 @@ -0,0 +1,61 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module ermsgm) + +;;; Functions for MACSYMA error messages, run-time stuff. +;;; Note: This file must be loaded before any files which use error messages. +;;; -GJC 11:24pm Saturday, 25 October 1980 + +;; **NOTE** The definition for STRING-FILE-NAME *MUST* come before any and +;; all use of out-of-core strings *including* DEFVAR's. + +(defun string-file-name (name) + name ;ignore + ()) + +; Make sure the LOADER's version will be used. It is an EXPR version that +; will latter be flushed. + +(eval-when (load) + (if (get 'STRING-FILE-NAME 'EXPR) + (putprop 'STRING-FILE-NAME (get 'STRING-FILE-NAME 'EXPR) 'EXPR))) + +(defvar string-files nil) +(defvar incore-files nil + "set up ONLY during the LOADING of a macsyma for + the SUSPEND operation. Then it is an ALIST of (file . offset)") +(defvar incore-message-file nil + "Set up ONLY during the LOADING of a macsyma for + the SUSPEND operation. Then it is the filename of + the common message file for all incore files.") + +(defvar string-filearray + ; name a file I know will be open, so that I can + ; get a file object. Ah, the NUL device. + (open '((NUL)) '(in fixnum dsk block))) +(close string-filearray) + + +(DEFMFUN ALLOCATE-MESSAGE-INDEX (FILE ERROR-MESSAGE-INDEX) + (LET ((TEMP (ASSOC FILE INCORE-FILES))) + (IF TEMP + (SETQ FILE INCORE-MESSAGE-FILE + ERROR-MESSAGE-INDEX (+ ERROR-MESSAGE-INDEX (CDR TEMP))))) + (CONS (CAR (OR (MEMBER FILE STRING-FILES) ; For cons-sharing, intern + (PUSH FILE STRING-FILES))) ; the FILE name list. + ERROR-MESSAGE-INDEX)) + +(DEFMFUN CHECK-OUT-OF-CORE-STRING (STRING &AUX (A STRING-FILEARRAY)) + (COND ((OR (ATOM STRING) (NOT (MEMBER (CAR STRING) STRING-FILES))) STRING) + (T (CNAMEF A (CAR STRING)) + (UNWIND-PROTECT + (PROGN + (OPEN A) + (FILEPOS A (CDR STRING)) + (FILEPOS A (IN A)) + (DO ((L NIL (CONS W L)) (W (IN A) (IN A))) + ((= W 0) (PNPUT (NREVERSE L) NIL)))) + (CLOSE A))))) + \ No newline at end of file diff --git a/src/maxsrc/h19.4 b/src/maxsrc/h19.4 new file mode 100644 index 00000000..d3726d0b --- /dev/null +++ b/src/maxsrc/h19.4 @@ -0,0 +1,47 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module h19) + +;; Package for doing character graphics on H19s. The Macsyma display package +;; uses this to draw quotients, matrices, boxes, etc. with contiguous lines. +;; This file gets loaded when Macsyma is started up and it is determined that a +;; H19 is being used. + +(DEFUN CG-BEGIN-GRAPHICS () (CG-IMAGE-TYO-N '(#\ALT #/F))) +(DEFUN CG-END-GRAPHICS () (CG-IMAGE-TYO-N '(#\ALT #/G))) + +(DEFUN CG-VERTICAL-BAR () (CG-TYO #/`)) +(DEFUN CG-HORIZONTAL-BAR () (CG-TYO #/a)) + +(DEFUN CG-UL-CORNER () (CG-TYO #/f)) +(DEFUN CG-UR-CORNER () (CG-TYO #/c)) +(DEFUN CG-LL-CORNER () (CG-TYO #/e)) +(DEFUN CG-LR-CORNER () (CG-TYO #/d)) + +;; Again we have to fool ITS. As far as its concerned, the cursor +;; has moved forward four character spaces. + +(DEFUN CG-D-SUMSIGN () + (CG-IMAGE-TYO-N '(#\ALT #/A #\ALT #/A)) + (CG-TYO-N '(#/{ #/{ #/{ #/{)) + (CG-IMAGE-TYO-N '(#\LF #\BS #\BS #\BS #\BS #/y #\SP #\SP #/o + #\LF #\BS #\BS #\BS #/> + #\LF #\BS #\BS #/x #\SP #\SP #/l + #\LF #\BS #\BS #\BS #\BS #/z #/z #/z #/z + #\ALT #/A #\ALT #/A))) + +(DEFUN CG-D-PRODSIGN () + (CG-IMAGE-TYO-N '(#\ALT #/A #\ALT #/A)) + (CG-TYO-N '(#/f #/s #/a #/s #/c)) + (CG-IMAGE-TYO-N '(#\LF #\BS #\BS #\BS #\BS #/` #\SP #/` + #\LF #\BS #\BS #\BS #/` #\SP #/` + #\LF #\BS #\BS #\BS #/u #\SP #/u + #\SP #\ALT #/A))) + +;; This should really be set in ALJABR;LOADER and not here, but we're not +;; always able to recognize the terminal type. For example, coming in via +;; supdup. So we want things to turn on when the file is loaded by hand. + +(SETQ CHARACTER-GRAPHICS-TTY T) diff --git a/src/maxsrc/ininte.54 b/src/maxsrc/ininte.54 new file mode 100644 index 00000000..69ee12b5 --- /dev/null +++ b/src/maxsrc/ininte.54 @@ -0,0 +1,1155 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module irinte) +(load-macsyma-macros rzmac) + +(DECLARE (SPECIAL CHECKCOEFSIGNLIST EC-1 R12 1//2 VAR GLOBALCAREFLAG + ZEROSIGNTEST PRODUCTCASE $RADEXPAND)) + +(DEFUN HASVAR (EXP) (NOT (FREEVAR EXP))) + +(DEFUN ZERP (A) (EQUAL A 0)) + +(DEFUN INTEGERPFR (A) (IF (NOT (INTEGERP A)) (INTEGERP1 A))) + +(DEFUN NONZERP (A) (NOT (EQUAL A 0))) + +(DEFUN FREEVNZ (A) (AND (FREEVAR A) (NOT (EQUAL A 0)))) + +(DEFUN INTE (FUNCT X) + (PROG (CHECKCOEFSIGNLIST GLOBALCAREFLAG $RADEXPAND) + (SETQ $RADEXPAND T) + (RETURN (INTIR-REF FUNCT X)))) + +(DEFUN INTIR-REF (FUN X) + (PROG (A) + (COND ((SETQ A (INTIR1 FUN X))(RETURN A))) + (COND ((SETQ A (INTIR2 FUN X))(RETURN A))) + (RETURN (INTIR3 FUN X)))) + +(DEFUN INTIR1 (FUN X) + (PROG (ASSOCLIST E0 R0 E1 E2 R1 R2 D P) + (SETQ ASSOCLIST (FACTPOW (SPECREPCHECK FUN) X)) + (SETQ E1 (CDRAS 'E1 ASSOCLIST) E2 (CDRAS 'E2 ASSOCLIST)) + (COND ((NULL ASSOCLIST)(RETURN NIL))) + (SETQ D (CDRAS 'D ASSOCLIST) P (CDRAS 'P ASSOCLIST) + E0 (CDRAS 'E0 ASSOCLIST) R0 (CDRAS 'R0 ASSOCLIST) + R1 (CDRAS 'R1 ASSOCLIST) R2 (CDRAS 'R2 ASSOCLIST)) + (COND ((FLOATP E0)(SETQ E0 (RDIS (RATION1 E0))))) + (COND ((FLOATP E1)(SETQ E1 (RDIS (RATION1 E1))))) + (COND ((FLOATP E2)(SETQ E2 (RDIS (RATION1 E2))))) + (RETURN (INTIR1-REF D P R0 E0 R1 E1 R2 E2 X)))) + +(DEFUN INTIR2 (FUNCT X) + (PROG (RES) + (COND ((SETQ RES (INTIR FUNCT X))(RETURN RES))) + (RETURN (INTIRFACTOROOT FUNCT X)))) + +(DEFUN INTIR3 (EXP X) + (PROG (ASSOCLIST E F G R0) + (COND ((SETQ ASSOCLIST (ELLIPTQUAD EXP X)) + (SETQ E (CDRAS 'E ASSOCLIST) F (CDRAS 'F ASSOCLIST) + G (CDRAS 'G ASSOCLIST) R0 (CDRAS 'R0 ASSOCLIST)) + (ASSUME `(($NOTEQUAL) ,E 0)) + (RETURN (INTIR3-R0TEST ASSOCLIST X E F G R0)))) + (RETURN NIL))) + +(DEFUN INTIR3-R0TEST (ASSOCLIST X E F G R0) + (COND ((ROOT+ANYTHING R0 X) NIL) + (T (INTIR3-REF ASSOCLIST X E F G R0)))) + +(DEFUN INTIR1-REF (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((AND (PLUSP NUME1)(PLUSP NUME2)) + (PP-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + ((AND (MINUSP NUME1)(MINUSP NUME2)) + (MM-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + ((PLUSP NUME1)(PM-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + (T (PM-INTIR1 D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN PP-INTIR1 (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((GREATERP NUME1 NUME2)(PP-INTIR1-EXEC D P R0 E0 R1 E1 R2 E2 X)) + (T (PP-INTIR1-EXEC D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN MM-INTIR1 (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((GREATERP NUME1 NUME2)(MM-INTIR1-EXEC D P R0 E0 R1 E1 R2 E2 X)) + (T (MM-INTIR1-EXEC D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN PM-INTIR1 (D P R0 E0 ROFPOS EPOS ROFNEG ENEG X) + ((LAMBDA (NUMEPOS NUMUL-1ENEG) + (COND ((GREATERP NUMEPOS NUMUL-1ENEG) + (MM-INTIR1 D (MUL P (POWER ROFPOS (SUB EPOS ENEG))) + R0 E0 ROFPOS ENEG ROFNEG ENEG X)) + ((OR (EQUAL E0 0) (PLUSP E0)) + (PP-INTIR1 D (MUL P (POWER ROFNEG (SUB ENEG EPOS))) + R0 E0 ROFPOS EPOS ROFNEG EPOS X)) + (T (MM-INTIR1 D (MUL P (POWER ROFPOS (SUB EPOS ENEG))) + R0 E0 ROFPOS ENEG ROFNEG ENEG X)))) + (CADR EPOS) + (MUL -1 (CADR ENEG)))) + +(DEFUN PP-INTIR1-EXEC (D P R0 E0 ROFMAX EMAX ROFMIN EMIN X) + (INTIR (MUL D P (COND ((EQUAL E0 0) 1) (T (POWER R0 E0))) + (POWER ROFMAX (ADD EMAX (MUL -1 EMIN))) + (POWER ($EXPAND (MUL ROFMAX ROFMIN)) EMIN)) X)) + +(DEFUN MM-INTIR1-EXEC (D P R0 E0 ROFMIN EMIN ROFMAX EMAX X) + (INTIR (MUL D P (COND ((EQUAL E0 0) 1) (T (POWER R0 E0))) + (POWER ROFMAX (ADD EMAX (MUL -1 EMIN))) + (POWER ($EXPAND (MUL ROFMAX ROFMIN)) EMIN)) X)) + +(DEFUN INTIR3-REF (ASSOCLIST X E F G R0) + ((LAMBDA (SIGNDISC D P E0) + (COND ((OR (EQ SIGNDISC '$POSITIVE)(EQ SIGNDISC '$NEGATIVE)) + (PNS-INTIR3 X E F G D P R0 E0)) + (T (ZS-INTIR3 X E F D P R0 E0)))) + (SIGNDISCR E F G) + (CDRAS 'D ASSOCLIST) + (CDRAS 'P ASSOCLIST) + (CDRAS 'E0 ASSOCLIST))) + +(DEFUN ROOT+ANYTHING (EXP VAR) + (M2 EXP '((MPLUS) ((COEFFPT) (C NONZERP) ((MEXPT) (U HASVAR) (V INTEGERPFR))) + ((COEFFPP)(C TRUE))) NIL)) + +(DEFUN PNS-INTIR3 (X E F G D P R0 E0) + ((LAMBDA (DISCR) + ((LAMBDA (P*R0^E0 2*E*X+F 2*E*D*INVDISC) + (MUL (SUB (INTIR2 (MUL 2*E*D*INVDISC + (INV (SUB 2*E*X+F DISCR)) + P*R0^E0) + X) + (INTIR2 (MUL 2*E*D*INVDISC + (INV (ADD 2*E*X+F DISCR)) + P*R0^E0) + X)))) + (MUL P (POWER R0 E0)) + (ADD (MUL 2 E X) F) + (MUL 2 E D (INV DISCR)))) + (POWER (SUB (MUL F F)(MUL 4 E G)) (INV 2)))) + +(DEFUN ZS-INTIR3 (X E F D P R0 E0) + (INTIR2 (MUL D P E + (POWER (ADD X (DIV F (ADD E E))) -2) (POWER R0 E0)) + X)) + +(DEFUN CDRAS (A B) + (CDR (ASSOC A B))) + +(DEFUN INTIR (FUNCT X) + (PROG (ASSOCLIST) + (SETQ ASSOCLIST (JMAUG (SPECREPCHECK FUNCT) X)) + (RETURN (INTI FUNCT X ASSOCLIST)))) + +(DEFUN INTI (FUNCT X ASSOCLIST) + (PROG (MET N EXPR F E DENOM) + (SETQ N (CDRAS 'N ASSOCLIST)) + (COND ((OR (NULL ASSOCLIST) (INTEGERP N)) + (RETURN NIL))) + (SETQ F (CDRAS 'F ASSOCLIST) E (CDRAS 'E ASSOCLIST)) + (COND ((OR (EQUAL E 0) (NULL E)) + (RETURN (INTIRA FUNCT X)))) + (COND ((NOT (NUMBERP F)) (GO JUMP))) + (COND ((PLUSP F)(GO JUMP))) + (SETQ DENOM (ADD (MUL F X) E) F (MUL -1 F) E (MUL -1 E) + FUNCT (MUL -1 (DIV (MEVAL (MUL DENOM FUNCT))(ADD (MUL F X) E)))) + JUMP (SETQ EXPR + (MUL (POWER F -1) + (INTIRA (DISTREXPANDROOT + (CDR ($SUBSTITUTE (MUL (POWER F -1) + (ADD (SETQ MET (GENSYM 'YANNIS)) + (MUL -1 E))) + X FUNCT))) + MET))) + (RETURN ($EXPAND ($SUBSTITUTE (ADD (MUL F X) E) MET EXPR))))) + +(DEFUN DISTREXPANDROOT (EXPR) + (COND ((NULL EXPR) 1) + (T (MUL (EXPANDROOT (CAR EXPR)) + (DISTREXPANDROOT (CDR EXPR)))))) + +(DEFUN EXPANDROOT (EXPR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (INTEGERPFR (CADDR EXPR))) + ($EXPAND EXPR)) + (T EXPR))))) + +(DEFUN INTIRFACTOROOT (EXPR X) + (PROG (ASSOCLIST EXP) + (SETQ EXP EXPR) + (COND ((SETQ ASSOCLIST (JMAUG (SETQ EXPR (DISTRFACTOR (TIMESTEST EXPR) X)) X)) + (RETURN (INTI EXPR X ASSOCLIST)))) + (SETQ GLOBALCAREFLAG 'T) + (COND ((SETQ ASSOCLIST (JMAUG (SETQ EXP (DISTRFACTOR (TIMESTEST EXP) X)) X)) + (SETQ GLOBALCAREFLAG NIL) + (RETURN (INTI EXP X ASSOCLIST)))) + (SETQ GLOBALCAREFLAG NIL) + (RETURN NIL))) + +(DEFUN DISTRFACTOR (EXPR X) + (COND ((NULL EXPR) 1) + (T (MUL (FACTOROOT (CAR EXPR) X) + (DISTRFACTOR (CDR EXPR) X))))) + +(DEFUN FACTOROOT (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (HASVAR EXPR) + (INTEGERPFR (CADDR EXPR))) + (CAREFULFACTOR EXPR VAR)) + (T EXPR))))) + +(DEFUN CAREFULFACTOR (EXPR X) + (COND ((NULL GLOBALCAREFLAG)($FACTOR EXPR)) + (T (RESTOREX ($FACTOR (POWER (DIV (CADR EXPR) X) (CADDR EXPR))) X)))) + +(DEFUN RESTOREX (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((EQ (CAAR EXPR) 'MTIMES) + (DISTRESTOREX (CDR EXPR) VAR)) + (T EXPR))))) + +(DEFUN DISTRESTOREX (EXPR VAR) + (COND ((NULL EXPR) 1) + (T (MUL (RESTOROOT (CAR EXPR) VAR) + (DISTRESTOREX (CDR EXPR) VAR))))) + +(DEFUN RESTOROOT (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (INTEGERPFR (CADDR EXPR)) + (MPLUSP (CADR EXPR))) + (POWER ($EXPAND (MUL VAR (CADR EXPR))) (CADDR EXPR))) + (T EXPR))))) + +(DEFUN TIMESTEST (EXPR) + (COND ((ATOM EXPR)(LIST EXPR)) + (T (COND ((EQ (CAAR EXPR) 'MTIMES)(CDR EXPR)) + (T (LIST EXPR)))))) + +(DEFUN INTIRA (FUNCT X) + (PROG (A B C EC-1 D M N ASSOCLIST PLUSPOWFO1 PLUSPOWFO2 MINUSPOWFO + POLFACT SIGNN POSZPOWLIST NEGPOWLIST R12) + (SETQ ASSOCLIST (JMAUG (SPECREPCHECK FUNCT) X)) + (SETQ N (CDRAS 'N ASSOCLIST) R12 1//2) + (COND ((OR (NULL ASSOCLIST) (INTEGERP N))(RETURN NIL))) + (COND ((FLOATP N)(SETQ N (RDIS (RATION1 N))))) + (SETQ D (CDRAS 'D ASSOCLIST)) + (COND ((EQUAL D 0) (RETURN 0))) + (SETQ C (CDRAS 'A ASSOCLIST)) + (IF (EQUAL C 0) (RETURN NIL)) + (SETQ M (CDRAS 'M ASSOCLIST) POLFACT (CDRAS 'P ASSOCLIST) N (CADR N) + SIGNN (CHECKSIGNTM N) EC-1 (POWER C -1) + B (CDRAS 'B ASSOCLIST) A (CDRAS 'C ASSOCLIST) + PLUSPOWFO1 (MUL R12 (PLUS N -1)) + MINUSPOWFO (MUL R12 (PLUS N 1)) + PLUSPOWFO2 (TIMES -1 MINUSPOWFO) + POSZPOWLIST (CAR (POWERCOEFLIST POLFACT M X)) + NEGPOWLIST (CADR (POWERCOEFLIST POLFACT M X))) + (COND ((AND (NULL NEGPOWLIST)(NOT (NULL POSZPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (AUGMULT (MUL D + (NUMMNUMN POSZPOWLIST + PLUSPOWFO1 + MINUSPOWFO C B A X)))))) + (RETURN (AUGMULT (MUL D + (NUMMDENN POSZPOWLIST + PLUSPOWFO2 C B A X)))))) + (COND ((AND (NULL POSZPOWLIST)(NOT (NULL NEGPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (AUGMULT (MUL D + (DENMNUMN NEGPOWLIST + MINUSPOWFO C B A X)))))) + (RETURN (AUGMULT (MUL D + (DENMDENN NEGPOWLIST + PLUSPOWFO2 C B A X)))))) + (COND ((AND (NOT (NULL NEGPOWLIST)) (NOT (NULL POSZPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (ADD (AUGMULT (MUL D + (NUMMNUMN POSZPOWLIST + PLUSPOWFO1 + MINUSPOWFO C B A X))) + (AUGMULT (MUL D + (DENMNUMN NEGPOWLIST + MINUSPOWFO C B A X))))))) + (RETURN (ADD (AUGMULT (MUL D + (NUMMDENN POSZPOWLIST + PLUSPOWFO2 C B A X))) + (AUGMULT (MUL D + (DENMDENN NEGPOWLIST + PLUSPOWFO2 C B A X))))))))) + +(DEFUN JMAUG (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT)(P POLYP)) + ((MEXPT) ((MPLUS) ((COEFFPT)(F FREEVAR)(X VARP)) + ((COEFFPP)(E FREEVAR))) + (M INTEGERP)) + ((MEXPT) ((MPLUS) ((COEFFPT) (A FREEVAR) ((MEXPT) (X VARP) 2)) + ((COEFFPT) (B FREEVAR)(X VARP)) + ((COEFFPP) (C FREEVAR))) + (N INTEGERP1))) + NIL)) + +(DEFUN FACTPOW (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT) (P POLYP)) + ((MEXPT) (R1 HASVAR) + (E1 INTEGERPFR)) + ((MEXPT) (R2 HASVAR) + (E2 INTEGERPFR)) + ((MEXPT) (R0 HASVAR) + (E0 INTEGERP))) + NIL)) + +(DEFUN ELLIPTQUAD (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT) (P POLYP)) + ((MEXPT) ((MPLUS) ((COEFFPT) (E FREEVNZ) ((MEXPT) (X VARP) 2)) + ((COEFFPT) (F FREEVAR) (X VARP)) + ((COEFFPP) (G FREEVAR))) + -1) + ((MEXPT) (R0 HASVAR) + (E0 INTEGERPFR))) + NIL)) + +(DEFUN POLFOO (C B A X) + (ADD (MUL C X X) + (MUL B X) + A)) + +(DEFUN POWERCOEFLIST (FUN M VAR) + (PROG (EXPANFUN MAXPOWFUN POWFUN COEF POSZPOWLIST NEGPOWLIST) + (SETQ EXPANFUN (UNQUOTE ($EXPAND (MUL (PREVCONSTEXPAN FUN VAR) + (POWER VAR M))))) + (COND ((AND (EQUAL FUN 1) (GREATERP M 0)) + (RETURN (CONS NIL (LIST (LIST (CONS M (LIST 1)))))))) + (COND ((AND (EQUAL FUN 1)(LESSP M 0)) + (RETURN (CONS NIL (LIST (LIST (CONS (TIMES -1 M ) (LIST 1)))))))) + (COND ((EQUAL EXPANFUN 1) + (RETURN (CONS (LIST (CONS 0 (LIST 1))) + (LIST NIL))))) + (SETQ MAXPOWFUN ($HIPOW EXPANFUN VAR) + POWFUN ($LOPOW EXPANFUN VAR)) + LOOP (SETQ COEF ($COEFF EXPANFUN (POWER VAR POWFUN))) + (COND ((NUMBERP COEF) (GO TESTJUMP))) + (GO NOJUMP) + TESTJUMP (COND ((AND (NOT (ZEROP POWFUN)) (ZEROP COEF)) + (GO JUMP))) + NOJUMP (COND ((GREATERP POWFUN 0) + (SETQ POSZPOWLIST (APPEND POSZPOWLIST + (LIST (CONS POWFUN (LIST COEF))))))) + (COND ((ZEROP POWFUN) + (SETQ POSZPOWLIST + (APPEND POSZPOWLIST + (LIST (CONS 0 (LIST (CONSTERM (CDR EXPANFUN) VAR)))))))) + (COND ((LESSP POWFUN 0) + (SETQ NEGPOWLIST (APPEND NEGPOWLIST + (LIST (CONS (TIMES -1 POWFUN)(LIST COEF))))))) + (COND ((EQUAL POWFUN MAXPOWFUN) + (RETURN (LIST POSZPOWLIST (REVERSE NEGPOWLIST))))) + JUMP (SETQ POWFUN (ADD1 POWFUN)) (GO LOOP))) + +(DEFUN CONSTERM (FUN VAR) + (COND ((NULL FUN) 0) + ((FREEOF VAR (CAR FUN)) + (ADD (CAR FUN) (CONSTERM (CDR FUN) VAR))) + (T (CONSTERM (CDR FUN) VAR)))) + +(DEFUN PREVCONSTEXPAN (FUN VAR) + (COND ((ATOM FUN) FUN) + ((EQ (CAAR FUN) 'MPLUS) + (COND ((AND (FREEOF VAR FUN) + (NOT (INSIDE FUN 'MEXPT))) + (LIST '(MQUOTE) FUN)) + ((AND (FREEOF VAR FUN) (INSIDE FUN 'MEXPT)) + (LIST '(MQUOTE) + (DISTRINPLUSPREV (CDR FUN) VAR))) + ((INSIDE FUN 'MEXPT) + (DISTRINPLUSPREV (CDR FUN) VAR)) + (T FUN))) + ((EQ (CAAR FUN) 'MTIMES) + (DISTRINTIMESPREV (CDR FUN) VAR)) + ((AND (NOT (INSIDE (CDR FUN) VAR)) + (EQ (CAAR FUN) 'MEXPT)) + (POWER (PREVCONSTEXPAN (CADR FUN) VAR) (CADDR FUN))) + (T FUN))) + +(DEFUN DISTRINPLUSPREV (FUN VAR) + (COND ((NULL FUN) 0) + (T (ADD (PREVCONSTEXPAN (CAR FUN) VAR) + (DISTRINPLUSPREV (CDR FUN) VAR))))) + +(DEFUN DISTRINTIMESPREV (FUN VAR) + (COND ((NULL FUN) 1) + (T (MUL (PREVCONSTEXPAN (CAR FUN) VAR) + (DISTRINTIMESPREV (CDR FUN) VAR))))) + +(DEFUN INSIDE (FUN ARG) + (COND ((ATOM FUN)(EQUAL FUN ARG)) + ((INSIDE (CAR FUN) ARG) T) + (T (INSIDE (CDR FUN) ARG)))) + +(DEFUN UNQUOTE (FUN) + (COND ((NOT (INSIDE FUN 'MQUOTE)) FUN) + (T (UNQUOTE (MEVAL FUN))))) + +(DEFUN CHECKSIGNTM (EXPR) + (PROG (ASLIST QUEST ZEROSIGNTEST PRODUCTCASE) + (SETQ ASLIST CHECKCOEFSIGNLIST) + (COND ((ATOM EXPR) (GO LOOP))) + (COND ((EQ (CAAR EXPR) 'MTIMES)(SETQ PRODUCTCASE T))) + LOOP (COND ((NULL ASLIST) + (SETQ CHECKCOEFSIGNLIST + (APPEND CHECKCOEFSIGNLIST + (LIST (CONS EXPR + (LIST + (SETQ QUEST (CHECKFLAGANDACT EXPR))))))) + (RETURN QUEST))) + (COND ((EQUAL (CAAR ASLIST) EXPR) (RETURN (CADAR ASLIST)))) + (SETQ ASLIST (CDR ASLIST)) + (GO LOOP))) + +(DEFUN CHECKFLAGANDACT (EXPR) + (COND (PRODUCTCASE + (SETQ PRODUCTCASE NIL) + (FINDSIGNOFTHEIRPRODUCT (FINDSIGNOFACTORS (CDR EXPR)))) + (T (ASKSIGN ($REALPART EXPR))))) + +(DEFUN FINDSIGNOFACTORS (LISTOFACTORS) + (COND ((NULL LISTOFACTORS) NIL) + ((EQ ZEROSIGNTEST '$ZERO) '$ZERO) + (T (APPEND (LIST (SETQ ZEROSIGNTEST (CHECKSIGNTM (CAR LISTOFACTORS)))) + (FINDSIGNOFACTORS (CDR LISTOFACTORS)))))) + +(DEFUN FINDSIGNOFTHEIRPRODUCT (LIST) + (PROG (SIGN) + (COND ((EQ LIST '$ZERO) (RETURN '$ZERO))) + (SETQ SIGN '$POSITIVE) + LOOP (COND ((NULL LIST) (RETURN SIGN))) + (COND ((EQ (CAR LIST) '$POSITIVE) + (SETQ LIST (CDR LIST)) + (GO LOOP))) + (COND ((EQ (CAR LIST) '$NEGATIVE) + (SETQ SIGN (CHANGESIGN SIGN) LIST (CDR LIST)) + (GO LOOP))) + (RETURN '$ZERO))) + +(DEFUN CHANGESIGN (SIGN) + (COND ((EQ SIGN '$POSITIVE) '$NEGATIVE) + (T '$POSITIVE))) + +(DEFUN DEN1 (C B A X) + ((LAMBDA (EXPO EXPR) + (PROG (SIGNDISCRIM SIGNC SIGNB) + (SETQ SIGNC (CHECKSIGNTM (POWER C -1))) + (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (SETQ SIGNDISCRIM (SIGNDIS2 C B A SIGNC SIGNB)) + (COND ((AND (EQ SIGNC '$POSITIVE) + (EQ SIGNDISCRIM '$NEGATIVE)) + (RETURN (AUGMULT (MUL* (POWER C EXPO) + (LIST '(%ASINH) + (MUL EXPR + (POWER (ADD (MUL 4 C A) + (MUL -1 B B)) + EXPO)))))))) + (COND ((AND (EQ SIGNC '$POSITIVE) + (EQ SIGNDISCRIM '$ZERO)) + (RETURN (AUGMULT (MUL* (POWER -1 EXPR) + (POWER C EXPO) + (LIST '(%LOG) EXPR)))))) + (COND ((EQ SIGNC '$POSITIVE) + (RETURN (AUGMULT (MUL* (POWER C EXPO) + (LIST '(%LOG) + (ADD (MUL 2 + (POWER C R12) + (POWER + (POLFOO C B + A X) + R12)) + EXPR))))))) + (COND ((AND (EQ SIGNC '$NEGATIVE) + (EQ SIGNDISCRIM '$POSITIVE)) + (RETURN (AUGMULT (MUL* -1 + (POWER (MUL -1 C) EXPO) + (LIST '(%ASIN) + (MUL EXPR + (POWER (ADD (MUL B B) + (MUL -4 C A)) + EXPO)))))))) + (COND ((EQ SIGNC '$NEGATIVE) + (RETURN (AUGMULT (MUL (POWER -1 EXPO) + (DEN1 (MUL -1 C) + (MUL -1 B) + (MUL -1 A) + X)))))))) + (LIST '(RAT) -1 2) (ADD (MUL 2 C X) B))) + +(DEFUN SIGNDISCR (C B A) + (CHECKSIGNTM (SIMPLIFYA (ADD (POWER B 2) + (MUL -4 C A)) + NIL))) + +(DEFUN ASKINVER (A) + (CHECKSIGNTM (POWER A -1))) + +(DEFUN SIGNDIS1 (C B A) + (COND ((EQUAL (MUL B A) 0) + (COND ((AND (EQUAL B 0)(EQUAL A 0)) '$ZERO) + (T '$NONZERO))) + (T (CHECKSIGNTM (POWER (ADD (MUL B B) (MUL -4 C A)) 2))))) + +(DEFUN SIGNDIS2 (C B A SIGNC SIGNB) + (COND ((EQUAL SIGNB '$ZERO) + (COND ((EQUAL A 0) '$ZERO) + (T ((LAMBDA (ASKINV) + (COND ((OR (AND (EQ SIGNC '$POSITIVE) + (EQ ASKINV '$NEGATIVE)) + (AND (EQ SIGNC '$NEGATIVE) + (EQ ASKINV '$POSITIVE))) + '$POSITIVE) + (T '$NEGATIVE))) + (ASKINVER A))))) + (T (COND ((EQUAL A 0) '$POSITIVE) + (T (SIGNDISCR C B A)))))) + +(DEFUN SIGNDIS3 (C B A SIGNA) + (COND ((EQUAL B 0) + (COND ((EQUAL (CHECKSIGNTM EC-1) SIGNA) '$NEGATIVE) + (T '$POSITIVE))) + (T (SIGNDISCR C B A)))) + +(DEFUN NUMMNUMN (POSZPOWLIST PLUSPOWFO1 P C B A X) + ((LAMBDA (EXPR EXPO EX) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES) + (SETQ RESULT 0 CONTROLPOW (CAAR POSZPOWLIST) + COEF (CADAR POSZPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (NUMN PLUSPOWFO1 C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (ADD (AUGMULT (MUL EXPR EXPO + (POWER (PLUS P P 1) -1))) + (AUGMULT (MUL -1 B R12 EXPO + (NUMN PLUSPOWFO1 C B A X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ RES2 (ADD (AUGMULT (MUL* X EXPR EXPO + (INV (PLUS P P 2)))) + (AUGMULT (MUL* B (PLUS P P 3) + (LIST '(RAT) -1 4) + EX + (INV (PLUS P P P 1 + (TIMES P P) + (TIMES P P))) + EXPR)) + (AUGMULT (MUL (INV (PLUS P 1)) + EX + (LIST '(RAT) 1 8.) + (ADD (MUL (POWER B 2) + (PLUS P P 3)) + (MUL -4 A C)) + (NUMN PLUSPOWFO1 C B A X))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (PRO) + (ADD (AUGMULT (MUL (POWER X (PLUS M -1)) + EXPR EXPO PRO)) + (AUGMULT (MUL -1 B (PLUS P P M M -1) + R12 EXPO PRO RES2)) + (AUGMULT (MUL -1 A (PLUS M -1) + EXPO PRO RES1)))) + (POWER (PLUS M P P) -1))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ POSZPOWLIST (CDR POSZPOWLIST)) + (COND ((NULL POSZPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR POSZPOWLIST)) + (SETQ CONTROLPOW (CAAR POSZPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER (POLFOO C B A X) (ADD P R12)) EC-1 (POWER C -2))) + +(DEFUN NUMN (P C B A X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5) + (COND ((ZEROP P) (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) EXP1 + EXP2 (POWER (POLFOO C B A X) EXP3))) + (AUGMULT (MUL (LIST '(RAT) 1 8) EXP1 EXP4 + (DEN1 C B A X))))) + (T (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) EXP1 EXP5 EXP2 + (POWER (POLFOO C B A X) (ADD P EXP3)))) + (AUGMULT (MUL (LIST '(RAT) 1 8) EXP1 EXP5 (PLUS P P 1) + EXP4 (NUMN (PLUS P -1) C B A X))))))) + EC-1 (ADD B (MUL 2 C X)) R12 + (ADD (MUL 4 A C) (MUL -1 B B)) (LIST '(RAT) 1 (PLUS P 1)))) + +(DEFUN AUGMULT (X) + ($MULTTHRU (SIMPLIFYA X NIL))) + +(DEFUN DENMDENN (NEGPOWLIST P C B A X) + ((LAMBDA (EXP1) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES SIGNA EA-1) + (SETQ SIGNA (CHECKSIGNTM (SIMPLIFYA A NIL))) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NOCONSTQUAD NEGPOWLIST P C B X)))) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) EA-1 (POWER A -1)) + (SETQ COEF (CADAR NEGPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (DEN1DENN P C B A X)) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ RES2 (ADD (AUGMULT (MUL -1 EA-1 (POWER X -1) EXP1)) + (AUGMULT (MUL -1 B (PLUS 1 P P) R12 + EA-1 (DEN1DENN P C B A X))) + (AUGMULT (MUL -2 P C EA-1 (DENN P C B A X))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (EXP2) + (ADD (AUGMULT (MUL EXP2 EA-1 + (POWER X (PLUS 1 (TIMES -1 M))) + EXP1)) + (AUGMULT (MUL B (PLUS P P M M -3) R12 + EA-1 EXP2 RES2)) + (AUGMULT (MUL C EA-1 EXP2 + (PLUS P P M -2) RES1)))) + (SIMPLIFYA (LIST '(RAT) -1 (PLUS M -1)) NIL))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) + CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER (POLFOO C B A X) (ADD R12 (TIMES -1 P))))) + +(DEFUN DENN (P C B A X) + ((LAMBDA (SIGNDISC EXP1 EXP2 EXP3) + (COND ((AND (EQ SIGNDISC '$ZERO)(ZEROP P)) + (AUGMULT (MUL* EC-1 + (LIST '(%LOG) (ADD X (MUL B R12 EC-1 )))))) + ((AND (EQ SIGNDISC '$ZERO)(GREATERP P 0)) + (AUGMULT (MUL* (LIST '(RAT) -1 (PLUS P P)) + (POWER C (MUL (LIST '(RAT) -1 2) + (PLUS P P 1))) + (POWER (ADD X (MUL B R12 EC-1 )) + (TIMES -2 P))))) + ((ZEROP P) (DEN1 C B A X)) + ((EQUAL P 1) + (AUGMULT (MUL 2 EXP1 EXP2 (POWER (POLFOO C B A X) + (LIST '(RAT) -1 2))))) + (T (ADD (AUGMULT (MUL 2 EXP1 EXP3 EXP2 + (POWER (POLFOO C B A X) + (ADD R12 (TIMES -1 P))))) + (AUGMULT (MUL 8 C (PLUS P -1) EXP3 EXP2 + (DENN (PLUS P -1) C B A X))))))) + (SIGNDIS1 C B A) (ADD B (MUL 2 C X)) + (POWER (ADD (MUL 4 A C)(MUL B B -1)) -1) (INV (PLUS P P -1)))) + +(DEFUN DEN1DENN (P C B A X) + ((LAMBDA (SIGNA EA-1) + (COND ((EQ SIGNA '$ZERO)(NOCONSTQUAD 1 P C B X)) + ((ZEROP P) (DEN1DEN1 C B A X)) + (T (ADD (AUGMULT (MUL (INV (PLUS P P -1)) EA-1 + (POWER (POLFOO C B A X) + (ADD R12 (TIMES -1 P))))) + (AUGMULT (MUL EA-1 (DEN1DENN (PLUS P -1) C B A X))) + (AUGMULT (MUL -1 R12 EA-1 B (DENN P C B A X))))))) + (CHECKSIGNTM (POWER A 2)) + (POWER A -1))) + +(DEFUN DEN1DEN1 (C B A X) + ((LAMBDA (EXP2 EXP3 EXP4) + (PROG (SIGNDISCRIM CONDITION SIGNA EXP1) + (SETQ SIGNA (CHECKSIGNTM (SIMPLIFYA A NIL))) + (SETQ CONDITION (ADD (MUL B X) A A)) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NOCONSTQUAD '((1 1)) 0 C B X)))) + (SETQ SIGNDISCRIM (SIGNDIS3 C B A SIGNA) + EXP1 (POWER A (INV -2))) + (COND ((AND (EQ SIGNA '$POSITIVE) + (EQ SIGNDISCRIM '$NEGATIVE)) + (RETURN (MUL* -1 EXP1 + (LIST '(%ASINH) + (AUGMULT (MUL EXP2 EXP3 + (POWER (ADD (MUL 4 A C) + (MUL -1 B B)) + EXP4)))))))) + (COND ((AND (EQ SIGNDISCRIM '$ZERO) + (EQ SIGNA '$POSITIVE)) + (RETURN (MUL* (POWER -1 CONDITION) -1 EXP1 + (LIST '(%LOG) + (AUGMULT (MUL EXP3 EXP2))))))) + (COND ((EQ SIGNA '$POSITIVE) + (RETURN (MUL* -1 EXP1 + (LIST '(%LOG) + (ADD B (MUL 2 A EXP3) + (MUL 2 EXP3 + (POWER A R12) + (POWER (POLFOO C B A X) + R12)))))))) + (COND ((AND (EQ SIGNA '$NEGATIVE) + (EQ SIGNDISCRIM '$POSITIVE)) + (RETURN (MUL* (POWER (MUL -1 A) EXP4) + (LIST '(%ASIN) + (AUGMULT (MUL EXP2 EXP3 + (POWER (ADD (MUL B B) + (MUL -4 A C)) + EXP4)))))))) + (RETURN (MUL -1 (POWER -1 R12) + (DEN1DEN1 (MUL -1 C) (MUL -1 B) (MUL -1 A) X))))) + (ADD (MUL B X) A A) (POWER (LIST '(MABS) X) -1) (LIST '(RAT) -1 2))) + +(DEFUN NOCONSTQUAD (NEGPOWLIST P C B X) + ((LAMBDA (EXP1 EXP2 EXP3) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 SIGNB M PARTRES EB-1) + (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (COND ((EQ SIGNB '$ZERO) + (RETURN (TRIVIAL1 NEGPOWLIST P C X)))) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST) EB-1 (INV B)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B 0 X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (ADD (AUGMULT (MUL -2 EXP1 EB-1 EXP2 + (POWER (POLFOO C B 0 X) + (ADD R12 EXP3)))) + (AUGMULT (MUL -4 P C EXP1 EB-1 (DENN P C B 0 X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ COUNT 3 M 2) + JUMP (SETQ PARTRES (ADD (AUGMULT (MUL -2 (INV (PLUS P P M M -1)) + EB-1 + (POWER X (MUL -1 M)) + (POWER (POLFOO C B 0 X) + (ADD R12 EXP3)))) + (AUGMULT (MUL -2 C (PLUS P P M -1) + EB-1 (INV (PLUS P P M M -1)) RES1)))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP3 (SETQ RES1 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) + CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 3) (GO JUMP3))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (GO JUMP2))) + (INV (PLUS P P 1)) (POWER X -1) (TIMES -1 P))) + +(DEFUN TRIVIAL1 (NEGPOWLIST P C X) + (COND ((NULL NEGPOWLIST) 0) + (T (ADD (AUGMULT (MUL (POWER X + (ADD (TIMES -2 P) + (MUL -1 + (CAAR NEGPOWLIST)))) + (CADAR NEGPOWLIST) + (POWER C + (ADD (TIMES -1 P) + (LIST '(RAT) -1 2))) + (INV (ADD (TIMES -2 P) + (MUL -1 (CAAR NEGPOWLIST)))))) + (TRIVIAL1 (CDR NEGPOWLIST) P C X))))) + +(DEFUN NUMMDENN (POSZPOWLIST P C B A X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5 EXP6 EXP7) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES SIGNDISCRIM) + (SETQ RESULT 0 CONTROLPOW (CAAR POSZPOWLIST)) + (SETQ COEF (CADAR POSZPOWLIST) SIGNDISCRIM (SIGNDIS1 C B A)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 + (ADD (AUGMULT (MUL -1 EC-1 EXP1 EXP2)) + (AUGMULT (MUL B (LIST '(RAT) -1 2) + EC-1 (DENN P C B A X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((AND (GREATERP P 0) + (NOT (EQ SIGNDISCRIM '$ZERO))) + (SETQ RES2 + (ADD (AUGMULT (MUL EC-1 EXP1 EXP3 EXP2 + (ADD (MUL 2 A B) + (MUL 2 B B X) + (MUL -4 A C X)))) + (AUGMULT (MUL EC-1 EXP3 EXP1 + (ADD (MUL 4 A C) + (MUL 2 B B P) + (MUL -3 B B)) + (DENN (PLUS P -1) + C B A X))))))) + (COND ((AND (EQUAL P 0) + (NOT (EQ SIGNDISCRIM '$ZERO))) + (SETQ RES2 + (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) + EXP5 + (ADD (MUL 2 C X) + (MUL -3 B)) + (POWER (POLFOO C B A X) + R12))) + (AUGMULT (MUL (LIST '(RAT) 1 8) + EXP5 + (ADD (MUL 3 B B) + (MUL -4 A C)) + (DEN1 C B A X))))))) + (COND ((AND (EQUAL P 0)(EQ SIGNDISCRIM '$ZERO)) + (SETQ RES2 + (ADD (AUGMULT (MUL* B B (LIST '(RAT) 1 4) + (POWER C -3) + (LIST '(%LOG) EXP4))) + (AUGMULT (MUL EC-1 R12 (POWER EXP4 2))) + (AUGMULT (MUL -1 B X EXP5)))))) + (COND ((AND (EQUAL P 1) (EQ SIGNDISCRIM '$ZERO)) + (SETQ RES2 + (ADD (AUGMULT (MUL* EC-1 (LIST '(%LOG) EXP4))) + (AUGMULT (MUL B EXP5 (POWER EXP4 -1))) + (AUGMULT (MUL (LIST '(RAT) -1 8) + (POWER C -3) + B B (POWER EXP4 -2))))))) + (COND ((AND (EQ SIGNDISCRIM '$ZERO)(GREATERP P 1)) + (SETQ RES2 + (ADD (AUGMULT (MUL EC-1 (POWER EXP4 EXP6) + (INV EXP6))) + (AUGMULT (MUL -1 B EXP5 (INV EXP7) + (POWER EXP4 EXP7))) + (AUGMULT (MUL B B (LIST '(RAT) -1 8) + (POWER C -3) + (INV P) + (POWER EXP4 + (TIMES -2 P)))))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (DENOM PM-1) + (ADD (AUGMULT (MUL* (POWER X PM-1) + EC-1 (LIST '(RAT) -1 DENOM) + (POWER (POLFOO C B A X) + (ADD R12 + (TIMES -1 P))))) + (AUGMULT (MUL B (PLUS P P 1 (TIMES -2 M)) + (LIST '(RAT) -1 2) + EC-1 (INV DENOM) RES2)) + (AUGMULT (MUL A PM-1 EC-1 (INV DENOM) RES1)))) + (PLUS P P (TIMES -1 M)) + (PLUS M -1))) + ON (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (COND ((EQUAL M (PLUS P P)) + (SETQ PARTRES + ((LAMBDA (EXPR) + (ADD (MUL X EXPR) + (MUL -1 (DISTRINT (CDR ($EXPAND EXPR)) + X)))) + (NUMMDENN (LIST (LIST (PLUS M -1) 1)) + P C B A X))) + (GO ON))) + (GO JUMP) + LOOP (SETQ POSZPOWLIST (CDR POSZPOWLIST)) + (COND ((NULL POSZPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR POSZPOWLIST) CONTROLPOW (CAAR POSZPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (INV (PLUS P P -1)) (POWER (POLFOO C B A X) (ADD R12 (TIMES -1 P))) + (POWER (ADD (MUL 4 A C)(MUL -1 B B)) -1) (ADD X (MUL B R12 EC-1)) + (POWER C -2) (PLUS 2 (TIMES -2 P)) (PLUS 1 (TIMES -2 P)))) + +(DEFUN DENMNUMN (NEGPOWLIST POW C B A X) + ((LAMBDA (EXP1 EXP2) + (PROG (RESULT CONTROLPOW P COEF COUNT RES1 RES2 M + PARTRES SIGNA EA-1) + (SETQ P (PLUS POW POW -1)) + (COND ((EQ (CAR NEGPOWLIST) 'T) + (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (GO THERE))) + (SETQ SIGNA (CHECKSIGNTM (POWER A 2))) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NONCONSTQUADENUM NEGPOWLIST P C B X)))) + (SETQ EA-1 (INV A)) + THERE (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF + (NUMN (ADD (MUL P R12) R12) + C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (DEN1NUMN POW C B A X)) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((NOT (EQUAL P 1)) + (SETQ RES2 (ADD (AUGMULT (MUL -1 EXP1 + (POWER (POLFOO C B A X) + (ADD POW + (LIST '(RAT) -1 2))))) + (AUGMULT (MUL B (LIST '(RAT) EXP2 2) + (DEN1NUMN (PLUS POW -1) + C B A X))) + (AUGMULT (MUL C EXP2 (NUMN (PLUS POW -2) + C B A X))))))) + (COND ((EQUAL P 1) + (SETQ RES2 (ADD (AUGMULT (MUL -1 (POWER (POLFOO C B A X) + R12) + EXP1)) + (AUGMULT (MUL B R12 (DEN1DEN1 C B A X))) + (AUGMULT (MUL C (DEN1 C B A X))))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (EXP3 EXP4) + (ADD (AUGMULT (MUL* (LIST '(RAT) -1 EXP3) + EA-1 (POWER X (PLUS 1 EXP4)) + (POWER (POLFOO C B A X) + (ADD (LIST '(RAT) P 2) + 1)))) + (AUGMULT (MUL (INV (PLUS M M -2)) + EA-1 B (PLUS P 4 (TIMES -2 M)) + RES2)) + (AUGMULT (MUL C EA-1 (PLUS P 3 EXP4) + (INV EXP3) RES1)))) + (PLUS M -1) (TIMES -1 M)) + M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER X -1) (PLUS POW POW -1))) + +(DEFUN NONCONSTQUADENUM (NEGPOWLIST P C B X) + (PROG (RESULT COEF M) + (COND ((EQUAL P 1)(RETURN (CASE1 NEGPOWLIST C B X)))) + (SETQ RESULT 0) + LOOP (SETQ M (CAAR NEGPOWLIST) COEF (CADAR NEGPOWLIST)) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF (CASEGEN M P C B X)))) + NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (GO LOOP))) + +(DEFUN CASEGEN (M P C B X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5) + (COND ((EQUAL P 1) (CASE1 (LIST (LIST M 1)) C B X)) + ((ZEROP M) (CASE0 P C B X)) + ((EQUAL M (PLUS P 1)) + (ADD (AUGMULT (MUL -1 EXP1 (INV EXP2) EXP3)) + (AUGMULT (MUL B R12 (CASEGEN EXP2 EXP4 C B X))) + (AUGMULT (MUL C (CASEGEN (PLUS M -2) EXP4 C B X))))) + ((EQUAL M 1) (ADD (AUGMULT (MUL (INV P) EXP1)) + (AUGMULT (MUL B R12 (CASE0 EXP4 C B X))))) + (T (ADD (AUGMULT (MUL -1 EXP1 (INV EXP5) EXP3)) + (AUGMULT (MUL -1 P B R12 (INV EXP5) + (CASEGEN EXP2 EXP4 C B X))))))) + (POWER (POLFOO C B 0 X)(LIST '(RAT) P 2)) + (PLUS M -1) + (POWER X (PLUS 1 (TIMES -1 M))) + (PLUS P -2) + (PLUS M -1 (TIMES -1 P)))) + +(DEFUN CASE1 (NEGPOWLIST C B X) + ((LAMBDA (EXP1 EB-1) + (PROG (RESULT CONTROLPOW M1 COEF COUNT RES1 RES2 M SIGNC + SIGNB PARTRES RES) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST) M1 (PLUS CONTROLPOW -2)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (CASE0 1 C B X))) + COUNT 1) + (GO LOOP))) + JUMP1 (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT + (ADD RESULT + (AUGMULT (MUL COEF (DEN1NUMN 1 C B 0 X)))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT + (ADD RESULT + (AUGMULT (MUL COEF + (DENMNUMN '(T (2 1)) + 1 C B 0 X)))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (COND ((EQ SIGNB '$ZERO)(SETQ COUNT 5)(GO JUMP5))) + (SETQ COUNT 4 M 0 SIGNC (CHECKSIGNTM EC-1)) + (COND ((EQ SIGNC '$POSITIVE) + (SETQ RES + (AUGMULT (MUL* 2 EXP1 + (LIST '(%LOG) + (ADD (POWER (MUL C X) + R12) + (POWER (ADD B + (MUL C X)) + R12)))))) + (GO JUMP4))) + (SETQ RES + (AUGMULT (MUL* 2 EXP1 + (LIST '(%ATAN) + (POWER (MUL C X + (POWER (ADD B + (MUL -1 C X)) + -1)) + R12))))) + JUMP4 (SETQ M (PLUS M 1) + RES (ADD (AUGMULT (MUL -2 (POWER (POLFOO C B 0 X) R12) + EB-1 (INV (PMM-1 M)) + (EXT-1M X M))) + (AUGMULT (MUL* (LIST '(RAT) -2 (PMM-1 M)) + C (SUB1 M) + EB-1 RES)))) + (COND ((EQUAL M M1) (SETQ RES2 RES) (GO JUMP4))) + (COND ((EQUAL (SUB1 M) M1) + (IF (NULL RES2) (RETURN NIL)) + (SETQ RES1 RES + PARTRES (ADD (AUGMULT (MUL -1 + (POWER (POLFOO C B 0 X) + R12) + (R1M M) + (EXT-1M X M))) + (AUGMULT (MUL B R12 (R1M M) RES1)) + (AUGMULT (MUL C (R1M M) RES2)))) + (GO ON))) + (GO JUMP4) + JUMP5 (SETQ M CONTROLPOW) + (COND ((ZEROP M) + (SETQ PARTRES (MUL* EXP1 (LIST '(%LOG) X))) + (GO ON))) + (SETQ PARTRES (MUL -1 EXP1 (EXT-1M X M) (R1M M))) + ON (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 5) (GO JUMP5))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (COND ((EQUAL COUNT 3) (GO JUMP3))) + (SETQ M1 (PLUS CONTROLPOW -2)) + (COND ((EQUAL M1 M) (SETQ RES2 RES1))) + (GO JUMP4))) + (POWER C (LIST '(RAT) -1 2)) (POWER B -1))) + +(DEFUN PMM-1 (M) (PLUS M M -1)) + +(DEFUN R1M (M) (LIST '(RAT) 1 M)) + +(DEFUN EXT-1M (X M) (POWER X (TIMES -1 M))) + +(DEFUN CASE0 (POWER C B X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EB-1) + (PROG (SIGNC P RESULT) + (SETQ SIGNC (CHECKSIGNTM EC-1) P 1) + (COND ((EQ SIGNC '$POSITIVE) + (SETQ RESULT + (ADD (AUGMULT (MUL EXP1 EC-1 EXP2 + (POWER (POLFOO C B 0 X) + R12))) + (AUGMULT (MUL* B B (LIST '(RAT) -1 8) + EXP3 + (LIST '(%LOG) + (ADD EXP2 + (MUL 2 + (POWER C R12) + (POWER + (POLFOO C B 0 X) + R12)))))))))) + (COND ((EQ SIGNC '$NEGATIVE) + (SETQ RESULT + (ADD (AUGMULT (MUL EXP1 EC-1 EXP4 + (POWER (POLFOO (MUL -1 C) + B 0 X) + R12))) + (AUGMULT (MUL* B B (LIST '(RAT) 1 8) + EXP3 + (LIST '(%ASIN) + (MUL EB-1 EXP4)))))))) + LOOP (COND ((EQUAL POWER P) (RETURN RESULT))) + (SETQ P (PLUS P 2) + RESULT ((LAMBDA (EXP5) + (ADD (AUGMULT (MUL R12 EC-1 EXP5 EXP2 + (POWER (POLFOO C B 0 X) + (LIST '(RAT) P 2)))) + (AUGMULT (MUL P B B (LIST '(RAT) -1 4) + EC-1 EXP5 RESULT)))) + (INV (PLUS P 1)))) + (GO LOOP))) + (LIST '(RAT) 1 4) (ADD B (MUL 2 C X)) (POWER C (LIST '(RAT) -3 2)) + (ADD (MUL 2 C X)(MUL -1 B)) (POWER B -1))) + +(DEFUN DEN1NUMN (P C B A X) + (COND ((EQUAL P 1) + (ADD (POWER (POLFOO C B A X) R12 ) + (AUGMULT (MUL A (DEN1DEN1 C B A X))) + (AUGMULT (MUL B R12 (DEN1 C B A X))))) + (T (ADD (AUGMULT (MUL (POWER (POLFOO C B A X) + (ADD P (LIST '(RAT) -1 2))) + (INV (PLUS P P -1)))) + (AUGMULT (MUL A (DEN1NUMN (PLUS P -1) C B A X))) + (AUGMULT (MUL B R12 (NUMN (PLUS P -2) C B A X))))))) + +(DEFUN DISTRINT (EXPR X) + (COND ((NULL EXPR) 0) + (T (ADD (INTIRA (CAR EXPR) X) + (DISTRINT (CDR EXPR) X))))) diff --git a/src/maxsrc/inmis.98 b/src/maxsrc/inmis.98 new file mode 100644 index 00000000..7ef7f1c3 --- /dev/null +++ b/src/maxsrc/inmis.98 @@ -0,0 +1,90 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module inmis) + +(DEFMVAR $LISTCONSTVARS NIL + "Causes LISTOFVARS to include %E, %PI, %I, and any variables declared + constant in the list it returns if they appear in exp. The default is + to omit these." BOOLEAN SEE-ALSO $LISTOFVARS) + +(DECLARE (SPECIAL LISTOFVARS)) + +(SETQ $COMBINEFLAG NIL $POLYFACTOR NIL) + +(DEFMFUN $UNKNOWN (F) (*CATCH NIL (UNKNOWN (MRATCHECK F)))) + +(DEFUN UNKNOWN (F) + (AND (NOT (MAPATOM F)) + (COND ((AND (EQ (CAAR F) 'MQAPPLY) + (NOT (GET (CAAADR F) 'SPECSIMP))) + (*THROW NIL T)) + ((NOT (GET (CAAR F) 'OPERATORS)) (*THROW NIL T)) + (T (MAPC 'UNKNOWN (CDR F)) NIL)))) + +(DEFMFUN $LISTOFVARS (E) + ((LAMBDA (LISTOFVARS) + (COND (($RATP E) + (AND (MEMQ 'TRUNC (CDDAR E)) + (SETQ E ($TAYTORAT E))) + (SETQ E + (CONS '(MLIST) + (SUBLIS (MAPCAR 'CONS + (CAR (CDDDAR E)) + ;;GENSYMLIST + (CADDAR E)) + ;;VARLIST + (UNION* (LISTOVARS (CADR E)) + (LISTOVARS (CDDR E)))))))) + (ATOMVARS E) + LISTOFVARS) + (LIST '(MLIST)))) + +(DEFUN ATOMVARS (E) + (COND ((AND (EQ (TYPEP E) 'SYMBOL) + (OR $LISTCONSTVARS (NOT ($CONSTANTP E)))) + (ADD2LNC E LISTOFVARS)) + ((ATOM E)) + ((EQ (CAAR E) 'MRAT) (ATOMVARS (RATDISREP E))) + ((MEMQ 'ARRAY (CAR E)) (MYADD2LNC E LISTOFVARS)) + (T (MAPC 'ATOMVARS (CDR E))))) + +(DEFUN MYADD2LNC (ITEM LIST) + (AND (NOT (MEMALIKE ITEM LIST)) (NCONC LIST (NCONS ITEM)))) + +;; Reset the settings of all Macsyma user-level switches to their initial +;; values. + +#+ITS +(DEFMFUN $RESET NIL + (load '((DSK MACSYM) RESET FASL)) + '$DONE) + +#+Multics +(DEFMFUN $RESET () + (LOAD (EXECUTABLE-DIR "RESET")) + '$DONE) + +#+NIL +(DEFMFUN $REST () + (LOAD "[MACSYMA]RESET")) + +;; Please do not use the following version on MC without consulting with me. +;; I already fixed several bugs in it, but the +ITS version works fine on MC +;; and takes less address space. - JPG +(DECLARE (SPECIAL MODULUS $FPPREC)) +#-(or ITS Multics NIL) ;This version should be eventually used on Multics. +(DEFMFUN $RESET () + (SETQ BASE 10. IBASE 10. *NOPOINT T MODULUS NIL ZUNDERFLOW T) + ($DEBUGMODE NIL) + (COND ((NOT (= $FPPREC 16.)) ($FPPREC 16.) (SETQ $FPPREC 16.))) + #+GC ($DSKGC NIL) + (LOAD #+PDP10 '((ALJABR) INIT RESET) + #+Lispm "MC:ALJABR;INIT RESET" + #+Multics (executable-dir "init_reset") + #+Unix ???) + ;; *** This can be flushed when all Macsyma user-switches are defined + ;; *** with DEFMVAR. This is part of an older mechanism. + #+PDP10 (LOAD '((MACSYM) RESET FASL)) + '$DONE) diff --git a/src/maxsrc/intpol.13 b/src/maxsrc/intpol.13 new file mode 100644 index 00000000..e1d2af95 --- /dev/null +++ b/src/maxsrc/intpol.13 @@ -0,0 +1,107 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Interpolation routine by CFFK. + +(macsyma-module intpol) +(load-macsyma-macros transm numerm) + +(declare (special $intpolrel $intpolabs $intpolerror) + (flonum $intpolrel $intpolabs a b c fa fb fc) + (fixnum lin) + (notype (interpolate-check flonum flonum flonum flonum))) + +(COMMENT | For historical information ONLY. | +(defun fmeval2 (x) + (cond ((fixp (setq x (meval x))) (float x)) + ((floatp x) x) + (t (displa x) (error '|not floating point|)))) +(defun qeval (y x z) (cond (x (fmeval2 (list '($ev) y (list '(mequal) x z) '$numer))) + (t (funcall y z)))) +) + +(or (boundp '$intpolabs) (setq $intpolabs 0.0)) +(or (boundp '$intpolrel) (setq $intpolrel 0.0)) +(or (boundp '$intpolerror) (setq $intpolerror t)) + +(Defun $interpolate_SUBR (F LEFT RIGHT) + (BIND-TRAMP1$ + F F + (prog (a b c fa fb fc lin) + (declare (flonum a b c fa fb fc) (fixnum lin)) + (setq A (FLOAT LEFT) + B (FLOAT RIGHT)) + (or (> b a) (setq a (prog2 niL b (setq b a)))) + (setq fa (FCALL$ f a) + fb (FCALL$ f b)) + (or (> (abs fa) $intpolabs) (return a)) + (or (> (abs fb) $intpolabs) (return b)) + (and (> (*$ fa fb) 0.0) + (cond ((eq $intpolerror t) + (merror "function has same sign at endpoints~%~M" + `((mlist) + ((mequal) ((f) ,a) ,fa) + ((mequal) ((f) ,b) ,fb)))) + (t (return $intpolerror)))) + (and (> fa 0.0) + (setq fa (prog2 nil fb (setq fb fa)) a (prog2 nil b (setq b a)))) + (setq lin 0.) + binary + (setq c (//$ (+$ a b) 2.0) + fc + (FCALL$ f c)) + (and (interpolate-check a c b fc) (return c)) + (cond ((< (abs (-$ fc (//$ (+$ fa fb) 2.0))) (*$ 0.1 (-$ fb fa))) + (setq lin (1+ lin))) + (t (setq lin 0.))) + (cond ((> fc 0.0) (setq fb fc b c)) (t (setq fa fc a c))) + (or (= lin 3.) (go binary)) + falsi + (setq c (cond ((> (+$ fb fa) 0.0) + (+$ a (*$ (-$ b a) (//$ fa (-$ fa fb))))) + (t (+$ b (*$ (-$ a b) (//$ fb (-$ fb fa)))))) + fc (FCALL$ f c)) + (and (interpolate-check a c b fc) (return c)) + (cond ((> fc 0.0) (setq fb fc b c)) (t (setq fa fc a c))) + (go falsi)))) + +(defun interpolate-check (a c b fc) + (not (and (prog2 nil (> (abs fc) $intpolabs) (setq fc (max (abs a) (abs b)))) + (> (abs (-$ b c)) (*$ $intpolrel fc)) + (> (abs (-$ c a)) (*$ $intpolrel fc))))) + + + + +(DEFUN INTERPOLATE-MACRO (FORM TRANSLP) + (SETQ FORM (CDR FORM)) + (COND ((= (LENGTH FORM) 3) + (COND (TRANSLP + `(($INTERPOLATE_SUBR) ,@FORM)) + (T + `((MPROG) ((MLIST) ((msetq) $NUMER T)) + (($INTERPOLATE_SUBR) ,@FORM))))) + ((= (LENGTH FORM) 4) + (LET (((EXP VAR . BNDS) FORM)) + (SETQ EXP (SUB ($LHS EXP) ($RHS EXP))) + (COND (TRANSLP + `(($INTERPOLATE_SUBR) + ((LAMBDA-I) ((MLIST) ,VAR) + (($MODEDECLARE) ,VAR $FLOAT) + ,EXP) + ,@BNDS)) + (T + `((MPROG) ((MLIST) ((msetq) $NUMER T)) + (($INTERPOLATE_SUBR) + ((LAMBDA) ((MLIST) ,VAR) ,EXP) + ,@BNDS)))))) + (T (merror "wrong number of args to INTERPOLATE")))) + +(DEFMSPEC $INTERPOLATE (FORM) + (MEVAL (INTERPOLATE-MACRO FORM NIL))) + +(def-translate-property $INTERPOLATE (FORM) + (let (($tr_numer t)) + (TRANSLATE (INTERPOLATE-MACRO FORM t)))) + + diff --git a/src/maxsrc/irinte.1 b/src/maxsrc/irinte.1 new file mode 100644 index 00000000..69ee12b5 --- /dev/null +++ b/src/maxsrc/irinte.1 @@ -0,0 +1,1155 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module irinte) +(load-macsyma-macros rzmac) + +(DECLARE (SPECIAL CHECKCOEFSIGNLIST EC-1 R12 1//2 VAR GLOBALCAREFLAG + ZEROSIGNTEST PRODUCTCASE $RADEXPAND)) + +(DEFUN HASVAR (EXP) (NOT (FREEVAR EXP))) + +(DEFUN ZERP (A) (EQUAL A 0)) + +(DEFUN INTEGERPFR (A) (IF (NOT (INTEGERP A)) (INTEGERP1 A))) + +(DEFUN NONZERP (A) (NOT (EQUAL A 0))) + +(DEFUN FREEVNZ (A) (AND (FREEVAR A) (NOT (EQUAL A 0)))) + +(DEFUN INTE (FUNCT X) + (PROG (CHECKCOEFSIGNLIST GLOBALCAREFLAG $RADEXPAND) + (SETQ $RADEXPAND T) + (RETURN (INTIR-REF FUNCT X)))) + +(DEFUN INTIR-REF (FUN X) + (PROG (A) + (COND ((SETQ A (INTIR1 FUN X))(RETURN A))) + (COND ((SETQ A (INTIR2 FUN X))(RETURN A))) + (RETURN (INTIR3 FUN X)))) + +(DEFUN INTIR1 (FUN X) + (PROG (ASSOCLIST E0 R0 E1 E2 R1 R2 D P) + (SETQ ASSOCLIST (FACTPOW (SPECREPCHECK FUN) X)) + (SETQ E1 (CDRAS 'E1 ASSOCLIST) E2 (CDRAS 'E2 ASSOCLIST)) + (COND ((NULL ASSOCLIST)(RETURN NIL))) + (SETQ D (CDRAS 'D ASSOCLIST) P (CDRAS 'P ASSOCLIST) + E0 (CDRAS 'E0 ASSOCLIST) R0 (CDRAS 'R0 ASSOCLIST) + R1 (CDRAS 'R1 ASSOCLIST) R2 (CDRAS 'R2 ASSOCLIST)) + (COND ((FLOATP E0)(SETQ E0 (RDIS (RATION1 E0))))) + (COND ((FLOATP E1)(SETQ E1 (RDIS (RATION1 E1))))) + (COND ((FLOATP E2)(SETQ E2 (RDIS (RATION1 E2))))) + (RETURN (INTIR1-REF D P R0 E0 R1 E1 R2 E2 X)))) + +(DEFUN INTIR2 (FUNCT X) + (PROG (RES) + (COND ((SETQ RES (INTIR FUNCT X))(RETURN RES))) + (RETURN (INTIRFACTOROOT FUNCT X)))) + +(DEFUN INTIR3 (EXP X) + (PROG (ASSOCLIST E F G R0) + (COND ((SETQ ASSOCLIST (ELLIPTQUAD EXP X)) + (SETQ E (CDRAS 'E ASSOCLIST) F (CDRAS 'F ASSOCLIST) + G (CDRAS 'G ASSOCLIST) R0 (CDRAS 'R0 ASSOCLIST)) + (ASSUME `(($NOTEQUAL) ,E 0)) + (RETURN (INTIR3-R0TEST ASSOCLIST X E F G R0)))) + (RETURN NIL))) + +(DEFUN INTIR3-R0TEST (ASSOCLIST X E F G R0) + (COND ((ROOT+ANYTHING R0 X) NIL) + (T (INTIR3-REF ASSOCLIST X E F G R0)))) + +(DEFUN INTIR1-REF (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((AND (PLUSP NUME1)(PLUSP NUME2)) + (PP-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + ((AND (MINUSP NUME1)(MINUSP NUME2)) + (MM-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + ((PLUSP NUME1)(PM-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + (T (PM-INTIR1 D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN PP-INTIR1 (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((GREATERP NUME1 NUME2)(PP-INTIR1-EXEC D P R0 E0 R1 E1 R2 E2 X)) + (T (PP-INTIR1-EXEC D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN MM-INTIR1 (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((GREATERP NUME1 NUME2)(MM-INTIR1-EXEC D P R0 E0 R1 E1 R2 E2 X)) + (T (MM-INTIR1-EXEC D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN PM-INTIR1 (D P R0 E0 ROFPOS EPOS ROFNEG ENEG X) + ((LAMBDA (NUMEPOS NUMUL-1ENEG) + (COND ((GREATERP NUMEPOS NUMUL-1ENEG) + (MM-INTIR1 D (MUL P (POWER ROFPOS (SUB EPOS ENEG))) + R0 E0 ROFPOS ENEG ROFNEG ENEG X)) + ((OR (EQUAL E0 0) (PLUSP E0)) + (PP-INTIR1 D (MUL P (POWER ROFNEG (SUB ENEG EPOS))) + R0 E0 ROFPOS EPOS ROFNEG EPOS X)) + (T (MM-INTIR1 D (MUL P (POWER ROFPOS (SUB EPOS ENEG))) + R0 E0 ROFPOS ENEG ROFNEG ENEG X)))) + (CADR EPOS) + (MUL -1 (CADR ENEG)))) + +(DEFUN PP-INTIR1-EXEC (D P R0 E0 ROFMAX EMAX ROFMIN EMIN X) + (INTIR (MUL D P (COND ((EQUAL E0 0) 1) (T (POWER R0 E0))) + (POWER ROFMAX (ADD EMAX (MUL -1 EMIN))) + (POWER ($EXPAND (MUL ROFMAX ROFMIN)) EMIN)) X)) + +(DEFUN MM-INTIR1-EXEC (D P R0 E0 ROFMIN EMIN ROFMAX EMAX X) + (INTIR (MUL D P (COND ((EQUAL E0 0) 1) (T (POWER R0 E0))) + (POWER ROFMAX (ADD EMAX (MUL -1 EMIN))) + (POWER ($EXPAND (MUL ROFMAX ROFMIN)) EMIN)) X)) + +(DEFUN INTIR3-REF (ASSOCLIST X E F G R0) + ((LAMBDA (SIGNDISC D P E0) + (COND ((OR (EQ SIGNDISC '$POSITIVE)(EQ SIGNDISC '$NEGATIVE)) + (PNS-INTIR3 X E F G D P R0 E0)) + (T (ZS-INTIR3 X E F D P R0 E0)))) + (SIGNDISCR E F G) + (CDRAS 'D ASSOCLIST) + (CDRAS 'P ASSOCLIST) + (CDRAS 'E0 ASSOCLIST))) + +(DEFUN ROOT+ANYTHING (EXP VAR) + (M2 EXP '((MPLUS) ((COEFFPT) (C NONZERP) ((MEXPT) (U HASVAR) (V INTEGERPFR))) + ((COEFFPP)(C TRUE))) NIL)) + +(DEFUN PNS-INTIR3 (X E F G D P R0 E0) + ((LAMBDA (DISCR) + ((LAMBDA (P*R0^E0 2*E*X+F 2*E*D*INVDISC) + (MUL (SUB (INTIR2 (MUL 2*E*D*INVDISC + (INV (SUB 2*E*X+F DISCR)) + P*R0^E0) + X) + (INTIR2 (MUL 2*E*D*INVDISC + (INV (ADD 2*E*X+F DISCR)) + P*R0^E0) + X)))) + (MUL P (POWER R0 E0)) + (ADD (MUL 2 E X) F) + (MUL 2 E D (INV DISCR)))) + (POWER (SUB (MUL F F)(MUL 4 E G)) (INV 2)))) + +(DEFUN ZS-INTIR3 (X E F D P R0 E0) + (INTIR2 (MUL D P E + (POWER (ADD X (DIV F (ADD E E))) -2) (POWER R0 E0)) + X)) + +(DEFUN CDRAS (A B) + (CDR (ASSOC A B))) + +(DEFUN INTIR (FUNCT X) + (PROG (ASSOCLIST) + (SETQ ASSOCLIST (JMAUG (SPECREPCHECK FUNCT) X)) + (RETURN (INTI FUNCT X ASSOCLIST)))) + +(DEFUN INTI (FUNCT X ASSOCLIST) + (PROG (MET N EXPR F E DENOM) + (SETQ N (CDRAS 'N ASSOCLIST)) + (COND ((OR (NULL ASSOCLIST) (INTEGERP N)) + (RETURN NIL))) + (SETQ F (CDRAS 'F ASSOCLIST) E (CDRAS 'E ASSOCLIST)) + (COND ((OR (EQUAL E 0) (NULL E)) + (RETURN (INTIRA FUNCT X)))) + (COND ((NOT (NUMBERP F)) (GO JUMP))) + (COND ((PLUSP F)(GO JUMP))) + (SETQ DENOM (ADD (MUL F X) E) F (MUL -1 F) E (MUL -1 E) + FUNCT (MUL -1 (DIV (MEVAL (MUL DENOM FUNCT))(ADD (MUL F X) E)))) + JUMP (SETQ EXPR + (MUL (POWER F -1) + (INTIRA (DISTREXPANDROOT + (CDR ($SUBSTITUTE (MUL (POWER F -1) + (ADD (SETQ MET (GENSYM 'YANNIS)) + (MUL -1 E))) + X FUNCT))) + MET))) + (RETURN ($EXPAND ($SUBSTITUTE (ADD (MUL F X) E) MET EXPR))))) + +(DEFUN DISTREXPANDROOT (EXPR) + (COND ((NULL EXPR) 1) + (T (MUL (EXPANDROOT (CAR EXPR)) + (DISTREXPANDROOT (CDR EXPR)))))) + +(DEFUN EXPANDROOT (EXPR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (INTEGERPFR (CADDR EXPR))) + ($EXPAND EXPR)) + (T EXPR))))) + +(DEFUN INTIRFACTOROOT (EXPR X) + (PROG (ASSOCLIST EXP) + (SETQ EXP EXPR) + (COND ((SETQ ASSOCLIST (JMAUG (SETQ EXPR (DISTRFACTOR (TIMESTEST EXPR) X)) X)) + (RETURN (INTI EXPR X ASSOCLIST)))) + (SETQ GLOBALCAREFLAG 'T) + (COND ((SETQ ASSOCLIST (JMAUG (SETQ EXP (DISTRFACTOR (TIMESTEST EXP) X)) X)) + (SETQ GLOBALCAREFLAG NIL) + (RETURN (INTI EXP X ASSOCLIST)))) + (SETQ GLOBALCAREFLAG NIL) + (RETURN NIL))) + +(DEFUN DISTRFACTOR (EXPR X) + (COND ((NULL EXPR) 1) + (T (MUL (FACTOROOT (CAR EXPR) X) + (DISTRFACTOR (CDR EXPR) X))))) + +(DEFUN FACTOROOT (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (HASVAR EXPR) + (INTEGERPFR (CADDR EXPR))) + (CAREFULFACTOR EXPR VAR)) + (T EXPR))))) + +(DEFUN CAREFULFACTOR (EXPR X) + (COND ((NULL GLOBALCAREFLAG)($FACTOR EXPR)) + (T (RESTOREX ($FACTOR (POWER (DIV (CADR EXPR) X) (CADDR EXPR))) X)))) + +(DEFUN RESTOREX (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((EQ (CAAR EXPR) 'MTIMES) + (DISTRESTOREX (CDR EXPR) VAR)) + (T EXPR))))) + +(DEFUN DISTRESTOREX (EXPR VAR) + (COND ((NULL EXPR) 1) + (T (MUL (RESTOROOT (CAR EXPR) VAR) + (DISTRESTOREX (CDR EXPR) VAR))))) + +(DEFUN RESTOROOT (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (INTEGERPFR (CADDR EXPR)) + (MPLUSP (CADR EXPR))) + (POWER ($EXPAND (MUL VAR (CADR EXPR))) (CADDR EXPR))) + (T EXPR))))) + +(DEFUN TIMESTEST (EXPR) + (COND ((ATOM EXPR)(LIST EXPR)) + (T (COND ((EQ (CAAR EXPR) 'MTIMES)(CDR EXPR)) + (T (LIST EXPR)))))) + +(DEFUN INTIRA (FUNCT X) + (PROG (A B C EC-1 D M N ASSOCLIST PLUSPOWFO1 PLUSPOWFO2 MINUSPOWFO + POLFACT SIGNN POSZPOWLIST NEGPOWLIST R12) + (SETQ ASSOCLIST (JMAUG (SPECREPCHECK FUNCT) X)) + (SETQ N (CDRAS 'N ASSOCLIST) R12 1//2) + (COND ((OR (NULL ASSOCLIST) (INTEGERP N))(RETURN NIL))) + (COND ((FLOATP N)(SETQ N (RDIS (RATION1 N))))) + (SETQ D (CDRAS 'D ASSOCLIST)) + (COND ((EQUAL D 0) (RETURN 0))) + (SETQ C (CDRAS 'A ASSOCLIST)) + (IF (EQUAL C 0) (RETURN NIL)) + (SETQ M (CDRAS 'M ASSOCLIST) POLFACT (CDRAS 'P ASSOCLIST) N (CADR N) + SIGNN (CHECKSIGNTM N) EC-1 (POWER C -1) + B (CDRAS 'B ASSOCLIST) A (CDRAS 'C ASSOCLIST) + PLUSPOWFO1 (MUL R12 (PLUS N -1)) + MINUSPOWFO (MUL R12 (PLUS N 1)) + PLUSPOWFO2 (TIMES -1 MINUSPOWFO) + POSZPOWLIST (CAR (POWERCOEFLIST POLFACT M X)) + NEGPOWLIST (CADR (POWERCOEFLIST POLFACT M X))) + (COND ((AND (NULL NEGPOWLIST)(NOT (NULL POSZPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (AUGMULT (MUL D + (NUMMNUMN POSZPOWLIST + PLUSPOWFO1 + MINUSPOWFO C B A X)))))) + (RETURN (AUGMULT (MUL D + (NUMMDENN POSZPOWLIST + PLUSPOWFO2 C B A X)))))) + (COND ((AND (NULL POSZPOWLIST)(NOT (NULL NEGPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (AUGMULT (MUL D + (DENMNUMN NEGPOWLIST + MINUSPOWFO C B A X)))))) + (RETURN (AUGMULT (MUL D + (DENMDENN NEGPOWLIST + PLUSPOWFO2 C B A X)))))) + (COND ((AND (NOT (NULL NEGPOWLIST)) (NOT (NULL POSZPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (ADD (AUGMULT (MUL D + (NUMMNUMN POSZPOWLIST + PLUSPOWFO1 + MINUSPOWFO C B A X))) + (AUGMULT (MUL D + (DENMNUMN NEGPOWLIST + MINUSPOWFO C B A X))))))) + (RETURN (ADD (AUGMULT (MUL D + (NUMMDENN POSZPOWLIST + PLUSPOWFO2 C B A X))) + (AUGMULT (MUL D + (DENMDENN NEGPOWLIST + PLUSPOWFO2 C B A X))))))))) + +(DEFUN JMAUG (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT)(P POLYP)) + ((MEXPT) ((MPLUS) ((COEFFPT)(F FREEVAR)(X VARP)) + ((COEFFPP)(E FREEVAR))) + (M INTEGERP)) + ((MEXPT) ((MPLUS) ((COEFFPT) (A FREEVAR) ((MEXPT) (X VARP) 2)) + ((COEFFPT) (B FREEVAR)(X VARP)) + ((COEFFPP) (C FREEVAR))) + (N INTEGERP1))) + NIL)) + +(DEFUN FACTPOW (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT) (P POLYP)) + ((MEXPT) (R1 HASVAR) + (E1 INTEGERPFR)) + ((MEXPT) (R2 HASVAR) + (E2 INTEGERPFR)) + ((MEXPT) (R0 HASVAR) + (E0 INTEGERP))) + NIL)) + +(DEFUN ELLIPTQUAD (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT) (P POLYP)) + ((MEXPT) ((MPLUS) ((COEFFPT) (E FREEVNZ) ((MEXPT) (X VARP) 2)) + ((COEFFPT) (F FREEVAR) (X VARP)) + ((COEFFPP) (G FREEVAR))) + -1) + ((MEXPT) (R0 HASVAR) + (E0 INTEGERPFR))) + NIL)) + +(DEFUN POLFOO (C B A X) + (ADD (MUL C X X) + (MUL B X) + A)) + +(DEFUN POWERCOEFLIST (FUN M VAR) + (PROG (EXPANFUN MAXPOWFUN POWFUN COEF POSZPOWLIST NEGPOWLIST) + (SETQ EXPANFUN (UNQUOTE ($EXPAND (MUL (PREVCONSTEXPAN FUN VAR) + (POWER VAR M))))) + (COND ((AND (EQUAL FUN 1) (GREATERP M 0)) + (RETURN (CONS NIL (LIST (LIST (CONS M (LIST 1)))))))) + (COND ((AND (EQUAL FUN 1)(LESSP M 0)) + (RETURN (CONS NIL (LIST (LIST (CONS (TIMES -1 M ) (LIST 1)))))))) + (COND ((EQUAL EXPANFUN 1) + (RETURN (CONS (LIST (CONS 0 (LIST 1))) + (LIST NIL))))) + (SETQ MAXPOWFUN ($HIPOW EXPANFUN VAR) + POWFUN ($LOPOW EXPANFUN VAR)) + LOOP (SETQ COEF ($COEFF EXPANFUN (POWER VAR POWFUN))) + (COND ((NUMBERP COEF) (GO TESTJUMP))) + (GO NOJUMP) + TESTJUMP (COND ((AND (NOT (ZEROP POWFUN)) (ZEROP COEF)) + (GO JUMP))) + NOJUMP (COND ((GREATERP POWFUN 0) + (SETQ POSZPOWLIST (APPEND POSZPOWLIST + (LIST (CONS POWFUN (LIST COEF))))))) + (COND ((ZEROP POWFUN) + (SETQ POSZPOWLIST + (APPEND POSZPOWLIST + (LIST (CONS 0 (LIST (CONSTERM (CDR EXPANFUN) VAR)))))))) + (COND ((LESSP POWFUN 0) + (SETQ NEGPOWLIST (APPEND NEGPOWLIST + (LIST (CONS (TIMES -1 POWFUN)(LIST COEF))))))) + (COND ((EQUAL POWFUN MAXPOWFUN) + (RETURN (LIST POSZPOWLIST (REVERSE NEGPOWLIST))))) + JUMP (SETQ POWFUN (ADD1 POWFUN)) (GO LOOP))) + +(DEFUN CONSTERM (FUN VAR) + (COND ((NULL FUN) 0) + ((FREEOF VAR (CAR FUN)) + (ADD (CAR FUN) (CONSTERM (CDR FUN) VAR))) + (T (CONSTERM (CDR FUN) VAR)))) + +(DEFUN PREVCONSTEXPAN (FUN VAR) + (COND ((ATOM FUN) FUN) + ((EQ (CAAR FUN) 'MPLUS) + (COND ((AND (FREEOF VAR FUN) + (NOT (INSIDE FUN 'MEXPT))) + (LIST '(MQUOTE) FUN)) + ((AND (FREEOF VAR FUN) (INSIDE FUN 'MEXPT)) + (LIST '(MQUOTE) + (DISTRINPLUSPREV (CDR FUN) VAR))) + ((INSIDE FUN 'MEXPT) + (DISTRINPLUSPREV (CDR FUN) VAR)) + (T FUN))) + ((EQ (CAAR FUN) 'MTIMES) + (DISTRINTIMESPREV (CDR FUN) VAR)) + ((AND (NOT (INSIDE (CDR FUN) VAR)) + (EQ (CAAR FUN) 'MEXPT)) + (POWER (PREVCONSTEXPAN (CADR FUN) VAR) (CADDR FUN))) + (T FUN))) + +(DEFUN DISTRINPLUSPREV (FUN VAR) + (COND ((NULL FUN) 0) + (T (ADD (PREVCONSTEXPAN (CAR FUN) VAR) + (DISTRINPLUSPREV (CDR FUN) VAR))))) + +(DEFUN DISTRINTIMESPREV (FUN VAR) + (COND ((NULL FUN) 1) + (T (MUL (PREVCONSTEXPAN (CAR FUN) VAR) + (DISTRINTIMESPREV (CDR FUN) VAR))))) + +(DEFUN INSIDE (FUN ARG) + (COND ((ATOM FUN)(EQUAL FUN ARG)) + ((INSIDE (CAR FUN) ARG) T) + (T (INSIDE (CDR FUN) ARG)))) + +(DEFUN UNQUOTE (FUN) + (COND ((NOT (INSIDE FUN 'MQUOTE)) FUN) + (T (UNQUOTE (MEVAL FUN))))) + +(DEFUN CHECKSIGNTM (EXPR) + (PROG (ASLIST QUEST ZEROSIGNTEST PRODUCTCASE) + (SETQ ASLIST CHECKCOEFSIGNLIST) + (COND ((ATOM EXPR) (GO LOOP))) + (COND ((EQ (CAAR EXPR) 'MTIMES)(SETQ PRODUCTCASE T))) + LOOP (COND ((NULL ASLIST) + (SETQ CHECKCOEFSIGNLIST + (APPEND CHECKCOEFSIGNLIST + (LIST (CONS EXPR + (LIST + (SETQ QUEST (CHECKFLAGANDACT EXPR))))))) + (RETURN QUEST))) + (COND ((EQUAL (CAAR ASLIST) EXPR) (RETURN (CADAR ASLIST)))) + (SETQ ASLIST (CDR ASLIST)) + (GO LOOP))) + +(DEFUN CHECKFLAGANDACT (EXPR) + (COND (PRODUCTCASE + (SETQ PRODUCTCASE NIL) + (FINDSIGNOFTHEIRPRODUCT (FINDSIGNOFACTORS (CDR EXPR)))) + (T (ASKSIGN ($REALPART EXPR))))) + +(DEFUN FINDSIGNOFACTORS (LISTOFACTORS) + (COND ((NULL LISTOFACTORS) NIL) + ((EQ ZEROSIGNTEST '$ZERO) '$ZERO) + (T (APPEND (LIST (SETQ ZEROSIGNTEST (CHECKSIGNTM (CAR LISTOFACTORS)))) + (FINDSIGNOFACTORS (CDR LISTOFACTORS)))))) + +(DEFUN FINDSIGNOFTHEIRPRODUCT (LIST) + (PROG (SIGN) + (COND ((EQ LIST '$ZERO) (RETURN '$ZERO))) + (SETQ SIGN '$POSITIVE) + LOOP (COND ((NULL LIST) (RETURN SIGN))) + (COND ((EQ (CAR LIST) '$POSITIVE) + (SETQ LIST (CDR LIST)) + (GO LOOP))) + (COND ((EQ (CAR LIST) '$NEGATIVE) + (SETQ SIGN (CHANGESIGN SIGN) LIST (CDR LIST)) + (GO LOOP))) + (RETURN '$ZERO))) + +(DEFUN CHANGESIGN (SIGN) + (COND ((EQ SIGN '$POSITIVE) '$NEGATIVE) + (T '$POSITIVE))) + +(DEFUN DEN1 (C B A X) + ((LAMBDA (EXPO EXPR) + (PROG (SIGNDISCRIM SIGNC SIGNB) + (SETQ SIGNC (CHECKSIGNTM (POWER C -1))) + (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (SETQ SIGNDISCRIM (SIGNDIS2 C B A SIGNC SIGNB)) + (COND ((AND (EQ SIGNC '$POSITIVE) + (EQ SIGNDISCRIM '$NEGATIVE)) + (RETURN (AUGMULT (MUL* (POWER C EXPO) + (LIST '(%ASINH) + (MUL EXPR + (POWER (ADD (MUL 4 C A) + (MUL -1 B B)) + EXPO)))))))) + (COND ((AND (EQ SIGNC '$POSITIVE) + (EQ SIGNDISCRIM '$ZERO)) + (RETURN (AUGMULT (MUL* (POWER -1 EXPR) + (POWER C EXPO) + (LIST '(%LOG) EXPR)))))) + (COND ((EQ SIGNC '$POSITIVE) + (RETURN (AUGMULT (MUL* (POWER C EXPO) + (LIST '(%LOG) + (ADD (MUL 2 + (POWER C R12) + (POWER + (POLFOO C B + A X) + R12)) + EXPR))))))) + (COND ((AND (EQ SIGNC '$NEGATIVE) + (EQ SIGNDISCRIM '$POSITIVE)) + (RETURN (AUGMULT (MUL* -1 + (POWER (MUL -1 C) EXPO) + (LIST '(%ASIN) + (MUL EXPR + (POWER (ADD (MUL B B) + (MUL -4 C A)) + EXPO)))))))) + (COND ((EQ SIGNC '$NEGATIVE) + (RETURN (AUGMULT (MUL (POWER -1 EXPO) + (DEN1 (MUL -1 C) + (MUL -1 B) + (MUL -1 A) + X)))))))) + (LIST '(RAT) -1 2) (ADD (MUL 2 C X) B))) + +(DEFUN SIGNDISCR (C B A) + (CHECKSIGNTM (SIMPLIFYA (ADD (POWER B 2) + (MUL -4 C A)) + NIL))) + +(DEFUN ASKINVER (A) + (CHECKSIGNTM (POWER A -1))) + +(DEFUN SIGNDIS1 (C B A) + (COND ((EQUAL (MUL B A) 0) + (COND ((AND (EQUAL B 0)(EQUAL A 0)) '$ZERO) + (T '$NONZERO))) + (T (CHECKSIGNTM (POWER (ADD (MUL B B) (MUL -4 C A)) 2))))) + +(DEFUN SIGNDIS2 (C B A SIGNC SIGNB) + (COND ((EQUAL SIGNB '$ZERO) + (COND ((EQUAL A 0) '$ZERO) + (T ((LAMBDA (ASKINV) + (COND ((OR (AND (EQ SIGNC '$POSITIVE) + (EQ ASKINV '$NEGATIVE)) + (AND (EQ SIGNC '$NEGATIVE) + (EQ ASKINV '$POSITIVE))) + '$POSITIVE) + (T '$NEGATIVE))) + (ASKINVER A))))) + (T (COND ((EQUAL A 0) '$POSITIVE) + (T (SIGNDISCR C B A)))))) + +(DEFUN SIGNDIS3 (C B A SIGNA) + (COND ((EQUAL B 0) + (COND ((EQUAL (CHECKSIGNTM EC-1) SIGNA) '$NEGATIVE) + (T '$POSITIVE))) + (T (SIGNDISCR C B A)))) + +(DEFUN NUMMNUMN (POSZPOWLIST PLUSPOWFO1 P C B A X) + ((LAMBDA (EXPR EXPO EX) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES) + (SETQ RESULT 0 CONTROLPOW (CAAR POSZPOWLIST) + COEF (CADAR POSZPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (NUMN PLUSPOWFO1 C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (ADD (AUGMULT (MUL EXPR EXPO + (POWER (PLUS P P 1) -1))) + (AUGMULT (MUL -1 B R12 EXPO + (NUMN PLUSPOWFO1 C B A X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ RES2 (ADD (AUGMULT (MUL* X EXPR EXPO + (INV (PLUS P P 2)))) + (AUGMULT (MUL* B (PLUS P P 3) + (LIST '(RAT) -1 4) + EX + (INV (PLUS P P P 1 + (TIMES P P) + (TIMES P P))) + EXPR)) + (AUGMULT (MUL (INV (PLUS P 1)) + EX + (LIST '(RAT) 1 8.) + (ADD (MUL (POWER B 2) + (PLUS P P 3)) + (MUL -4 A C)) + (NUMN PLUSPOWFO1 C B A X))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (PRO) + (ADD (AUGMULT (MUL (POWER X (PLUS M -1)) + EXPR EXPO PRO)) + (AUGMULT (MUL -1 B (PLUS P P M M -1) + R12 EXPO PRO RES2)) + (AUGMULT (MUL -1 A (PLUS M -1) + EXPO PRO RES1)))) + (POWER (PLUS M P P) -1))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ POSZPOWLIST (CDR POSZPOWLIST)) + (COND ((NULL POSZPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR POSZPOWLIST)) + (SETQ CONTROLPOW (CAAR POSZPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER (POLFOO C B A X) (ADD P R12)) EC-1 (POWER C -2))) + +(DEFUN NUMN (P C B A X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5) + (COND ((ZEROP P) (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) EXP1 + EXP2 (POWER (POLFOO C B A X) EXP3))) + (AUGMULT (MUL (LIST '(RAT) 1 8) EXP1 EXP4 + (DEN1 C B A X))))) + (T (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) EXP1 EXP5 EXP2 + (POWER (POLFOO C B A X) (ADD P EXP3)))) + (AUGMULT (MUL (LIST '(RAT) 1 8) EXP1 EXP5 (PLUS P P 1) + EXP4 (NUMN (PLUS P -1) C B A X))))))) + EC-1 (ADD B (MUL 2 C X)) R12 + (ADD (MUL 4 A C) (MUL -1 B B)) (LIST '(RAT) 1 (PLUS P 1)))) + +(DEFUN AUGMULT (X) + ($MULTTHRU (SIMPLIFYA X NIL))) + +(DEFUN DENMDENN (NEGPOWLIST P C B A X) + ((LAMBDA (EXP1) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES SIGNA EA-1) + (SETQ SIGNA (CHECKSIGNTM (SIMPLIFYA A NIL))) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NOCONSTQUAD NEGPOWLIST P C B X)))) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) EA-1 (POWER A -1)) + (SETQ COEF (CADAR NEGPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (DEN1DENN P C B A X)) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ RES2 (ADD (AUGMULT (MUL -1 EA-1 (POWER X -1) EXP1)) + (AUGMULT (MUL -1 B (PLUS 1 P P) R12 + EA-1 (DEN1DENN P C B A X))) + (AUGMULT (MUL -2 P C EA-1 (DENN P C B A X))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (EXP2) + (ADD (AUGMULT (MUL EXP2 EA-1 + (POWER X (PLUS 1 (TIMES -1 M))) + EXP1)) + (AUGMULT (MUL B (PLUS P P M M -3) R12 + EA-1 EXP2 RES2)) + (AUGMULT (MUL C EA-1 EXP2 + (PLUS P P M -2) RES1)))) + (SIMPLIFYA (LIST '(RAT) -1 (PLUS M -1)) NIL))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) + CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER (POLFOO C B A X) (ADD R12 (TIMES -1 P))))) + +(DEFUN DENN (P C B A X) + ((LAMBDA (SIGNDISC EXP1 EXP2 EXP3) + (COND ((AND (EQ SIGNDISC '$ZERO)(ZEROP P)) + (AUGMULT (MUL* EC-1 + (LIST '(%LOG) (ADD X (MUL B R12 EC-1 )))))) + ((AND (EQ SIGNDISC '$ZERO)(GREATERP P 0)) + (AUGMULT (MUL* (LIST '(RAT) -1 (PLUS P P)) + (POWER C (MUL (LIST '(RAT) -1 2) + (PLUS P P 1))) + (POWER (ADD X (MUL B R12 EC-1 )) + (TIMES -2 P))))) + ((ZEROP P) (DEN1 C B A X)) + ((EQUAL P 1) + (AUGMULT (MUL 2 EXP1 EXP2 (POWER (POLFOO C B A X) + (LIST '(RAT) -1 2))))) + (T (ADD (AUGMULT (MUL 2 EXP1 EXP3 EXP2 + (POWER (POLFOO C B A X) + (ADD R12 (TIMES -1 P))))) + (AUGMULT (MUL 8 C (PLUS P -1) EXP3 EXP2 + (DENN (PLUS P -1) C B A X))))))) + (SIGNDIS1 C B A) (ADD B (MUL 2 C X)) + (POWER (ADD (MUL 4 A C)(MUL B B -1)) -1) (INV (PLUS P P -1)))) + +(DEFUN DEN1DENN (P C B A X) + ((LAMBDA (SIGNA EA-1) + (COND ((EQ SIGNA '$ZERO)(NOCONSTQUAD 1 P C B X)) + ((ZEROP P) (DEN1DEN1 C B A X)) + (T (ADD (AUGMULT (MUL (INV (PLUS P P -1)) EA-1 + (POWER (POLFOO C B A X) + (ADD R12 (TIMES -1 P))))) + (AUGMULT (MUL EA-1 (DEN1DENN (PLUS P -1) C B A X))) + (AUGMULT (MUL -1 R12 EA-1 B (DENN P C B A X))))))) + (CHECKSIGNTM (POWER A 2)) + (POWER A -1))) + +(DEFUN DEN1DEN1 (C B A X) + ((LAMBDA (EXP2 EXP3 EXP4) + (PROG (SIGNDISCRIM CONDITION SIGNA EXP1) + (SETQ SIGNA (CHECKSIGNTM (SIMPLIFYA A NIL))) + (SETQ CONDITION (ADD (MUL B X) A A)) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NOCONSTQUAD '((1 1)) 0 C B X)))) + (SETQ SIGNDISCRIM (SIGNDIS3 C B A SIGNA) + EXP1 (POWER A (INV -2))) + (COND ((AND (EQ SIGNA '$POSITIVE) + (EQ SIGNDISCRIM '$NEGATIVE)) + (RETURN (MUL* -1 EXP1 + (LIST '(%ASINH) + (AUGMULT (MUL EXP2 EXP3 + (POWER (ADD (MUL 4 A C) + (MUL -1 B B)) + EXP4)))))))) + (COND ((AND (EQ SIGNDISCRIM '$ZERO) + (EQ SIGNA '$POSITIVE)) + (RETURN (MUL* (POWER -1 CONDITION) -1 EXP1 + (LIST '(%LOG) + (AUGMULT (MUL EXP3 EXP2))))))) + (COND ((EQ SIGNA '$POSITIVE) + (RETURN (MUL* -1 EXP1 + (LIST '(%LOG) + (ADD B (MUL 2 A EXP3) + (MUL 2 EXP3 + (POWER A R12) + (POWER (POLFOO C B A X) + R12)))))))) + (COND ((AND (EQ SIGNA '$NEGATIVE) + (EQ SIGNDISCRIM '$POSITIVE)) + (RETURN (MUL* (POWER (MUL -1 A) EXP4) + (LIST '(%ASIN) + (AUGMULT (MUL EXP2 EXP3 + (POWER (ADD (MUL B B) + (MUL -4 A C)) + EXP4)))))))) + (RETURN (MUL -1 (POWER -1 R12) + (DEN1DEN1 (MUL -1 C) (MUL -1 B) (MUL -1 A) X))))) + (ADD (MUL B X) A A) (POWER (LIST '(MABS) X) -1) (LIST '(RAT) -1 2))) + +(DEFUN NOCONSTQUAD (NEGPOWLIST P C B X) + ((LAMBDA (EXP1 EXP2 EXP3) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 SIGNB M PARTRES EB-1) + (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (COND ((EQ SIGNB '$ZERO) + (RETURN (TRIVIAL1 NEGPOWLIST P C X)))) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST) EB-1 (INV B)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B 0 X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (ADD (AUGMULT (MUL -2 EXP1 EB-1 EXP2 + (POWER (POLFOO C B 0 X) + (ADD R12 EXP3)))) + (AUGMULT (MUL -4 P C EXP1 EB-1 (DENN P C B 0 X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ COUNT 3 M 2) + JUMP (SETQ PARTRES (ADD (AUGMULT (MUL -2 (INV (PLUS P P M M -1)) + EB-1 + (POWER X (MUL -1 M)) + (POWER (POLFOO C B 0 X) + (ADD R12 EXP3)))) + (AUGMULT (MUL -2 C (PLUS P P M -1) + EB-1 (INV (PLUS P P M M -1)) RES1)))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP3 (SETQ RES1 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) + CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 3) (GO JUMP3))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (GO JUMP2))) + (INV (PLUS P P 1)) (POWER X -1) (TIMES -1 P))) + +(DEFUN TRIVIAL1 (NEGPOWLIST P C X) + (COND ((NULL NEGPOWLIST) 0) + (T (ADD (AUGMULT (MUL (POWER X + (ADD (TIMES -2 P) + (MUL -1 + (CAAR NEGPOWLIST)))) + (CADAR NEGPOWLIST) + (POWER C + (ADD (TIMES -1 P) + (LIST '(RAT) -1 2))) + (INV (ADD (TIMES -2 P) + (MUL -1 (CAAR NEGPOWLIST)))))) + (TRIVIAL1 (CDR NEGPOWLIST) P C X))))) + +(DEFUN NUMMDENN (POSZPOWLIST P C B A X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5 EXP6 EXP7) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES SIGNDISCRIM) + (SETQ RESULT 0 CONTROLPOW (CAAR POSZPOWLIST)) + (SETQ COEF (CADAR POSZPOWLIST) SIGNDISCRIM (SIGNDIS1 C B A)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 + (ADD (AUGMULT (MUL -1 EC-1 EXP1 EXP2)) + (AUGMULT (MUL B (LIST '(RAT) -1 2) + EC-1 (DENN P C B A X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((AND (GREATERP P 0) + (NOT (EQ SIGNDISCRIM '$ZERO))) + (SETQ RES2 + (ADD (AUGMULT (MUL EC-1 EXP1 EXP3 EXP2 + (ADD (MUL 2 A B) + (MUL 2 B B X) + (MUL -4 A C X)))) + (AUGMULT (MUL EC-1 EXP3 EXP1 + (ADD (MUL 4 A C) + (MUL 2 B B P) + (MUL -3 B B)) + (DENN (PLUS P -1) + C B A X))))))) + (COND ((AND (EQUAL P 0) + (NOT (EQ SIGNDISCRIM '$ZERO))) + (SETQ RES2 + (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) + EXP5 + (ADD (MUL 2 C X) + (MUL -3 B)) + (POWER (POLFOO C B A X) + R12))) + (AUGMULT (MUL (LIST '(RAT) 1 8) + EXP5 + (ADD (MUL 3 B B) + (MUL -4 A C)) + (DEN1 C B A X))))))) + (COND ((AND (EQUAL P 0)(EQ SIGNDISCRIM '$ZERO)) + (SETQ RES2 + (ADD (AUGMULT (MUL* B B (LIST '(RAT) 1 4) + (POWER C -3) + (LIST '(%LOG) EXP4))) + (AUGMULT (MUL EC-1 R12 (POWER EXP4 2))) + (AUGMULT (MUL -1 B X EXP5)))))) + (COND ((AND (EQUAL P 1) (EQ SIGNDISCRIM '$ZERO)) + (SETQ RES2 + (ADD (AUGMULT (MUL* EC-1 (LIST '(%LOG) EXP4))) + (AUGMULT (MUL B EXP5 (POWER EXP4 -1))) + (AUGMULT (MUL (LIST '(RAT) -1 8) + (POWER C -3) + B B (POWER EXP4 -2))))))) + (COND ((AND (EQ SIGNDISCRIM '$ZERO)(GREATERP P 1)) + (SETQ RES2 + (ADD (AUGMULT (MUL EC-1 (POWER EXP4 EXP6) + (INV EXP6))) + (AUGMULT (MUL -1 B EXP5 (INV EXP7) + (POWER EXP4 EXP7))) + (AUGMULT (MUL B B (LIST '(RAT) -1 8) + (POWER C -3) + (INV P) + (POWER EXP4 + (TIMES -2 P)))))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (DENOM PM-1) + (ADD (AUGMULT (MUL* (POWER X PM-1) + EC-1 (LIST '(RAT) -1 DENOM) + (POWER (POLFOO C B A X) + (ADD R12 + (TIMES -1 P))))) + (AUGMULT (MUL B (PLUS P P 1 (TIMES -2 M)) + (LIST '(RAT) -1 2) + EC-1 (INV DENOM) RES2)) + (AUGMULT (MUL A PM-1 EC-1 (INV DENOM) RES1)))) + (PLUS P P (TIMES -1 M)) + (PLUS M -1))) + ON (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (COND ((EQUAL M (PLUS P P)) + (SETQ PARTRES + ((LAMBDA (EXPR) + (ADD (MUL X EXPR) + (MUL -1 (DISTRINT (CDR ($EXPAND EXPR)) + X)))) + (NUMMDENN (LIST (LIST (PLUS M -1) 1)) + P C B A X))) + (GO ON))) + (GO JUMP) + LOOP (SETQ POSZPOWLIST (CDR POSZPOWLIST)) + (COND ((NULL POSZPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR POSZPOWLIST) CONTROLPOW (CAAR POSZPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (INV (PLUS P P -1)) (POWER (POLFOO C B A X) (ADD R12 (TIMES -1 P))) + (POWER (ADD (MUL 4 A C)(MUL -1 B B)) -1) (ADD X (MUL B R12 EC-1)) + (POWER C -2) (PLUS 2 (TIMES -2 P)) (PLUS 1 (TIMES -2 P)))) + +(DEFUN DENMNUMN (NEGPOWLIST POW C B A X) + ((LAMBDA (EXP1 EXP2) + (PROG (RESULT CONTROLPOW P COEF COUNT RES1 RES2 M + PARTRES SIGNA EA-1) + (SETQ P (PLUS POW POW -1)) + (COND ((EQ (CAR NEGPOWLIST) 'T) + (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (GO THERE))) + (SETQ SIGNA (CHECKSIGNTM (POWER A 2))) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NONCONSTQUADENUM NEGPOWLIST P C B X)))) + (SETQ EA-1 (INV A)) + THERE (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF + (NUMN (ADD (MUL P R12) R12) + C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (DEN1NUMN POW C B A X)) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((NOT (EQUAL P 1)) + (SETQ RES2 (ADD (AUGMULT (MUL -1 EXP1 + (POWER (POLFOO C B A X) + (ADD POW + (LIST '(RAT) -1 2))))) + (AUGMULT (MUL B (LIST '(RAT) EXP2 2) + (DEN1NUMN (PLUS POW -1) + C B A X))) + (AUGMULT (MUL C EXP2 (NUMN (PLUS POW -2) + C B A X))))))) + (COND ((EQUAL P 1) + (SETQ RES2 (ADD (AUGMULT (MUL -1 (POWER (POLFOO C B A X) + R12) + EXP1)) + (AUGMULT (MUL B R12 (DEN1DEN1 C B A X))) + (AUGMULT (MUL C (DEN1 C B A X))))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (EXP3 EXP4) + (ADD (AUGMULT (MUL* (LIST '(RAT) -1 EXP3) + EA-1 (POWER X (PLUS 1 EXP4)) + (POWER (POLFOO C B A X) + (ADD (LIST '(RAT) P 2) + 1)))) + (AUGMULT (MUL (INV (PLUS M M -2)) + EA-1 B (PLUS P 4 (TIMES -2 M)) + RES2)) + (AUGMULT (MUL C EA-1 (PLUS P 3 EXP4) + (INV EXP3) RES1)))) + (PLUS M -1) (TIMES -1 M)) + M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER X -1) (PLUS POW POW -1))) + +(DEFUN NONCONSTQUADENUM (NEGPOWLIST P C B X) + (PROG (RESULT COEF M) + (COND ((EQUAL P 1)(RETURN (CASE1 NEGPOWLIST C B X)))) + (SETQ RESULT 0) + LOOP (SETQ M (CAAR NEGPOWLIST) COEF (CADAR NEGPOWLIST)) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF (CASEGEN M P C B X)))) + NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (GO LOOP))) + +(DEFUN CASEGEN (M P C B X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5) + (COND ((EQUAL P 1) (CASE1 (LIST (LIST M 1)) C B X)) + ((ZEROP M) (CASE0 P C B X)) + ((EQUAL M (PLUS P 1)) + (ADD (AUGMULT (MUL -1 EXP1 (INV EXP2) EXP3)) + (AUGMULT (MUL B R12 (CASEGEN EXP2 EXP4 C B X))) + (AUGMULT (MUL C (CASEGEN (PLUS M -2) EXP4 C B X))))) + ((EQUAL M 1) (ADD (AUGMULT (MUL (INV P) EXP1)) + (AUGMULT (MUL B R12 (CASE0 EXP4 C B X))))) + (T (ADD (AUGMULT (MUL -1 EXP1 (INV EXP5) EXP3)) + (AUGMULT (MUL -1 P B R12 (INV EXP5) + (CASEGEN EXP2 EXP4 C B X))))))) + (POWER (POLFOO C B 0 X)(LIST '(RAT) P 2)) + (PLUS M -1) + (POWER X (PLUS 1 (TIMES -1 M))) + (PLUS P -2) + (PLUS M -1 (TIMES -1 P)))) + +(DEFUN CASE1 (NEGPOWLIST C B X) + ((LAMBDA (EXP1 EB-1) + (PROG (RESULT CONTROLPOW M1 COEF COUNT RES1 RES2 M SIGNC + SIGNB PARTRES RES) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST) M1 (PLUS CONTROLPOW -2)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (CASE0 1 C B X))) + COUNT 1) + (GO LOOP))) + JUMP1 (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT + (ADD RESULT + (AUGMULT (MUL COEF (DEN1NUMN 1 C B 0 X)))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT + (ADD RESULT + (AUGMULT (MUL COEF + (DENMNUMN '(T (2 1)) + 1 C B 0 X)))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (COND ((EQ SIGNB '$ZERO)(SETQ COUNT 5)(GO JUMP5))) + (SETQ COUNT 4 M 0 SIGNC (CHECKSIGNTM EC-1)) + (COND ((EQ SIGNC '$POSITIVE) + (SETQ RES + (AUGMULT (MUL* 2 EXP1 + (LIST '(%LOG) + (ADD (POWER (MUL C X) + R12) + (POWER (ADD B + (MUL C X)) + R12)))))) + (GO JUMP4))) + (SETQ RES + (AUGMULT (MUL* 2 EXP1 + (LIST '(%ATAN) + (POWER (MUL C X + (POWER (ADD B + (MUL -1 C X)) + -1)) + R12))))) + JUMP4 (SETQ M (PLUS M 1) + RES (ADD (AUGMULT (MUL -2 (POWER (POLFOO C B 0 X) R12) + EB-1 (INV (PMM-1 M)) + (EXT-1M X M))) + (AUGMULT (MUL* (LIST '(RAT) -2 (PMM-1 M)) + C (SUB1 M) + EB-1 RES)))) + (COND ((EQUAL M M1) (SETQ RES2 RES) (GO JUMP4))) + (COND ((EQUAL (SUB1 M) M1) + (IF (NULL RES2) (RETURN NIL)) + (SETQ RES1 RES + PARTRES (ADD (AUGMULT (MUL -1 + (POWER (POLFOO C B 0 X) + R12) + (R1M M) + (EXT-1M X M))) + (AUGMULT (MUL B R12 (R1M M) RES1)) + (AUGMULT (MUL C (R1M M) RES2)))) + (GO ON))) + (GO JUMP4) + JUMP5 (SETQ M CONTROLPOW) + (COND ((ZEROP M) + (SETQ PARTRES (MUL* EXP1 (LIST '(%LOG) X))) + (GO ON))) + (SETQ PARTRES (MUL -1 EXP1 (EXT-1M X M) (R1M M))) + ON (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 5) (GO JUMP5))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (COND ((EQUAL COUNT 3) (GO JUMP3))) + (SETQ M1 (PLUS CONTROLPOW -2)) + (COND ((EQUAL M1 M) (SETQ RES2 RES1))) + (GO JUMP4))) + (POWER C (LIST '(RAT) -1 2)) (POWER B -1))) + +(DEFUN PMM-1 (M) (PLUS M M -1)) + +(DEFUN R1M (M) (LIST '(RAT) 1 M)) + +(DEFUN EXT-1M (X M) (POWER X (TIMES -1 M))) + +(DEFUN CASE0 (POWER C B X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EB-1) + (PROG (SIGNC P RESULT) + (SETQ SIGNC (CHECKSIGNTM EC-1) P 1) + (COND ((EQ SIGNC '$POSITIVE) + (SETQ RESULT + (ADD (AUGMULT (MUL EXP1 EC-1 EXP2 + (POWER (POLFOO C B 0 X) + R12))) + (AUGMULT (MUL* B B (LIST '(RAT) -1 8) + EXP3 + (LIST '(%LOG) + (ADD EXP2 + (MUL 2 + (POWER C R12) + (POWER + (POLFOO C B 0 X) + R12)))))))))) + (COND ((EQ SIGNC '$NEGATIVE) + (SETQ RESULT + (ADD (AUGMULT (MUL EXP1 EC-1 EXP4 + (POWER (POLFOO (MUL -1 C) + B 0 X) + R12))) + (AUGMULT (MUL* B B (LIST '(RAT) 1 8) + EXP3 + (LIST '(%ASIN) + (MUL EB-1 EXP4)))))))) + LOOP (COND ((EQUAL POWER P) (RETURN RESULT))) + (SETQ P (PLUS P 2) + RESULT ((LAMBDA (EXP5) + (ADD (AUGMULT (MUL R12 EC-1 EXP5 EXP2 + (POWER (POLFOO C B 0 X) + (LIST '(RAT) P 2)))) + (AUGMULT (MUL P B B (LIST '(RAT) -1 4) + EC-1 EXP5 RESULT)))) + (INV (PLUS P 1)))) + (GO LOOP))) + (LIST '(RAT) 1 4) (ADD B (MUL 2 C X)) (POWER C (LIST '(RAT) -3 2)) + (ADD (MUL 2 C X)(MUL -1 B)) (POWER B -1))) + +(DEFUN DEN1NUMN (P C B A X) + (COND ((EQUAL P 1) + (ADD (POWER (POLFOO C B A X) R12 ) + (AUGMULT (MUL A (DEN1DEN1 C B A X))) + (AUGMULT (MUL B R12 (DEN1 C B A X))))) + (T (ADD (AUGMULT (MUL (POWER (POLFOO C B A X) + (ADD P (LIST '(RAT) -1 2))) + (INV (PLUS P P -1)))) + (AUGMULT (MUL A (DEN1NUMN (PLUS P -1) C B A X))) + (AUGMULT (MUL B R12 (NUMN (PLUS P -2) C B A X))))))) + +(DEFUN DISTRINT (EXPR X) + (COND ((NULL EXPR) 0) + (T (ADD (INTIRA (CAR EXPR) X) + (DISTRINT (CDR EXPR) X))))) diff --git a/src/maxsrc/irinte.54 b/src/maxsrc/irinte.54 new file mode 100755 index 00000000..69ee12b5 --- /dev/null +++ b/src/maxsrc/irinte.54 @@ -0,0 +1,1155 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module irinte) +(load-macsyma-macros rzmac) + +(DECLARE (SPECIAL CHECKCOEFSIGNLIST EC-1 R12 1//2 VAR GLOBALCAREFLAG + ZEROSIGNTEST PRODUCTCASE $RADEXPAND)) + +(DEFUN HASVAR (EXP) (NOT (FREEVAR EXP))) + +(DEFUN ZERP (A) (EQUAL A 0)) + +(DEFUN INTEGERPFR (A) (IF (NOT (INTEGERP A)) (INTEGERP1 A))) + +(DEFUN NONZERP (A) (NOT (EQUAL A 0))) + +(DEFUN FREEVNZ (A) (AND (FREEVAR A) (NOT (EQUAL A 0)))) + +(DEFUN INTE (FUNCT X) + (PROG (CHECKCOEFSIGNLIST GLOBALCAREFLAG $RADEXPAND) + (SETQ $RADEXPAND T) + (RETURN (INTIR-REF FUNCT X)))) + +(DEFUN INTIR-REF (FUN X) + (PROG (A) + (COND ((SETQ A (INTIR1 FUN X))(RETURN A))) + (COND ((SETQ A (INTIR2 FUN X))(RETURN A))) + (RETURN (INTIR3 FUN X)))) + +(DEFUN INTIR1 (FUN X) + (PROG (ASSOCLIST E0 R0 E1 E2 R1 R2 D P) + (SETQ ASSOCLIST (FACTPOW (SPECREPCHECK FUN) X)) + (SETQ E1 (CDRAS 'E1 ASSOCLIST) E2 (CDRAS 'E2 ASSOCLIST)) + (COND ((NULL ASSOCLIST)(RETURN NIL))) + (SETQ D (CDRAS 'D ASSOCLIST) P (CDRAS 'P ASSOCLIST) + E0 (CDRAS 'E0 ASSOCLIST) R0 (CDRAS 'R0 ASSOCLIST) + R1 (CDRAS 'R1 ASSOCLIST) R2 (CDRAS 'R2 ASSOCLIST)) + (COND ((FLOATP E0)(SETQ E0 (RDIS (RATION1 E0))))) + (COND ((FLOATP E1)(SETQ E1 (RDIS (RATION1 E1))))) + (COND ((FLOATP E2)(SETQ E2 (RDIS (RATION1 E2))))) + (RETURN (INTIR1-REF D P R0 E0 R1 E1 R2 E2 X)))) + +(DEFUN INTIR2 (FUNCT X) + (PROG (RES) + (COND ((SETQ RES (INTIR FUNCT X))(RETURN RES))) + (RETURN (INTIRFACTOROOT FUNCT X)))) + +(DEFUN INTIR3 (EXP X) + (PROG (ASSOCLIST E F G R0) + (COND ((SETQ ASSOCLIST (ELLIPTQUAD EXP X)) + (SETQ E (CDRAS 'E ASSOCLIST) F (CDRAS 'F ASSOCLIST) + G (CDRAS 'G ASSOCLIST) R0 (CDRAS 'R0 ASSOCLIST)) + (ASSUME `(($NOTEQUAL) ,E 0)) + (RETURN (INTIR3-R0TEST ASSOCLIST X E F G R0)))) + (RETURN NIL))) + +(DEFUN INTIR3-R0TEST (ASSOCLIST X E F G R0) + (COND ((ROOT+ANYTHING R0 X) NIL) + (T (INTIR3-REF ASSOCLIST X E F G R0)))) + +(DEFUN INTIR1-REF (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((AND (PLUSP NUME1)(PLUSP NUME2)) + (PP-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + ((AND (MINUSP NUME1)(MINUSP NUME2)) + (MM-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + ((PLUSP NUME1)(PM-INTIR1 D P R0 E0 R1 E1 R2 E2 X)) + (T (PM-INTIR1 D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN PP-INTIR1 (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((GREATERP NUME1 NUME2)(PP-INTIR1-EXEC D P R0 E0 R1 E1 R2 E2 X)) + (T (PP-INTIR1-EXEC D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN MM-INTIR1 (D P R0 E0 R1 E1 R2 E2 X) + ((LAMBDA (NUME1 NUME2) + (COND ((GREATERP NUME1 NUME2)(MM-INTIR1-EXEC D P R0 E0 R1 E1 R2 E2 X)) + (T (MM-INTIR1-EXEC D P R0 E0 R2 E2 R1 E1 X)))) + (CADR E1) (CADR E2))) + +(DEFUN PM-INTIR1 (D P R0 E0 ROFPOS EPOS ROFNEG ENEG X) + ((LAMBDA (NUMEPOS NUMUL-1ENEG) + (COND ((GREATERP NUMEPOS NUMUL-1ENEG) + (MM-INTIR1 D (MUL P (POWER ROFPOS (SUB EPOS ENEG))) + R0 E0 ROFPOS ENEG ROFNEG ENEG X)) + ((OR (EQUAL E0 0) (PLUSP E0)) + (PP-INTIR1 D (MUL P (POWER ROFNEG (SUB ENEG EPOS))) + R0 E0 ROFPOS EPOS ROFNEG EPOS X)) + (T (MM-INTIR1 D (MUL P (POWER ROFPOS (SUB EPOS ENEG))) + R0 E0 ROFPOS ENEG ROFNEG ENEG X)))) + (CADR EPOS) + (MUL -1 (CADR ENEG)))) + +(DEFUN PP-INTIR1-EXEC (D P R0 E0 ROFMAX EMAX ROFMIN EMIN X) + (INTIR (MUL D P (COND ((EQUAL E0 0) 1) (T (POWER R0 E0))) + (POWER ROFMAX (ADD EMAX (MUL -1 EMIN))) + (POWER ($EXPAND (MUL ROFMAX ROFMIN)) EMIN)) X)) + +(DEFUN MM-INTIR1-EXEC (D P R0 E0 ROFMIN EMIN ROFMAX EMAX X) + (INTIR (MUL D P (COND ((EQUAL E0 0) 1) (T (POWER R0 E0))) + (POWER ROFMAX (ADD EMAX (MUL -1 EMIN))) + (POWER ($EXPAND (MUL ROFMAX ROFMIN)) EMIN)) X)) + +(DEFUN INTIR3-REF (ASSOCLIST X E F G R0) + ((LAMBDA (SIGNDISC D P E0) + (COND ((OR (EQ SIGNDISC '$POSITIVE)(EQ SIGNDISC '$NEGATIVE)) + (PNS-INTIR3 X E F G D P R0 E0)) + (T (ZS-INTIR3 X E F D P R0 E0)))) + (SIGNDISCR E F G) + (CDRAS 'D ASSOCLIST) + (CDRAS 'P ASSOCLIST) + (CDRAS 'E0 ASSOCLIST))) + +(DEFUN ROOT+ANYTHING (EXP VAR) + (M2 EXP '((MPLUS) ((COEFFPT) (C NONZERP) ((MEXPT) (U HASVAR) (V INTEGERPFR))) + ((COEFFPP)(C TRUE))) NIL)) + +(DEFUN PNS-INTIR3 (X E F G D P R0 E0) + ((LAMBDA (DISCR) + ((LAMBDA (P*R0^E0 2*E*X+F 2*E*D*INVDISC) + (MUL (SUB (INTIR2 (MUL 2*E*D*INVDISC + (INV (SUB 2*E*X+F DISCR)) + P*R0^E0) + X) + (INTIR2 (MUL 2*E*D*INVDISC + (INV (ADD 2*E*X+F DISCR)) + P*R0^E0) + X)))) + (MUL P (POWER R0 E0)) + (ADD (MUL 2 E X) F) + (MUL 2 E D (INV DISCR)))) + (POWER (SUB (MUL F F)(MUL 4 E G)) (INV 2)))) + +(DEFUN ZS-INTIR3 (X E F D P R0 E0) + (INTIR2 (MUL D P E + (POWER (ADD X (DIV F (ADD E E))) -2) (POWER R0 E0)) + X)) + +(DEFUN CDRAS (A B) + (CDR (ASSOC A B))) + +(DEFUN INTIR (FUNCT X) + (PROG (ASSOCLIST) + (SETQ ASSOCLIST (JMAUG (SPECREPCHECK FUNCT) X)) + (RETURN (INTI FUNCT X ASSOCLIST)))) + +(DEFUN INTI (FUNCT X ASSOCLIST) + (PROG (MET N EXPR F E DENOM) + (SETQ N (CDRAS 'N ASSOCLIST)) + (COND ((OR (NULL ASSOCLIST) (INTEGERP N)) + (RETURN NIL))) + (SETQ F (CDRAS 'F ASSOCLIST) E (CDRAS 'E ASSOCLIST)) + (COND ((OR (EQUAL E 0) (NULL E)) + (RETURN (INTIRA FUNCT X)))) + (COND ((NOT (NUMBERP F)) (GO JUMP))) + (COND ((PLUSP F)(GO JUMP))) + (SETQ DENOM (ADD (MUL F X) E) F (MUL -1 F) E (MUL -1 E) + FUNCT (MUL -1 (DIV (MEVAL (MUL DENOM FUNCT))(ADD (MUL F X) E)))) + JUMP (SETQ EXPR + (MUL (POWER F -1) + (INTIRA (DISTREXPANDROOT + (CDR ($SUBSTITUTE (MUL (POWER F -1) + (ADD (SETQ MET (GENSYM 'YANNIS)) + (MUL -1 E))) + X FUNCT))) + MET))) + (RETURN ($EXPAND ($SUBSTITUTE (ADD (MUL F X) E) MET EXPR))))) + +(DEFUN DISTREXPANDROOT (EXPR) + (COND ((NULL EXPR) 1) + (T (MUL (EXPANDROOT (CAR EXPR)) + (DISTREXPANDROOT (CDR EXPR)))))) + +(DEFUN EXPANDROOT (EXPR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (INTEGERPFR (CADDR EXPR))) + ($EXPAND EXPR)) + (T EXPR))))) + +(DEFUN INTIRFACTOROOT (EXPR X) + (PROG (ASSOCLIST EXP) + (SETQ EXP EXPR) + (COND ((SETQ ASSOCLIST (JMAUG (SETQ EXPR (DISTRFACTOR (TIMESTEST EXPR) X)) X)) + (RETURN (INTI EXPR X ASSOCLIST)))) + (SETQ GLOBALCAREFLAG 'T) + (COND ((SETQ ASSOCLIST (JMAUG (SETQ EXP (DISTRFACTOR (TIMESTEST EXP) X)) X)) + (SETQ GLOBALCAREFLAG NIL) + (RETURN (INTI EXP X ASSOCLIST)))) + (SETQ GLOBALCAREFLAG NIL) + (RETURN NIL))) + +(DEFUN DISTRFACTOR (EXPR X) + (COND ((NULL EXPR) 1) + (T (MUL (FACTOROOT (CAR EXPR) X) + (DISTRFACTOR (CDR EXPR) X))))) + +(DEFUN FACTOROOT (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (HASVAR EXPR) + (INTEGERPFR (CADDR EXPR))) + (CAREFULFACTOR EXPR VAR)) + (T EXPR))))) + +(DEFUN CAREFULFACTOR (EXPR X) + (COND ((NULL GLOBALCAREFLAG)($FACTOR EXPR)) + (T (RESTOREX ($FACTOR (POWER (DIV (CADR EXPR) X) (CADDR EXPR))) X)))) + +(DEFUN RESTOREX (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((EQ (CAAR EXPR) 'MTIMES) + (DISTRESTOREX (CDR EXPR) VAR)) + (T EXPR))))) + +(DEFUN DISTRESTOREX (EXPR VAR) + (COND ((NULL EXPR) 1) + (T (MUL (RESTOROOT (CAR EXPR) VAR) + (DISTRESTOREX (CDR EXPR) VAR))))) + +(DEFUN RESTOROOT (EXPR VAR) + (COND ((ATOM EXPR) EXPR) + (T (COND ((AND (EQ (CAAR EXPR) 'MEXPT) + (INTEGERPFR (CADDR EXPR)) + (MPLUSP (CADR EXPR))) + (POWER ($EXPAND (MUL VAR (CADR EXPR))) (CADDR EXPR))) + (T EXPR))))) + +(DEFUN TIMESTEST (EXPR) + (COND ((ATOM EXPR)(LIST EXPR)) + (T (COND ((EQ (CAAR EXPR) 'MTIMES)(CDR EXPR)) + (T (LIST EXPR)))))) + +(DEFUN INTIRA (FUNCT X) + (PROG (A B C EC-1 D M N ASSOCLIST PLUSPOWFO1 PLUSPOWFO2 MINUSPOWFO + POLFACT SIGNN POSZPOWLIST NEGPOWLIST R12) + (SETQ ASSOCLIST (JMAUG (SPECREPCHECK FUNCT) X)) + (SETQ N (CDRAS 'N ASSOCLIST) R12 1//2) + (COND ((OR (NULL ASSOCLIST) (INTEGERP N))(RETURN NIL))) + (COND ((FLOATP N)(SETQ N (RDIS (RATION1 N))))) + (SETQ D (CDRAS 'D ASSOCLIST)) + (COND ((EQUAL D 0) (RETURN 0))) + (SETQ C (CDRAS 'A ASSOCLIST)) + (IF (EQUAL C 0) (RETURN NIL)) + (SETQ M (CDRAS 'M ASSOCLIST) POLFACT (CDRAS 'P ASSOCLIST) N (CADR N) + SIGNN (CHECKSIGNTM N) EC-1 (POWER C -1) + B (CDRAS 'B ASSOCLIST) A (CDRAS 'C ASSOCLIST) + PLUSPOWFO1 (MUL R12 (PLUS N -1)) + MINUSPOWFO (MUL R12 (PLUS N 1)) + PLUSPOWFO2 (TIMES -1 MINUSPOWFO) + POSZPOWLIST (CAR (POWERCOEFLIST POLFACT M X)) + NEGPOWLIST (CADR (POWERCOEFLIST POLFACT M X))) + (COND ((AND (NULL NEGPOWLIST)(NOT (NULL POSZPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (AUGMULT (MUL D + (NUMMNUMN POSZPOWLIST + PLUSPOWFO1 + MINUSPOWFO C B A X)))))) + (RETURN (AUGMULT (MUL D + (NUMMDENN POSZPOWLIST + PLUSPOWFO2 C B A X)))))) + (COND ((AND (NULL POSZPOWLIST)(NOT (NULL NEGPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (AUGMULT (MUL D + (DENMNUMN NEGPOWLIST + MINUSPOWFO C B A X)))))) + (RETURN (AUGMULT (MUL D + (DENMDENN NEGPOWLIST + PLUSPOWFO2 C B A X)))))) + (COND ((AND (NOT (NULL NEGPOWLIST)) (NOT (NULL POSZPOWLIST))) + (COND ((EQ SIGNN '$POSITIVE) + (RETURN (ADD (AUGMULT (MUL D + (NUMMNUMN POSZPOWLIST + PLUSPOWFO1 + MINUSPOWFO C B A X))) + (AUGMULT (MUL D + (DENMNUMN NEGPOWLIST + MINUSPOWFO C B A X))))))) + (RETURN (ADD (AUGMULT (MUL D + (NUMMDENN POSZPOWLIST + PLUSPOWFO2 C B A X))) + (AUGMULT (MUL D + (DENMDENN NEGPOWLIST + PLUSPOWFO2 C B A X))))))))) + +(DEFUN JMAUG (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT)(P POLYP)) + ((MEXPT) ((MPLUS) ((COEFFPT)(F FREEVAR)(X VARP)) + ((COEFFPP)(E FREEVAR))) + (M INTEGERP)) + ((MEXPT) ((MPLUS) ((COEFFPT) (A FREEVAR) ((MEXPT) (X VARP) 2)) + ((COEFFPT) (B FREEVAR)(X VARP)) + ((COEFFPP) (C FREEVAR))) + (N INTEGERP1))) + NIL)) + +(DEFUN FACTPOW (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT) (P POLYP)) + ((MEXPT) (R1 HASVAR) + (E1 INTEGERPFR)) + ((MEXPT) (R2 HASVAR) + (E2 INTEGERPFR)) + ((MEXPT) (R0 HASVAR) + (E0 INTEGERP))) + NIL)) + +(DEFUN ELLIPTQUAD (EXP VAR) + (M2 EXP '((MTIMES) ((COEFFTT) (D FREEVAR)) + ((COEFFTT) (P POLYP)) + ((MEXPT) ((MPLUS) ((COEFFPT) (E FREEVNZ) ((MEXPT) (X VARP) 2)) + ((COEFFPT) (F FREEVAR) (X VARP)) + ((COEFFPP) (G FREEVAR))) + -1) + ((MEXPT) (R0 HASVAR) + (E0 INTEGERPFR))) + NIL)) + +(DEFUN POLFOO (C B A X) + (ADD (MUL C X X) + (MUL B X) + A)) + +(DEFUN POWERCOEFLIST (FUN M VAR) + (PROG (EXPANFUN MAXPOWFUN POWFUN COEF POSZPOWLIST NEGPOWLIST) + (SETQ EXPANFUN (UNQUOTE ($EXPAND (MUL (PREVCONSTEXPAN FUN VAR) + (POWER VAR M))))) + (COND ((AND (EQUAL FUN 1) (GREATERP M 0)) + (RETURN (CONS NIL (LIST (LIST (CONS M (LIST 1)))))))) + (COND ((AND (EQUAL FUN 1)(LESSP M 0)) + (RETURN (CONS NIL (LIST (LIST (CONS (TIMES -1 M ) (LIST 1)))))))) + (COND ((EQUAL EXPANFUN 1) + (RETURN (CONS (LIST (CONS 0 (LIST 1))) + (LIST NIL))))) + (SETQ MAXPOWFUN ($HIPOW EXPANFUN VAR) + POWFUN ($LOPOW EXPANFUN VAR)) + LOOP (SETQ COEF ($COEFF EXPANFUN (POWER VAR POWFUN))) + (COND ((NUMBERP COEF) (GO TESTJUMP))) + (GO NOJUMP) + TESTJUMP (COND ((AND (NOT (ZEROP POWFUN)) (ZEROP COEF)) + (GO JUMP))) + NOJUMP (COND ((GREATERP POWFUN 0) + (SETQ POSZPOWLIST (APPEND POSZPOWLIST + (LIST (CONS POWFUN (LIST COEF))))))) + (COND ((ZEROP POWFUN) + (SETQ POSZPOWLIST + (APPEND POSZPOWLIST + (LIST (CONS 0 (LIST (CONSTERM (CDR EXPANFUN) VAR)))))))) + (COND ((LESSP POWFUN 0) + (SETQ NEGPOWLIST (APPEND NEGPOWLIST + (LIST (CONS (TIMES -1 POWFUN)(LIST COEF))))))) + (COND ((EQUAL POWFUN MAXPOWFUN) + (RETURN (LIST POSZPOWLIST (REVERSE NEGPOWLIST))))) + JUMP (SETQ POWFUN (ADD1 POWFUN)) (GO LOOP))) + +(DEFUN CONSTERM (FUN VAR) + (COND ((NULL FUN) 0) + ((FREEOF VAR (CAR FUN)) + (ADD (CAR FUN) (CONSTERM (CDR FUN) VAR))) + (T (CONSTERM (CDR FUN) VAR)))) + +(DEFUN PREVCONSTEXPAN (FUN VAR) + (COND ((ATOM FUN) FUN) + ((EQ (CAAR FUN) 'MPLUS) + (COND ((AND (FREEOF VAR FUN) + (NOT (INSIDE FUN 'MEXPT))) + (LIST '(MQUOTE) FUN)) + ((AND (FREEOF VAR FUN) (INSIDE FUN 'MEXPT)) + (LIST '(MQUOTE) + (DISTRINPLUSPREV (CDR FUN) VAR))) + ((INSIDE FUN 'MEXPT) + (DISTRINPLUSPREV (CDR FUN) VAR)) + (T FUN))) + ((EQ (CAAR FUN) 'MTIMES) + (DISTRINTIMESPREV (CDR FUN) VAR)) + ((AND (NOT (INSIDE (CDR FUN) VAR)) + (EQ (CAAR FUN) 'MEXPT)) + (POWER (PREVCONSTEXPAN (CADR FUN) VAR) (CADDR FUN))) + (T FUN))) + +(DEFUN DISTRINPLUSPREV (FUN VAR) + (COND ((NULL FUN) 0) + (T (ADD (PREVCONSTEXPAN (CAR FUN) VAR) + (DISTRINPLUSPREV (CDR FUN) VAR))))) + +(DEFUN DISTRINTIMESPREV (FUN VAR) + (COND ((NULL FUN) 1) + (T (MUL (PREVCONSTEXPAN (CAR FUN) VAR) + (DISTRINTIMESPREV (CDR FUN) VAR))))) + +(DEFUN INSIDE (FUN ARG) + (COND ((ATOM FUN)(EQUAL FUN ARG)) + ((INSIDE (CAR FUN) ARG) T) + (T (INSIDE (CDR FUN) ARG)))) + +(DEFUN UNQUOTE (FUN) + (COND ((NOT (INSIDE FUN 'MQUOTE)) FUN) + (T (UNQUOTE (MEVAL FUN))))) + +(DEFUN CHECKSIGNTM (EXPR) + (PROG (ASLIST QUEST ZEROSIGNTEST PRODUCTCASE) + (SETQ ASLIST CHECKCOEFSIGNLIST) + (COND ((ATOM EXPR) (GO LOOP))) + (COND ((EQ (CAAR EXPR) 'MTIMES)(SETQ PRODUCTCASE T))) + LOOP (COND ((NULL ASLIST) + (SETQ CHECKCOEFSIGNLIST + (APPEND CHECKCOEFSIGNLIST + (LIST (CONS EXPR + (LIST + (SETQ QUEST (CHECKFLAGANDACT EXPR))))))) + (RETURN QUEST))) + (COND ((EQUAL (CAAR ASLIST) EXPR) (RETURN (CADAR ASLIST)))) + (SETQ ASLIST (CDR ASLIST)) + (GO LOOP))) + +(DEFUN CHECKFLAGANDACT (EXPR) + (COND (PRODUCTCASE + (SETQ PRODUCTCASE NIL) + (FINDSIGNOFTHEIRPRODUCT (FINDSIGNOFACTORS (CDR EXPR)))) + (T (ASKSIGN ($REALPART EXPR))))) + +(DEFUN FINDSIGNOFACTORS (LISTOFACTORS) + (COND ((NULL LISTOFACTORS) NIL) + ((EQ ZEROSIGNTEST '$ZERO) '$ZERO) + (T (APPEND (LIST (SETQ ZEROSIGNTEST (CHECKSIGNTM (CAR LISTOFACTORS)))) + (FINDSIGNOFACTORS (CDR LISTOFACTORS)))))) + +(DEFUN FINDSIGNOFTHEIRPRODUCT (LIST) + (PROG (SIGN) + (COND ((EQ LIST '$ZERO) (RETURN '$ZERO))) + (SETQ SIGN '$POSITIVE) + LOOP (COND ((NULL LIST) (RETURN SIGN))) + (COND ((EQ (CAR LIST) '$POSITIVE) + (SETQ LIST (CDR LIST)) + (GO LOOP))) + (COND ((EQ (CAR LIST) '$NEGATIVE) + (SETQ SIGN (CHANGESIGN SIGN) LIST (CDR LIST)) + (GO LOOP))) + (RETURN '$ZERO))) + +(DEFUN CHANGESIGN (SIGN) + (COND ((EQ SIGN '$POSITIVE) '$NEGATIVE) + (T '$POSITIVE))) + +(DEFUN DEN1 (C B A X) + ((LAMBDA (EXPO EXPR) + (PROG (SIGNDISCRIM SIGNC SIGNB) + (SETQ SIGNC (CHECKSIGNTM (POWER C -1))) + (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (SETQ SIGNDISCRIM (SIGNDIS2 C B A SIGNC SIGNB)) + (COND ((AND (EQ SIGNC '$POSITIVE) + (EQ SIGNDISCRIM '$NEGATIVE)) + (RETURN (AUGMULT (MUL* (POWER C EXPO) + (LIST '(%ASINH) + (MUL EXPR + (POWER (ADD (MUL 4 C A) + (MUL -1 B B)) + EXPO)))))))) + (COND ((AND (EQ SIGNC '$POSITIVE) + (EQ SIGNDISCRIM '$ZERO)) + (RETURN (AUGMULT (MUL* (POWER -1 EXPR) + (POWER C EXPO) + (LIST '(%LOG) EXPR)))))) + (COND ((EQ SIGNC '$POSITIVE) + (RETURN (AUGMULT (MUL* (POWER C EXPO) + (LIST '(%LOG) + (ADD (MUL 2 + (POWER C R12) + (POWER + (POLFOO C B + A X) + R12)) + EXPR))))))) + (COND ((AND (EQ SIGNC '$NEGATIVE) + (EQ SIGNDISCRIM '$POSITIVE)) + (RETURN (AUGMULT (MUL* -1 + (POWER (MUL -1 C) EXPO) + (LIST '(%ASIN) + (MUL EXPR + (POWER (ADD (MUL B B) + (MUL -4 C A)) + EXPO)))))))) + (COND ((EQ SIGNC '$NEGATIVE) + (RETURN (AUGMULT (MUL (POWER -1 EXPO) + (DEN1 (MUL -1 C) + (MUL -1 B) + (MUL -1 A) + X)))))))) + (LIST '(RAT) -1 2) (ADD (MUL 2 C X) B))) + +(DEFUN SIGNDISCR (C B A) + (CHECKSIGNTM (SIMPLIFYA (ADD (POWER B 2) + (MUL -4 C A)) + NIL))) + +(DEFUN ASKINVER (A) + (CHECKSIGNTM (POWER A -1))) + +(DEFUN SIGNDIS1 (C B A) + (COND ((EQUAL (MUL B A) 0) + (COND ((AND (EQUAL B 0)(EQUAL A 0)) '$ZERO) + (T '$NONZERO))) + (T (CHECKSIGNTM (POWER (ADD (MUL B B) (MUL -4 C A)) 2))))) + +(DEFUN SIGNDIS2 (C B A SIGNC SIGNB) + (COND ((EQUAL SIGNB '$ZERO) + (COND ((EQUAL A 0) '$ZERO) + (T ((LAMBDA (ASKINV) + (COND ((OR (AND (EQ SIGNC '$POSITIVE) + (EQ ASKINV '$NEGATIVE)) + (AND (EQ SIGNC '$NEGATIVE) + (EQ ASKINV '$POSITIVE))) + '$POSITIVE) + (T '$NEGATIVE))) + (ASKINVER A))))) + (T (COND ((EQUAL A 0) '$POSITIVE) + (T (SIGNDISCR C B A)))))) + +(DEFUN SIGNDIS3 (C B A SIGNA) + (COND ((EQUAL B 0) + (COND ((EQUAL (CHECKSIGNTM EC-1) SIGNA) '$NEGATIVE) + (T '$POSITIVE))) + (T (SIGNDISCR C B A)))) + +(DEFUN NUMMNUMN (POSZPOWLIST PLUSPOWFO1 P C B A X) + ((LAMBDA (EXPR EXPO EX) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES) + (SETQ RESULT 0 CONTROLPOW (CAAR POSZPOWLIST) + COEF (CADAR POSZPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (NUMN PLUSPOWFO1 C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (ADD (AUGMULT (MUL EXPR EXPO + (POWER (PLUS P P 1) -1))) + (AUGMULT (MUL -1 B R12 EXPO + (NUMN PLUSPOWFO1 C B A X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ RES2 (ADD (AUGMULT (MUL* X EXPR EXPO + (INV (PLUS P P 2)))) + (AUGMULT (MUL* B (PLUS P P 3) + (LIST '(RAT) -1 4) + EX + (INV (PLUS P P P 1 + (TIMES P P) + (TIMES P P))) + EXPR)) + (AUGMULT (MUL (INV (PLUS P 1)) + EX + (LIST '(RAT) 1 8.) + (ADD (MUL (POWER B 2) + (PLUS P P 3)) + (MUL -4 A C)) + (NUMN PLUSPOWFO1 C B A X))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (PRO) + (ADD (AUGMULT (MUL (POWER X (PLUS M -1)) + EXPR EXPO PRO)) + (AUGMULT (MUL -1 B (PLUS P P M M -1) + R12 EXPO PRO RES2)) + (AUGMULT (MUL -1 A (PLUS M -1) + EXPO PRO RES1)))) + (POWER (PLUS M P P) -1))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ POSZPOWLIST (CDR POSZPOWLIST)) + (COND ((NULL POSZPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR POSZPOWLIST)) + (SETQ CONTROLPOW (CAAR POSZPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER (POLFOO C B A X) (ADD P R12)) EC-1 (POWER C -2))) + +(DEFUN NUMN (P C B A X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5) + (COND ((ZEROP P) (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) EXP1 + EXP2 (POWER (POLFOO C B A X) EXP3))) + (AUGMULT (MUL (LIST '(RAT) 1 8) EXP1 EXP4 + (DEN1 C B A X))))) + (T (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) EXP1 EXP5 EXP2 + (POWER (POLFOO C B A X) (ADD P EXP3)))) + (AUGMULT (MUL (LIST '(RAT) 1 8) EXP1 EXP5 (PLUS P P 1) + EXP4 (NUMN (PLUS P -1) C B A X))))))) + EC-1 (ADD B (MUL 2 C X)) R12 + (ADD (MUL 4 A C) (MUL -1 B B)) (LIST '(RAT) 1 (PLUS P 1)))) + +(DEFUN AUGMULT (X) + ($MULTTHRU (SIMPLIFYA X NIL))) + +(DEFUN DENMDENN (NEGPOWLIST P C B A X) + ((LAMBDA (EXP1) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES SIGNA EA-1) + (SETQ SIGNA (CHECKSIGNTM (SIMPLIFYA A NIL))) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NOCONSTQUAD NEGPOWLIST P C B X)))) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) EA-1 (POWER A -1)) + (SETQ COEF (CADAR NEGPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (DEN1DENN P C B A X)) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ RES2 (ADD (AUGMULT (MUL -1 EA-1 (POWER X -1) EXP1)) + (AUGMULT (MUL -1 B (PLUS 1 P P) R12 + EA-1 (DEN1DENN P C B A X))) + (AUGMULT (MUL -2 P C EA-1 (DENN P C B A X))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (EXP2) + (ADD (AUGMULT (MUL EXP2 EA-1 + (POWER X (PLUS 1 (TIMES -1 M))) + EXP1)) + (AUGMULT (MUL B (PLUS P P M M -3) R12 + EA-1 EXP2 RES2)) + (AUGMULT (MUL C EA-1 EXP2 + (PLUS P P M -2) RES1)))) + (SIMPLIFYA (LIST '(RAT) -1 (PLUS M -1)) NIL))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) + CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER (POLFOO C B A X) (ADD R12 (TIMES -1 P))))) + +(DEFUN DENN (P C B A X) + ((LAMBDA (SIGNDISC EXP1 EXP2 EXP3) + (COND ((AND (EQ SIGNDISC '$ZERO)(ZEROP P)) + (AUGMULT (MUL* EC-1 + (LIST '(%LOG) (ADD X (MUL B R12 EC-1 )))))) + ((AND (EQ SIGNDISC '$ZERO)(GREATERP P 0)) + (AUGMULT (MUL* (LIST '(RAT) -1 (PLUS P P)) + (POWER C (MUL (LIST '(RAT) -1 2) + (PLUS P P 1))) + (POWER (ADD X (MUL B R12 EC-1 )) + (TIMES -2 P))))) + ((ZEROP P) (DEN1 C B A X)) + ((EQUAL P 1) + (AUGMULT (MUL 2 EXP1 EXP2 (POWER (POLFOO C B A X) + (LIST '(RAT) -1 2))))) + (T (ADD (AUGMULT (MUL 2 EXP1 EXP3 EXP2 + (POWER (POLFOO C B A X) + (ADD R12 (TIMES -1 P))))) + (AUGMULT (MUL 8 C (PLUS P -1) EXP3 EXP2 + (DENN (PLUS P -1) C B A X))))))) + (SIGNDIS1 C B A) (ADD B (MUL 2 C X)) + (POWER (ADD (MUL 4 A C)(MUL B B -1)) -1) (INV (PLUS P P -1)))) + +(DEFUN DEN1DENN (P C B A X) + ((LAMBDA (SIGNA EA-1) + (COND ((EQ SIGNA '$ZERO)(NOCONSTQUAD 1 P C B X)) + ((ZEROP P) (DEN1DEN1 C B A X)) + (T (ADD (AUGMULT (MUL (INV (PLUS P P -1)) EA-1 + (POWER (POLFOO C B A X) + (ADD R12 (TIMES -1 P))))) + (AUGMULT (MUL EA-1 (DEN1DENN (PLUS P -1) C B A X))) + (AUGMULT (MUL -1 R12 EA-1 B (DENN P C B A X))))))) + (CHECKSIGNTM (POWER A 2)) + (POWER A -1))) + +(DEFUN DEN1DEN1 (C B A X) + ((LAMBDA (EXP2 EXP3 EXP4) + (PROG (SIGNDISCRIM CONDITION SIGNA EXP1) + (SETQ SIGNA (CHECKSIGNTM (SIMPLIFYA A NIL))) + (SETQ CONDITION (ADD (MUL B X) A A)) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NOCONSTQUAD '((1 1)) 0 C B X)))) + (SETQ SIGNDISCRIM (SIGNDIS3 C B A SIGNA) + EXP1 (POWER A (INV -2))) + (COND ((AND (EQ SIGNA '$POSITIVE) + (EQ SIGNDISCRIM '$NEGATIVE)) + (RETURN (MUL* -1 EXP1 + (LIST '(%ASINH) + (AUGMULT (MUL EXP2 EXP3 + (POWER (ADD (MUL 4 A C) + (MUL -1 B B)) + EXP4)))))))) + (COND ((AND (EQ SIGNDISCRIM '$ZERO) + (EQ SIGNA '$POSITIVE)) + (RETURN (MUL* (POWER -1 CONDITION) -1 EXP1 + (LIST '(%LOG) + (AUGMULT (MUL EXP3 EXP2))))))) + (COND ((EQ SIGNA '$POSITIVE) + (RETURN (MUL* -1 EXP1 + (LIST '(%LOG) + (ADD B (MUL 2 A EXP3) + (MUL 2 EXP3 + (POWER A R12) + (POWER (POLFOO C B A X) + R12)))))))) + (COND ((AND (EQ SIGNA '$NEGATIVE) + (EQ SIGNDISCRIM '$POSITIVE)) + (RETURN (MUL* (POWER (MUL -1 A) EXP4) + (LIST '(%ASIN) + (AUGMULT (MUL EXP2 EXP3 + (POWER (ADD (MUL B B) + (MUL -4 A C)) + EXP4)))))))) + (RETURN (MUL -1 (POWER -1 R12) + (DEN1DEN1 (MUL -1 C) (MUL -1 B) (MUL -1 A) X))))) + (ADD (MUL B X) A A) (POWER (LIST '(MABS) X) -1) (LIST '(RAT) -1 2))) + +(DEFUN NOCONSTQUAD (NEGPOWLIST P C B X) + ((LAMBDA (EXP1 EXP2 EXP3) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 SIGNB M PARTRES EB-1) + (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (COND ((EQ SIGNB '$ZERO) + (RETURN (TRIVIAL1 NEGPOWLIST P C X)))) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST) EB-1 (INV B)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B 0 X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (ADD (AUGMULT (MUL -2 EXP1 EB-1 EXP2 + (POWER (POLFOO C B 0 X) + (ADD R12 EXP3)))) + (AUGMULT (MUL -4 P C EXP1 EB-1 (DENN P C B 0 X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (SETQ COUNT 3 M 2) + JUMP (SETQ PARTRES (ADD (AUGMULT (MUL -2 (INV (PLUS P P M M -1)) + EB-1 + (POWER X (MUL -1 M)) + (POWER (POLFOO C B 0 X) + (ADD R12 EXP3)))) + (AUGMULT (MUL -2 C (PLUS P P M -1) + EB-1 (INV (PLUS P P M M -1)) RES1)))) + (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP3 (SETQ RES1 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) + CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 3) (GO JUMP3))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (GO JUMP2))) + (INV (PLUS P P 1)) (POWER X -1) (TIMES -1 P))) + +(DEFUN TRIVIAL1 (NEGPOWLIST P C X) + (COND ((NULL NEGPOWLIST) 0) + (T (ADD (AUGMULT (MUL (POWER X + (ADD (TIMES -2 P) + (MUL -1 + (CAAR NEGPOWLIST)))) + (CADAR NEGPOWLIST) + (POWER C + (ADD (TIMES -1 P) + (LIST '(RAT) -1 2))) + (INV (ADD (TIMES -2 P) + (MUL -1 (CAAR NEGPOWLIST)))))) + (TRIVIAL1 (CDR NEGPOWLIST) P C X))))) + +(DEFUN NUMMDENN (POSZPOWLIST P C B A X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5 EXP6 EXP7) + (PROG (RESULT CONTROLPOW COEF COUNT RES1 RES2 M PARTRES SIGNDISCRIM) + (SETQ RESULT 0 CONTROLPOW (CAAR POSZPOWLIST)) + (SETQ COEF (CADAR POSZPOWLIST) SIGNDISCRIM (SIGNDIS1 C B A)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (DENN P C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 + (ADD (AUGMULT (MUL -1 EC-1 EXP1 EXP2)) + (AUGMULT (MUL B (LIST '(RAT) -1 2) + EC-1 (DENN P C B A X))))) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((AND (GREATERP P 0) + (NOT (EQ SIGNDISCRIM '$ZERO))) + (SETQ RES2 + (ADD (AUGMULT (MUL EC-1 EXP1 EXP3 EXP2 + (ADD (MUL 2 A B) + (MUL 2 B B X) + (MUL -4 A C X)))) + (AUGMULT (MUL EC-1 EXP3 EXP1 + (ADD (MUL 4 A C) + (MUL 2 B B P) + (MUL -3 B B)) + (DENN (PLUS P -1) + C B A X))))))) + (COND ((AND (EQUAL P 0) + (NOT (EQ SIGNDISCRIM '$ZERO))) + (SETQ RES2 + (ADD (AUGMULT (MUL (LIST '(RAT) 1 4) + EXP5 + (ADD (MUL 2 C X) + (MUL -3 B)) + (POWER (POLFOO C B A X) + R12))) + (AUGMULT (MUL (LIST '(RAT) 1 8) + EXP5 + (ADD (MUL 3 B B) + (MUL -4 A C)) + (DEN1 C B A X))))))) + (COND ((AND (EQUAL P 0)(EQ SIGNDISCRIM '$ZERO)) + (SETQ RES2 + (ADD (AUGMULT (MUL* B B (LIST '(RAT) 1 4) + (POWER C -3) + (LIST '(%LOG) EXP4))) + (AUGMULT (MUL EC-1 R12 (POWER EXP4 2))) + (AUGMULT (MUL -1 B X EXP5)))))) + (COND ((AND (EQUAL P 1) (EQ SIGNDISCRIM '$ZERO)) + (SETQ RES2 + (ADD (AUGMULT (MUL* EC-1 (LIST '(%LOG) EXP4))) + (AUGMULT (MUL B EXP5 (POWER EXP4 -1))) + (AUGMULT (MUL (LIST '(RAT) -1 8) + (POWER C -3) + B B (POWER EXP4 -2))))))) + (COND ((AND (EQ SIGNDISCRIM '$ZERO)(GREATERP P 1)) + (SETQ RES2 + (ADD (AUGMULT (MUL EC-1 (POWER EXP4 EXP6) + (INV EXP6))) + (AUGMULT (MUL -1 B EXP5 (INV EXP7) + (POWER EXP4 EXP7))) + (AUGMULT (MUL B B (LIST '(RAT) -1 8) + (POWER C -3) + (INV P) + (POWER EXP4 + (TIMES -2 P)))))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (DENOM PM-1) + (ADD (AUGMULT (MUL* (POWER X PM-1) + EC-1 (LIST '(RAT) -1 DENOM) + (POWER (POLFOO C B A X) + (ADD R12 + (TIMES -1 P))))) + (AUGMULT (MUL B (PLUS P P 1 (TIMES -2 M)) + (LIST '(RAT) -1 2) + EC-1 (INV DENOM) RES2)) + (AUGMULT (MUL A PM-1 EC-1 (INV DENOM) RES1)))) + (PLUS P P (TIMES -1 M)) + (PLUS M -1))) + ON (SETQ M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (COND ((EQUAL M (PLUS P P)) + (SETQ PARTRES + ((LAMBDA (EXPR) + (ADD (MUL X EXPR) + (MUL -1 (DISTRINT (CDR ($EXPAND EXPR)) + X)))) + (NUMMDENN (LIST (LIST (PLUS M -1) 1)) + P C B A X))) + (GO ON))) + (GO JUMP) + LOOP (SETQ POSZPOWLIST (CDR POSZPOWLIST)) + (COND ((NULL POSZPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR POSZPOWLIST) CONTROLPOW (CAAR POSZPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (INV (PLUS P P -1)) (POWER (POLFOO C B A X) (ADD R12 (TIMES -1 P))) + (POWER (ADD (MUL 4 A C)(MUL -1 B B)) -1) (ADD X (MUL B R12 EC-1)) + (POWER C -2) (PLUS 2 (TIMES -2 P)) (PLUS 1 (TIMES -2 P)))) + +(DEFUN DENMNUMN (NEGPOWLIST POW C B A X) + ((LAMBDA (EXP1 EXP2) + (PROG (RESULT CONTROLPOW P COEF COUNT RES1 RES2 M + PARTRES SIGNA EA-1) + (SETQ P (PLUS POW POW -1)) + (COND ((EQ (CAR NEGPOWLIST) 'T) + (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (GO THERE))) + (SETQ SIGNA (CHECKSIGNTM (POWER A 2))) + (COND ((EQ SIGNA '$ZERO) + (RETURN (NONCONSTQUADENUM NEGPOWLIST P C B X)))) + (SETQ EA-1 (INV A)) + THERE (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF + (NUMN (ADD (MUL P R12) R12) + C B A X))) + COUNT 1) + (GO LOOP))) + JUMP1 (SETQ RES1 (DEN1NUMN POW C B A X)) + (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES1))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((NOT (EQUAL P 1)) + (SETQ RES2 (ADD (AUGMULT (MUL -1 EXP1 + (POWER (POLFOO C B A X) + (ADD POW + (LIST '(RAT) -1 2))))) + (AUGMULT (MUL B (LIST '(RAT) EXP2 2) + (DEN1NUMN (PLUS POW -1) + C B A X))) + (AUGMULT (MUL C EXP2 (NUMN (PLUS POW -2) + C B A X))))))) + (COND ((EQUAL P 1) + (SETQ RES2 (ADD (AUGMULT (MUL -1 (POWER (POLFOO C B A X) + R12) + EXP1)) + (AUGMULT (MUL B R12 (DEN1DEN1 C B A X))) + (AUGMULT (MUL C (DEN1 C B A X))))))) + (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF RES2))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ COUNT 4 M 3) + JUMP (SETQ PARTRES + ((LAMBDA (EXP3 EXP4) + (ADD (AUGMULT (MUL* (LIST '(RAT) -1 EXP3) + EA-1 (POWER X (PLUS 1 EXP4)) + (POWER (POLFOO C B A X) + (ADD (LIST '(RAT) P 2) + 1)))) + (AUGMULT (MUL (INV (PLUS M M -2)) + EA-1 B (PLUS P 4 (TIMES -2 M)) + RES2)) + (AUGMULT (MUL C EA-1 (PLUS P 3 EXP4) + (INV EXP3) RES1)))) + (PLUS M -1) (TIMES -1 M)) + M (PLUS M 1)) + (COND ((GREATERP M CONTROLPOW) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + (GO LOOP))) + JUMP4 (SETQ RES1 RES2 RES2 PARTRES) + (GO JUMP) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 4) (GO JUMP4))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (GO JUMP3))) + (POWER X -1) (PLUS POW POW -1))) + +(DEFUN NONCONSTQUADENUM (NEGPOWLIST P C B X) + (PROG (RESULT COEF M) + (COND ((EQUAL P 1)(RETURN (CASE1 NEGPOWLIST C B X)))) + (SETQ RESULT 0) + LOOP (SETQ M (CAAR NEGPOWLIST) COEF (CADAR NEGPOWLIST)) + (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF (CASEGEN M P C B X)))) + NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (GO LOOP))) + +(DEFUN CASEGEN (M P C B X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EXP5) + (COND ((EQUAL P 1) (CASE1 (LIST (LIST M 1)) C B X)) + ((ZEROP M) (CASE0 P C B X)) + ((EQUAL M (PLUS P 1)) + (ADD (AUGMULT (MUL -1 EXP1 (INV EXP2) EXP3)) + (AUGMULT (MUL B R12 (CASEGEN EXP2 EXP4 C B X))) + (AUGMULT (MUL C (CASEGEN (PLUS M -2) EXP4 C B X))))) + ((EQUAL M 1) (ADD (AUGMULT (MUL (INV P) EXP1)) + (AUGMULT (MUL B R12 (CASE0 EXP4 C B X))))) + (T (ADD (AUGMULT (MUL -1 EXP1 (INV EXP5) EXP3)) + (AUGMULT (MUL -1 P B R12 (INV EXP5) + (CASEGEN EXP2 EXP4 C B X))))))) + (POWER (POLFOO C B 0 X)(LIST '(RAT) P 2)) + (PLUS M -1) + (POWER X (PLUS 1 (TIMES -1 M))) + (PLUS P -2) + (PLUS M -1 (TIMES -1 P)))) + +(DEFUN CASE1 (NEGPOWLIST C B X) + ((LAMBDA (EXP1 EB-1) + (PROG (RESULT CONTROLPOW M1 COEF COUNT RES1 RES2 M SIGNC + SIGNB PARTRES RES) + (SETQ RESULT 0 CONTROLPOW (CAAR NEGPOWLIST) + COEF (CADAR NEGPOWLIST) M1 (PLUS CONTROLPOW -2)) + (COND ((ZEROP CONTROLPOW) + (SETQ RESULT (AUGMULT (MUL COEF (CASE0 1 C B X))) + COUNT 1) + (GO LOOP))) + JUMP1 (COND ((EQUAL CONTROLPOW 1) + (SETQ RESULT + (ADD RESULT + (AUGMULT (MUL COEF (DEN1NUMN 1 C B 0 X)))) + COUNT 2) + (GO LOOP))) + JUMP2 (COND ((EQUAL CONTROLPOW 2) + (SETQ RESULT + (ADD RESULT + (AUGMULT (MUL COEF + (DENMNUMN '(T (2 1)) + 1 C B 0 X)))) + COUNT 3) + (GO LOOP))) + JUMP3 (SETQ SIGNB (CHECKSIGNTM (POWER B 2))) + (COND ((EQ SIGNB '$ZERO)(SETQ COUNT 5)(GO JUMP5))) + (SETQ COUNT 4 M 0 SIGNC (CHECKSIGNTM EC-1)) + (COND ((EQ SIGNC '$POSITIVE) + (SETQ RES + (AUGMULT (MUL* 2 EXP1 + (LIST '(%LOG) + (ADD (POWER (MUL C X) + R12) + (POWER (ADD B + (MUL C X)) + R12)))))) + (GO JUMP4))) + (SETQ RES + (AUGMULT (MUL* 2 EXP1 + (LIST '(%ATAN) + (POWER (MUL C X + (POWER (ADD B + (MUL -1 C X)) + -1)) + R12))))) + JUMP4 (SETQ M (PLUS M 1) + RES (ADD (AUGMULT (MUL -2 (POWER (POLFOO C B 0 X) R12) + EB-1 (INV (PMM-1 M)) + (EXT-1M X M))) + (AUGMULT (MUL* (LIST '(RAT) -2 (PMM-1 M)) + C (SUB1 M) + EB-1 RES)))) + (COND ((EQUAL M M1) (SETQ RES2 RES) (GO JUMP4))) + (COND ((EQUAL (SUB1 M) M1) + (IF (NULL RES2) (RETURN NIL)) + (SETQ RES1 RES + PARTRES (ADD (AUGMULT (MUL -1 + (POWER (POLFOO C B 0 X) + R12) + (R1M M) + (EXT-1M X M))) + (AUGMULT (MUL B R12 (R1M M) RES1)) + (AUGMULT (MUL C (R1M M) RES2)))) + (GO ON))) + (GO JUMP4) + JUMP5 (SETQ M CONTROLPOW) + (COND ((ZEROP M) + (SETQ PARTRES (MUL* EXP1 (LIST '(%LOG) X))) + (GO ON))) + (SETQ PARTRES (MUL -1 EXP1 (EXT-1M X M) (R1M M))) + ON (SETQ RESULT (ADD RESULT (AUGMULT (MUL COEF PARTRES)))) + LOOP (SETQ NEGPOWLIST (CDR NEGPOWLIST)) + (COND ((NULL NEGPOWLIST) (RETURN RESULT))) + (SETQ COEF (CADAR NEGPOWLIST) CONTROLPOW (CAAR NEGPOWLIST)) + (COND ((EQUAL COUNT 5) (GO JUMP5))) + (COND ((EQUAL COUNT 1) (GO JUMP1))) + (COND ((EQUAL COUNT 2) (GO JUMP2))) + (COND ((EQUAL COUNT 3) (GO JUMP3))) + (SETQ M1 (PLUS CONTROLPOW -2)) + (COND ((EQUAL M1 M) (SETQ RES2 RES1))) + (GO JUMP4))) + (POWER C (LIST '(RAT) -1 2)) (POWER B -1))) + +(DEFUN PMM-1 (M) (PLUS M M -1)) + +(DEFUN R1M (M) (LIST '(RAT) 1 M)) + +(DEFUN EXT-1M (X M) (POWER X (TIMES -1 M))) + +(DEFUN CASE0 (POWER C B X) + ((LAMBDA (EXP1 EXP2 EXP3 EXP4 EB-1) + (PROG (SIGNC P RESULT) + (SETQ SIGNC (CHECKSIGNTM EC-1) P 1) + (COND ((EQ SIGNC '$POSITIVE) + (SETQ RESULT + (ADD (AUGMULT (MUL EXP1 EC-1 EXP2 + (POWER (POLFOO C B 0 X) + R12))) + (AUGMULT (MUL* B B (LIST '(RAT) -1 8) + EXP3 + (LIST '(%LOG) + (ADD EXP2 + (MUL 2 + (POWER C R12) + (POWER + (POLFOO C B 0 X) + R12)))))))))) + (COND ((EQ SIGNC '$NEGATIVE) + (SETQ RESULT + (ADD (AUGMULT (MUL EXP1 EC-1 EXP4 + (POWER (POLFOO (MUL -1 C) + B 0 X) + R12))) + (AUGMULT (MUL* B B (LIST '(RAT) 1 8) + EXP3 + (LIST '(%ASIN) + (MUL EB-1 EXP4)))))))) + LOOP (COND ((EQUAL POWER P) (RETURN RESULT))) + (SETQ P (PLUS P 2) + RESULT ((LAMBDA (EXP5) + (ADD (AUGMULT (MUL R12 EC-1 EXP5 EXP2 + (POWER (POLFOO C B 0 X) + (LIST '(RAT) P 2)))) + (AUGMULT (MUL P B B (LIST '(RAT) -1 4) + EC-1 EXP5 RESULT)))) + (INV (PLUS P 1)))) + (GO LOOP))) + (LIST '(RAT) 1 4) (ADD B (MUL 2 C X)) (POWER C (LIST '(RAT) -3 2)) + (ADD (MUL 2 C X)(MUL -1 B)) (POWER B -1))) + +(DEFUN DEN1NUMN (P C B A X) + (COND ((EQUAL P 1) + (ADD (POWER (POLFOO C B A X) R12 ) + (AUGMULT (MUL A (DEN1DEN1 C B A X))) + (AUGMULT (MUL B R12 (DEN1 C B A X))))) + (T (ADD (AUGMULT (MUL (POWER (POLFOO C B A X) + (ADD P (LIST '(RAT) -1 2))) + (INV (PLUS P P -1)))) + (AUGMULT (MUL A (DEN1NUMN (PLUS P -1) C B A X))) + (AUGMULT (MUL B R12 (NUMN (PLUS P -2) C B A X))))))) + +(DEFUN DISTRINT (EXPR X) + (COND ((NULL EXPR) 0) + (T (ADD (INTIRA (CAR EXPR) X) + (DISTRINT (CDR EXPR) X))))) diff --git a/src/maxsrc/laplac.202 b/src/maxsrc/laplac.202 new file mode 100644 index 00000000..d23ec972 --- /dev/null +++ b/src/maxsrc/laplac.202 @@ -0,0 +1,935 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module laplac) + +(DECLARE (SPECIAL DVAR VAR-LIST VAR-PARM-LIST VAR PARM $SAVEFACTORS + CHECKFACTORS $RATFAC $KEEPFLOAT NOUNL NOUNSFLAG) + (*EXPR SUBFUNMAKE) + (*LEXPR $DIFF $EXPAND $MULTTHRU $RATSIMP) + ) + +(DEFUN EXPONENTIATE (POW) + ;;;COMPUTES %E**Z WHERE Z IS AN ARBITRARY EXPRESSION TAKING SOME OF THE WORK AWAY FROM SIMPEXPT + (COND ((ZEROP1 POW) 1) + ((EQUAL POW 1) '$%E) + (T (POWER '$%E POW)))) + +(DEFUN FIXUPREST (REST) + ;;;REST IS A PRODUCT WITHOUT THE MTIMES.FIXUPREST PUTS BACK THE MTIMES + (COND ((NULL REST) 1) + ((CDR REST) (CONS '(MTIMES SIMP) REST)) + (T (CAR REST)))) + +(DEFUN POSINT MACRO (X) (SUBST (CADR X) 'Y '(AND (FIXP Y) (> Y 0)))) + +(DEFUN NEGINT MACRO (X) (SUBST (CADR X) 'Y '(AND (FIXP Y) (< Y 0)))) + +(DEFUN ISQUADRATICP (E X) + ((LAMBDA (B) + (COND ((ZEROP1 B) (LIST 0 0 E)) + ((FREEOF X B) (LIST 0 B (SUBSTITUTE 0 X E))) + ((SETQ B (ISLINEAR B X)) + (LIST (DIV* (CAR B) 2) (CDR B) (SUBSTITUTE 0 X E))))) + (SDIFF E X))) + + +;;;INITIALIZES SOME GLOBAL VARIABLES THEN CALLS THE DISPATCHING FUNCTION + +(DEFMFUN $LAPLACE (FUN VAR PARM) + (SETQ FUN (MRATCHECK FUN)) + (COND ((OR NOUNSFLAG (MEMQ '%LAPLACE NOUNL)) (SETQ FUN (REMLAPLACE FUN)))) + (COND ((AND (NULL (ATOM FUN)) (EQ (CAAR FUN) 'MEQUAL)) + (LIST '(MEQUAL SIMP) + (LAPLACE (CADR FUN)) + (LAPLACE (CADDR FUN)))) + (T (LAPLACE FUN)))) + +;;;LAMBDA BINDS SOME SPECIAL VARIABLES TO NIL AND DISPATCHES + +(DEFUN REMLAPLACE (E) + (COND ((ATOM E) E) + (T (CONS (DELQ 'LAPLACE (APPEND (CAR E) NIL) 1) (MAPCAR 'REMLAPLACE (CDR E)))))) + +(DEFUN LAPLACE (FUN) + ((LAMBDA (DVAR VAR-LIST VAR-PARM-LIST) + ;;; Handles easy cases and calls appropriate function on others. + (COND ((EQUAL FUN 0) 0) + ((EQUAL FUN 1) + (COND ((ZEROP1 PARM) (SIMPLIFY (LIST '($DELTA) 0))) + (T (POWER PARM -1)))) + ((ALIKE1 FUN VAR) (POWER PARM -2)) + ((OR (ATOM FUN) (FREEOF VAR FUN)) + (COND ((ZEROP1 PARM) (MUL2 FUN (SIMPLIFY (LIST '($DELTA) 0)))) + (T (MUL2 FUN (POWER PARM -1))))) + (T ((LAMBDA (OP) + (COND ((EQ OP 'MPLUS) + (LAPLUS FUN)) + ((EQ OP 'MTIMES) + (LAPTIMES (CDR FUN))) + ((EQ OP 'MEXPT) + (LAPEXPT FUN NIL)) + ((EQ OP '%SIN) + (LAPSIN FUN NIL NIL)) + ((EQ OP '%COS) + (LAPSIN FUN NIL T)) + ((EQ OP '%SINH) + (LAPSINH FUN NIL NIL)) + ((EQ OP '%COSH) + (LAPSINH FUN NIL T)) + ((EQ OP '%LOG) + (LAPLOG FUN)) + ((EQ OP '%DERIVATIVE) + (LAPDIFF FUN)) + ((EQ OP '%INTEGRATE) + (LAPINT FUN)) + ((EQ OP '%SUM) + (LIST '(%SUM SIMP) + (LAPLACE (CADR FUN)) + (CADDR FUN) + (CADDDR FUN) + (CAR (CDDDDR FUN)))) + ((EQ OP '%ERF) + (LAPERF FUN)) + ((AND (EQ OP '%ILT)(EQ (CADDDR FUN) VAR)) + (COND ((EQ PARM (CADDR FUN))(CADR FUN)) + (T (SUBST PARM (CADDR FUN)(CADR FUN)))) +) ((EQ OP '$DELTA) + (LAPDELTA FUN NIL)) + ((SETQ OP ($GET OP '$LAPLACE)) + (MCALL OP FUN VAR PARM)) + (T (LAPDEFINT FUN)))) + (CAAR FUN))))) + NIL + NIL + NIL)) + +(DEFUN LAPLUS (FUN) + (SIMPLUS (CONS '(MPLUS) + (MAPCAR (FUNCTION LAPLACE) (CDR FUN))) + 1. + T)) + +(DEFUN LAPTIMES (FUN) + ;;;EXPECTS A LIST (PERHAPS EMPTY) OF FUNCTIONS MULTIPLIED TOGETHER WITHOUT THE MTIMES + ;;;SEES IF IT CAN APPLY THE FIRST AS A TRANSFORMATION ON THE REST OF THE FUNCTIONS + (COND ((NULL FUN) (LIST '(MEXPT SIMP) PARM -1.)) + ((NULL (CDR FUN)) (LAPLACE (CAR FUN))) + ((FREEOF VAR (CAR FUN)) + (SIMPTIMES (LIST '(MTIMES) + (CAR FUN) + (LAPTIMES (CDR FUN))) + 1. + T)) + ((EQ (CAR FUN) VAR) + (SIMPTIMES (LIST '(MTIMES) + -1. + (SDIFF (LAPTIMES (CDR FUN)) PARM)) + 1. + T)) + (T ((LAMBDA (OP) + (COND ((EQ OP 'MEXPT) + (LAPEXPT (CAR FUN) (CDR FUN))) + ((EQ OP 'MPLUS) + (LAPLUS ($MULTTHRU (FIXUPREST (CDR FUN)) (CAR FUN)))) + ((EQ OP '%SIN) + (LAPSIN (CAR FUN) (CDR FUN) NIL)) + ((EQ OP '%COS) + (LAPSIN (CAR FUN) (CDR FUN) T)) + ((EQ OP '%SINH) + (LAPSINH (CAR FUN) (CDR FUN) NIL)) + ((EQ OP '%COSH) + (LAPSINH (CAR FUN) (CDR FUN) T)) + ((EQ OP '$DELTA) + (LAPDELTA (CAR FUN) (CDR FUN))) + + (T (LAPSHIFT (CAR FUN) (CDR FUN))))) + (CAAAR FUN))))) + +(DEFUN LAPEXPT (FUN REST) + ;;;HANDLES %E**(A*T+B)*REST(T), %E**(A*T**2+B*T+C), + ;;; 1/SQRT(A*T+B), OR T**K*REST(T) + (PROG (AB BASE-OF-FUN POWER RESULT) + (SETQ BASE-OF-FUN (CADR FUN) POWER (CADDR FUN)) + (COND + ((AND + (FREEOF VAR BASE-OF-FUN) + (SETQ + AB + (ISQUADRATICP + (COND ((EQ BASE-OF-FUN '$%E) POWER) + (T (SIMPTIMES (LIST '(MTIMES) + POWER + (LIST '(%LOG) + BASE-OF-FUN)) + 1. + NIL))) + VAR))) + (COND ((EQUAL (CAR AB) 0.) (GO %E-CASE-LIN)) + ((NULL REST) (GO %E-CASE-QUAD)) + (T (GO NOLUCK)))) + ((AND (EQ BASE-OF-FUN VAR) (FREEOF VAR POWER)) + (GO VAR-CASE)) + ((AND (ALIKE1 '((RAT) -1. 2.) POWER) (NULL REST) + (SETQ AB (ISLINEAR BASE-OF-FUN VAR))) + (SETQ RESULT (DIV* (CDR AB) (CAR AB))) + (RETURN (SIMPTIMES + (LIST '(MTIMES) + (LIST '(MEXPT) + (DIV* '$%PI + (LIST '(MTIMES) + (CAR AB) + PARM)) + '((RAT) 1. 2.)) + (EXPONENTIATE (LIST '(MTIMES) RESULT PARM)) + (LIST '(MPLUS) + 1. + (LIST '(MTIMES) + -1. + (LIST '(%ERF) + (LIST '(MEXPT) + (LIST '(MTIMES) + RESULT + PARM) + '((RAT) + 1. + 2.))) + ))) 1 NIL))) + (T (GO NOLUCK))) + %E-CASE-LIN + (SETQ + RESULT + (COND + (REST ($RATSIMP ($AT (LAPTIMES REST) + (LIST '(MEQUAL SIMP) + PARM + (LIST '(MPLUS SIMP) + PARM + (AFIXSIGN (CADR AB) + NIL)))))) + (T (LIST '(MEXPT) + (LIST '(MPLUS) + PARM + (AFIXSIGN (CADR AB) NIL)) + -1.)))) + (RETURN (SIMPTIMES (LIST '(MTIMES) + (EXPONENTIATE (CADDR AB)) + RESULT) + 1. + NIL)) + %E-CASE-QUAD + (SETQ RESULT (AFIXSIGN (CAR AB) NIL)) + (SETQ + RESULT + (LIST + '(MTIMES) + (DIV* (LIST '(MEXPT) + (DIV* '$%PI RESULT) + '((RAT) 1. 2.)) + 2.) + (EXPONENTIATE (DIV* (LIST '(MEXPT) PARM 2.) + (LIST '(MTIMES) + 4. + RESULT))) + (LIST '(MPLUS) + 1. + (LIST '(MTIMES) + -1. + (LIST '(%ERF) + (DIV* PARM + (LIST '(MTIMES) + 2. + (LIST '(MEXPT) + RESULT + '((RAT) + 1. + 2.))))) + )))) + (AND (NULL (EQUAL (CADR AB) 0.)) + (SETQ RESULT + (SUBSTITUTE (LIST '(MPLUS) + PARM + (LIST '(MTIMES) + -1. + (CADR AB))) + PARM + RESULT))) + (RETURN (SIMPTIMES (LIST '(MTIMES) + (EXPONENTIATE (CADDR AB)) + RESULT) 1 NIL)) + VAR-CASE + (COND ((OR (NULL REST) (FREEOF VAR (FIXUPREST REST))) + (GO VAR-EASY-CASE))) + (COND ((POSINT POWER) + (RETURN (AFIXSIGN (APPLY '$DIFF + (LIST (LAPTIMES REST) + PARM + POWER)) + (EVEN POWER)))) + ((NEGINT POWER) + (RETURN (MYDEFINT (HACKIT POWER REST) + (CREATENAME PARM (MINUS POWER)) + PARM))) + (T (GO NOLUCK))) + VAR-EASY-CASE + (SETQ POWER + (SIMPLUS (LIST '(MPLUS) 1. POWER) 1. T)) + (OR (EQ (ASKSIGN POWER) '$POSITIVE) (GO NOLUCK)) + (SETQ RESULT (LIST (LIST '(%GAMMA) POWER) + (LIST '(MEXPT) + PARM + (AFIXSIGN POWER NIL)))) + (AND REST (SETQ RESULT (NCONC RESULT REST))) + (RETURN (SIMPTIMES (CONS '(MTIMES) RESULT) + 1. + NIL)) + NOLUCK + (RETURN + (COND + ((AND (POSINT POWER) + (MEMQ (CAAR BASE-OF-FUN) + '(MPLUS %SIN %COS %SINH %COSH))) + (LAPTIMES (CONS BASE-OF-FUN + (CONS (COND ((= POWER 2.) BASE-OF-FUN) + (T (LIST '(MEXPT SIMP) + BASE-OF-FUN + (SUB1 POWER)))) + REST)))) + (T (LAPSHIFT FUN REST)))))) + +(DEFUN MYDEFINT (F X A) + ;;;INTEGRAL FROM A TO INFINITY OF F(X) + ((LAMBDA (TRYINT) (COND (TRYINT (CAR TRYINT)) + (T (LIST '(%INTEGRATE SIMP) + F + X + A + '$INF)))) + (AND (NOT ($UNKNOWN F)) + (ERRSET ($DEFINT F X A '$INF))))) + +(DEFUN CREATENAME + ;;;CREATES HOPEFULLY UNIQUE NAMES FOR VARIABLE OF INTEGRATION + (HEAD TAIL) + (implode (NCONC (EXPLODEC HEAD) (EXPLODEC TAIL)))) + +(DECLARE (FIXNUM EXPONENT)) + +(DEFUN HACKIT (EXPONENT REST) + ;;;REDUCES LAPLACE(F(T)/T**N,T,S) CASE TO LAPLACE(F(T)/T**(N-1),T,S) CASE + (COND ((EQUAL EXPONENT -1.) + ((LAMBDA (PARM) (LAPTIMES REST)) (CREATENAME PARM 1.))) + (T (MYDEFINT (HACKIT (1+ EXPONENT) REST) + (CREATENAME PARM (DIFFERENCE -1. EXPONENT)) + (CREATENAME PARM (MINUS EXPONENT)))))) + +(DECLARE (NOTYPE EXPONENT)) + +(DEFUN AFIXSIGN (FUNCT SIGNSWITCH) + ;;;MULTIPLIES FUNCT BY -1 IF SIGNSWITCH IS NIL + (COND (SIGNSWITCH FUNCT) + (T (SIMPTIMES (LIST '(MTIMES) -1. FUNCT) 1. T)))) + + + +(DEFUN LAPSHIFT (FUN REST) + (COND ((ATOM FUN) (merror "INTERNAL ERROR")) + ((OR (MEMQ 'LAPLACE (CAR FUN)) (NULL REST)) + (LAPDEFINT (COND (REST (SIMPTIMES (CONS '(MTIMES) + (CONS FUN REST)) 1 T)) + (T FUN)))) + (T (LAPTIMES (APPEND REST + (NCONS (CONS (APPEND (CAR FUN) + '(LAPLACE)) + (CDR FUN)))))))) + +(DEFUN MOSTPART (F PARM SIGN A B) + ;;;COMPUTES %E**(W*B*%I)*F(S-W*A*%I) WHERE W=-1 IF SIGN IS T ELSE W=1 + ((LAMBDA (SUBSTINFUN) + (COND ((ZEROP1 B) SUBSTINFUN) + (T (LIST '(MTIMES) + (EXPONENTIATE (AFIXSIGN (LIST '(MTIMES) + B + '$%I) + (NULL SIGN))) + SUBSTINFUN)))) + ($AT F + (LIST '(MEQUAL SIMP) + PARM + (LIST '(MPLUS SIMP) + PARM + (AFIXSIGN (LIST '(MTIMES) + A + '$%I) + SIGN)))))) + +(DEFUN COMPOSE + ;;;IF WHICHSIGN IS NIL THEN SIN TRANSFORM ELSE COS TRANSFORM + (FUN PARM WHICHSIGN A B) + ((LAMBDA (RESULT) + ($RATSIMP (SIMPTIMES (CONS '(MTIMES) + (COND (WHICHSIGN RESULT) + (T (CONS '$%I + RESULT)))) + 1 NIL))) + (LIST '((RAT) 1. 2.) + (LIST '(MPLUS) + (MOSTPART FUN PARM T A B) + (AFIXSIGN (MOSTPART FUN PARM NIL A B) + WHICHSIGN))))) + +(DEFUN LAPSIN + ;;;FUN IS OF THE FORM SIN(A*T+B)*REST(T) OR COS + (FUN REST TRIGSWITCH) + ((LAMBDA (AB) + (COND + (AB + (COND + (REST (COMPOSE (LAPTIMES REST) + PARM + TRIGSWITCH + (CAR AB) + (CDR AB))) + (T (SIMPTIMES + (LIST + '(MTIMES) + (COND + ((ZEROP1 (CDR AB)) + (COND (TRIGSWITCH PARM) (T (CAR AB)))) + (T (COND (TRIGSWITCH (LIST '(MPLUS) + (LIST '(MTIMES) + PARM + (LIST '(%COS) + (CDR AB))) + (LIST '(MTIMES) + -1. + (CAR AB) + (LIST '(%SIN) + (CDR AB))))) + (T (LIST '(MPLUS) + (LIST '(MTIMES) + PARM + (LIST '(%SIN) + (CDR AB))) + (LIST '(MTIMES) + (CAR AB) + (LIST '(%COS) + (CDR AB)))))))) + (LIST '(MEXPT) + (LIST '(MPLUS) + (LIST '(MEXPT) PARM 2.) + (LIST '(MEXPT) (CAR AB) 2.)) + -1.)) + 1 NIL)))) + (T (LAPSHIFT FUN REST)))) + (ISLINEAR (CADR FUN) VAR))) + +(DEFUN LAPSINH + ;;;FUN IS OF THE FORM SINH(A*T+B)*REST(T) OR IS COSH + (FUN REST SWITCH) + (COND ((ISLINEAR (CADR FUN) VAR) + ($RATSIMP + (LAPLUS + (SIMPLUS + (LIST '(MPLUS) + (NCONC (LIST '(MTIMES) + (LIST '(MEXPT) + '$%E + (CADR FUN)) + '((RAT) 1. 2.)) + REST) + (AFIXSIGN (NCONC (LIST '(MTIMES) + (LIST '(MEXPT) + '$%E + (AFIXSIGN (CADR FUN) + NIL)) + '((RAT) 1. 2.)) + REST) + SWITCH)) + 1. + NIL)))) + (T (LAPSHIFT FUN REST)))) + +(DEFUN LAPLOG + ;;;FUN IS OF THE FORM LOG(A*T) + (FUN) ((LAMBDA (AB) + (COND ((AND AB (ZEROP1 (CDR AB))) + (SIMPTIMES (LIST '(MTIMES) + (LIST '(MPLUS) + (subfunmake '$PSI + '(0) + (NCONS 1.)) + (LIST '(%LOG) + (CAR AB)) + (LIST '(MTIMES) + -1. + (LIST '(%LOG) + PARM))) + (LIST '(MEXPT) + PARM + -1.)) + 1 NIL)) + (T (LAPDEFINT FUN)))) + (ISLINEAR (CADR FUN) VAR))) + +(DEFUN RAISEUP (FBASE EXPONENT) + (COND ((EQUAL EXPONENT 1.) FBASE) + (T (LIST '(MEXPT) FBASE EXPONENT)))) + +(DEFUN LAPDELTA (FUN REST) + ;;TAKES TRANSFORM OF DELTA(A*T+B)*F(T) + ((LAMBDA (AB SIGN RECIPA) + (COND + (AB + (SETQ RECIPA (POWER (CAR AB) -1) AB (DIV (CDR AB) (CAR AB))) + (SETQ SIGN (ASKSIGN AB) RECIPA (SIMPLIFYA (LIST '(MABS) RECIPA) NIL)) + (SIMPLIFYA (COND ((EQ SIGN '$POSITIVE) 0) + ((EQ SIGN '$ZERO) + (LIST '(MTIMES) + (SUBSTITUTE 0 VAR (FIXUPREST REST)) + RECIPA)) + (T (LIST '(MTIMES) + (SUBSTITUTE (NEG AB) + VAR + (FIXUPREST REST)) + (LIST '(MEXPT) + '$%E + (CONS '(MTIMES) + (CONS PARM (NCONS AB)))) + RECIPA))) + NIL)) + (T (LAPSHIFT FUN REST)))) + (ISLINEAR (CADR FUN) VAR) NIL NIL)) + +(DEFUN LAPERF (FUN ) + ((LAMBDA (AB) + (COND + ((AND AB (EQUAL (CDR AB) 0.)) + (SIMPTIMES (LIST '(MTIMES) + (DIV* (EXPONENTIATE (DIV* (LIST '(MEXPT) + PARM + 2.) + (LIST '(MTIMES) + 4. + (LIST '(MEXPT) + (CAR AB) + 2.)))) + PARM) + (LIST '(MPLUS) + 1. + (LIST '(MTIMES) + -1. + (LIST '(%ERF) + (DIV* PARM + (LIST '(MTIMES) + 2. + (CAR AB)))) + ))) 1 NIL)) + (T (LAPDEFINT FUN)))) + (ISLINEAR (CADR FUN) VAR))) +(DEFUN LAPDEFINT (FUN) + (PROG (TRYINT MULT) + (AND ($UNKNOWN FUN)(GO SKIP)) + (SETQ MULT (SIMPTIMES (LIST '(MTIMES) (EXPONENTIATE + (LIST '(MTIMES SIMP) -1 VAR PARM)) FUN) 1 NIL)) + (MEVAL `(($ASSUME) ,@(LIST (LIST '(MGREATERP) PARM 0)))) + (SETQ TRYINT (ERRSET ($DEFINT MULT VAR 0 '$INF))) + (MEVAL `(($FORGET) ,@(LIST (LIST '(MGREATERP) PARM 0)))) + (AND TRYINT (NOT (EQ (CAAAR TRYINT) '%INTEGRATE)) (RETURN (CAR TRYINT))) + SKIP (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM)))) + + +(DECLARE (FIXNUM ORDER)) + +(DEFUN LAPDIFF + ;;;FUN IS OF THE FORM DIFF(F(T),T,N) WHERE N IS A POSITIVE INTEGER + (FUN) (PROG (DIFFLIST DEGREE FRONTEND RESULTLIST NEWDLIST ORDER + ARG2) + (SETQ NEWDLIST (SETQ DIFFLIST (COPY (CDDR FUN)))) + (SETQ ARG2 (LIST '(MEQUAL SIMP) VAR 0.)) + A (COND ((NULL DIFFLIST) + (RETURN (CONS '(%DERIVATIVE SIMP) + (CONS (LIST '(%LAPLACE SIMP) + (CADR FUN) + VAR + PARM) + NEWDLIST)))) + ((EQ (CAR DIFFLIST) VAR) + (SETQ DEGREE (CADR DIFFLIST) + DIFFLIST (CDDR DIFFLIST)) + (GO OUT))) + (SETQ DIFFLIST (CDR (SETQ FRONTEND (CDR DIFFLIST)))) + (GO A) + OUT (COND ((NULL (POSINT DEGREE)) + (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM)))) + (COND (FRONTEND (RPLACD FRONTEND DIFFLIST)) + (T (SETQ NEWDLIST DIFFLIST))) + (COND (NEWDLIST (SETQ FUN (CONS '(%DERIVATIVE SIMP) + (CONS (CADR FUN) + NEWDLIST)))) + (T (SETQ FUN (CADR FUN)))) + (SETQ ORDER 0.) + LOOP (SETQ DEGREE (1- DEGREE)) + (SETQ RESULTLIST + (CONS (LIST '(MTIMES) + (RAISEUP PARM DEGREE) + ($AT ($DIFF FUN VAR ORDER) ARG2)) + RESULTLIST)) + (SETQ ORDER (1+ ORDER)) + (AND (> DEGREE 0.) (GO LOOP)) + (SETQ RESULTLIST (COND ((CDR RESULTLIST) + (CONS '(MPLUS) + RESULTLIST)) + (T (CAR RESULTLIST)))) + (RETURN (SIMPLUS (LIST '(MPLUS) + (LIST '(MTIMES) + (RAISEUP PARM ORDER) + (LAPLACE FUN)) + (LIST '(MTIMES) + -1. + RESULTLIST)) + 1 NIL)))) + +(DECLARE (NOTYPE ORDER)) + +(DEFUN LAPINT + ;;;FUN IS OF THE FORM INTEGRATE(F(X)*G(T)*H(T-X),X,0,T) + (FUN) (PROG (NEWFUN PARM-LIST F) + (AND DVAR (GO CONVOLUTION)) + (SETQ DVAR (CADR (SETQ NEWFUN (CDR FUN)))) + (AND (CDDR NEWFUN) + (ZEROP1 (CADDR NEWFUN)) + (EQ (CADDDR NEWFUN) VAR) + (GO CONVOLUTIONTEST)) + NOTCON + (SETQ NEWFUN (CDR FUN)) + (COND ((CDDR NEWFUN) + (COND ((AND (FREEOF VAR (CADDR NEWFUN)) + (FREEOF VAR (CADDDR NEWFUN))) + (RETURN (LIST '(%INTEGRATE SIMP) + (LAPLACE (CAR NEWFUN)) + DVAR + (CADDR NEWFUN) + (CADDDR NEWFUN)))) + (T (GO GIVEUP)))) + (T (RETURN (LIST '(%INTEGRATE SIMP) + (LAPLACE (CAR NEWFUN)) + DVAR)))) + GIVEUP + (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM)) + CONVOLUTIONTEST + (SETQ NEWFUN ($FACTOR (CAR NEWFUN))) + (COND ((EQ (CAAR NEWFUN) 'MTIMES) + (SETQ F (CADR NEWFUN) NEWFUN (CDDR NEWFUN))) + (T (SETQ F NEWFUN NEWFUN NIL))) + GOTHRULIST + (COND ((FREEOF DVAR F) + (SETQ PARM-LIST (CONS F PARM-LIST))) + ((FREEOF VAR F) (SETQ VAR-LIST (CONS F VAR-LIST))) + ((FREEOF DVAR + ($RATSIMP (SUBSTITUTE (LIST '(MPLUS) + VAR + DVAR) + VAR + F))) + (SETQ VAR-PARM-LIST (CONS F VAR-PARM-LIST))) + (T (GO NOTCON))) + (COND (NEWFUN (SETQ F (CAR NEWFUN) NEWFUN (CDR NEWFUN)) + (GO GOTHRULIST))) + (AND + PARM-LIST + (RETURN + (LAPLACE + (CONS + '(MTIMES) + (NCONC PARM-LIST + (NCONS (LIST '(%INTEGRATE) + (CONS '(MTIMES) + (APPEND VAR-LIST + VAR-PARM-LIST)) + DVAR + 0. + VAR))))))) + CONVOLUTION + (RETURN + (SIMPTIMES + (LIST + '(MTIMES) + (LAPLACE ($EXPAND (SUBSTITUTE VAR + DVAR + (FIXUPREST VAR-LIST)))) + (LAPLACE + ($EXPAND (SUBSTITUTE 0. + DVAR + (FIXUPREST VAR-PARM-LIST))))) + 1. + T)))) + +(DECLARE (SPECIAL VARLIST RATFORM ILS ILT)) + +(DEFMFUN $ILT (EXP ILS ILT) + ;;;EXP IS F(S)/G(S) WHERE F AND G ARE POLYNOMIALS IN S AND DEGR(F) < DEGR(G) + (LET (VARLIST ($SAVEFACTORS T) CHECKFACTORS $RATFAC $KEEPFLOAT) + ;;; MAKES ILS THE MAIN VARIABLE + (SETQ VARLIST (LIST ILS)) + (NEWVAR EXP) + (ORDERPOINTER VARLIST) + (SETQ VAR (CAADR (RATREP* ILS))) + (COND ((AND (NULL (ATOM EXP)) + (EQ (CAAR EXP) 'MEQUAL)) + (LIST '(MEQUAL) + ($ILT (CADR EXP) ILS ILT) + ($ILT (CADDR EXP) ILS ILT))) + ((ZEROP1 EXP) 0.) + ((FREEOF ILS EXP) + (LIST '(%ILT SIMP) EXP ILS ILT)) + (T (ILT0 EXP))))) + +(DEFUN RATIONALP (LE V) + (COND ((NULL LE)) + ((AND (NULL (ATOM (CAR LE))) (NULL (FREEOF V (CAR LE)))) + NIL) + (T (RATIONALP (CDR LE) V)))) + +(DEFUN ILT0 + ;;;THIS FUNCTION DOES THE PARTIAL FRACTION DECOMPOSITION + (EXP) (PROG (WHOLEPART FRPART NUM DENOM Y CONTENT REAL FACTOR + APART BPART PARNUMER RATARG RATFORM) + (AND (MPLUSP EXP) + (RETURN (SIMPLUS (CONS '(MPLUS) + (MAPCAR (FUNCTION (LAMBDA(F)($ILT F ILS ILT))) (CDR EXP))) 1 T))) + (AND (NULL (ATOM EXP)) + (EQ (CAAR EXP) '%LAPLACE) + (EQ (CADDDR EXP) ILS) + (RETURN (COND ((EQ (CADDR EXP) ILT) (CADR EXP)) + (T (SUBST ILT + (CADDR EXP) + (CADR EXP)))))) + (SETQ RATARG (RATREP* EXP)) + (OR (RATIONALP VARLIST ILS) + (RETURN (LIST '(%ILT SIMP) EXP ILS ILT))) + (SETQ RATFORM (CAR RATARG)) + (SETQ DENOM (RATDENOMINATOR (CDR RATARG))) + (SETQ FRPART (PDIVIDE (RATNUMERATOR (CDR RATARG)) DENOM)) + (SETQ WHOLEPART (CAR FRPART)) + (SETQ FRPART (RATQU (CADR FRPART) DENOM)) + (COND ((NOT (ZEROP1 (CAR WHOLEPART))) + (RETURN (LIST '(%ILT SIMP) EXP ILS ILT))) + ((ZEROP1 (CAR FRPART)) (RETURN 0))) + (SETQ NUM (CAR FRPART) DENOM (CDR FRPART)) + (SETQ Y (OLDCONTENT DENOM)) + (SETQ CONTENT (CAR Y)) + (SETQ REAL (CADR Y)) + (SETQ FACTOR (PFACTOR REAL)) + LOOP (COND ((NULL (CDDR FACTOR)) + (SETQ APART REAL + BPART 1 + Y '((0 . 1) 1 . 1)) + (GO SKIP))) + (SETQ APART (PEXPT (CAR FACTOR) (CADR FACTOR))) + (SETQ BPART (CAR (RATQU REAL APART))) + (SETQ Y (BPROG APART BPART)) + SKIP (SETQ FRPART + (CDR (RATDIVIDE (RATTI (RATNUMERATOR NUM) + (CDR Y) + T) + (RATTI (RATDENOMINATOR NUM) + (RATTI CONTENT APART T) + T)))) + (SETQ + PARNUMER + (CONS (ILT1 (RATQU (RATNUMERATOR FRPART) + (RATTI (RATDENOMINATOR FRPART) + (RATTI (RATDENOMINATOR NUM) + CONTENT + T) + T)) + (CAR FACTOR) + (CADR FACTOR)) + PARNUMER)) + (SETQ FACTOR (CDDR FACTOR)) + (COND ((NULL FACTOR) + (RETURN (SIMPLUS (CONS '(MPLUS) PARNUMER) + 1. + T)))) + (SETQ NUM (CDR (RATDIVIDE (RATTI NUM (CAR Y) T) + (RATTI CONTENT BPART T)))) + (SETQ REAL BPART) + (GO LOOP))) + +(DECLARE (FIXNUM K) (SPECIAL Q Z)) + +(DEFUN ILT1 (P Q K) + ((LAMBDA (Z) + (COND (( ONEP1 K)(ILT3 P )) + (T (SETQ Z (BPROG Q (PDERIVATIVE Q VAR)))(ILT2 P K)))) NIL)) + + +(DEFUN ILT2 + ;;;INVERTS P(S)/Q(S)**K WHERE Q(S) IS IRREDUCIBLE + ;;;DOESN'T CALL ILT3 IF Q(S) IS LINEAR + (P K) + (PROG (Y A B) + (AND (ONEP1 K)(RETURN (ILT3 P))) + (SETQ K (1- K)) + (SETQ A (RATTI P (CAR Z) T)) + (SETQ B (RATTI P (CDR Z) T)) + (SETQ Y (PEXPT Q K)) + (COND + ((OR (NULL (EQUAL (PDEGREE Q VAR) 1.)) + (> (PDEGREE (CAR P) VAR) 0.)) + (RETURN + (SIMPLUS + (LIST + '(MPLUS) + (ILT2 + (CDR (RATDIVIDE (RATPLUS A + (RATQU (RATDERIVATIVE B + VAR) + K)) + Y)) + K) + ($MULTTHRU (SIMPTIMES (LIST '(MTIMES) + ILT + (POWER K -1) + (ILT2 (CDR (RATDIVIDE B Y)) K)) + 1. + T))) + 1. + T)))) + (SETQ A (DISREP (POLCOEF Q 1.)) + B (DISREP (POLCOEF Q 0.))) + (RETURN + (SIMPTIMES (LIST '(MTIMES) + (DISREP P) + (RAISEUP ILT K) + (SIMPEXPT (LIST '(MEXPT) + '$%E + (LIST '(MTIMES) + -1. + ILT + B + (LIST '(MEXPT) + A + -1.))) + 1. + NIL) + (LIST '(MEXPT) + A + (DIFFERENCE -1. K)) + (LIST '(MEXPT) + (FACTORIAL K) + -1.)) + 1. + NIL)))) + +(DECLARE (NOTYPE K)) + +(DEFUN COEF MACRO (POL) (SUBST (CADR POL) (QUOTE DEG) + '(DISREP (RATQU (POLCOEF (CAR P) DEG) (CDR P))))) + +(DEFUN LAPSUM N (CONS '(MPLUS)(LISTIFY N))) +(DEFUN LAPPROD N (CONS '(MTIMES)(LISTIFY N))) +(DEFUN EXPO N (CONS '(MEXPT)(LISTIFY N))) +(DEFUN ILT3 + ;;;INVERTS P(S)/Q(S) WHERE Q(S) IS IRREDUCIBLE + (P ) (PROG (DISCRIM SIGN A C D E B1 B0 R TERM1 TERM2 DEGR) + (SETQ E (DISREP (POLCOEF Q 0.)) + D (DISREP (POLCOEF Q 1.)) + DEGR (PDEGREE Q VAR)) + (AND (EQUAL DEGR 1.) + (RETURN + (SIMPTIMES (LAPPROD + (DISREP P) + (EXPO D -1.) + (EXPO + '$%E + (LAPPROD + -1. + ILT + E + (EXPO + D + -1.)))) + 1. + NIL))) + (SETQ C (DISREP (POLCOEF Q 2))) + (AND (EQUAL DEGR 2.) (GO QUADRATIC)) + (AND (EQUAL DEGR 3.) (ZEROP1 C) (ZEROP1 D) + (GO CUBIC)) + (RETURN (LIST '(%ILT SIMP) (DIV* (DISREP P)(DISREP Q)) ILS ILT)) + CUBIC (SETQ A (DISREP (POLCOEF Q 3)) + R (SIMPNRT (DIV* E A) 3)) + (SETQ D (DIV* (DISREP P)(LAPPROD A (LAPSUM + (EXPO ILS 3)(EXPO '%R 3))))) + (RETURN (ILT0 (SUBSTITUTE R '%R ($PARTFRAC D ILS)))) + QUADRATIC (SETQ B0 (COEF 0) B1 (COEF 1)) + + (SETQ DISCRIM + (SIMPLUS (LAPSUM + (LAPPROD + 4. + E + C) + (LAPPROD -1. D D)) + 1. + NIL)) + (SETQ SIGN (COND ((FREE DISCRIM '$%I) (ASKSIGN DISCRIM)) (T '$POSITIVE)) + TERM1 '(%COS) + TERM2 '(%SIN)) + (SETQ DEGR (EXPO '$%E (LAPPROD ILT D (POWER C -1) '((RAT SIMP) -1 2)))) + (COND ((EQ SIGN '$ZERO) + (RETURN (SIMPTIMES (LAPPROD DEGR (LAPSUM (DIV* B1 C)(LAPPROD + (DIV* (LAPSUM (LAPPROD 2 B0 C)(LAPPROD -1 B1 D)) + (LAPPROD 2 C C)) ILT))) 1 NIL)) +) ((EQ SIGN '$NEGATIVE) + (SETQ TERM1 '(%COSH) + TERM2 '(%SINH) + DISCRIM (SIMPTIMES (LAPPROD + -1. + DISCRIM) + 1. + T)))) + (SETQ DISCRIM (SIMPNRT DISCRIM 2)) + (SETQ + SIGN + (SIMPTIMES + (LAPPROD + (LAPSUM + (LAPPROD + 2. + B0 + C) + (LAPPROD + -1. + B1 + D)) + (EXPO DISCRIM -1.)) + 1. + NIL)) + (SETQ C (POWER C -1)) + (SETQ DISCRIM (SIMPTIMES (LAPPROD + DISCRIM + ILT + '((RAT SIMP) 1. 2.) + C) + 1. + T)) + (RETURN + (SIMPTIMES + (LAPPROD + C + DEGR + (LAPSUM + (LAPPROD + B1 + (LIST TERM1 DISCRIM)) + (LAPPROD + SIGN + (LIST TERM2 DISCRIM)))) + 1. + NIL)))) + +(DECLARE (UNSPECIAL DVAR ILS ILT NOUNL PARM Q RATFORM VAR VARLIST + VAR-LIST VAR-PARM-LIST Z)) diff --git a/src/maxsrc/laplac.205 b/src/maxsrc/laplac.205 new file mode 100644 index 00000000..2fc1dd0a --- /dev/null +++ b/src/maxsrc/laplac.205 @@ -0,0 +1,918 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1976, 1983 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module laplac) + +(DECLARE (SPECIAL DVAR VAR-LIST VAR-PARM-LIST VAR PARM $SAVEFACTORS + CHECKFACTORS $RATFAC $KEEPFLOAT NOUNL NOUNSFLAG) + (*EXPR SUBFUNMAKE) + (*LEXPR $DIFF $EXPAND $MULTTHRU $RATSIMP)) + +(DEFUN EXPONENTIATE (POW) + ;;;COMPUTES %E**Z WHERE Z IS AN ARBITRARY EXPRESSION TAKING SOME OF THE WORK AWAY FROM SIMPEXPT + (COND ((ZEROP1 POW) 1) + ((EQUAL POW 1) '$%E) + (T (POWER '$%E POW)))) + +(DEFUN FIXUPREST (REST) + ;;;REST IS A PRODUCT WITHOUT THE MTIMES.FIXUPREST PUTS BACK THE MTIMES + (COND ((NULL REST) 1) + ((CDR REST) (CONS '(MTIMES SIMP) REST)) + (T (CAR REST)))) + +(DEFUN POSINT MACRO (X) (SUBST (CADR X) 'Y '(AND (FIXP Y) (> Y 0)))) + +(DEFUN NEGINT MACRO (X) (SUBST (CADR X) 'Y '(AND (FIXP Y) (< Y 0)))) + +(DEFUN ISQUADRATICP (E X) + ((LAMBDA (B) + (COND ((ZEROP1 B) (LIST 0 0 E)) + ((FREEOF X B) (LIST 0 B (SUBSTITUTE 0 X E))) + ((SETQ B (ISLINEAR B X)) + (LIST (DIV* (CAR B) 2) (CDR B) (SUBSTITUTE 0 X E))))) + (SDIFF E X))) + + +;;;INITIALIZES SOME GLOBAL VARIABLES THEN CALLS THE DISPATCHING FUNCTION + +(DEFMFUN $LAPLACE (E VAR PARM) + (IF (OR NOUNSFLAG (MEMQ '%LAPLACE NOUNL)) + (SETQ E (REMLAPLACE (SPECREPCHECK E)))) + (LAPLACE E)) + +(DEFUN REMLAPLACE (E) + (IF (ATOM E) E (CONS (DELQ 'LAPLACE (APPEND (CAR E) NIL) 1) + (MAPCAR #'REMLAPLACE (CDR E))))) + +(DEFUN LAPLACE (FUN) + ((LAMBDA (DVAR VAR-LIST VAR-PARM-LIST) + ;;; Handles easy cases and calls appropriate function on others. + (COND ((EQUAL FUN 0) 0) + ((EQUAL FUN 1) + (COND ((ZEROP1 PARM) (SIMPLIFY (LIST '($DELTA) 0))) + (T (POWER PARM -1)))) + ((MBAGP FUN) (CONS (CAR FUN) (MAPCAR #'LAPLACE (CDR FUN)))) + ((SPECREPP FUN) (LAPLACE (SPECDISREP FUN))) + ((ALIKE1 FUN VAR) (POWER PARM -2)) + ((OR (ATOM FUN) (FREEOF VAR FUN)) + (COND ((ZEROP1 PARM) (MUL2 FUN (SIMPLIFY (LIST '($DELTA) 0)))) + (T (MUL2 FUN (POWER PARM -1))))) + (T ((LAMBDA (OP) + (COND ((EQ OP 'MPLUS) + (ADDN (MAPCAR #'LAPLACE (CDR FUN)) T)) + ((EQ OP 'MTIMES) + (LAPTIMES (CDR FUN))) + ((EQ OP 'MEXPT) + (LAPEXPT FUN NIL)) + ((EQ OP '%SIN) + (LAPSIN FUN NIL NIL)) + ((EQ OP '%COS) + (LAPSIN FUN NIL T)) + ((EQ OP '%SINH) + (LAPSINH FUN NIL NIL)) + ((EQ OP '%COSH) + (LAPSINH FUN NIL T)) + ((EQ OP '%LOG) + (LAPLOG FUN)) + ((EQ OP '%DERIVATIVE) + (LAPDIFF FUN)) + ((EQ OP '%INTEGRATE) + (LAPINT FUN)) + ((EQ OP '%SUM) + (LIST '(%SUM SIMP) + (LAPLACE (CADR FUN)) + (CADDR FUN) + (CADDDR FUN) + (CAR (CDDDDR FUN)))) + ((EQ OP '%ERF) + (LAPERF FUN)) + ((AND (EQ OP '%ILT)(EQ (CADDDR FUN) VAR)) + (COND ((EQ PARM (CADDR FUN))(CADR FUN)) + (T (SUBST PARM (CADDR FUN)(CADR FUN)))) +) ((EQ OP '$DELTA) + (LAPDELTA FUN NIL)) + ((SETQ OP ($GET OP '$LAPLACE)) + (MCALL OP FUN VAR PARM)) + (T (LAPDEFINT FUN)))) + (CAAR FUN))))) + NIL + NIL + NIL)) + +(DEFUN LAPLUS (FUN) (ADDN (MAPCAR #'LAPLACE (CDR FUN)) T)) + +(DEFUN LAPTIMES (FUN) + ;;;EXPECTS A LIST (PERHAPS EMPTY) OF FUNCTIONS MULTIPLIED TOGETHER WITHOUT THE MTIMES + ;;;SEES IF IT CAN APPLY THE FIRST AS A TRANSFORMATION ON THE REST OF THE FUNCTIONS + (COND ((NULL FUN) (LIST '(MEXPT SIMP) PARM -1)) + ((NULL (CDR FUN)) (LAPLACE (CAR FUN))) + ((FREEOF VAR (CAR FUN)) + (SIMPTIMES (LIST '(MTIMES) + (CAR FUN) + (LAPTIMES (CDR FUN))) + 1 T)) + ((EQ (CAR FUN) VAR) + (SIMPTIMES (LIST '(MTIMES) + -1 + (SDIFF (LAPTIMES (CDR FUN)) PARM)) + 1 T)) + (T ((LAMBDA (OP) + (COND ((EQ OP 'MEXPT) + (LAPEXPT (CAR FUN) (CDR FUN))) + ((EQ OP 'MPLUS) + (LAPLUS ($MULTTHRU (FIXUPREST (CDR FUN)) (CAR FUN)))) + ((EQ OP '%SIN) + (LAPSIN (CAR FUN) (CDR FUN) NIL)) + ((EQ OP '%COS) + (LAPSIN (CAR FUN) (CDR FUN) T)) + ((EQ OP '%SINH) + (LAPSINH (CAR FUN) (CDR FUN) NIL)) + ((EQ OP '%COSH) + (LAPSINH (CAR FUN) (CDR FUN) T)) + ((EQ OP '$DELTA) + (LAPDELTA (CAR FUN) (CDR FUN))) + + (T (LAPSHIFT (CAR FUN) (CDR FUN))))) + (CAAAR FUN))))) + +(DEFUN LAPEXPT (FUN REST) + ;;;HANDLES %E**(A*T+B)*REST(T), %E**(A*T**2+B*T+C), + ;;; 1/SQRT(A*T+B), OR T**K*REST(T) + (PROG (AB BASE-OF-FUN POWER RESULT) + (SETQ BASE-OF-FUN (CADR FUN) POWER (CADDR FUN)) + (COND + ((AND + (FREEOF VAR BASE-OF-FUN) + (SETQ + AB + (ISQUADRATICP + (COND ((EQ BASE-OF-FUN '$%E) POWER) + (T (SIMPTIMES (LIST '(MTIMES) + POWER + (LIST '(%LOG) + BASE-OF-FUN)) + 1. + NIL))) + VAR))) + (COND ((EQUAL (CAR AB) 0.) (GO %E-CASE-LIN)) + ((NULL REST) (GO %E-CASE-QUAD)) + (T (GO NOLUCK)))) + ((AND (EQ BASE-OF-FUN VAR) (FREEOF VAR POWER)) + (GO VAR-CASE)) + ((AND (ALIKE1 '((RAT) -1. 2.) POWER) (NULL REST) + (SETQ AB (ISLINEAR BASE-OF-FUN VAR))) + (SETQ RESULT (DIV* (CDR AB) (CAR AB))) + (RETURN (SIMPTIMES + (LIST '(MTIMES) + (LIST '(MEXPT) + (DIV* '$%PI + (LIST '(MTIMES) + (CAR AB) + PARM)) + '((RAT) 1. 2.)) + (EXPONENTIATE (LIST '(MTIMES) RESULT PARM)) + (LIST '(MPLUS) + 1. + (LIST '(MTIMES) + -1. + (LIST '(%ERF) + (LIST '(MEXPT) + (LIST '(MTIMES) + RESULT + PARM) + '((RAT) + 1. + 2.))) + ))) 1 NIL))) + (T (GO NOLUCK))) + %E-CASE-LIN + (SETQ + RESULT + (COND + (REST ($RATSIMP ($AT (LAPTIMES REST) + (LIST '(MEQUAL SIMP) + PARM + (LIST '(MPLUS SIMP) + PARM + (AFIXSIGN (CADR AB) + NIL)))))) + (T (LIST '(MEXPT) + (LIST '(MPLUS) + PARM + (AFIXSIGN (CADR AB) NIL)) + -1.)))) + (RETURN (SIMPTIMES (LIST '(MTIMES) + (EXPONENTIATE (CADDR AB)) + RESULT) + 1. + NIL)) + %E-CASE-QUAD + (SETQ RESULT (AFIXSIGN (CAR AB) NIL)) + (SETQ + RESULT + (LIST + '(MTIMES) + (DIV* (LIST '(MEXPT) + (DIV* '$%PI RESULT) + '((RAT) 1. 2.)) + 2.) + (EXPONENTIATE (DIV* (LIST '(MEXPT) PARM 2.) + (LIST '(MTIMES) + 4. + RESULT))) + (LIST '(MPLUS) + 1. + (LIST '(MTIMES) + -1. + (LIST '(%ERF) + (DIV* PARM + (LIST '(MTIMES) + 2. + (LIST '(MEXPT) + RESULT + '((RAT) + 1. + 2.))))) + )))) + (AND (NULL (EQUAL (CADR AB) 0.)) + (SETQ RESULT + (SUBSTITUTE (LIST '(MPLUS) + PARM + (LIST '(MTIMES) + -1. + (CADR AB))) + PARM + RESULT))) + (RETURN (SIMPTIMES (LIST '(MTIMES) + (EXPONENTIATE (CADDR AB)) + RESULT) 1 NIL)) + VAR-CASE + (COND ((OR (NULL REST) (FREEOF VAR (FIXUPREST REST))) + (GO VAR-EASY-CASE))) + (COND ((POSINT POWER) + (RETURN (AFIXSIGN (APPLY '$DIFF + (LIST (LAPTIMES REST) + PARM + POWER)) + (EVEN POWER)))) + ((NEGINT POWER) + (RETURN (MYDEFINT (HACKIT POWER REST) + (CREATENAME PARM (MINUS POWER)) + PARM))) + (T (GO NOLUCK))) + VAR-EASY-CASE + (SETQ POWER + (SIMPLUS (LIST '(MPLUS) 1 POWER) 1 T)) + (OR (EQ (ASKSIGN POWER) '$POSITIVE) (GO NOLUCK)) + (SETQ RESULT (LIST (LIST '(%GAMMA) POWER) + (LIST '(MEXPT) + PARM + (AFIXSIGN POWER NIL)))) + (AND REST (SETQ RESULT (NCONC RESULT REST))) + (RETURN (SIMPTIMES (CONS '(MTIMES) RESULT) + 1 + NIL)) + NOLUCK + (RETURN + (COND + ((AND (POSINT POWER) + (MEMQ (CAAR BASE-OF-FUN) + '(MPLUS %SIN %COS %SINH %COSH))) + (LAPTIMES (CONS BASE-OF-FUN + (CONS (COND ((= POWER 2.) BASE-OF-FUN) + (T (LIST '(MEXPT SIMP) + BASE-OF-FUN + (SUB1 POWER)))) + REST)))) + (T (LAPSHIFT FUN REST)))))) + +(DEFUN MYDEFINT (F X A) + ;;;INTEGRAL FROM A TO INFINITY OF F(X) + ((LAMBDA (TRYINT) (COND (TRYINT (CAR TRYINT)) + (T (LIST '(%INTEGRATE SIMP) + F + X + A + '$INF)))) + (AND (NOT ($UNKNOWN F)) + (ERRSET ($DEFINT F X A '$INF))))) + +(DEFUN CREATENAME + ;;;CREATES HOPEFULLY UNIQUE NAMES FOR VARIABLE OF INTEGRATION + (HEAD TAIL) + (implode (NCONC (EXPLODEC HEAD) (EXPLODEC TAIL)))) + +(DECLARE (FIXNUM EXPONENT)) + +(DEFUN HACKIT (EXPONENT REST) + ;;;REDUCES LAPLACE(F(T)/T**N,T,S) CASE TO LAPLACE(F(T)/T**(N-1),T,S) CASE + (COND ((EQUAL EXPONENT -1.) + ((LAMBDA (PARM) (LAPTIMES REST)) (CREATENAME PARM 1.))) + (T (MYDEFINT (HACKIT (1+ EXPONENT) REST) + (CREATENAME PARM (DIFFERENCE -1. EXPONENT)) + (CREATENAME PARM (MINUS EXPONENT)))))) + +(DECLARE (NOTYPE EXPONENT)) + +(DEFUN AFIXSIGN (FUNCT SIGNSWITCH) + ;;;MULTIPLIES FUNCT BY -1 IF SIGNSWITCH IS NIL + (COND (SIGNSWITCH FUNCT) + (T (SIMPTIMES (LIST '(MTIMES) -1. FUNCT) 1. T)))) + + + +(DEFUN LAPSHIFT (FUN REST) + (COND ((ATOM FUN) (merror "INTERNAL ERROR")) + ((OR (MEMQ 'LAPLACE (CAR FUN)) (NULL REST)) + (LAPDEFINT (COND (REST (SIMPTIMES (CONS '(MTIMES) + (CONS FUN REST)) 1 T)) + (T FUN)))) + (T (LAPTIMES (APPEND REST + (NCONS (CONS (APPEND (CAR FUN) + '(LAPLACE)) + (CDR FUN)))))))) + +(DEFUN MOSTPART (F PARM SIGN A B) + ;;;COMPUTES %E**(W*B*%I)*F(S-W*A*%I) WHERE W=-1 IF SIGN IS T ELSE W=1 + ((LAMBDA (SUBSTINFUN) + (COND ((ZEROP1 B) SUBSTINFUN) + (T (LIST '(MTIMES) + (EXPONENTIATE (AFIXSIGN (LIST '(MTIMES) + B + '$%I) + (NULL SIGN))) + SUBSTINFUN)))) + ($AT F + (LIST '(MEQUAL SIMP) + PARM + (LIST '(MPLUS SIMP) + PARM + (AFIXSIGN (LIST '(MTIMES) + A + '$%I) + SIGN)))))) + +(DEFUN COMPOSE + ;;;IF WHICHSIGN IS NIL THEN SIN TRANSFORM ELSE COS TRANSFORM + (FUN PARM WHICHSIGN A B) + ((LAMBDA (RESULT) + ($RATSIMP (SIMPTIMES (CONS '(MTIMES) + (COND (WHICHSIGN RESULT) + (T (CONS '$%I + RESULT)))) + 1 NIL))) + (LIST '((RAT) 1. 2.) + (LIST '(MPLUS) + (MOSTPART FUN PARM T A B) + (AFIXSIGN (MOSTPART FUN PARM NIL A B) + WHICHSIGN))))) + +(DEFUN LAPSIN + ;;;FUN IS OF THE FORM SIN(A*T+B)*REST(T) OR COS + (FUN REST TRIGSWITCH) + ((LAMBDA (AB) + (COND + (AB + (COND + (REST (COMPOSE (LAPTIMES REST) + PARM + TRIGSWITCH + (CAR AB) + (CDR AB))) + (T (SIMPTIMES + (LIST + '(MTIMES) + (COND + ((ZEROP1 (CDR AB)) + (COND (TRIGSWITCH PARM) (T (CAR AB)))) + (T (COND (TRIGSWITCH (LIST '(MPLUS) + (LIST '(MTIMES) + PARM + (LIST '(%COS) + (CDR AB))) + (LIST '(MTIMES) + -1. + (CAR AB) + (LIST '(%SIN) + (CDR AB))))) + (T (LIST '(MPLUS) + (LIST '(MTIMES) + PARM + (LIST '(%SIN) + (CDR AB))) + (LIST '(MTIMES) + (CAR AB) + (LIST '(%COS) + (CDR AB)))))))) + (LIST '(MEXPT) + (LIST '(MPLUS) + (LIST '(MEXPT) PARM 2.) + (LIST '(MEXPT) (CAR AB) 2.)) + -1.)) + 1 NIL)))) + (T (LAPSHIFT FUN REST)))) + (ISLINEAR (CADR FUN) VAR))) + +(DEFUN LAPSINH + ;;;FUN IS OF THE FORM SINH(A*T+B)*REST(T) OR IS COSH + (FUN REST SWITCH) + (COND ((ISLINEAR (CADR FUN) VAR) + ($RATSIMP + (LAPLUS + (SIMPLUS + (LIST '(MPLUS) + (NCONC (LIST '(MTIMES) + (LIST '(MEXPT) + '$%E + (CADR FUN)) + '((RAT) 1. 2.)) + REST) + (AFIXSIGN (NCONC (LIST '(MTIMES) + (LIST '(MEXPT) + '$%E + (AFIXSIGN (CADR FUN) + NIL)) + '((RAT) 1. 2.)) + REST) + SWITCH)) + 1. + NIL)))) + (T (LAPSHIFT FUN REST)))) + +(DEFUN LAPLOG + ;;;FUN IS OF THE FORM LOG(A*T) + (FUN) ((LAMBDA (AB) + (COND ((AND AB (ZEROP1 (CDR AB))) + (SIMPTIMES (LIST '(MTIMES) + (LIST '(MPLUS) + (subfunmake '$PSI + '(0) + (NCONS 1.)) + (LIST '(%LOG) + (CAR AB)) + (LIST '(MTIMES) + -1. + (LIST '(%LOG) + PARM))) + (LIST '(MEXPT) + PARM + -1.)) + 1 NIL)) + (T (LAPDEFINT FUN)))) + (ISLINEAR (CADR FUN) VAR))) + +(DEFUN RAISEUP (FBASE EXPONENT) + (COND ((EQUAL EXPONENT 1.) FBASE) + (T (LIST '(MEXPT) FBASE EXPONENT)))) + +(DEFUN LAPDELTA (FUN REST) + ;;TAKES TRANSFORM OF DELTA(A*T+B)*F(T) + ((LAMBDA (AB SIGN RECIPA) + (COND + (AB + (SETQ RECIPA (POWER (CAR AB) -1) AB (DIV (CDR AB) (CAR AB))) + (SETQ SIGN (ASKSIGN AB) RECIPA (SIMPLIFYA (LIST '(MABS) RECIPA) NIL)) + (SIMPLIFYA (COND ((EQ SIGN '$POSITIVE) 0) + ((EQ SIGN '$ZERO) + (LIST '(MTIMES) + (SUBSTITUTE 0 VAR (FIXUPREST REST)) + RECIPA)) + (T (LIST '(MTIMES) + (SUBSTITUTE (NEG AB) + VAR + (FIXUPREST REST)) + (LIST '(MEXPT) + '$%E + (CONS '(MTIMES) + (CONS PARM (NCONS AB)))) + RECIPA))) + NIL)) + (T (LAPSHIFT FUN REST)))) + (ISLINEAR (CADR FUN) VAR) NIL NIL)) + +(DEFUN LAPERF (FUN ) + ((LAMBDA (AB) + (COND + ((AND AB (EQUAL (CDR AB) 0.)) + (SIMPTIMES (LIST '(MTIMES) + (DIV* (EXPONENTIATE (DIV* (LIST '(MEXPT) + PARM + 2.) + (LIST '(MTIMES) + 4. + (LIST '(MEXPT) + (CAR AB) + 2.)))) + PARM) + (LIST '(MPLUS) + 1. + (LIST '(MTIMES) + -1. + (LIST '(%ERF) + (DIV* PARM + (LIST '(MTIMES) + 2. + (CAR AB)))) + ))) 1 NIL)) + (T (LAPDEFINT FUN)))) + (ISLINEAR (CADR FUN) VAR))) +(DEFUN LAPDEFINT (FUN) + (PROG (TRYINT MULT) + (AND ($UNKNOWN FUN)(GO SKIP)) + (SETQ MULT (SIMPTIMES (LIST '(MTIMES) (EXPONENTIATE + (LIST '(MTIMES SIMP) -1 VAR PARM)) FUN) 1 NIL)) + (MEVAL `(($ASSUME) ,@(LIST (LIST '(MGREATERP) PARM 0)))) + (SETQ TRYINT (ERRSET ($DEFINT MULT VAR 0 '$INF))) + (MEVAL `(($FORGET) ,@(LIST (LIST '(MGREATERP) PARM 0)))) + (AND TRYINT (NOT (EQ (CAAAR TRYINT) '%INTEGRATE)) (RETURN (CAR TRYINT))) + SKIP (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM)))) + + +(DECLARE (FIXNUM ORDER)) + +(DEFUN LAPDIFF + ;;;FUN IS OF THE FORM DIFF(F(T),T,N) WHERE N IS A POSITIVE INTEGER + (FUN) (PROG (DIFFLIST DEGREE FRONTEND RESULTLIST NEWDLIST ORDER + ARG2) + (SETQ NEWDLIST (SETQ DIFFLIST (COPY (CDDR FUN)))) + (SETQ ARG2 (LIST '(MEQUAL SIMP) VAR 0.)) + A (COND ((NULL DIFFLIST) + (RETURN (CONS '(%DERIVATIVE SIMP) + (CONS (LIST '(%LAPLACE SIMP) + (CADR FUN) + VAR + PARM) + NEWDLIST)))) + ((EQ (CAR DIFFLIST) VAR) + (SETQ DEGREE (CADR DIFFLIST) + DIFFLIST (CDDR DIFFLIST)) + (GO OUT))) + (SETQ DIFFLIST (CDR (SETQ FRONTEND (CDR DIFFLIST)))) + (GO A) + OUT (COND ((NULL (POSINT DEGREE)) + (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM)))) + (COND (FRONTEND (RPLACD FRONTEND DIFFLIST)) + (T (SETQ NEWDLIST DIFFLIST))) + (COND (NEWDLIST (SETQ FUN (CONS '(%DERIVATIVE SIMP) + (CONS (CADR FUN) + NEWDLIST)))) + (T (SETQ FUN (CADR FUN)))) + (SETQ ORDER 0.) + LOOP (SETQ DEGREE (1- DEGREE)) + (SETQ RESULTLIST + (CONS (LIST '(MTIMES) + (RAISEUP PARM DEGREE) + ($AT ($DIFF FUN VAR ORDER) ARG2)) + RESULTLIST)) + (SETQ ORDER (1+ ORDER)) + (AND (> DEGREE 0.) (GO LOOP)) + (SETQ RESULTLIST (COND ((CDR RESULTLIST) + (CONS '(MPLUS) + RESULTLIST)) + (T (CAR RESULTLIST)))) + (RETURN (SIMPLUS (LIST '(MPLUS) + (LIST '(MTIMES) + (RAISEUP PARM ORDER) + (LAPLACE FUN)) + (LIST '(MTIMES) + -1. + RESULTLIST)) + 1 NIL)))) + +(DECLARE (NOTYPE ORDER)) + +(DEFUN LAPINT + ;;;FUN IS OF THE FORM INTEGRATE(F(X)*G(T)*H(T-X),X,0,T) + (FUN) (PROG (NEWFUN PARM-LIST F) + (AND DVAR (GO CONVOLUTION)) + (SETQ DVAR (CADR (SETQ NEWFUN (CDR FUN)))) + (AND (CDDR NEWFUN) + (ZEROP1 (CADDR NEWFUN)) + (EQ (CADDDR NEWFUN) VAR) + (GO CONVOLUTIONTEST)) + NOTCON + (SETQ NEWFUN (CDR FUN)) + (COND ((CDDR NEWFUN) + (COND ((AND (FREEOF VAR (CADDR NEWFUN)) + (FREEOF VAR (CADDDR NEWFUN))) + (RETURN (LIST '(%INTEGRATE SIMP) + (LAPLACE (CAR NEWFUN)) + DVAR + (CADDR NEWFUN) + (CADDDR NEWFUN)))) + (T (GO GIVEUP)))) + (T (RETURN (LIST '(%INTEGRATE SIMP) + (LAPLACE (CAR NEWFUN)) + DVAR)))) + GIVEUP + (RETURN (LIST '(%LAPLACE SIMP) FUN VAR PARM)) + CONVOLUTIONTEST + (SETQ NEWFUN ($FACTOR (CAR NEWFUN))) + (COND ((EQ (CAAR NEWFUN) 'MTIMES) + (SETQ F (CADR NEWFUN) NEWFUN (CDDR NEWFUN))) + (T (SETQ F NEWFUN NEWFUN NIL))) + GOTHRULIST + (COND ((FREEOF DVAR F) + (SETQ PARM-LIST (CONS F PARM-LIST))) + ((FREEOF VAR F) (SETQ VAR-LIST (CONS F VAR-LIST))) + ((FREEOF DVAR + ($RATSIMP (SUBSTITUTE (LIST '(MPLUS) + VAR + DVAR) + VAR + F))) + (SETQ VAR-PARM-LIST (CONS F VAR-PARM-LIST))) + (T (GO NOTCON))) + (COND (NEWFUN (SETQ F (CAR NEWFUN) NEWFUN (CDR NEWFUN)) + (GO GOTHRULIST))) + (AND + PARM-LIST + (RETURN + (LAPLACE + (CONS + '(MTIMES) + (NCONC PARM-LIST + (NCONS (LIST '(%INTEGRATE) + (CONS '(MTIMES) + (APPEND VAR-LIST + VAR-PARM-LIST)) + DVAR + 0 + VAR))))))) + CONVOLUTION + (RETURN + (SIMPTIMES + (LIST + '(MTIMES) + (LAPLACE ($EXPAND (SUBSTITUTE VAR + DVAR + (FIXUPREST VAR-LIST)))) + (LAPLACE + ($EXPAND (SUBSTITUTE 0 + DVAR + (FIXUPREST VAR-PARM-LIST))))) + 1 + T)))) + +(DECLARE (SPECIAL VARLIST RATFORM ILS ILT)) + +(DEFMFUN $ILT (EXP ILS ILT) + ;;;EXP IS F(S)/G(S) WHERE F AND G ARE POLYNOMIALS IN S AND DEGR(F) < DEGR(G) + (LET (VARLIST ($SAVEFACTORS T) CHECKFACTORS $RATFAC $KEEPFLOAT) + ;;; MAKES ILS THE MAIN VARIABLE + (SETQ VARLIST (LIST ILS)) + (NEWVAR EXP) + (ORDERPOINTER VARLIST) + (SETQ VAR (CAADR (RATREP* ILS))) + (COND ((MBAGP EXP) + (CONS (CAR EXP) + (MAPCAR #'(LAMBDA (E) ($ILT E ILS ILT)) (CDR EXP)))) + ((ZEROP1 EXP) 0) + ((FREEOF ILS EXP) (LIST '(%ILT SIMP) EXP ILS ILT)) + (T (ILT0 EXP))))) + +(DEFUN RATIONALP (LE V) + (COND ((NULL LE)) + ((AND (NULL (ATOM (CAR LE))) (NULL (FREEOF V (CAR LE)))) + NIL) + (T (RATIONALP (CDR LE) V)))) + +(DEFUN ILT0 (EXP) ;; This function does the partial fraction decomposition. + (PROG (WHOLEPART FRPART NUM DENOM Y CONTENT REAL FACTOR + APART BPART PARNUMER RATARG RATFORM) + (IF (MPLUSP EXP) + (RETURN + (ADDN (MAPCAR #'(LAMBDA (E) ($ILT E ILS ILT)) (CDR EXP)) T))) + (AND (NULL (ATOM EXP)) + (EQ (CAAR EXP) '%LAPLACE) + (EQ (CADDDR EXP) ILS) + (RETURN (COND ((EQ (CADDR EXP) ILT) (CADR EXP)) + (T (SUBST ILT (CADDR EXP) (CADR EXP)))))) + (SETQ RATARG (RATREP* EXP)) + (OR (RATIONALP VARLIST ILS) + (RETURN (LIST '(%ILT SIMP) EXP ILS ILT))) + (SETQ RATFORM (CAR RATARG)) + (SETQ DENOM (RATDENOMINATOR (CDR RATARG))) + (SETQ FRPART (PDIVIDE (RATNUMERATOR (CDR RATARG)) DENOM)) + (SETQ WHOLEPART (CAR FRPART)) + (SETQ FRPART (RATQU (CADR FRPART) DENOM)) + (COND ((NOT (ZEROP1 (CAR WHOLEPART))) + (RETURN (LIST '(%ILT SIMP) EXP ILS ILT))) + ((ZEROP1 (CAR FRPART)) (RETURN 0))) + (SETQ NUM (CAR FRPART) DENOM (CDR FRPART)) + (SETQ Y (OLDCONTENT DENOM)) + (SETQ CONTENT (CAR Y)) + (SETQ REAL (CADR Y)) + (SETQ FACTOR (PFACTOR REAL)) + LOOP (COND ((NULL (CDDR FACTOR)) + (SETQ APART REAL + BPART 1 + Y '((0 . 1) 1 . 1)) + (GO SKIP))) + (SETQ APART (PEXPT (CAR FACTOR) (CADR FACTOR))) + (SETQ BPART (CAR (RATQU REAL APART))) + (SETQ Y (BPROG APART BPART)) + SKIP (SETQ FRPART + (CDR (RATDIVIDE (RATTI (RATNUMERATOR NUM) + (CDR Y) + T) + (RATTI (RATDENOMINATOR NUM) + (RATTI CONTENT APART T) + T)))) + (SETQ + PARNUMER + (CONS (ILT1 (RATQU (RATNUMERATOR FRPART) + (RATTI (RATDENOMINATOR FRPART) + (RATTI (RATDENOMINATOR NUM) + CONTENT + T) + T)) + (CAR FACTOR) + (CADR FACTOR)) + PARNUMER)) + (SETQ FACTOR (CDDR FACTOR)) + (COND ((NULL FACTOR) + (RETURN (SIMPLUS (CONS '(MPLUS) PARNUMER) + 1 + T)))) + (SETQ NUM (CDR (RATDIVIDE (RATTI NUM (CAR Y) T) + (RATTI CONTENT BPART T)))) + (SETQ REAL BPART) + (GO LOOP))) + +(DECLARE (FIXNUM K) (SPECIAL Q Z)) + +(DEFUN ILT1 (P Q K) + ((LAMBDA (Z) + (COND ((ONEP1 K) (ILT3 P)) + (T (SETQ Z (BPROG Q (PDERIVATIVE Q VAR)))(ILT2 P K)))) NIL)) + +(DEFUN ILT2 + ;;;INVERTS P(S)/Q(S)**K WHERE Q(S) IS IRREDUCIBLE + ;;;DOESN'T CALL ILT3 IF Q(S) IS LINEAR + (P K) + (PROG (Y A B) + (AND (ONEP1 K)(RETURN (ILT3 P))) + (SETQ K (1- K)) + (SETQ A (RATTI P (CAR Z) T)) + (SETQ B (RATTI P (CDR Z) T)) + (SETQ Y (PEXPT Q K)) + (COND + ((OR (NULL (EQUAL (PDEGREE Q VAR) 1.)) + (> (PDEGREE (CAR P) VAR) 0.)) + (RETURN + (SIMPLUS + (LIST + '(MPLUS) + (ILT2 + (CDR (RATDIVIDE (RATPLUS A + (RATQU (RATDERIVATIVE B + VAR) + K)) + Y)) + K) + ($MULTTHRU (SIMPTIMES (LIST '(MTIMES) + ILT + (POWER K -1) + (ILT2 (CDR (RATDIVIDE B Y)) K)) + 1. + T))) + 1. + T)))) + (SETQ A (DISREP (POLCOEF Q 1.)) + B (DISREP (POLCOEF Q 0.))) + (RETURN + (SIMPTIMES (LIST '(MTIMES) + (DISREP P) + (RAISEUP ILT K) + (SIMPEXPT (LIST '(MEXPT) + '$%E + (LIST '(MTIMES) + -1. + ILT + B + (LIST '(MEXPT) + A + -1.))) + 1. + NIL) + (LIST '(MEXPT) + A + (DIFFERENCE -1. K)) + (LIST '(MEXPT) + (FACTORIAL K) + -1.)) + 1. + NIL)))) + +(DECLARE (NOTYPE K)) + +(DEFUN COEF MACRO (POL) (SUBST (CADR POL) (QUOTE DEG) + '(DISREP (RATQU (POLCOEF (CAR P) DEG) (CDR P))))) + +(DEFUN LAPSUM N (CONS '(MPLUS)(LISTIFY N))) +(DEFUN LAPPROD N (CONS '(MTIMES)(LISTIFY N))) +(DEFUN EXPO N (CONS '(MEXPT)(LISTIFY N))) +(DEFUN ILT3 + ;;;INVERTS P(S)/Q(S) WHERE Q(S) IS IRREDUCIBLE + (P ) (PROG (DISCRIM SIGN A C D E B1 B0 R TERM1 TERM2 DEGR) + (SETQ E (DISREP (POLCOEF Q 0.)) + D (DISREP (POLCOEF Q 1.)) + DEGR (PDEGREE Q VAR)) + (AND (EQUAL DEGR 1.) + (RETURN + (SIMPTIMES (LAPPROD + (DISREP P) + (EXPO D -1.) + (EXPO + '$%E + (LAPPROD + -1. + ILT + E + (EXPO + D + -1.)))) + 1. + NIL))) + (SETQ C (DISREP (POLCOEF Q 2))) + (AND (EQUAL DEGR 2.) (GO QUADRATIC)) + (AND (EQUAL DEGR 3.) (ZEROP1 C) (ZEROP1 D) + (GO CUBIC)) + (RETURN (LIST '(%ILT SIMP) (DIV* (DISREP P)(DISREP Q)) ILS ILT)) + CUBIC (SETQ A (DISREP (POLCOEF Q 3)) + R (SIMPNRT (DIV* E A) 3)) + (SETQ D (DIV* (DISREP P)(LAPPROD A (LAPSUM + (EXPO ILS 3)(EXPO '%R 3))))) + (RETURN (ILT0 (SUBSTITUTE R '%R ($PARTFRAC D ILS)))) + QUADRATIC (SETQ B0 (COEF 0) B1 (COEF 1)) + + (SETQ DISCRIM + (SIMPLUS (LAPSUM + (LAPPROD + 4. + E + C) + (LAPPROD -1. D D)) + 1. + NIL)) + (SETQ SIGN (COND ((FREE DISCRIM '$%I) (ASKSIGN DISCRIM)) (T '$POSITIVE)) + TERM1 '(%COS) + TERM2 '(%SIN)) + (SETQ DEGR (EXPO '$%E (LAPPROD ILT D (POWER C -1) '((RAT SIMP) -1 2)))) + (COND ((EQ SIGN '$ZERO) + (RETURN (SIMPTIMES (LAPPROD DEGR (LAPSUM (DIV* B1 C)(LAPPROD + (DIV* (LAPSUM (LAPPROD 2 B0 C)(LAPPROD -1 B1 D)) + (LAPPROD 2 C C)) ILT))) 1 NIL)) +) ((EQ SIGN '$NEGATIVE) + (SETQ TERM1 '(%COSH) + TERM2 '(%SINH) + DISCRIM (SIMPTIMES (LAPPROD + -1. + DISCRIM) + 1. + T)))) + (SETQ DISCRIM (SIMPNRT DISCRIM 2)) + (SETQ + SIGN + (SIMPTIMES + (LAPPROD + (LAPSUM + (LAPPROD + 2. + B0 + C) + (LAPPROD + -1. + B1 + D)) + (EXPO DISCRIM -1.)) + 1. + NIL)) + (SETQ C (POWER C -1)) + (SETQ DISCRIM (SIMPTIMES (LAPPROD + DISCRIM + ILT + '((RAT SIMP) 1. 2.) + C) + 1. + T)) + (RETURN + (SIMPTIMES + (LAPPROD + C + DEGR + (LAPSUM + (LAPPROD + B1 + (LIST TERM1 DISCRIM)) + (LAPPROD + SIGN + (LIST TERM2 DISCRIM)))) + 1. + NIL)))) + +(DECLARE (UNSPECIAL DVAR ILS ILT NOUNL PARM Q RATFORM VAR VARLIST + VAR-LIST VAR-PARM-LIST Z)) + \ No newline at end of file diff --git a/src/maxsrc/ldisp.43 b/src/maxsrc/ldisp.43 new file mode 100644 index 00000000..508b8436 --- /dev/null +++ b/src/maxsrc/ldisp.43 @@ -0,0 +1,100 @@ +;;; -*- LISP -*- +;;; Auxiliary DISPLA package for doing 1-D display +;;; +;;; (c) 1979 Massachusetts Institute of Technology +;;; +;;; See KMP for details + +(DECLARE (*EXPR MSTRING STRIPDOLLAR) + (SPECIAL LINEAR-DISPLAY-BREAK-TABLE FORTRANP)) + +#-LISPM +(EVAL-WHEN (EVAL COMPILE) + (SSTATUS MACRO /# '+INTERNAL-/#-MACRO SPLICING)) + +;;; (LINEAR-DISPLA ) +;;; +;;; Display text linearly. This function should be usable in any case +;;; DISPLA is usable and will attempt to do something reasonable with +;;; its input. + +(DEFUN LINEAR-DISPLA (X) + (TERPRI) + (COND ((NOT (ATOM X)) + (COND ((EQ (CAAR X) 'MLABLE) + (COND ((CADR X) + (PRIN1 (LIST (STRIPDOLLAR (CADR X)))) + (TYO 32.))) + (LINEAR-DISPLA1 (CADDR X) (CHARPOS T))) + ((EQ (CAAR X) 'MTEXT) + (DO ((X (CDR X) (CDR X)) + (FORTRANP)) ; Atoms in MTEXT + ((NULL X)) ; should omit ?'s + (SETQ FORTRANP (ATOM (CAR X))) + (LINEAR-DISPLA1 (CAR X) 0.) + (TYO 32.))) + (T + (LINEAR-DISPLA1 X 0.)))) + (T + (LINEAR-DISPLA1 X 0.))) + (TERPRI)) + +;;; LINEAR-DISPLAY-BREAK-TABLE +;;; Table entries have the form ( . ) +;;; +;;; The linear display thing will feel free to break BEFORE any +;;; of these 's unless they are preceded by one of the +;;; characters. + +(SETQ LINEAR-DISPLAY-BREAK-TABLE + '((#/= #/: #/=) + (#/( #/( #/[) + (#/) #/) #/]) + (#/[ #/( #/[) + (#/] #/) #/]) + (#/: #/:) + (#/+ #/E #/B) + (#/- #/E #/B) + (#/* #/*) + (#/^))) + +;;; (FIND-NEXT-BREAK ) +;;; Tells how long it will be before the next allowable +;;; text break in a list of chars. + +(DEFUN FIND-NEXT-BREAK (L) + (DO ((I 0. (1+ I)) + (TEMP) + (L L (CDR L))) + ((NULL L) I) + (COND ((MEMBER (CAR L) '(#\SPACE #/,)) (RETURN I)) + ((AND (SETQ TEMP (ASSQ (CADR L) LINEAR-DISPLAY-BREAK-TABLE)) + (NOT (MEMQ (CAR L) (CDR TEMP)))) + (RETURN I))))) + +;;; (LINEAR-DISPLA1 ) +;;; Displays as best it can on this line. +;;; If atom is too long to go on line, types # and a carriage return. +;;; If end of line is found and an elegant break is seen +;;; (see FIND-NEXT-BREAK), it will type a carriage return and indent +;;; spaces. + +(DEFUN LINEAR-DISPLA1 (X INDENT) + (LET ((CHARS (MSTRING X))) + (DO ((END-COLUMN (- (LINEL T) 3.)) + (CHARS CHARS (CDR CHARS)) + (I (CHARPOS T) (1+ I)) + (J (FIND-NEXT-BREAK CHARS) (1- J))) + ((NULL CHARS) T) + (TYO (CAR CHARS)) + (COND ((< J 1) + (SETQ J (FIND-NEXT-BREAK (CDR CHARS))) + (COND ((> (+ I J) END-COLUMN) + (TERPRI) + (DO ((I 0. (1+ I))) ((= I INDENT)) (TYO 32.)) + (SETQ I INDENT)))) + ((= I END-COLUMN) + (PRINC '/#) + (TERPRI) + (SETQ I -1.)))))) + diff --git a/src/maxsrc/mdot.94 b/src/maxsrc/mdot.94 new file mode 100644 index 00000000..0f2725a1 --- /dev/null +++ b/src/maxsrc/mdot.94 @@ -0,0 +1,379 @@ +;; -*- Mode: Lisp; Package: Macsyma -*- +;; (c) Copyright 1982 Massachusetts Institute of Technology + +;; Non-commutative product and exponentiation simplifier +;; Written: July 1978 by CWH + +;; Flags to control simplification: + +(macsyma-module mdot) + +(DEFMVAR $DOTCONSTRULES T + "Causes a non-commutative product of a constant and +another term to be simplified to a commutative product. Turning on this +flag effectively turns on DOT0SIMP, DOT0NSCSIMP, and DOT1SIMP as well.") + +(DEFMVAR $DOT0SIMP T + "Causes a non-commutative product of zero and a scalar term to +be simplified to a commutative product.") + +(DEFMVAR $DOT0NSCSIMP T + "Causes a non-commutative product of zero and a nonscalar term +to be simplified to a commutative product.") + +(DEFMVAR $DOT1SIMP T + "Causes a non-commutative product of one and another term to be +simplified to a commutative product.") + +(DEFMVAR $DOTSCRULES NIL + "Causes a non-commutative product of a scalar and another term to +be simplified to a commutative product. Scalars and constants are carried +to the front of the expression.") + +(DEFMVAR $DOTDISTRIB NIL + "Causes every non-commutative product to be expanded each time it +is simplified, i.e. A . (B + C) will simplify to A . B + A . C.") + +(DEFMVAR $DOTEXPTSIMP T "Causes A . A to be simplified to A ^^ 2.") + +(DEFMVAR $DOTASSOC T + "Causes a non-commutative product to be considered associative, so +that A . (B . C) is simplified to A . B . C. If this flag is off, dot is +taken to be right associative, i.e. A . B . C is simplified to A . (B . C).") + +(DEFMVAR $DOALLMXOPS T + "Causes all operations relating to matrices (and lists) to be +carried out. For example, the product of two matrices will actually be +computed rather than simply being returned. Turning on this switch +effectively turns on the following three.") + +(DEFMVAR $DOMXMXOPS T "Causes matrix-matrix operations to be carried out.") + +(DEFMVAR $DOSCMXOPS NIL "Causes scalar-matrix operations to be carried out.") + +(DEFMVAR $DOMXNCTIMES NIL + "Causes non-commutative products of matrices to be carried out.") + +(DEFMVAR $SCALARMATRIXP T + "Causes a square matrix of dimension one to be converted to a +scalar, i.e. its only element.") + +(DEFMVAR $DOTIDENT 1 "The value to be returned by X^^0.") + +(DEFMVAR $ASSUMESCALAR T + "This governs whether unknown expressions 'exp' are assumed to behave +like scalars for combinations of the form 'exp op matrix' where op is one of +{+, *, ^, .}. It has three settings: + +FALSE -- such expressions behave like non-scalars. +TRUE -- such expressions behave like scalars only for the commutative + operators but not for non-commutative multiplication. +ALL -- such expressions will behave like scalars for all operators + listed above. + +Note: This switch is primarily for the benefit of old code. If possible, +you should declare your variables to be SCALAR or NONSCALAR so that there +is no need to rely on the setting of this switch.") + +;; Specials defined elsewhere. + +(DECLARE (SPECIAL $EXPOP $EXPON ; Controls behavior of EXPAND + SIGN ; Something to do with BBSORT1 + ) + (FIXNUM $EXPOP $EXPON) + (*EXPR FIRSTN $IDENT POWERX MXORLISTP1 ONEP1 + SCALAR-OR-CONSTANT-P EQTEST BBSORT1 OUTERMAP1 TIMEX)) + +(defun simpnct (exp vestigial simp-flag) + vestigial ;ignored + (let ((check exp) + (first-factor (simpcheck (cadr exp) simp-flag)) + (remainder (if (cdddr exp) + (ncmuln (cddr exp) simp-flag) + (simpcheck (caddr exp) simp-flag)))) + (cond ((null (cdr exp)) $dotident) + ((null (cddr exp)) first-factor) + +; This does (. sc m) --> (* sc m) and (. (* sc m1) m2) --> (* sc (. m1 m2)) +; and (. m1 (* sc m2)) --> (* sc (. m1 m2)) where sc can be a scalar +; or constant, and m1 and m2 are non-constant, non-scalar expressions. + + ((commutative-productp first-factor remainder) + (mul2 first-factor remainder)) + ((product-with-inner-scalarp first-factor) + (let ((p-p (partition-product first-factor))) + (outer-constant (car p-p) (cdr p-p) remainder))) + ((product-with-inner-scalarp remainder) + (let ((p-p (partition-product remainder))) + (outer-constant (car p-p) first-factor (cdr p-p)))) + +; This code does distribution when flags are set and when called by +; $EXPAND. The way we recognize if we are called by $EXPAND is to look at +; the value of $EXPOP, but this is a kludge since $EXPOP has nothing to do +; with expanding (. A (+ B C)) --> (+ (. A B) (. A C)). I think that +; $EXPAND wants to have two flags: one which says to convert +; exponentiations to repeated products, and another which says to +; distribute products over sums. + + ((and (mplusp first-factor) (or $dotdistrib (not (zerop $expop)))) + (addn (mapcar #'(lambda (x) (ncmul x remainder)) + (cdr first-factor)) + t)) + ((and (mplusp remainder) (or $dotdistrib (not (zerop $expop)))) + (addn (mapcar #'(lambda (x) (ncmul first-factor x)) + (cdr remainder)) + t)) + +; This code carries out matrix operations when flags are set. + + ((matrix-matrix-productp first-factor remainder) + (timex first-factor remainder)) + ((or (scalar-matrix-productp first-factor remainder) + (scalar-matrix-productp remainder first-factor)) + (simplifya (outermap1 'mnctimes first-factor remainder) t)) + +; (. (^^ x n) (^^ x m)) --> (^^ x (+ n m)) + + ((and (simpnct-alike first-factor remainder) $dotexptsimp) + (simpnct-merge-factors first-factor remainder)) + +; (. (. x y) z) --> (. x y z) + + ((and (mnctimesp first-factor) $dotassoc) + (ncmuln (append (cdr first-factor) + (if (mnctimesp remainder) + (cdr remainder) + (ncons remainder))) + t)) + +; (. (^^ (. x y) m) (^^ (. x y) n) z) --> (. (^^ (. x y) m+n) z) +; (. (^^ (. x y) m) x y z) --> (. (^^ (. x y) m+1) z) +; (. x y (^^ (. x y) m) z) --> (. (^^ (. x y) m+1) z) +; (. x y x y z) --> (. (^^ (. x y) 2) z) + + ((and (mnctimesp remainder) $dotassoc $dotexptsimp) + (setq exp (simpnct-merge-product first-factor (cdr remainder))) + (if (and (mnctimesp exp) $dotassoc) + (simpnct-antisym-check (cdr exp) check) + (eqtest exp check))) + +; (. x (. y z)) --> (. x y z) + + ((and (mnctimesp remainder) $dotassoc) + (simpnct-antisym-check (cons first-factor (cdr remainder)) check)) + + (t (eqtest (list '(mnctimes) first-factor remainder) check))))) + +; Predicate functions for simplifying a non-commutative product to a +; commutative one. SIMPNCT-CONSTANTP actually determines if a term is a +; constant and is not a nonscalar, i.e. not declared nonscalar and not a +; constant list or matrix. The function CONSTANTP determines if its argument +; is a number or a variable declared constant. + +(defun commutative-productp (first-factor remainder) + (or (simpnct-sc-or-const-p first-factor) + (simpnct-sc-or-const-p remainder) + (simpnct-onep first-factor) + (simpnct-onep remainder) + (zero-productp first-factor remainder) + (zero-productp remainder first-factor))) + +(defun simpnct-sc-or-const-p (term) + (or (simpnct-constantp term) (simpnct-assumescalarp term))) + +(defun simpnct-constantp (term) + (and $dotconstrules + (or (mnump term) + (and ($constantp term) (not ($nonscalarp term)))))) + +(defun simpnct-assumescalarp (term) + (and $dotscrules (scalar-or-constant-p term (eq $assumescalar '$all)))) + +(defun simpnct-onep (term) (and $dot1simp (onep1 term))) + +(defun zero-productp (one-term other-term) + (and (zerop1 one-term) + $dot0simp + (or $dot0nscsimp (not ($nonscalarp other-term))))) + +; This function takes a form and determines if it is a product +; containing a constant or a declared scalar. Note that in the +; next three functions, the word "scalar" is used to refer to a constant +; or a declared scalar. This is a bad way of doing things since we have +; to cdr down an expression twice: once to determine if a scalar is there +; and once again to pull it out. + +(defun product-with-inner-scalarp (product) + (and (mtimesp product) + (or $dotconstrules $dotscrules) + (do ((factor-list (cdr product) (cdr factor-list))) + ((null factor-list) nil) + (if (simpnct-sc-or-const-p (car factor-list)) + (return t))))) + +; This function takes a commutative product and separates it into a scalar +; part and a non-scalar part. + +(defun partition-product (product) + (do ((factor-list (cdr product) (cdr factor-list)) + (scalar-list nil) + (nonscalar-list nil)) + ((null factor-list) (cons (nreverse scalar-list) + (muln (nreverse nonscalar-list) t))) + (if (simpnct-sc-or-const-p (car factor-list)) + (push (car factor-list) scalar-list) + (push (car factor-list) nonscalar-list)))) + +; This function takes a list of constants and scalars, and two nonscalar +; expressions and forms a non-commutative product of the nonscalar +; expressions, and a commutative product of the constants and scalars and +; the non-commutative product. + +(defun outer-constant (constant nonscalar1 nonscalar2) + (muln (nconc constant (ncons (ncmul nonscalar1 nonscalar2))) t)) + +(defun simpnct-base (term) (if (mncexptp term) (cadr term) term)) + +(defun simpnct-power (term) (if (mncexptp term) (caddr term) 1)) + +(defun simpnct-alike (term1 term2) + (alike1 (simpnct-base term1) (simpnct-base term2))) + +(defun simpnct-merge-factors (term1 term2) + (ncpower (simpnct-base term1) + (add2 (simpnct-power term1) (simpnct-power term2)))) + +(defun matrix-matrix-productp (term1 term2) + (and (or $doallmxops $domxmxops $domxnctimes) + (mxorlistp1 term1) + (mxorlistp1 term2))) + +(defun scalar-matrix-productp (term1 term2) + (and (or $doallmxops $doscmxops) + (mxorlistp1 term1) + (scalar-or-constant-p term2 (eq $assumescalar '$all)))) + +(declare (muzzled t)) + +(defun simpncexpt (exp vestigial simp-flag) + vestigial ;ignored + (let ((factor (simpcheck (cadr exp) simp-flag)) + (power (simpcheck (caddr exp) simp-flag)) + (check exp)) + (twoargcheck exp) + (cond ((zerop1 power) + (if (mxorlistp1 factor) (identitymx factor) $dotident)) + ((onep1 power) factor) + ((simpnct-sc-or-const-p factor) (power factor power)) + ((and (zerop1 factor) $dot0simp) factor) + ((and (onep1 factor) $dot1simp) factor) + ((and (or $doallmxops $domxmxops) (mxorlistp1 factor)) + (let (($scalarmatrixp (or ($listp factor) $scalarmatrixp))) + (simplify (powerx factor power)))) + + ;; This does (A+B)^^2 --> A^^2 + A.B + B.A + B^^2 + ;; and (A.B)^^2 --> A.B.A.B + + ((and (or (mplusp factor) + (and (not $dotexptsimp) (mnctimesp factor))) + (fixp power) + (not (greaterp power $expop)) + (plusp power)) + (ncmul factor (ncpower factor (1- power)))) + + ;; This does the same thing as above for (A+B)^^(-2) + ;; and (A.B)^^(-2). Here the "-" operator does the trick + ;; for us. + + ((and (or (mplusp factor) + (and (not $dotexptsimp) (mnctimesp factor))) + (fixp power) + (not (greaterp (minus power) $expon)) + (minusp power)) + (ncmul (simpnct-invert factor) (ncpower factor (1+ power)))) + ((product-with-inner-scalarp factor) + (let ((p-p (partition-product factor))) + (mul2 (power (muln (car p-p) t) power) + (ncpower (cdr p-p) power)))) + ((and $dotassoc (mncexptp factor)) + (ncpower (cadr factor) (mul2 (caddr factor) power))) + (t (eqtest (list '(mncexpt) factor power) check))))) + +(declare (muzzled nil)) + +(defun simpnct-invert (exp) + (cond ((mnctimesp exp) + (ncmuln (nreverse (mapcar #'simpnct-invert (cdr exp))) t)) + ((and (mncexptp exp) (fixp (caddr exp))) + (ncpower (cadr exp) (minus (caddr exp)))) + (t (list '(mncexpt simp) exp -1)))) + +(defun identitymx (x) + (if (and ($listp (cadr x)) (= (length (cdr x)) (length (cdadr x)))) + (simplifya (cons (car x) (cdr ($ident (length (cdr x))))) t) + $dotident)) + +; This function incorporates the hairy search which enables such +; simplifications as (. a b a b) --> (^^ (. a b) 2). It assumes +; that FIRST-FACTOR is not a dot product and that REMAINDER is. +; For the product (. a b c d e), three basic types of comparisons +; are done: +; +; 1) a <---> b first-factor <---> inner-product +; a <---> (. b c) +; a <---> (. b c d) +; a <---> (. b c d e) (this case handled in SIMPNCT) +; +; 2) (. a b) <---> c outer-product <---> (car rest) +; (. a b c) <---> d +; (. a b c d) <---> e +; +; 3) (. a b) <---> (. c d) outer-product <---> (firstn rest) +; +; Note that INNER-PRODUCT and OUTER-PRODUCT share list structure which +; is clobbered as new terms are added. + +(defun simpnct-merge-product (first-factor remainder) + (let ((half-product-length (// (1+ (length remainder)) 2)) + (inner-product (car remainder)) + (outer-product (list '(mnctimes) first-factor (car remainder)))) + (do ((merge-length 2 (1+ merge-length)) + (rest (cdr remainder) (cdr rest))) + ((null rest) outer-product) + (cond ((simpnct-alike first-factor inner-product) + (return + (ncmuln + (cons (simpnct-merge-factors first-factor inner-product) + rest) + t))) + ((simpnct-alike outer-product (car rest)) + (return + (ncmuln + (cons (simpnct-merge-factors outer-product (car rest)) + (cdr rest)) + t))) + ((and (not (> merge-length half-product-length)) + (alike1 outer-product + (cons '(mnctimes) + (firstn merge-length rest)))) + (return + (ncmuln (cons (ncpower outer-product 2) + (nthcdr merge-length rest)) + t))) + ((= merge-length 2) + (setq inner-product + (cons '(mnctimes) (cddr outer-product))))) + (rplacd (last inner-product) (ncons (car rest)))))) + +(defun simpnct-antisym-check (l check) + (let (sign) + (cond ((and (get 'mnctimes '$antisymmetric) (cddr l)) + (setq l (bbsort1 l)) + (cond ((equal l 0) 0) + ((prog1 (null sign) + (setq l (eqtest (cons '(mnctimes) l) check))) + l) + (t (neg l)))) + (t (eqtest (cons '(mnctimes) l) check))))) + +(declare (unspecial sign)) diff --git a/src/maxsrc/merror.47 b/src/maxsrc/merror.47 new file mode 100644 index 00000000..ebdaea06 --- /dev/null +++ b/src/maxsrc/merror.47 @@ -0,0 +1,252 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module merror) + +;;; Macsyma error signalling. +;;; 2:08pm Tuesday, 30 June 1981 George Carrette. + +(DEFMVAR $ERROR '((MLIST SIMP) |&No error.|) + "During an error break this is bound to a list + of the arguments to the call to ERROR, with the message + text in a compact format.") + +(DEFMVAR $ERRORMSG 'T + "If FALSE then NO error message is printed!") + +(DEFMFUN $ERROR (&REST L) + "Signals a Macsyma user error." + (apply #'merror (fstringc L))) + +(DEFMVAR $ERROR_SIZE 10. + "Expressions greater in some size measure over this value + are replaced by symbols {ERREXP1, ERREXP2,...} in the error + display, the symbols being set to the expressions, so that one can + look at them with expression editing tools. The default value of + this variable may be determined by factors of terminal speed and type.") + +(DECLARE (FIXNUM (ERROR-SIZE NIL))) + +(DEFUN ERROR-SIZE (EXP) + (IF (ATOM EXP) 0 + (DO ((L (CDR EXP) (CDR L)) + (N 1 (1+ (+ N (ERROR-SIZE (CAR L)))))) + ((OR (NULL L) + ;; no need to go any further, and this will save us + ;; from circular structures. (Which they display + ;; package would have a hell of a time with too.) + (> N $ERROR_SIZE)) + N) + (DECLARE (FIXNUM N))))) + +;;; Problem: Most macsyma users do not take advantage of break-points +;;; for debugging. Therefore they need to have the error variables +;;; SET (as the old ERREXP was), and not PROGV bound. The problem with +;;; this is that recursive errors will bash the old value of the +;;; error variables. However, since we do bind the value of the +;;; variable $ERROR, calling the function $ERRORMSG will always +;;; set things back. It would be better to bind these variables, +;;; for, amoung other things, then the values could get garbage +;;; collected. + +(DEFMFUN MERROR (STRING &REST L) + (SETQ STRING (CHECK-OUT-OF-CORE-STRING STRING)) + (LET (($ERROR `((MLIST) ,STRING ,@L))) + (AND $ERRORMSG ($ERRORMSG)) + (ERROR #+(OR LISPM NIL) STRING))) + +#+LISPM +;; This tells the error handler to report the context of +;; the error as the function that called MERROR, instead of +;; saying that the error was in MERROR. +(DEFPROP MERROR T :ERROR-REPORTER) + +(DEFMVAR $ERROR_SYMS '((MLIST) $ERREXP1 $ERREXP2 $ERREXP3) + "Symbols to bind the too-large error expresssions to") + +(DEFUN ($ERROR_SYMS ASSIGN) (VAR VAL) + (IF (NOT (AND ($LISTP VAL) + (DO ((L (CDR VAL) (CDR L))) + ((NULL L) (RETURN T)) + (IF (NOT (SYMBOLP (CAR L))) (RETURN NIL))))) + (MERROR "The variable ~M being set to ~M which is not a list of symbols." + VAR VAL))) + +(DEFUN PROCESS-ERROR-ARGL (L) + ;; This returns things so that we could set or bind. + (DO ((ERROR-SYMBOLS NIL) + (ERROR-VALUES NIL) + (NEW-ARGL NIL) + (SYMBOL-NUMBER 0)) + ((NULL L) + (LIST (NREVERSE ERROR-SYMBOLS) + (NREVERSE ERROR-VALUES) + (NREVERSE NEW-ARGL))) + (LET ((FORM (POP L))) + (COND ((> (ERROR-SIZE FORM) $ERROR_SIZE) + (SETQ SYMBOL-NUMBER (1+ SYMBOL-NUMBER)) + (LET ((SYM (NTHCDR SYMBOL-NUMBER $ERROR_SYMS))) + (COND (SYM + (SETQ SYM (CAR SYM))) + ('ELSE + (SETQ SYM (CONCAT '$ERREXP SYMBOL-NUMBER)) + (SETQ $ERROR_SYMS (APPEND $ERROR_SYMS (LIST SYM))))) + (PUSH SYM ERROR-SYMBOLS) + (PUSH FORM ERROR-VALUES) + (PUSH SYM NEW-ARGL))) + ('ELSE + (PUSH FORM NEW-ARGL)))))) + +(DEFMFUN $ERRORMSG () + "ERRORMSG() redisplays the error message while in an error break." + ;; Don't optimize out call to PROCESS-ERROR-ARGL in case of + ;; multiple calls to $ERRORMSG, because the user may have changed + ;; the values of the special variables controling its behavior. + ;; The real expense here is when MFORMAT calls the DISPLA package. + (LET ((THE-JIG (PROCESS-ERROR-ARGL (CDDR $ERROR)))) + (MAPC #'SET (CAR THE-JIG) (CADR THE-JIG)) + (CURSORPOS 'A #-LISPM NIL) + (LET ((ERRSET NIL)) + (IF (NULL (ERRSET + (LEXPR-FUNCALL #'MFORMAT NIL (CADR $ERROR) (CADDR THE-JIG)))) + (MTELL "~%** Error while printing error message **~%~A~%" + (CADR $ERROR) + ))) + (IF (NOT (ZEROP (CHARPOS T))) (MTERPRI))) + '$DONE) + +(DEFMFUN READ-ONLY-ASSIGN (VAR VAL) + (IF MUNBINDP + 'MUNBINDP + (MERROR "Attempting to assign read-only variable ~:M the value:~%~M" + VAR VAL))) + +(DEFPROP $ERROR READ-ONLY-ASSIGN ASSIGN) + + +;; THIS THROWS TO (*CATCH 'RATERR ...), WHEN A PROGRAM ANTICIPATES +;; AN ERROR (E.G. ZERO-DIVIDE) BY SETTING UP A CATCH AND SETTING +;; ERRRJFFLAG TO T. Someday this will be replaced with SIGNAL. +;; Such skill with procedure names! I'd love to see how he'd do with +;; city streets. + +;;; N.B. I think the above comment is by CWH, this function used +;;; to be in RAT;RAT3A. Its not a bad try really, one of the better +;;; in macsyma. Once all functions of this type are rounded up +;;; I'll see about implementing signaling. -GJC + +(DEFMFUN ERRRJF N + (IF ERRRJFFLAG (*THROW 'RATERR NIL) (APPLY #'MERROR (LISTIFY N)))) + +;;; The user-error function is called on |&foo| "strings" and expressions. +;;; Cons up a format string so that $ERROR can be bound. +;;; This might also be done at code translation time. +;;; This is a bit crude. + +(defmfun fstringc (L) + (do ((sl nil) (s) (sb) + (se nil)) + ((null l) + (setq sl (maknam sl)) + #+PDP10 + (putprop sl t '+INTERNAL-STRING-MARKER) + (cons sl (nreverse se))) + (setq s (pop l)) + (cond ((and (symbolp s) (= (getcharn s 1) #/&)) + (setq sb (cdr (exploden s)))) + (t + (push s se) + (setq sb (list #/~ #/M)))) + (setq sl (nconc sl sb (if (null l) nil (list #\SP)))))) + + + +#+PDP10 +(PROGN 'COMPILE + ;; Fun and games with the pdp-10. The calling sequence for + ;; subr, (arguments passed through registers), is much smaller + ;; than that for lsubrs. If we really where going to do a lot + ;; of this hackery then we would define some kind of macro + ;; for it. + (LET ((X (GETL 'MERROR '(EXPR LSUBR)))) + (REMPROP '*MERROR (CAR X)) + (PUTPROP '*MERROR (CADR X) (CAR X))) + (DECLARE (*LEXPR *MERROR)) + (DEFMFUN *MERROR-1 (A) (*MERROR A)) + (DEFMFUN *MERROR-2 (A B) (*MERROR A B)) + (DEFMFUN *MERROR-3 (A B C) (*MERROR A B C)) + (DEFMFUN *MERROR-4 (A B C D) (*MERROR A B C D)) + (DEFMFUN *MERROR-5 (A B C D E) (*MERROR A B C D E)) + + + (LET ((X (GETL 'ERRRJF '(EXPR LSUBR)))) + (REMPROP '*ERRRJF (CAR X)) + (PUTPROP '*ERRRJF (CADR X) (CAR X))) + (DECLARE (*LEXPR *ERRRJF)) + (DEFMFUN *ERRRJF-1 (A) (*ERRRJF A)) + + ) +#+Maclisp +(progn 'compile +(defun m-wna-eh (((f . actual-args) args-info)) + ;; generate a nice user-readable message about this lisp error. + ;; F may be a symbol or a lambda expression. + ;; args-info may be nil, an args-info form, or a formal argument list. + (merror "~M ~A to function ~A" + `((mlist) ,@actual-args) + ;; get the error messages passed as first arg to lisp ERROR. + (caaddr (errframe ())) + (if (symbolp f) + (if (or (equal (args f) args-info) + (symbolp args-info)) + f + `((,f),@args-info)) + `((lambda)((mlist),@(cadr f)))))) + +(defun m-wta-eh ((object)) + (merror "~A: ~A" (caaddr (errframe ())) object)) + +(defun m-ubv-eh ((variable)) + (merror "Unbound variable: ~A" variable)) + +;; TRANSL generates regular LISP function calls for functions which +;; are lisp defined at translation time, and in compiled code. +;; MEXPRs can be handled by the UUF (Undefined User Function) handler. + +(DEFVAR UUF-FEXPR-ALIST ()) + +(DEFUN UUF-HANDLER (X) + (LET ((FUNP (OR (MGETL (CAR X) '(MEXPR MMACRO)) + (GETL (CAR X) '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S))))) + (CASEQ (CAR FUNP) + ((MEXPR) + ;; The return value of the UUF-HANDLER is put back into + ;; the "CAR EVALUATION LOOP" of the S-EXP. It is evaluated, + ;; checked for "functionality" and applied if a function, + ;; otherwise it is evaluated again, unless it's atomic, + ;; in which case it will call the UNDF-FNCTN handler again, + ;; unless (STATUS PUNT) is NIL in which case it is + ;; evaluated (I think). One might honestly ask + ;; why the maclisp evaluator behaves like this. -GJC + `((QUOTE (LAMBDA *N* + (MAPPLY ',(CAR X) (LISTIFY *N*) ',(CAR X)))))) + ((MMACRO TRANSLATED-MMACRO) + (MERROR + "Call to a macro '~:@M' which was undefined during translation." + (CAR X))) + ((MFEXPR* MFEXPR*S) + ;; An call in old translated code to what was a FEXPR. + (LET ((CELL (ASSQ (CAR X) UUF-FEXPR-ALIST))) + (OR CELL + (LET ((NAME (GENSYM))) + (PUTPROP NAME + `(LAMBDA (,NAME) (MEVAL (CONS '(,(CAR X)) ,NAME))) + 'FEXPR) + (SETQ CELL (LIST (CAR X) NAME)) + (PUSH CELL UUF-FEXPR-ALIST))) + (CDR CELL))) + (T + (MERROR "Call to an undefined function '~A' at Lisp level." + (CAR X)))))) +) \ No newline at end of file diff --git a/src/maxsrc/mformt.27 b/src/maxsrc/mformt.27 new file mode 100644 index 00000000..97d1fa49 --- /dev/null +++ b/src/maxsrc/mformt.27 @@ -0,0 +1,145 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mformt) +(load-macsyma-macros mforma) + +(EVAL-WHEN (EVAL) + (SETQ MACRO-EXPANSION-USE 'DISPLACE)) + +(DEF-MFORMAT) + +(DEF-MFORMAT-VAR /:-FLAG NIL T) +(DEF-MFORMAT-VAR /@-FLAG NIL T) +(DEF-MFORMAT-VAR PARAMETER 0 T) ; Who can read "~33,34,87A" ? +(DEF-MFORMAT-VAR PARAMETER-P NIL T) +(DEF-MFORMAT-VAR TEXT NIL NIL) +(DEF-MFORMAT-VAR TEXT-TEMP NIL NIL) +(DEF-MFORMAT-VAR DISPLA-P NIL NIL) +(DEF-MFORMAT-VAR PRE-%-P NIL NIL) +(DEF-MFORMAT-VAR POST-%-P NIL NIL) + +#-PDP10 +(DEFMFUN CHECK-OUT-OF-CORE-STRING (string) string) + +(DEFMACRO PUSH-TEXT-TEMP () + '(IF TEXT-TEMP (SETQ TEXT (CONS (CONS '(TEXT-STRING) (NREVERSE TEXT-TEMP)) + TEXT) + TEXT-TEMP NIL))) + +(DEFMACRO OUTPUT-TEXT () + '(PROGN (PUSH-TEXT-TEMP) + (OUTPUT-TEXT* STREAM TEXT DISPLA-P PRE-%-P POST-%-P) + (SETQ TEXT NIL DISPLA-P NIL PRE-%-P NIL POST-%-P NIL))) + +(DEF-MFORMAT-OP (#/% #/&) + (COND ((OR TEXT TEXT-TEMP) + (SETQ POST-%-P T) + ;; there is text to output. + (OUTPUT-TEXT)) + (T + (SETQ PRE-%-P T)))) + +(DEF-MFORMAT-OP #/M + (PUSH-TEXT-TEMP) + (LET ((ARG (POP-MFORMAT-ARG))) + (AND @-FLAG (ATOM ARG) + (SETQ ARG (OR (GET ARG 'OP) ARG))) + (COND (/:-FLAG + (PUSH (CONS '(TEXT-STRING) (MSTRING ARG)) TEXT)) + (T + (SETQ DISPLA-P T) + (PUSH ARG TEXT))))) + +(DEF-MFORMAT-OP #/A + (PUSH-TEXT-TEMP) + (PUSH (CONS '(TEXT-STRING) (EXPLODEN (POP-MFORMAT-ARG))) TEXT)) + +(DEF-MFORMAT-OP #/S + (PUSH-TEXT-TEMP) + (PUSH (CONS '(TEXT-STRING) + (MAP #'(LAMBDA (C) + (RPLACA C (GETCHARN (CAR C) 1))) + (EXPLODE (POP-MFORMAT-ARG)))) + TEXT)) + +(DEFMFUN MFORMAT N + (OR (> N 1) + ;; make error message without new symbols. + ;; This error should not happen in compiled code because + ;; this check is done at compile time too. + (ERROR 'WRNG-NO-ARGS 'MFORMAT)) + (LET ((STREAM (ARG 1)) + (STRING (exploden (check-out-of-core-string (ARG 2)))) + (arg-index 2)) + #+NIL + (AND (OR (NULL STREAM) + (EQ T STREAM)) + (SETQ STREAM STANDARD-OUTPUT)) + ;; This is all done via macros to save space, + ;; (No functions, no special variable symbols.) + ;; If the lack of flexibilty becomes an issue then + ;; it can be changed easily. + (MFORMAT-LOOP (OUTPUT-TEXT)) + ;; On Multics keep from getting bitten by line buffering. + #+Multics + (FORCE-OUTPUT STREAM) + )) + +(DEFUN OUTPUT-TEXT* (STREAM TEXT DISPLA-P PRE-%-P POST-%-P) + (SETQ TEXT (NREVERSE TEXT)) + ;; outputs a META-LINE of text. + (COND (DISPLA-P (DISPLAF (CONS '(MTEXT) TEXT) STREAM)) + (T + (IF PRE-%-P (TERPRI STREAM)) + (DO () + ((NULL TEXT)) + (DO ((L (CDR (POP TEXT)) (CDR L))) + ((NULL L)) + (TYO (CAR L) STREAM))) + (IF POST-%-P (TERPRI STREAM))))) + +(DEFUN (TEXT-STRING DIMENSION) (FORM RESULT) + ;; come up with something more efficient later. + (DIMENSION-ATOM (MAKNAM (CDR FORM)) RESULT)) + +(DEFMFUN DISPLAF (OBJECT STREAM) + ;; for DISPLA to a file. actually this works for SFA's and + ;; other streams in maclisp. + (IF (EQ STREAM NIL) + (DISPLA OBJECT) + (LET ((/^R T) + (/^W T) + (OUTFILES (NCONS STREAM))) + (DISPLA OBJECT)))) + + +(DEFMFUN MTELL (&REST L) + (LEXPR-FUNCALL #'MFORMAT NIL L)) + + +;; Calling-sequence optimizations. +#+PDP10 +(PROGN 'COMPILE + (LET ((X (GETL 'MFORMAT '(EXPR LSUBR)))) + (REMPROP '*MFORMAT (CAR X)) + (PUTPROP '*MFORMAT (CADR X) (CAR X))) + (DECLARE (*LEXPR *MFORMAT)) + (DEFMFUN *MFORMAT-2 (A B) (*MFORMAT A B)) + (DEFMFUN *MFORMAT-3 (A B C) (*MFORMAT A B C)) + (DEFMFUN *MFORMAT-4 (A B C D) (*MFORMAT A B C D)) + (DEFMFUN *MFORMAT-5 (A B C D E) (*MFORMAT A B C D E)) + + (LET ((X (GETL 'MTELL '(EXPR LSUBR)))) + (REMPROP '*MTELL (CAR X)) + (PUTPROP '*MTELL (CADR X) (CAR X))) + (DECLARE (*LEXPR *MTELL)) + (DEFMFUN MTELL1 (A) (*MTELL A)) + (DEFMFUN MTELL2 (A B) (*MTELL A B)) + (DEFMFUN MTELL3 (A B C) (*MTELL A B C)) + (DEFMFUN MTELL4 (A B C D) (*MTELL A B C D)) + (DEFMFUN MTELL5 (A B C D E) (*MTELL A B C D E)) + ) + + diff --git a/src/maxsrc/mload.121 b/src/maxsrc/mload.121 new file mode 100644 index 00000000..59e3fd50 --- /dev/null +++ b/src/maxsrc/mload.121 @@ -0,0 +1,479 @@ +;;; -*- Mode: Lisp; Package: Macsyma -*- +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mload) + +;; I decided to move most of the file hacking utilities I used in TRANSL to +;; this file. -GJC + +;; Concepts: +;; Lisp_level_filename. Anything taken by the built-in lisp I/O primitives. +;; +;; User_level_filename. Comes through the macsyma reader, so it has an extra "&" +;; in the pname in the case of "filename" or has extra "$" and has undergone +;; ALIAS transformation in the case of 'FOOBAR or '[FOO,BAR,BAZ]. +;; +;; Canonical_filename. Can be passed to built-in lisp I/O primitives, and +;; can also be passed back to the user, is specially handled by the DISPLAY. +;; +;; Functions: +;; $FILENAME_MERGE. Takes User_level_filename(s) and Canonical_filename(s) and +;; merges them together, returning a Canonical_filename. +;; +;; TO-MACSYMA-NAMESTRING. Converts a Lisp_level_filename to a Canonical_filename +;; +;; $FILE_SEARCH ............ Takes a user or canonical filename and a list of types of +;; applicable files to look for. +;; $FILE_TYPE ............. Takes a user or canonical filename and returns +;; NIL, $MACSYMA, $LISP, or $FASL. +;; CALL-BATCH1 ............. takes a canonical filename and a no-echop flag. + +;; Note: This needs to be generalized some more to take into account +;; the lispmachine situation of access to many different file systems +;; at the same time without, and also take into account the way it presently +;; deals with that situation. The main thing wrong now is that the file-default +;; strings are constants. + +;; What a cannonical filename is on the different systems: +;; This is for informational purposes only, as the Macsyma-Namestringp +;; predicate is provided. +;; [PDP-10 Maclisp] An uninterned symbol with various properties. +;; [Franz Lisp] a string or a symbol (whose print name is used). +;; [Multics Maclisp] A STRING. +;; [LispMachine] A generic pathname object, which is a system-provided FLAVOR. +;; [NIL] Not decided yet, but a STRING should do ok, since in NIL files are +;; a low-level primitive, and programs, modules, and environments are the +;; practical abstraction used. No attempt is made to come up with ad-hoc generalizations +;; of the ITS'ish and DEC'ish filenames, as such attempts fail miserably to provide +;; the functionality of filesystems such as on Multics. + +(DECLARE (SPECIAL $FILE_SEARCH $FILE_TYPES)) + +(DEFMFUN $LISTP_CHECK (VAR VAL) + "Gives an error message including its first argument if its second + argument is not a LIST" + (OR ($LISTP VAL) + (MERROR "The variable ~:M being set to a non-LISTP object:~%~M" + VAR VAL))) + +(DEFPROP $FILE_SEARCH $LISTP_CHECK ASSIGN) + +(DEFPROP $FILE_TYPES $LISTP_CHECK ASSIGN) + +#-Franz +(DEFMFUN $FILE_SEARCH (X &OPTIONAL + (LISTP NIL) + (L $FILE_TYPES)) + (SETQ X ($FILENAME_MERGE X)) + (IF ($LISTP L) (SETQ L (CDR L)) + (MERROR "3'rd arg to FILE_SEARCH not a list.~%~M" L)) + (DO ((MERGE-SPECS (CONS ($filename_merge) + ;; Get a complete "star filename" + (CDR $FILE_SEARCH)) + (CDR MERGE-SPECS)) + (PROBED) + (FOUND)) + ((NULL MERGE-SPECS) + (IF LISTP + `((MLIST) ,@(NREVERSE FOUND)) + (MERROR "Could not find file which matches ~M" X))) + (IF (DO ((L L (CDR L)) + (U ($FILENAME_MERGE (CAR MERGE-SPECS)))) + ((NULL L) NIL) + (IF (SETQ PROBED (PROBEF ($FILENAME_MERGE X U (CAR L)))) + (IF LISTP + (PUSH (TO-MACSYMA-NAMESTRING PROBED) FOUND) + (RETURN T)))) + (RETURN (TO-MACSYMA-NAMESTRING PROBED))))) + +;; filename merging is unheard of on Unix. +;; If the user doesn't supply a file extension, we look for .o, .l and .v +;; and finally the file itself. If the user supplies one of the standard +;; extensions, we just use that. +#+Franz +(defmfun $file_search (x &optional (listp nil) (l $file_types)) + (let ((filelist (cond ((cdr $file_search)) + (t '(".")))) + (extlist (cond ((member (substring x -2) '(".o" ".l" ".v")) + '(nil)) + (t '(".o" ".l" ".v" nil))))) + (do ((dir filelist (cdr dir)) + (ret)) + ((null dir) + (cond (listp '((mlist))) + (t (MERROR "Could not find file ~M" X)))) + (cond ((setq ret + (do ((try extlist (cdr try)) + (this)) + ((null try)) + (setq this (cond ((null (car try)) x) + (t (concat x (car try))))) + (cond ((not (equal "." (car dir))) + (setq this (concat (car dir) "//" this)))) + (cond ((probef this) + (return + (cond (listp `((mlist) + ,(to-macsyma-namestring x))) + (t (to-macsyma-namestring this)))))))) + (return ret)))))) + + +(DECLARE (SPECIAL $LOADPRINT)) + +(DEFMFUN LOAD-AND-TELL (FILENAME) + (LOADFILE FILENAME + T ;; means this is a lisp-level call, not user-level. + $LOADPRINT)) + +#+PDP10 +(PROGN 'COMPILE +;; on the PDP10 cannonical filenames are represented as symbols +;; with a DIMENSION-LIST property of DISPLAY-FILENAME. + +(DEFUN DIMENSION-FILENAME (FORM RESULT) + (DIMENSION-STRING (CONS #/" (NCONC (EXPLODEN FORM) (LIST #/"))) RESULT)) + +(DEFUN TO-MACSYMA-NAMESTRING (X) + ;; create an uninterned symbol, uninterned so that + ;; it will be GC'd. + (SETQ X (PNPUT (PNGET (NAMESTRING X) 7) NIL)) + (PUTPROP X 'DIMENSION-FILENAME 'DIMENSION-LIST) + X) + +(DEFUN MACSYMA-NAMESTRINGP (X) + (AND (SYMBOLP X) (EQ (GET X 'DIMENSION-LIST) 'DIMENSION-FILENAME))) + +(DEFMACRO ERRSET-NAMESTRING (X) + `(LET ((ERRSET NIL)) + (ERRSET (NAMESTRING ,X) NIL))) + +(DEFMFUN $FILENAME_MERGE N + (DO ((F "" (MERGEF (MACSYMA-NAMESTRING-SUB (ARG J)) F)) + (J N (1- J))) + ((ZEROP J) + (TO-MACSYMA-NAMESTRING F)))) +) + +#+Franz +(progn 'compile + +;; a first crack at these functions + +(defun to-macsyma-namestring (x) + (cond ((macsyma-namestringp x) x) + ((symbolp x) + (cond ((memq (getcharn x 1) '(#/& #/$)) + (substring (get_pname x) 2)) + (t (get_pname x)))) + (t (merror "to-macsyma-namestring: non symbol arg ~M~%" x)))) + +(defun macsyma-namestringp (x) + (stringp x)) + +;;--- $filename_merge +; may not need this ask filename merging is not done on Unix systems. +; +(defmfun $filename_merge (&rest files) + (cond (files (filestrip (ncons (car files)))))) +) + +#+MULTICS +(PROGN 'COMPILE +(DEFUN TO-MACSYMA-NAMESTRING (X) + (cond ((macsyma-namestringp x) x) + ((symbolp x) (substring (string x) 1)) + ((listp x) (namestring x)) + (t x))) + +(DEFUN MACSYMA-NAMESTRINGP (X) (STRINGP X)) +(DEFUN ERRSET-NAMESTRING (X) + (IF (ATOM X) (NCONS (STRING X)) (ERRSET (NAMESTRING X) NIL))) + +(DEFMFUN $FILENAME_MERGE (&REST FILE-SPECS) + (SETQ FILE-SPECS (cond (file-specs + (MAPCAR #'MACSYMA-NAMESTRING-SUB FILE-SPECS)) + (t '("**")))) + (TO-MACSYMA-NAMESTRING (IF (NULL (CDR FILE-SPECS)) + (CAR FILE-SPECS) + (APPLY #'MERGEF FILE-SPECS)))) + +) + +#+LISPM +(PROGN 'COMPILE +(DEFUN TO-MACSYMA-NAMESTRING (X) + (FS:PARSE-PATHNAME X)) +(DEFUN MACSYMA-NAMESTRINGP (X) + (TYPEP X 'FS:PATHNAME)) +(DEFUN ERRSET-NAMESTRING (X) + (LET ((ERRSET NIL)) + (ERRSET (FS:PARSE-PATHNAME X) NIL))) + +(DEFMFUN $FILENAME_MERGE (&REST FILE-SPECS) + (DO ((F "" (FS:MERGE-PATHNAME-DEFAULTS (MACSYMA-NAMESTRING-SUB + (NTH (1- J) FILE-SPECS)) + F)) + (J (LENGTH FILE-SPECS) (1- J))) + ((ZEROP J) + (TO-MACSYMA-NAMESTRING F)))) +) + +(DEFUN MACSYMA-NAMESTRING-SUB (USER-OBJECT) + (IF (MACSYMA-NAMESTRINGP USER-OBJECT) USER-OBJECT + (LET* ((SYSTEM-OBJECT + (COND ((ATOM USER-OBJECT) + (FULLSTRIP1 USER-OBJECT)) + (($LISTP USER-OBJECT) + (FULLSTRIP (CDR USER-OBJECT))) + (T + (MERROR "Bad file spec:~%~M" USER-OBJECT)))) + (NAMESTRING-TRY (ERRSET-NAMESTRING SYSTEM-OBJECT))) + (IF NAMESTRING-TRY (CAR NAMESTRING-TRY) + ;; know its small now, so print on same line. + (MERROR "Bad file spec: ~:M" USER-OBJECT))))) + +(DEFMFUN open-out-dsk (x) + (open x #-LISPM '(out dsk ascii block) + #+LISPM '(:out :ascii))) +(DEFMFUN open-in-dsk (x) + (open x #-LISPM '(in dsk ascii block) + #+LISPM '(:in :ascii))) + +#-MAXII +(PROGN 'COMPILE + +(DECLARE (SPECIAL DSKFNP OLDST ST $NOLABELS REPHRASE)) + +(DEFMFUN CALL-BATCH1 (FILENAME ^W) + (LET ((^R (AND ^R (NOT ^W))) + ($NOLABELS T) + ($CHANGE_FILEDEFAULTS) + (DSKFNP T) + (OLDST) + (ST)) + ;; cons #/& to avoid the double-stripdollar problem. + (BATCH1 (LIST (MAKNAM (CONS #/& (EXPLODEN FILENAME)))) + NIL + NIL + #-Franz T + #+Franz nil) + (SETQ REPHRASE T))) + + +(DEFMVAR *IN-$BATCHLOAD* NIL + "I should have a single state variable with a bit-vector or even a list + of symbols for describing the state of file translation.") +(DEFMVAR *IN-TRANSLATE-FILE* NIL "") +(DEFMVAR *IN-MACSYMA-INDEXER* NIL) + +(DEFUN TRANSLATE-MACEXPR (FORM &optional FILEPOS) + (COND (*IN-TRANSLATE-FILE* + (TRANSLATE-MACEXPR-ACTUAL FORM FILEPOS)) + (*in-macsyma-indexer* + (outex-hook-exp form)) + (T + (LET ((R (ERRSET (MEVAL* FORM)))) + (COND ((NULL R) + (LET ((^W NIL)) + (MERROR "~%This form caused an error in evaluation:~ + ~%~:M" FORM)))))))) + + +(DEFMFUN $BATCHLOAD (FILENAME) + (LET ((WINP NIL) + (NAME ($FILENAME_MERGE FILENAME)) + (*IN-$BATCHLOAD* T)) + (IF $LOADPRINT + (MTELL "~%Batching the file ~M~%" NAME)) + (UNWIND-PROTECT + (PROGN (CALL-BATCH1 NAME T) + (SETQ WINP T) + NAME) + ;; unwind protected. + (IF WINP + (IF $LOADPRINT (MTELL "Batching done.")) + (MTELL "Some error in loading this file: ~M" NAME))))) + +;; end of moby & crufty #-MAXII +) + +#+MAXII +(DEFMFUN $BATCHLOAD (FILENAME) + (LET ((EOF (LIST NIL)) + (NAME ($FILENAME_MERGE FILENAME)) + (*MREAD-PROMPT* "(Batching) ")) + (IF $LOADPRINT + (MTELL "~%Batching the file ~M~%" NAME)) + (WITH-OPEN-FILE (STREAM NAME '(:IN :ASCII)) + (DO ((FORM NIL (MREAD STREAM EOF))) + ((EQ FORM EOF) + (IF $LOADPRINT (MTELL "Batching done.")) + '$DONE) + (MEVAL* (CADDR FORM)))))) + + +(DEFMFUN $LOAD (MACSYMA-USER-FILENAME + &AUX + (FILENAME ($FILENAME_MERGE MACSYMA-USER-FILENAME))) + "This is the generic file loading function. + LOAD(/"filename/") will either BATCHLOAD or LOADFILE the file, + depending on wether the file contains Macsyma, Lisp, or Compiled + code. The file specifications default such that a compiled file + is searched for first, then a lisp file, and finally a macsyma batch + file. This command is designed to provide maximum utility and + convenience for writers of packages and users of the macsyma->lisp + translator." + (LET* ((SEARCHED-FOR ($FILE_SEARCH FILENAME)) + (TYPE ($FILE_TYPE SEARCHED-FOR))) + (CASEQ TYPE + (($MACSYMA) + ($BATCHLOAD SEARCHED-FOR)) + (($LISP $FASL) + ;; do something about handling errors + ;; during loading. Foobar fail act errors. + (LOAD-AND-TELL SEARCHED-FOR)) + (T + (MERROR "MACSYMA BUG: Unknown file type ~M" TYPE))) + SEARCHED-FOR + )) + +#+Multics +(DEFMFUN $FILE_TYPE (FILE) + (SETQ FILE ($FILENAME_MERGE FILE)) + (IF (NULL (PROBEF FILE)) NIL + (CASEQ (CAR (LAST (NAMELIST FILE))) + ((MACSYMA) '$MACSYMA) + ((LISP) '$LISP) + (T '$FASL)))) + +#-MULTICS +(DEFMFUN $FILE_TYPE (FILENAME &AUX STREAM) + (SETQ FILENAME ($FILENAME_MERGE FILENAME)) + (COND ((NULL (PROBEF FILENAME)) + NIL) +#-Franz ((FASLP FILENAME) + '$FASL) +#+Franz ((cdr (assoc (substring filename -2) + '((".l" . $lisp) (".o" . $fasl) (".v" . $macsyma))))) + ('ELSE + ;; This has to be simple and small for greatest utility + ;; as an in-core pdp10 function. + (UNWIND-PROTECT + (DO ((C (PROGN (SETQ STREAM (OPEN-IN-DSK FILENAME)) + #\SP) + (TYI STREAM -1))) + ((NOT (MEMBER C '(#\SP #\TAB #\CR #\LF #\FF))) + ;; heuristic number one, + ;; check for cannonical language "comment." as first thing + ;; in file after whitespace. + (COND ((MEMBER C '(-1 #/;)) + '$LISP) + ((AND (= C #//) + (= (TYI STREAM -1) #/*)) + '$MACSYMA) + #+Franz ((eq c 7) ;; fasl files begin with bytes 7,1 + '$fasl) ;; but just seeing 7 is good enough + ('ELSE + ;; the above will win with all Lisp files written by + ;; the macsyma system, e.g. the $SAVE and + ;; $TRANSLATE_FILE commands, all lisp files written + ;; by macsyma system programmers, and anybody else + ;; who starts his files with a "comment," lisp or + ;; macsyma. + (FILEPOS STREAM 0) + ;; heuristic number two, see if READ returns something + ;; evaluable. + (LET ((FORM (LET ((ERRSET NIL)) + ;; this is really bad to do since + ;; it can screw the lisp programmer out + ;; of a chance to identify read errors + ;; as they happen. + (ERRSET (READ STREAM NIL) NIL)))) + (IF (OR (NULL FORM) + (ATOM (CAR FORM))) + '$MACSYMA + '$LISP)))))) + ;; Unwind protected. + (IF STREAM (CLOSE STREAM)))))) + +#+LISPM +(defun faslp (filename) + ;; wasteful to be opening file objects so many times, one for + ;; each predicate and then again to actually load. Fix that perhaps + ;; by having the predicates return "failure-objects," which can be + ;; passed on to other predicates and on to FS:FASLOAD-INTERNAL and + ;; FS:READFILE-INTERNAL. + (with-open-file (stream filename '(:read :fixnum)) + (funcall stream ':qfaslp))) + +(DEFMVAR $FILE_SEARCH + #+ITS + `((MLIST) + ,@(MAPCAR #'TO-MACSYMA-NAMESTRING + '("DSK:SHARE;" "DSK:SHARE1;" "DSK:SHARE2;" "DSK:SHAREM;"))) + #+Franz + `((mlist) + ,@(mapcar #'to-macsyma-namestring + `("." + ,(concat vaxima-main-dir "//share") + ,(concat vaxima-main-dir "//demo")))) + + #+LISPM + `((MLIST) + ,@(MAPCAR #'TO-MACSYMA-NAMESTRING + '("MC:LMMAXR;" "MC:LMMAXQ;"))) + #+Multics + '((MLIST)) + "During startup initialized to a list of places the LOAD function + should search for files." + ) + +#+Multics +(PROGN 'COMPILE +;; We need an abstract entry in this list to indicate "working_dir". +(DEFMFUN INITIATE-FILE-SEARCH-LIST () + (LET ((WHERE-AM-I (CAR (NAMELIST EXECUTABLE-DIR)))) + (SETQ + $FILE_SEARCH + `((MLIST) + ,@(mapcar #'to-macsyma-namestring + `(,(string-append (PATHNAME-UTIL "hd") ">**") + ,(string-append (NAMESTRING `(,WHERE-AM-I "share")) ">**") + ,(string-append (NAMESTRING `(,WHERE-AM-I "executable")) + ">**"))))))) + +;; These forms getting evaluated at macsyma start-up time. +(if (boundp 'macsyma-startup-queue) + (PUSH '(INITIATE-FILE-SEARCH-LIST) MACSYMA-STARTUP-QUEUE) + (setq macsyma-startup-queue '((initiate-file-search-list)))) + +;; Done for debuggings sake. +(eval-when (eval load) + (initiate-file-search-list)) + +) + +#-LISPM +(DEFMVAR $FILE_TYPES + `((MLIST) + ,@(MAPCAR #'TO-MACSYMA-NAMESTRING + #+ITS + ;; ITS filesystem. Sigh. This should be runtime conditionalization. + '("* FASL" "* TRLISP" "* LISP" "* >") + #+MULTICS + '("**" "**.lisp" "**.macsyma"))) + "The types of files that can be loaded into a macsyma automatically") +#+LISPM +(DEFMVAR $FILE_TYPES '((MLIST) "* FASL" "* TRLISP" "* LISP" "* >")) + +(defmfun mfilename-onlyp (x) + "Returns T iff the argument could only be reasonably taken as a filename." + (cond ((macsyma-namestringp x) t) + (($listp x) t) + ((symbolp x) + (= #/& (getcharn x 1))) + ('else + nil))) + diff --git a/src/maxsrc/mtrace.41 b/src/maxsrc/mtrace.41 new file mode 100644 index 00000000..c0f6ccf4 --- /dev/null +++ b/src/maxsrc/mtrace.41 @@ -0,0 +1,654 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mtrace) + +(declare (*lexpr trace-mprint) ;; forward references + (genprefix mtrace-)) + +;;; a reasonable trace capability for macsyma users. +;;; 8:10pm Saturday, 10 January 1981 -GJC. + +;; TRACE(F1,F2,...) /* traces the functions */ +;; TRACE() /* returns a list of functions under trace */ +;; UNTRACE(F1,F2,...) /* untraces the functions */ +;; UNTRACE() /* untraces all functions. */ +;; TRACE_MAX_INDENT /* The maximum indentation of trace printing. */ +;; +;; TRACE_OPTIONS(F,option1,option2,...) /* gives F options */ +;; +;; TRACE_BREAK_ARG /* Bound to list of argument during BREAK ENTER, +;; and the return value during BREAK EXIT. +;; This lets you change the arguments to a function, +;; or make a function return a different value, +;; which are both usefull debugging hacks. +;; +;; You probably want to give this a short alias +;; for typing convenience. +;; */ +;; +;; An option is either a keyword, FOO. +;; or an expression FOO(PREDICATE_FUNCTION); +;; +;; A keyword means that the option is in effect, an keyword +;; expression means to apply the predicate function to some arguments +;; to determine if the option is in effect. The argument list is always +;; [LEVEL,DIRECTION, FUNCTION, ITEM] where +;; LEVEL is the recursion level for the function. +;; DIRECTION is either ENTER or EXIT. +;; FUNCTION is the name of the function. +;; ITEM is either the argument list or the return value. +;; +;; ---------------------------------------------- +;; | Keyword | Meaning of return value | +;; ---------------------------------------------- +;; | NOPRINT | If TRUE do no printing. | +;; | BREAK | If TRUE give a breakpoint. | +;; | LISP_PRINT | If TRUE use lisp printing. | +;; | INFO | Extra info to print | +;; | ERRORCATCH | If TRUE errors are caught. | +;; ---------------------------------------------- +;; +;; General interface functions. These would be called by user debugging utilities. +;; +;; TRACE_IT('F) /* Trace the function named F */ +;; TRACE /* list of functions presently traced. */ +;; UNTRACE_IT('F) /* Untrace the function named F */ +;; GET('F,'TRACE_OPTIONS) /* Access the trace options of F */ +;; +;; Sophisticated feature: +;; TRACE_SAFETY a variable with default value TRUE. +;; Example: F(X):=X; BREAKP([L]):=(PRINT("Hi!",L),FALSE), +;; TRACE(F,BREAKP); TRACE_OPTIONS(F,BREAK(BREAKP)); +;; F(X); Note that even though BREAKP is traced, and it is called, +;; it does not print out as if it were traced. If you set +;; TRACE_SAFETY:FALSE; then F(X); will cause a normal trace-printing +;; for BREAKP. However, then consider TRACE_OPTIONS(BREAKP,BREAK(BREAKP)); +;; When TRACE_SAFETY:FALSE; F(X); will give an infinite recursion, +;; which it would not if safety were turned on. +;; [Just thinking about this gives me a headache.] + +;;; Structures. + +(defmacro trace-p (x) `(mget ,x 'trace)) +(defmacro trace-type (x) `(mget ,x 'trace-type)) +(defmacro trace-level (x) `(mget ,x 'trace-level)) +(defmacro trace-options (x) `($get ,x '$trace_options)) + +;;; User interface functions. + +(defmvar $trace (list '(mlist)) "List of functions actively traced") +(putprop '$trace #'read-only-assign 'assign) + +(defun mlistcan-$all (fun list default) + "totally random utility function" + (if (null list) default + `((mlist) ,@(mapcan fun + (if (memq (car list) '($all $functions)) + (mapcar #'caar (cdr $functions)) + list))))) + +(defmspec $trace (form) + (mlistcan-$all #'macsyma-trace (cdr form) $trace)) + +(defmfun $trace_it (function) `((mlist),@(macsyma-trace function))) + + +(defmspec $untrace (form) + `((mlist) ,@(mapcan #'macsyma-untrace (or (cdr form) + (cdr $trace))))) + +(defmfun $untrace_it (function) `((mlist) ,@(macsyma-untrace function))) + +(defmspec $trace_options (form) + (setf (trace-options (cadr form)) + `((mlist) ,@(cddr form)))) + + + +;;; System interface functions. + +(defvar hard-to-trace '(trace-handler listify args setplist + trace-apply + *apply mapply)) + + +;; A list of functions called by the TRACE-HANDLEr at times when +;; it cannot possibly shield itself from a continuation which would +;; cause infinite recursion. We are assuming the best-case of +;; compile code. + +(defun macsyma-trace (fun) (macsyma-trace-sub fun 'trace-handler $trace)) + +(defun macsyma-trace-sub (fun handler ilist &aux temp) + (cond ((not (symbolp fun)) + (mtell "~%Bad arg to TRACE: ~M" fun) + nil) + ((trace-p fun) + ;; Things which redefine should be expected to reset this + ;; to NIL. + (mtell "~%~@:M is already traced." fun) + nil) + ((memq fun hard-to-trace) + (mtell + "~%The function ~:@M cannot be traced because: ASK GJC~%" + fun) + nil) + ((null (setq temp (macsyma-fsymeval fun))) + (mtell "~%~@:M has no functional properties." fun) + nil) + ((memq (car temp) '(mmacro translated-mmacro)) + (mtell "~%~@:M is a macro, won't trace well, so use ~ + the MACROEXPAND function to debug it." fun) + nil) + ((get (car temp) 'shadow) + (put-trace-info fun (car temp) ilist) + (trace-fshadow fun (car temp) + (make-trace-hook fun (car temp) handler)) + (list fun)) + (t + (mtell "~%~@:M has functional properties not understood by TRACE" + fun) + nil))) + +(defvar trace-handling-stack ()) + +(defun macsyma-untrace (fun) (macsyma-untrace-sub fun 'trace-handler $trace)) + +(defun macsyma-untrace-sub (fun handler ilist) + (prog1 + (cond ((not (symbolp fun)) + (mtell "~%Bad arg to UNTRACE: ~M" fun) + nil) + ((not (trace-p fun)) + (mtell "~%~:@M is not traced." fun) + nil) + (t + (trace-unfshadow fun (trace-type fun)) + (rem-trace-info fun ilist) + (list fun))) + (if (memq fun trace-handling-stack) + ;; yes, he has re-defined or untraced the function + ;; during the trace-handling application. + ;; This is not strange, in fact it happens all the + ;; time when the user is using the $ERRORCATCH option! + (macsyma-trace-sub fun handler ilist)))) + +(defun put-trace-info (fun type ilist) + (setf (trace-p fun) fun) ; needed for MEVAL at this time also. + (setf (trace-type fun) type) + (LET ((SYM (GENSYM))) + (SET SYM 0) + (setf (trace-level fun) SYM)) + (push fun (cdr ilist)) + (list fun)) + +(defun rem-trace-info (fun ilist) + (setf (trace-p fun) nil) + (or (memq fun trace-handling-stack) + (setf (trace-level fun) nil)) + (setf (trace-type fun) nil) + (delq fun ilist) + (list fun)) + + +;; Placing the TRACE functional hook. +;; Because the function properties in macsyma are used by the EDITOR, SAVE, +;; and GRIND commands it is not possible to simply replace the function +;; being traced with a hook and to store the old definition someplace. +;; [We do know how to cons up machine-code hooks on the fly, so that +;; is not stopping us]. + + +;; This data should be formalized somehow at the time of +;; definition of the DEFining form. + +(defprop subr expr shadow) +(defprop lsubr expr shadow) +(defprop expr expr shadow) +(defprop mfexpr*s mfexpr* shadow) +(defprop mfexpr* mfexpr* shadow) +(defprop fsubr fexpr shadow) +(defprop fexpr fexpr shadow) + +#-Multics +(progn +;; too slow to snap links on multics. +(defprop subr t uuolinks) +(defprop lsubr t uuolinks) +(defprop fsubr t uuolinks) ; believe it or not. +) + +(defprop mexpr t mget) +(defprop mexpr expr shadow) + +(defun get! (x y) + (or (get x y) + (get! (error (list "Undefined" y "property") x 'wrng-type-arg) + y))) + +(defun trace-fshadow (fun type value) + ;; the value is defined to be a lisp functional object, which + ;; might have to be compiled to be placed in certain locations. + (if (get type 'uuolinks) + (sstatus uuolinks)) + (let ((shadow (get! type 'shadow))) + (setplist fun (list* shadow value (plist fun))))) + +(defun trace-unfshadow (fun type) + ;; what a hack. + (remprop fun (get! type 'shadow))) + +(defun trace-fsymeval (fun) + (or + (let ((type-of (trace-type fun))) + (if (get type-of 'mget) + (if (eq (get! type-of 'shadow) type-of) + (mget (cdr (mgetl fun (list type-of))) type-of) + (mget fun type-of)) + (if (eq (get! type-of 'shadow) type-of) + (get (cdr (getl fun (list type-of))) type-of) + (get fun type-of)))) + (trace-fsymeval + (merror "Macsyma BUG: Trace property for ~:@M went away without hook." + fun)))) + + +;;; The handling of a traced call. + +(defvar trace-indent-level -1) + +(defmacro bind-sym (symbol value . body) + #-Multics + ;; is by far the best dynamic binding generally available. + `(progv (list ,symbol) + (list ,value) + ,@body) + #+Multics ; PROGV is wedged on multics. + `(let ((the-symbol ,symbol) + (the-value ,value)) + (let ((old-value (symeval the-symbol))) + (unwind-protect + (progn (set the-symbol the-value) + ,@body) + (set the-symbol old-value))))) + +;; We really want to (BINDF (TRACE-LEVEL FUN) (1+ (TRACE-LEVEL FUN)) ...) +;; (Think about PROGV and SETF and BINDF. If the trace object where +;; a closure, then we want to fluid bind instance variables.) + +;; From JPG;SUPRV +;;(DEFMFUN $ERRCATCH FEXPR (L) +;; (LET ((ERRCATCH (CONS BINDLIST LOCLIST)) RET) +;; (IF (NULL (SETQ RET (ERRSET (MEVALN L) LISPERRPRINT))) +;; (ERRLFUN1 ERRCATCH)) +;; (CONS '(MLIST) RET))) +;; ERRLFUN1 does the UNBINDING. +;; As soon as error handlers are written and signalling is +;; implemented, use the correct thing and get rid of this macro. + +(declare (special errcatch lisperrprint bindlist loclist) + (*expr errlfun1)) + +(defmacro macsyma-errset (form &aux (ret (gensym))) + `(let ((errcatch (cons bindlist loclist)) ,ret) + (setq ,ret (errset ,form lisperrprint)) + (or ,ret (errlfun1 errcatch)) + ,ret)) + +(defvar predicate-arglist nil) + +(defvar return-to-trace-handle nil) + +(defun trace-handler (fun largs) + (If return-to-trace-handle + ;; we were called by the trace-handler. + (trace-apply fun largs) + (let ((trace-indent-level (1+ trace-indent-level)) + (return-to-trace-handle t) + (trace-handling-stack (cons fun trace-handling-stack)) + (LEVEL-SYM (TRACE-LEVEL fun))(LEVEL)) + (SETQ LEVEL (1+ (SYMEVAL LEVEL-SYM))) + (BIND-SYM + LEVEL-SYM + LEVEL + (do ((ret-val)(continuation)(predicate-arglist))(nil) + (setq predicate-arglist `(,level $enter ,fun ((mlist) ,@largs))) + (setq largs (trace-enter-break fun level largs)) + (trace-enter-print fun level largs) + (cond ((trace-option-p fun '$errorcatch) + (setq ret-val (macsyma-errset (trace-apply fun largs))) + (cond ((null ret-val) + (setq ret-val (trace-error-break fun level largs)) + (setq continuation (car ret-val) + ret-val (cdr ret-val))) + (t + (setq continuation 'exit + ret-val (car ret-val))))) + (t + (setq continuation 'exit + ret-val (trace-apply fun largs)))) + (caseq continuation + ((exit) + (setq predicate-arglist `(,level $exit ,fun ,ret-val)) + (setq ret-val (trace-exit-break fun level ret-val)) + (trace-exit-print fun level ret-val) + (return ret-val)) + ((retry) + (setq largs ret-val) + (MTELL "~%Re applying the function ~:@M~%" fun)) + ((error) + (MERROR "~%Signaling error for function ~:@M~%" fun)))))))) + + +;; The (Trace-options function) access is not optimized to take place +;; only once per trace-handle call. This is so that the user may change +;; options during his break loops. +;; Question: Should we bind return-to-trace-handle to NIL when we +;; call the user's predicate? He has control over his own lossage. + +(defmvar $trace_safety t "This is subtle") + +(defun trace-option-p (function KEYWORD) + (do ((options + (LET ((OPTIONS (TRACE-OPTIONS FUNCTION))) + (COND ((NULL OPTIONS) NIL) + (($LISTP OPTIONS) (CDR OPTIONS)) + (T + (mtell "Trace options for ~:@M not a list, so ignored." + function) + NIL))) + (CDR OPTIONS)) + (OPTION)) + ((null options) nil) + (setq OPTION (CAR OPTIONS)) + (cond ((atom option) + (if (eq option keyword) (return t))) + ((eq (caar option) keyword) + (let ((return-to-trace-handle $trace_safety)) + (return (mapply (cadr option) predicate-arglist + "&A trace option predicate"))))))) + + +(defun trace-enter-print (fun lev largs &aux (mlargs `((mlist) ,@largs))) + (if (not (trace-option-p fun '$noprint)) + (let ((info (trace-option-p fun '$info))) + (cond ((trace-option-p fun '$lisp_print) + (trace-print `(,lev enter ,fun ,largs ,@info))) + (t + (trace-mprint lev " Enter " (mopstringnam fun) " " mlargs + (if info " -> " "") + (if info info ""))))))) + +(defun mopstringnam (x) (maknam (mstring (getop x)))) + +(defun trace-exit-print (fun lev ret-val) + (if (not (trace-option-p fun '$noprint)) + (let ((info (trace-option-p fun '$info))) + (cond ((trace-option-p fun '$lisp_print) + (trace-print `(,lev exit ,fun ,ret-val ,@info))) + (t + (trace-mprint lev " Exit " (mopstringnam fun) " " ret-val + (if info " -> " "") + (if info info ""))))))) + +(defmvar $trace_break_arg '$TRACE_BREAK_ARG + "During trace Breakpoints bound to the argument list or return value") + +(defun trace-enter-break (fun lev largs) + (if (trace-option-p fun '$break) + (do ((return-to-trace-handle nil) + ($trace_break_arg `((mlist) ,@largs)))(nil) + ($break '|&Trace entering| fun '|&level| lev) + (cond (($listp $trace_break_arg) + (return (cdr $trace_break_arg))) + (t + (mtell "~%Trace_break_arg set to nonlist, ~ + please try again")))) + largs)) + +(defun trace-exit-break (fun lev ret-val) + (if (trace-option-p fun '$break) + (let (($trace_break_arg ret-val) + (return-to-trace-handle nil)) + ($break '|&Trace exiting| fun '|&level| lev) + $trace_break_arg) + ret-val)) + +(defun pred-$read (predicate argl bad-message) + (do ((ans))(nil) + (setq ans (apply #'$read argl)) + (if (funcall predicate ans) (return ans)) + (mtell "~%Unacceptable input, ~A~%" bad-message))) + +(declare (special upper)) + +(defun ask-choicep (list &rest header-message) + (do ((j 0 (1+ j)) + (dlist nil + (list* "î" `((marrow) ,j ,(car ilist)) dlist)) + (ilist list (cdr ilist))) + ((null ilist) + (setq dlist (nconc header-message (cons "î" (nreverse dlist)))) + (let ((upper (1- j))) + (pred-$read #'(lambda (val) + (and (fixp val) + (>= val 0) + (<= val upper))) + dlist + "please reply with an integer from the menue."))))) + +(declare (unspecial upper)) + +(defun trace-error-break (fun level largs) + (caseq (ask-choicep '("Signal an error, i.e. PUNT?" + "Retry with same arguments?" + "Retry with new arguments?" + "Exit with user supplied value") + "Error during application of" (mopstringnam fun) + "at level" level + "î" "Do you want to:") + ((0) + '(error)) + ((1) + (cons 'retry largs)) + ((2) + (cons 'retry (let (($trace_break_arg `((mlist) ,largs))) + (cdr (pred-$read '$listp + (list + "Enter new argument list for" + (mopstringnam fun)) + "please enter a list."))))) + + ((3) + (cons 'exit ($read "Enter value to return"))))) + + +;;; application dispatch, and the consing up of the trace hook. + +(defun macsyma-fsymeval (fun) + (let ((try (macsyma-fsymeval-sub fun))) + (cond (try try) + ((get fun 'autoload) + (load-and-tell (get fun 'autoload)) + (setq try (macsyma-fsymeval-sub fun)) + (or try + (mtell "~%~:@M has no functional~ + properties after autoloading.~%" + fun)) + try) + (t try)))) + +(defun macsyma-fsymeval-sub (fun) + ;; The semantics of $TRANSRUN are herein taken from DESCRIBE, + ;; a carefull reading of MEVAL1 reveals, well... I've promised to watch + ;; my language in these comments. + + (let ((mprops (mgetl fun '(mexpr mmacro))) + (lprops (getl fun '(subr lsubr expr fexpr macro fsubr + translated-mmacro mfexpr* mfexpr*s)))) + (cond ($TRANSRUN + ;; the default, so its really a waste to have looked for + ;; those mprops. Its better to fix the crock than to + ;; optimize this though! + (or lprops mprops)) + (t + (or mprops lprops))))) + +(Defprop EXPR EXPR HOOK-TYPE) +(DEFPROP MEXPR EXPR HOOK-TYPE) +(Defprop SUBR EXPR HOOK-TYPE) +(Defprop LSUBR EXPR HOOK-TYPE) +(Defprop FEXPR FEXPR HOOK-TYPE) +(Defprop FSUBR FEXPR HOOK-TYPE) +(Defprop MFEXPR* MACRO HOOK-TYPE) +(Defprop MFEXPR*S MACRO HOOK-TYPE) + +(defun make-trace-hook (fun type handler) + (CASEQ (GET! TYPE 'HOOK-TYPE) + ((EXPR) + `(lambda trace-nargs + (,handler ',fun (listify trace-nargs)))) + ((FEXPR) + `(LAMBDA (TRACE-ARGL) + (,HANDLER ',FUN TRACE-ARGL))) + ((MACRO) + `(lambda (TRACE-FORM) + (,HANDLER (CAAR TRACE-FORM) (LIST TRACE-FORM)))))) + + +(defun trace-apply (fun largs) + (let ((prop (trace-fsymeval fun)) + (type (trace-type fun)) + (return-to-trace-handle nil)) + (caseq type + ((mexpr) + (mapply prop largs "&A traced function")) + ((expr) + (apply prop largs)) + ((subr lsubr) + ;; no need to be fast here. + (args 'the-trace-apply-hack (args fun)) + (setplist 'the-trace-apply-hack (list type prop)) + (apply 'the-trace-apply-hack largs)) + ((MFEXPR*) + (FUNCALL PROP (CAR LARGS))) + ((MFEXPR*S) + (SUBRCALL NIL PROP (CAR LARGS))) + ((FEXPR) + (FUNCALL PROP LARGS)) + ((FSUBR) + (SUBRCALL NIL PROP LARGS))))) + +;;; I/O cruft + +(defmvar $trace_max_indent 15. "max number of spaces it will go right" + FIXNUM) +(putprop '$trace_max_indent #'assign-mode-check 'assign) +(putprop '$trace_max_indent '$fixnum 'mode) + +(defun (spaceout dimension) (form result) + (dimension-string (*make-list (cadr form) #\sp) result)) + +(defun trace-mprint (&rest l) + (mtell-open "~M" + `((mtext) + ((spaceout) ,(min $trace_max_indent trace-indent-level)) + ,@l))) + +(defun trace-print (form) + (terpri) + (do ((j (min $trace_max_indent trace-indent-level) + (1- j))) + ((not (> j 0))) + (tyo #\sp)) + (if prin1 (funcall prin1 form) + (prin1 form)) + (tyo #\sp)) + + +;; 9:02pm Monday, 18 May 1981 -GJC +;; A function benchmark facility using trace utilities. +;; This provides medium accuracy, enough for most user needs. + +(DEFMVAR $TIMER '((MLIST)) "List of functions under active timetrace") +(PUTPROP '$TIMER #'READ-ONLY-ASSIGN 'ASSIGN) + +(DEFMSPEC $TIMER (FORM) + (MLISTCAN-$ALL #'macsyma-timer (cdr form) $timer)) + +(DEFMSPEC $UNTIMER (FORM) + `((MLIST) ,@(MAPCAN #'MACSYMA-UNTIMER (OR (CDR FORM) + (CDR $TIMER))))) + +(DEFUN MICRO-TO-SEC (RUNTIME) + (MUL RUNTIME 1.0E-6 '$SEC)) +(DEFUN MICRO-PER-CALL-TO-SEC (RUNTIME CALLS) + (DIV (MICRO-TO-SEC RUNTIME) + (IF (ZEROP CALLS) 1 CALLS))) + +(DEFUN TIMER-MLIST (FUNCTION CALLS RUNTIME GCTIME) + `((MLIST SIMP) ,FUNCTION + ,(MICRO-PER-CALL-TO-SEC (PLUS RUNTIME GCTIME) CALLS) + ,CALLS + ,(MICRO-TO-SEC RUNTIME) + ,(MICRO-TO-SEC GCTIME))) + +(DEFMSPEC $TIMER_INFO (FORM) + (DO ((L (OR (CDR FORM) (CDR $TIMER)) + (CDR L)) + (V NIL) + (TOTAL-RUNTIME 0) + (TOTAL-GCTIME 0) + (TOTAL-CALLS 0)) + ((NULL L) + `(($matrix simp) + ((MLIST SIMP) $FUNCTION $TIME//CALL $CALLS $RUNTIME $GCTIME) + ,.(NREVERSE V) + ,(TIMER-MLIST '$TOTAL TOTAL-CALLS TOTAL-RUNTIME TOTAL-GCTIME))) + (LET ((RUNTIME ($GET (CAR L) '$RUNTIME)) + (GCTIME ($GET (CAR L) '$GCTIME)) + (CALLS ($GET (CAR L) '$CALLS))) + (WHEN RUNTIME + (SETQ TOTAL-CALLS (PLUS CALLS TOTAL-CALLS)) + (SETQ TOTAL-RUNTIME (PLUS RUNTIME TOTAL-RUNTIME)) + (SETQ TOTAL-GCTIME (PLUS GCTIME TOTAL-GCTIME)) + (PUSH (TIMER-MLIST (CAR L) CALLS RUNTIME GCTIME) V))))) + +(DEFUN macsyma-timer (fun) + (PROG1 (macsyma-trace-sub fun 'timer-handler $timer) + ($PUT FUN 0 '$RUNTIME) + ($PUT FUN 0 '$GCTIME) + ($PUT FUN 0 '$CALLS) + )) + +(defun macsyma-untimer (fun) (macsyma-untrace-sub fun 'timer-handler $timer)) + +(DEFVAR RUNTIME-DEVALUE 0) +(DEFVAR GCTIME-DEVALUE 0) + +(DEFMVAR $TIMER_DEVALUE NIL + "If true, then time spent inside calls to other timed functions is + subtracted from the timing figure for a function.") + +(DEFUN TIMER-HANDLER (FUN LARGS) + ;; N.B. Doesn't even try to account for use of DYNAMIC CONTROL + ;; such as ERRSET ERROR and CATCH and THROW, as these are + ;; rare and the overhead for the unwind-protect is high. + (LET ((RUNTIME (RUNTIME)) + (GCTIME (STATUS GCTIME)) + (OLD-RUNTIME-DEVALUE RUNTIME-DEVALUE) + (OLD-GCTIME-DEVALUE GCTIME-DEVALUE)) + (PROG1 (TRACE-APPLY FUN LARGS) + (SETQ OLD-RUNTIME-DEVALUE (- RUNTIME-DEVALUE OLD-RUNTIME-DEVALUE)) + (SETQ OLD-GCTIME-DEVALUE (- GCTIME-DEVALUE OLD-GCTIME-DEVALUE)) + (SETQ RUNTIME (- (RUNTIME) RUNTIME OLD-RUNTIME-DEVALUE)) + (SETQ GCTIME (- (STATUS GCTIME) GCTIME OLD-GCTIME-DEVALUE)) + (WHEN $TIMER_DEVALUE + (SETQ RUNTIME-DEVALUE (+ RUNTIME-DEVALUE RUNTIME)) + (SETQ GCTIME-DEVALUE (+ GCTIME-DEVALUE GCTIME))) + ($PUT FUN (+ ($GET FUN '$RUNTIME) RUNTIME) '$RUNTIME) + ($PUT FUN (+ ($GET FUN '$GCTIME) GCTIME) '$GCTIME) + ($PUT FUN (1+ ($GET FUN '$CALLS)) '$CALLS)))) + \ No newline at end of file diff --git a/src/maxsrc/mtree.1 b/src/maxsrc/mtree.1 new file mode 100644 index 00000000..a8431c33 --- /dev/null +++ b/src/maxsrc/mtree.1 @@ -0,0 +1,86 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mtree) + + +;;; A general macsyma tree walker. + +;;; It is cleaner to have the flags and handlers passed as arguments +;;; to the function instead of having them be special variables. +;;; In maclisp this also happens to win big, because the arguments +;;; merely stay in registers. + + +(DEFMFUN MTREE-SUBST (FORM CAR-FLAG MOP-FLAG SUBST-ER) + (COND ((ATOM FORM) + (SUBRCALL NIL SUBST-ER FORM MOP-FLAG)) + (CAR-FLAG + (COND (($RATP FORM) + (LET* ((DISREP ($RATDISREP FORM)) + (SUB (MTREE-SUBST DISREP T MOP-FLAG SUBST-ER))) + (COND ((EQ DISREP SUB) FORM) + (T ($RAT SUB))))) + ((ATOM (CAR FORM)) + (MERROR "Illegal expression being walked.")) + (T + (LET ((CDR-VALUE (MTREE-SUBST (CDR FORM) + NIL MOP-FLAG SUBST-ER)) + (CAAR-VALUE (MTREE-SUBST (CAAR FORM) + T T SUBST-ER))) + (COND ((AND (EQ CDR-VALUE (CDR FORM)) + (EQ (CAAR FORM) CAAR-VALUE)) + FORM) + ; cannonicalize the operator. + ((AND (LEGAL-LAMBDA CAAR-VALUE) + $SUBLIS_APPLY_LAMBDA) + `((,CAAR-VALUE + ,@(COND ((MEMQ 'ARRAY (CAR FORM)) '(ARRAY)) + (T NIL))) + ,@CDR-VALUE)) + (T + `((MQAPPLY + ,@(COND ((MEMQ 'ARRAY (CAR FORM)) '(ARRAY)) + (T NIL))) + ,CAAR-VALUE + ,@CDR-VALUE))))))) + (T + (LET ((CAR-VALUE (MTREE-SUBST (CAR FORM) T MOP-FLAG SUBST-ER)) + (CDR-VALUE (MTREE-SUBST (CDR FORM) NIL MOP-FLAG SUBST-ER))) + (COND ((AND (EQ (CAR FORM) CAR-VALUE) + (EQ (CDR FORM) CDR-VALUE)) + FORM) + (T + (CONS CAR-VALUE CDR-VALUE))))))) + +(DEFUN LEGAL-LAMBDA (X) + (COND ((ATOM X) NIL) + ((ATOM (CAR X)) + (EQ (CAR X) 'LAMBDA)) + (T + (EQ (CAAR X) 'LAMBDA)))) + +(DEF-PROCEDURE-PROPERTY + $APPLY_NOUNS + (LAMBDA (ATOM MOP-FLAG) + (COND (MOP-FLAG + (LET ((TEMP (GET ATOM '$APPLY_NOUNS))) + (COND (TEMP TEMP) + ((SETQ TEMP (GET ATOM 'NOUN)) + ; the reason I do this instead of + ; applying it now is that the simplifier + ; has to walk the tree anyway, and this + ; way we avoid funargiez. + (PUTPROP ATOM + `((LAMBDA) ((MLIST) ((MLIST) L)) + (($APPLY) ((MQUOTE) ,TEMP) + L)) + '$APPLY_NOUNS)) + (T ATOM)))) + (T ATOM))) + FOOBAR) + +(DEFMFUN $APPLY_NOUNS (EXP) + (LET (($SUBLIS_APPLY_LAMBDA T)) + (MTREE-SUBST EXP T NIL (GET '$APPLY_NOUNS 'FOOBAR)))) diff --git a/src/maxsrc/mutils.11 b/src/maxsrc/mutils.11 new file mode 100644 index 00000000..36718c0b --- /dev/null +++ b/src/maxsrc/mutils.11 @@ -0,0 +1,57 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module mutils) + +;;; General purpose Macsyma utilities. This file contains runtime functions +;;; which perform operations on Macsyma functions or data, but which are +;;; too general for placement in a particular file. +;;; +;;; Every function in this file is known about externally. + + + +;;; (ASSOL item A-list) +;;; +;;; Like ASSOC, but uses ALIKE1 as the comparison predicate rather +;;; than EQUAL. +;;; +;;; Meta-Synonym: (ASS #'ALIKE1 ITEM ALIST) + +(DEFMFUN ASSOL (ITEM ALIST) + (DOLIST (PAIR ALIST) + (IF (ALIKE1 ITEM (CAR PAIR)) (RETURN PAIR)))) +;;; + +(DEFMFUN ASSOLIKE (ITEM ALIST) + (CDR (ASSOL ITEM ALIST))) + +; Old ASSOLIKE definition: +; +; (defun assolike (e l) +; (prog nil +; loop (cond ((null l) (return nil)) +; ((alike1 e (caar l)) (return (cdar l)))) +; (setq l (cdr l)) +; (go loop))) + +;;; (MEM #'ALIKE1 X L) + +(DEFMFUN MEMALIKE (X L) + (DO L L (CDR L) (NULL L) + (COND ((ALIKE1 X (CAR L)) (RETURN L))))) + +;;;Do we want MACROS for these on MC and on Multics?? -Jim 1/29/81 +#+Multics +(PROGN 'COMPILE + (DEFMFUN MSTRINGP (X) + (AND (SYMBOLP X) + (EQUAL (GETCHARN X 1) #/&))) + + (DEFMFUN MSTRING-TO-STRING (X) + (SUBSTRING (STRING X) 1)) + + (DEFMFUN STRING-TO-MSTRING (X) + (MAKE-SYMBOL (STRING-APPEND "&" X))) +) diff --git a/src/maxsrc/ndiffq.5 b/src/maxsrc/ndiffq.5 new file mode 100644 index 00000000..f0c06508 --- /dev/null +++ b/src/maxsrc/ndiffq.5 @@ -0,0 +1,199 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1981 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module ndiffq) + +(load-macsyma-macros numerm) + +;;; Some numerical differential equation routines. + +(defmfun $init_float_array (array x0 x1 &aux + (a (get-array array '(flonum) 1))) + (setq x0 (float x0) + x1 (float x1)) + (let ((n (array-dimension-n 1 a))) + (do ((j 0 (1+ j)) + (h (//$ (-$ x1 x0) (float (1- n)))) + (x x0 (+$ x h))) + ((= j n) array) + (setf (aref$ a j) x)))) + +(defmfun $map_float_array (ya f xa) + (let* ((y (get-array ya '(flonum) 1)) + (n (array-dimension-n 1 y)) + (x (get-array xa '(flonum) 1 n))) + (bind-tramp1$ + f f + (do ((j 0 (1+ j))) + ((= j n) ya) + (setf (aref$ y j) (fcall$ f (aref$ x j))))))) + +;;; Runge-Kutta method for getting starting values. + +(defvar runge-^]-int nil) +(defun runge-^]-int () (setq runge-^]-int t)) + +(defun $runge_kutta (f x y &rest higher-order) + (let ((runge-^]-int nil) + (USER-TIMESOFAR (CONS #'runge-^]-int USER-TIMESOFAR))) + (if ($listp f) + (if higher-order + (merror "Runge_Kutta handles systems of order 1 only.") + (let* ((fl (mapcar #'(lambda (f) (make-gtramp$ f 2)) (cdr f))) + (xa (get-array x '(flonum) 1)) + (n (array-dimension-n 1 xa))) + (if (and ($listp y) + (= (length fl) (length (cdr y)))) + (runge-kutta-1-n fl xa + (mapcar #'(lambda (y) + (get-array y '(flonum) 1 n)) + (cdr y))) + (merror "Not a list of length ~M~%~M" (length fl) y)))) + (let* ((xa (get-array x '(flonum) 1)) + (n (array-dimension-n 1 xa)) + (ya (get-array y '(flonum) 1 n))) + (caseq (length higher-order) + ((0) + (bind-tramp2$ + f f + (runge-kutta-1 f xa ya))) + ((1) + (bind-tramp3$ + f f + (runge-kutta-2 f xa ya + (get-array (car higher-order) '(flonum) 1 n)))) + (t + (merror "Runge_Kutta of order greater than 2 is unimplemented")))))) + ;; return value to user. + y) + +(defvar one-half$ (//$ 1.0 2.0)) +(defvar one-third$ (//$ 1.0 3.0)) +(defvar one-sixth$ (//$ 1.0 6.0)) +(defvar one-eighth$ (//$ 1.0 8.0)) + +(DEFVAR RUNGE-KUTTA-1 NIL) + +(defun runge-kutta-1 (f x y) + (do ((m-1 (1- (array-dimension-n 1 x))) + (n 0 (1+ n)) + (x_n)(y_n)(h)(k1)(k2)(k3)(k4)) + ((= n m-1)) + (declare (fixnum n-1 n) + (flonum x_n y_n h k1 k2 k3 k4)) + (setq x_n (aref$ x n)) + (setq y_n (aref$ y n)) + (WHEN RUNGE-^]-INT + (SETQ RUNGE-^]-INT NIL) + (MTELL "~A steps, calculating F(~A,~A)" N X_N Y_N)) + (setq h (-$ (aref$ x (1+ n)) x_n)) + ;; Formula 25.5.10 pp 896 of Abramowitz & Stegun. + (setq k1 (*$ h (fcall$ f x_n y_n))) + (setq k2 (*$ h (fcall$ f + (+$ x_n (*$ one-half$ h)) + (+$ y_n (*$ one-half$ k1))))) + (setq k3 (*$ h (fcall$ f + (+$ x_n (*$ one-half$ h)) + (+$ y_n (*$ one-half$ k2))))) + (setq k4 (*$ h (fcall$ f + (+$ x_n h) + (+$ y_n k3)))) + (setf (aref$ y (1+ n)) + (+$ y_n (*$ one-sixth$ (+$ k1 k4)) + (*$ one-third$ (+$ k2 k3)))))) + +(defun runge-kutta-2 (f x y y-p) + (do ((m-1 (1- (array-dimension-n 1 x))) + (n 0 (1+ n)) + (x_n)(y_n)(y-p_n)(h)(k1)(k2)(k3)(k4)) + ((= n m-1)) + (declare (fixnum m-1 n) + (flonum x_n y_n y-p_n h k1 k2 k3 k4)) + (setq x_n (aref$ x n)) + (setq y_n (aref$ y n)) + (setq y-p_n (aref$ y-p n)) + (WHEN RUNGE-^]-INT + (SETQ RUNGE-^]-INT NIL) + (MTELL "~A steps, calculating F(~A,~A,~A)" N X_N Y_N Y-P_N)) + (setq h (-$ (aref$ x (1+ n)) x_n)) + ;; Formula 25.5.20 pp 897 of Abramowitz & Stegun. + (setq k1 (*$ h (fcall$ f x_n y_n y-p_n))) + (setq k2 (*$ h (fcall$ f + (+$ x_n (*$ one-half$ h)) + (+$ y_n (*$ one-half$ h y-p_n) + (*$ one-eighth$ h k1)) + (+$ y-p_n (*$ one-half$ k1))))) + (setq k3 (*$ h (fcall$ f + (+$ x_n (*$ one-half$ h)) + (+$ y_n (*$ one-half$ h y-p_n) + (*$ one-eighth$ h k1)) + (+$ y-p_n (*$ one-half$ k2))))) + (setq k4 (*$ h (fcall$ f + (+$ x_n h) + (+$ y_n (*$ h y-p_n) + (*$ one-half$ h k3)) + (+$ y-p_n k3)))) + (setf (aref$ y (1+ n)) + (+$ y_n (*$ h (+$ y-p_n (*$ one-sixth$ (+$ k1 k2 k3)))))) + (setf (aref$ y-p (1+ n)) + (+$ y-p_n (+$ (*$ one-third$ (+$ k2 k3)) + (*$ one-sixth$ (+$ k1 k4))))))) + +(defun runge-kutta-1-n (fl x yl + &aux + (m (array-dimension-n 1 x)) + (d (length fl))) + (do ((m-1 (1- m)) + (n 0 (1+ n)) + (h) + (x_n) + (y_n (make-array$ d)) + (K1 (make-array$ d)) + (K2 (make-array$ d)) + (K3 (make-array$ d)) + (K4 (make-array$ d)) + (ACC (make-array$ d))) + ((= n m-1) + (free-array$ y_n) + (free-array$ k1) + (free-array$ k2) + (free-array$ k3) + (free-array$ k4) + (free-array$ acc) + nil) + (declare (fixnum m-1 n) (flonum x_n h)) + (setq x_n (aref$ x n)) + (when (= n 0) + (do ((l yl (cdr l)) + (j 0 (1+ j))) + ((null l)) + (setf (aref$ y_n j) (aref$ (car l) n)))) + (WHEN RUNGE-^]-INT + (SETQ RUNGE-^]-INT NIL) + (MTELL "~A steps, calculating ~M" n + `(($F) ,x_n ,@(listarray y_n)))) + (setq h (-$ (aref$ x (1+ n)) x_n)) + (gvapply$-x-ar$ k1 fl x_n y_n) + (ar$*s k1 k1 h) + (ar$*s acc k1 one-half$) + (ar$+ar$ acc acc y_n) + (gvapply$-x-ar$ k2 fl (+$ x_n (*$ h one-half$)) acc) + (ar$*s k2 k2 h) + (ar$*s acc k2 one-half$) + (ar$+ar$ acc acc y_n) + (gvapply$-x-ar$ k3 fl (+$ x_n (*$ h one-half$)) acc) + (ar$*s k3 k3 h) + (ar$+ar$ acc k3 y_n) + (gvapply$-x-ar$ k4 fl (+$ x_n h) acc) + (ar$*s k4 k4 h) + (ar$+ar$ k1 k1 k4) + (ar$*s k1 k1 one-sixth$) + (ar$+ar$ k2 k2 k3) + (ar$*s k2 k2 one-third$) + (ar$+ar$ y_n y_n k1) + (ar$+ar$ y_n y_n k2) + (do ((l yl (cdr l)) + (j 0 (1+ j))) + ((null l)) + (setf (aref$ (car l) (1+ n)) (aref$ y_n j))))) diff --git a/src/maxsrc/numer.17 b/src/maxsrc/numer.17 new file mode 100644 index 00000000..08102c42 --- /dev/null +++ b/src/maxsrc/numer.17 @@ -0,0 +1,276 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1982 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module numer) +(load-macsyma-macros numerm) + +;;; Interface of lisp numerical routines to macsyma. +;;; 4:34pm Thursday, 28 May 1981 - George Carrette. + +(DEFMACRO COMPATIBLE-ARRAY-TYPE? (TYPE TYPE-LIST) + #+MACLISP + `(MEMQ ,TYPE ,TYPE-LIST) + #+LISPM + (PROGN TYPE-LIST + `(EQ ,TYPE 'ART-Q)) + ) + +(DEFMFUN GET-ARRAY (X &OPTIONAL (KINDS NIL) (/#-DIMS) &REST DIMENSIONS) + "Get-Array is fairly general. + Examples: + (get-array ar '(flonum) 2 3 5) makes sure ar is a flonum array + with 2 dimensions, of 3 and 5. + (get-array ar '(fixnum) 1) gets a 1 dimensional fixnum array." + (COND ((NULL KINDS) + (CASEQ (TYPEP X) + ((ARRAY) X) + ((SYMBOL) + (OR (GET X 'ARRAY) + (AND (FBOUNDP X) + (EQ 'ARRAY (TYPEP (FSYMEVAL X))) + (FSYMEVAL X)) + (MERROR "Not a lisp array:~%~M" X))) + (T + (MERROR "Not a lisp array:~%~M" X)))) + ((NULL /#-DIMS) + (LET ((A (GET-ARRAY X))) + (COND ((COMPATIBLE-ARRAY-TYPE? (ARRAY-TYPE A) KINDS) A) + (T + (MERROR "~:M is not an array of type: ~:M" + X + `((mlist) ,@kinds)))))) + ((NULL DIMENSIONS) + (LET ((A (GET-ARRAY X KINDS))) + (COND ((= (ARRAY-/#-DIMS A) /#-DIMS) A) + (T + (MERROR "~:M does not have ~:M dimensions." X /#-DIMS))))) + ('ELSE + (LET ((A (GET-ARRAY X KINDS /#-DIMS))) + (DO ((J 1 (1+ J)) + (L DIMENSIONS (CDR L))) + ((NULL L) + A) + (OR (OR (EQ (CAR L) '*) + (= (CAR L) (ARRAY-DIMENSION-N J A))) + (MERROR "~:M does not have dimension ~:M equal to ~:M" + X + J + (CAR L)))))))) + +(DECLARE (SPECIAL %E-VAL)) + +(DEFUN MTO-FLOAT (X) + (FLOAT (IF (NUMBERP X) + X + (LET (($NUMER T) ($FLOAT T)) + (RESIMPLIFY (SUBST %E-VAL '$%E X)))))) + +;;; Trampolines for calling with numerical efficiency. + +(DEFVAR TRAMP$-ALIST ()) + +(DEFMACRO DEFTRAMP$ (NARGS) + (LET ((TRAMP$ (SYMBOLCONC 'TRAMP NARGS '$)) + #+MACLISP + (TRAMP$-S (SYMBOLCONC 'TRAMP NARGS '$-S)) + (TRAMP$-F (SYMBOLCONC 'TRAMP NARGS '$-F)) + (TRAMP$-M (SYMBOLCONC 'TRAMP NARGS '$-M)) + (L (MAKE-LIST NARGS))) + (LET ((ARG-LIST (MAPCAR #'(LAMBDA (IGNORE)(GENSYM)) L)) + #+MACLISP + (ARG-TYPE-LIST (MAPCAR #'(LAMBDA (IGNORE) 'FLONUM) L))) + `(PROGN 'COMPILE + (PUSH '(,NARGS ,TRAMP$ + #+MACLISP ,TRAMP$-S + ,TRAMP$-F ,TRAMP$-M) + TRAMP$-ALIST) + (DEFMVAR ,TRAMP$ "Contains the object to jump to if needed") + #+MACLISP + (DECLARE (FLONUM (,TRAMP$-S ,@ARG-TYPE-LIST) + (,TRAMP$-F ,@ARG-TYPE-LIST) + (,TRAMP$-M ,@ARG-TYPE-LIST))) + #+MACLISP + (DEFUN ,TRAMP$-S ,ARG-LIST + (FLOAT (SUBRCALL NIL ,TRAMP$ ,@ARG-LIST))) + (DEFUN ,TRAMP$-F ,ARG-LIST + (FLOAT (FUNCALL ,TRAMP$ ,@ARG-LIST))) + (DEFUN ,TRAMP$-M ,ARG-LIST + (FLOAT (MAPPLY ,TRAMP$ (LIST ,@ARG-LIST) ',TRAMP$))))))) + +(DEFTRAMP$ 1) +(DEFTRAMP$ 2) +(DEFTRAMP$ 3) + +(DEFMFUN MAKE-TRAMP$ (F N) + (LET ((L (ASSOC N TRAMP$-ALIST))) + (IF (NULL L) + (MERROR "BUG: No trampoline of argument length ~M" N)) + (POP L) + (LET ((TRAMP$ (POP L)) + #+MACLISP + (TRAMP$-S (POP L)) + (TRAMP$-F (POP L)) + (TRAMP$-M (POP L))) + (LET ((WHATNOT (FUNTYPEP F))) + (CASEQ (CAR WHATNOT) + ((OPERATORS) + (SET TRAMP$ F) + (GETSUBR! TRAMP$-M)) + ((MEXPR) + (SET TRAMP$ (CADR WHATNOT)) + (GETSUBR! TRAMP$-M)) + #+MACLISP + ((SUBR) + (COND ((SHIT-EQ (CADR WHATNOT) (GETSUBR! TRAMP$-S)) + ;; This depends on the fact that the lisp compiler + ;; always outputs the same first instruction for + ;; "flonum compiled" subrs. + (CADR WHATNOT)) + ('ELSE + (SET TRAMP$ (CADR WHATNOT)) + (GETSUBR! TRAMP$-S)))) + ((EXPR LSUBR) + (SET TRAMP$ (CADR WHATNOT)) + (GETSUBR! TRAMP$-F)) + (T + (MERROR "Undefined or inscrutable function~%~M" F))))))) + + +(DEFUN GETSUBR! (X) + (OR #+MACLISP(GET X 'SUBR) + #+LISPM (AND (FBOUNDP X) (FSYMEVAL X)) + (GETSUBR! (ERROR "No subr property for it!" X 'WRNG-TYPE-ARG)))) + +(DEFUN FUNTYPEP (F) + (COND ((SYMBOLP F) + (LET ((MPROPS (MGETL F '(MEXPR))) + (LPROPS #+MACLISP (GETL F '(SUBR LSUBR EXPR)) + #+LISPM (AND (FBOUNDP F) + (LIST 'EXPR (FSYMEVAL F))))) + (OR (IF $TRANSRUN + (OR LPROPS MPROPS) + (OR MPROPS LPROPS)) + (GETL F '(OPERATORS))))) + ((EQ (TYPEP F) 'LIST) + (LIST (IF (MEMQ (CAR F) '(FUNCTION LAMBDA NAMED-LAMBDA)) + 'EXPR + 'MEXPR) + F)) + ('ELSE + NIL))) + +#+MACLISP +(DEFUN SHIT-EQ (X Y) (= (EXAMINE (MAKNUM X)) (EXAMINE (MAKNUM Y)))) + +;; For some purposes we need a more general trampoline mechanism, +;; not limited by the need to use a special variable and a +;; BIND-TRAMP$ mechanism. + +;; For now, we just need the special cases F(X), and F(X,Y) for plotting, +;; and the hackish GAPPLY$-AR$ for systems of equations. + +(DEFUN MAKE-GTRAMP$ (F NARGS) + NARGS + ;; for now, ignoring the number of arguments, but we really should + ;; do this error checking. + (LET ((K (FUNTYPEP F))) + (CASEQ (CAR K) + ((OPERATORS) + (CONS 'OPERATORS F)) + #+MACLISP + ((SUBR) + (IF (SHIT-EQ (CADR K) (GETSUBR! 'TRAMP1$-S)) + (CONS 'SUBR$ (CADR K)) + (CONS 'SUBR (CADR K)))) + ((MEXPR EXPR LSUBR) + (CONS (CAR K) (CADR K))) + (T + (MERROR "Undefined or inscrutable function~%~M" F))))) + +(DEFUN GCALL1$ (F X) + (CASEQ (CAR F) + #+MACLISP + ((SUBR$) + (SUBRCALL FLONUM (CDR F) X)) + #+MACLISP + ((SUBR) + (FLOAT (SUBRCALL NIL (CDR F) X))) + #+MACLISP + ((LSUBR) + (FLOAT (LSUBRCALL NIL (CDR F) X))) + ((EXPR) + (FLOAT (FUNCALL (CDR F) X))) + ((MEXPR OPERATORS) + (FLOAT (MAPPLY (CDR F) (LIST X) NIL))) + (T + (MERROR "BUG: GCALL1$")))) + +(DEFUN GCALL2$ (F X Y) + (CASEQ (CAR F) + #+MACLISP + ((SUBR$) + (SUBRCALL FLONUM (CDR F) X Y)) + #+MACLISP + ((SUBR) + (FLOAT (SUBRCALL NIL (CDR F) X Y))) + #+MACLISP + ((LSUBR) + (FLOAT (LSUBRCALL NIL (CDR F) X Y))) + ((EXPR) + (FLOAT (FUNCALL (CDR F) X Y))) + ((MEXPR OPERATORS) + (FLOAT (MAPPLY (CDR F) (LIST X Y) NIL))) + (T + (MERROR "BUG: GCALL2$")))) + +(DEFUN AR$+AR$ (A$ B$ C$) + (DO ((N (ARRAY-DIMENSION-N 1 A$)) + (J 0 (1+ J))) + ((= J N)) + (DECLARE (FIXNUM N J)) + (SETF (AREF$ A$ J) (+$ (AREF$ B$ J) (AREF$ C$ J))))) + +(DEFUN AR$*S (A$ B$ S) + (DO ((N (ARRAY-DIMENSION-N 1 A$)) + (J 0 (1+ J))) + ((= J N)) + (DECLARE (FIXNUM N J)) + (SETF (AREF$ A$ J) (*$ (AREF$ B$ J) S)))) + +(DEFUN AR$GCALL2$ (AR FL X Y) + (DO ((J 0 (1+ J)) + (L FL (CDR L))) + ((NULL L)) + (SETF (AREF$ AR J) (GCALL2$ (CAR L) X Y)))) + +(DEFUN MAKE-GTRAMP (F NARGS) + NARGS + ;; for now, ignoring the number of arguments, but we really should + ;; do this error checking. + (LET ((K (FUNTYPEP F))) + (CASEQ (CAR K) + ((OPERATORS) + (CONS 'OPERATORS F)) + #+MACLISP + ((SUBR) + (CONS 'SUBR (CADR K))) + ((MEXPR EXPR LSUBR) + (CONS (CAR K) (CADR K))) + (T + (MERROR "Undefined or inscrutable function~%~M" F))))) + +(DEFUN GCALL3 (F A1 A2 A3) + (CASEQ (CAR F) + #+MACLISP + ((SUBR) + (SUBRCALL T (CDR F) A1 A2 A3)) + #+MACLISP + ((LSUBR) + (LSUBRCALL T (CDR F) A1 A2 A3)) + ((EXPR) + (FUNCALL (CDR F) A1 A2 A3)) + ((MEXPR OPERATORS) + (MAPPLY (CDR F) (LIST A1 A2 A3) 'GCALL3)) + (T + (MERROR "BUG: GCALL3")))) diff --git a/src/maxsrc/opers.75 b/src/maxsrc/opers.75 new file mode 100644 index 00000000..1e42d018 --- /dev/null +++ b/src/maxsrc/opers.75 @@ -0,0 +1,142 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module opers) + +;; This file is the run-time half of the OPERS package, an interface to the +;; Macsyma general representation simplifier. When new expressions are being +;; created, the functions in this file or the macros in MOPERS should be called +;; rather than the entrypoints in SIMP such as SIMPLIFYA or SIMPLUS. Many of +;; the functions in this file will do a pre-simplification to prevent +;; unnecessary consing. [Of course, this is really the "wrong" thing, since +;; knowledge about 0 being the additive identity of the reals is now +;; kept in two different places.] + +;; The basic functions in the virtual interface are ADD, SUB, MUL, DIV, POWER, +;; NCMUL, NCPOWER, NEG, INV. Each of these functions assume that their +;; arguments are simplified. Some functions will have a "*" adjoined to the +;; end of the name (as in ADD*). These do not assume that their arguments are +;; simplified. In addition, there are a few entrypoints such as ADDN, MULN +;; which take a list of terms as a first argument, and a simplification flag as +;; the second argument. The above functions are the only entrypoints to this +;; package. + +;; The functions ADD2, ADD2*, MUL2, MUL2*, and MUL3 are for use internal to +;; this package and should not be called externally. Note that MOPERS is +;; needed to compile this file. + +;; Addition primitives. + +(defmfun add2 (x y) + (cond ((=0 x) y) + ((=0 y) x) + (t (simplifya `((mplus) ,x ,y) t)))) + +(defmfun add2* (x y) + (cond ((=0 x) (simplifya y nil)) + ((=0 y) (simplifya x nil)) + (t (simplifya `((mplus) ,x ,y) nil)))) + +;; The first two cases in this cond shouldn't be needed, but exist +;; for compatibility with the old OPERS package. The old ADDLIS +;; deleted zeros ahead of time. Is this worth it? + +(defmfun addn (terms simp-flag) + (cond ((null terms) 0) + (t (simplifya `((mplus) . ,terms) simp-flag)))) + +(declare (special $negdistrib) (muzzled t)) + +(defmfun neg (x) + (cond ((numberp x) (minus x)) + (t (let (($negdistrib t)) + (simplifya `((mtimes) -1 ,x) t))))) + +(declare (muzzled nil)) + +(defmfun sub (x y) + (cond ((=0 y) x) + ((=0 x) (neg y)) + (t (add x (neg y))))) + +(defmfun sub* (x y) + (add (simplifya x nil) (mul -1 (simplifya y nil)))) + +;; Multiplication primitives -- is it worthwhile to handle the 3-arg +;; case specially? Don't simplify x*0 --> 0 since x could be non-scalar. + +(defmfun mul2 (x y) + (cond ((=1 x) y) + ((=1 y) x) + (t (simplifya `((mtimes) ,x ,y) t)))) + +(defmfun mul2* (x y) + (cond ((=1 x) (simplifya y nil)) + ((=1 y) (simplifya x nil)) + (t (simplifya `((mtimes) ,x ,y) nil)))) + +(defmfun mul3 (x y z) + (cond ((=1 x) (mul2 y z)) + ((=1 y) (mul2 x z)) + ((=1 z) (mul2 x y)) + (t (simplifya `((mtimes) ,x ,y ,z) t)))) + +;; The first two cases in this cond shouldn't be needed, but exist +;; for compatibility with the old OPERS package. The old MULSLIS +;; deleted ones ahead of time. Is this worth it? + +(defmfun muln (factors simp-flag) + (cond ((null factors) 1) + ((atom factors) factors) + (t (simplifya `((mtimes) . ,factors) simp-flag)))) + +(defmfun div (x y) (if (=1 x) (inv y) (mul x (inv y)))) + +(defmfun div* (x y) (if (=1 x) (inv* y) (mul (simplifya x nil) (inv* y)))) + +(defmfun ncmul2 (x y) (simplifya `((mnctimes) ,x ,y) t)) +(defmfun ncmuln (factors flag) (simplifya `((mnctimes) . ,factors) flag)) + +;; Exponentiation + +;; Don't use BASE as a parameter name since it is special in MacLisp. + +(defmfun power (*base power) + (cond ((=1 power) *base) + (t (simplifya `((mexpt) ,*base ,power) t)))) + +(defmfun power* (*base power) + (cond ((=1 power) (simplifya *base nil)) + (t (simplifya `((mexpt) ,*base ,power) nil)))) + +(defmfun ncpower (x y) + (cond ((=0 y) 1) + ((=1 y) x) + (t (simplifya `((mncexpt) ,x ,y) t)))) + +;; [Add something for constructing equations here at some point.] + +;; (ROOT X N) takes the Nth root of X. +;; Warning! Simplifier may give a complex expression back, starting from a +;; positive (evidently) real expression, viz. sqrt[(sinh-sin) / (sin-sinh)] or +;; something. + +(defmfun root (x n) + (cond ((=0 x) 0) + ((=1 x) 1) + (t (simplifya `((mexpt) ,x ((rat) 1 ,n)) t)))) + +;; (Porm flag expr) is +expr if flag is true, and -expr +;; otherwise. Morp is the opposite. Names stand for "plus or minus" +;; and vice versa. + +(defmfun porm (s x) (if s x (neg x))) +(defmfun morp (s x) (if s (neg x) x)) + +;; On PDP-10s, this is a function so as to save address space. A one argument +;; call is shorter than a two argument call, and this function is called +;; several places. In Franz, Multics, and the LISPM, this macros out on the +;; assumption that calls are more expensive than the additional memory. + +(defmfun simplify (x) (simplifya x nil)) diff --git a/src/maxsrc/ops.1 b/src/maxsrc/ops.1 new file mode 100644 index 00000000..70260ed8 --- /dev/null +++ b/src/maxsrc/ops.1 @@ -0,0 +1,47 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module ops) + + +;;; mathematical ops to call from translated code. +;;; this is to replace maxsrc;opers, thus simplifying things, +;;; and removing extra symbols from the environment. +;;; With the OPEXPRP switch set these will also speed up +;;; macsyma arithmetic. + +(DEFMACRO DEF-MARITH-NARY (MPLUS ZERO ZEROP PLUS) + `(DEFUN ,MPLUS N + (LET ((SUM ,ZERO) + (PUNT ()) + (ARG)) + (DO ((J 1 (1+ J))) + ((> J N) + (IF (NULL PUNT) SUM + (SIMPLIFY + `((,',MPLUS) ,.(IF (,ZEROP SUM) NIL (LIST SUM)) + ,.PUNT)))) + (SETQ ARG (ARG J)) + (IF (NUMBERP ARG) + (SETQ SUM (,PLUS SUM ARG)) + (PUSH ARG PUNT)))))) + +(DEF-MARITH-NARY MPLUS 0 ZEROP PLUS) +(DEF-MARITH-NARY MTIMES 1 ONEP TIMES) + +(DEFMACRO DEF-MARITH-BINARY (MEXPT EXPT) + `(DEFUN ,MEXPT (X Y) + (IF (AND (NUMBERP X) (NUMBERP Y)) + (,EXPT X Y) + (SIMPLIFY `((,',MEXPT) ,X ,Y))))) + +(DEF-MARITH-BINARY MEXPT EXPT) +(DEF-MARITH-BINARY MQUOTIENT QUOTIENT) + +(DEFMACRO DEF-MARITH-UNARY (MMINUS MINUS) + `(DEFUN ,MMINUS (X) + (IF (NUMBERP X) (,MINUS X) (SIMPLIFY `((,',MMINUS) ,X))))) + +(DEF-MARITH-UNARY MMINUS MINUS) + diff --git a/src/maxsrc/outex.37 b/src/maxsrc/outex.37 new file mode 100644 index 00000000..4016eac5 --- /dev/null +++ b/src/maxsrc/outex.37 @@ -0,0 +1,209 @@ +;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;; +;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; 1:42am Thursday, 26 June 1980 -gjc + +(macsyma-module outex) + +;;; To PARSE a file of macsyma expressions, and make them quickly +;;; and randomly accesable. Made for used by ELL's ODE package. +;;; -GJC + +(defvar *parsed-output-file*) ;; written to during psuedo batching. +(defvar *filepos-table* nil) ;; pushed on during psuedo batching. + +;;; Format of file. +;;; ....... +;;; File is ascii to avoid hair of fixnum=>ascii conversion for read. + +#.(PROGN (SETQ FP-LENGTH 10.) NIL) + +(DEFUN WRITE-FP (X &AUX (BASE 10.) (*NOPOINT T)) + (DO ((N (LET ((TN (- #.FP-LENGTH (FLATSIZE X)))) + (IF (MINUSP TN) (MERROR "OUTEX internal BUG") TN)) + (1- N))) + ((= N 0) + (PRIN1 X *PARSED-OUTPUT-FILE*)) + (TYO #/0 *PARSED-OUTPUT-FILE*))) + +(defmfun $make_index_file (filename + &AUX + (lfilename ($filename_merge filename)) + (temp (probef lfilename)) + (*filepos-table* nil)) + (or temp + (merror "File does not exist. ~M" lfilename)) + (setq lfilename (to-macsyma-namestring temp)) + (iota ((*parsed-output-file* + (mergef "* _PARS_" lfilename) + '(out dsk ascii block))) + (WRITE-FP 0) + (let ((*in-macsyma-indexer* t)) + (call-batch1 lfilename t)) + ;; o.k. the work is done, lets write the index file. + (LET ((IPOINTER (FILEPOS *PARSED-OUTPUT-FILE*))) + (FILEPOS *PARSED-OUTPUT-FILE* 0) + (WRITE-FP IPOINTER) + (FILEPOS *PARSED-OUTPUT-FILE* IPOINTER)) + (WRITE-FP (LENGTH *FILEPOS-TABLE*)) + (DO ((L (NREVERSE *FILEPOS-TABLE*) (CDR L))) + ((NULL L)) + (WRITE-FP (CAR L))) + (renamef *parsed-output-file* "* PARSED") + `((mlist) + ,lfilename + ,(to-macsyma-namestring (truename *parsed-output-file*))))) + + +(defmfun outex-hook-exp (form) + ;; the function is called in MLOAD on expressions + ;; in the BATCH file. + (push (filepos *parsed-output-file*) *filepos-table*) + (outex-print form)) + +(defun outex-print (form) + (terpri *parsed-output-file*) + (outex-prin1 form) + (tyo #\SP *parsed-output-file*)) + +(defun outex-prin1 (form) + ;; this wants to check for (MPLUS SIMP) and various other + ;; headers, and output #.(GET 'MPLUS 'SIMPIND) + ;; and other hacks. maybe. + (prin1 form *parsed-output-file*)) + +;;; these functions are for accessing the index file once +;;; produced. + +(declare (splitfile OUTEY)) + +(eval-when (eval compile) +(DEFSTRUCT (INDEX-FILE ARRAY CONC-NAME) + ARRAY + INDEX-POINTER + N-ELEMENTS)) + +(defmfun $open_index_file (filename + &AUX OB + (lfilename ($filename_merge filename)) + (pfilen (mergef "* parsed" lfilename)) + (sym + (concat (namestring (probef pfilen)) + '|-index-file-object|))) + (iota ((fi Pfilen '(in dsK ASCII BLOCK))) + (SETQ OB (MAKE-INDEX-FILE ARRAY FI + INDEX-POINTER (READ-FP FI))) + (FILEPOS FI (INDEX-FILE-INDEX-POINTER OB)) + (SETF (INDEX-FILE-N-ELEMENTS OB) + (READ-FP FI))) + (putprop sym OB 'index-file) + sym) + +(defmacro get-index-file (x) + (if (atom x) + `(and (symbolp ,x) (get ,x 'index-file)) + `(let ((temp ,x)) (get-index-file temp)))) + +(defmfun $index_file_DIM (sym &aux + (index-file (get-index-file sym))) + (or index-file + (merror "not an index file: ~%~M" SYM)) + (index-file-n-ELEMENTS INDEX-FILE)) + +(defmfun $read_nth_object (n sym) + (or (and (fixp n) (plusp n)) + (merror + "The first arg was not a positive integer index.~%~M" n)) + (let ((if (get-index-file sym))) + (or if (merror "2nd arg not an index file~%~M" sym)) + (and (> n (index-file-n-ELEMENTS if)) + (merror "Not that many objects in the file. ~:M ~:M" + n sym)) + (let ((index) + (STREAM (index-file-ARRAY IF))) + (unwind-protect + (progn + (OPEN STREAM) + (FILEPOS STREAM (+ (* N #.FP-LENGTH) + (INDEX-FILE-INDEX-POINTER IF))) + (SETQ INDEX (READ-FP STREAM)) + (FILEPOS STREAM INDEX) + (READ STREAM)) + (CLOSE STREAM))))) + +(DEFUN READ-FP (S) + (DO ((N 0 (+ (- (TYI S) #/0) (* N 10.))) + (J #.FP-LENGTH (1- J))) + ((= J 0) N))) + +(defmfun $map_over_index_file (func file + &aux + (index-file (get-index-file file))) + (or INDEX-FILE + (merror "2nd argument not an indexed file object.~%~M" file)) + (let ((fp (index-file-ARRAY INDEX-FILE))) + (unwind-protect + (do ((j (progn (open fp)(READ-FP FP) 1) (1+ j)) + (l nil (CONS (mcall func (simplify (READ FP)) j) L))) + ((> J (INDEX-FILE-N-ELEMENTS INDEX-FILE)) + `((mlist) ,@(nreverse l)))) + (close fp)))) + + + +;;; Additional comments about implementation: + +;;; An indexed file object is represented at macsyma level by a symbol +;;; with an indexed-file property. When array-objects are put into +;;; macsyma, it will be an array-function of some kind. + +;;; This makes for very fast random accessing of +;;; expressions in a file, incredibly faster than using BATCH, +;;; very important for files of test cases. + +;;; These are not FEXPR's because the major use of these guys is +;;; in programs which test files of equations. Normal argument evaluation +;;; is certainly desired. + + + +;;; at first I was interning an symbol table for the file, +;;; this lost incredibly for files with lots of "Strings..." i.e. +;;; |&Strings...| +;;; Now: The INDEX file expects to be a FIXNUM mode file. +;;; i.e. We should be able to do FILEPOSE and IN and OUT on it +;;; and it should act like a FIXNUM ARRAY. +;;; Any system should have a FIXNUM mode file, if not, it can +;;; be simulated by ascii files. The exact number of BITs in a FIXNUM +;;; doesn't really matter either. The FIXNUMs are just the FILEPOS +;;; of expressions in the PARSED file. + +;;; Things to add: Support for Symbolic reference to the +;;; expressions through the FOO&& type labels. This seemed to +;;; be slightly kludgy to put into the present BATCH1, so I'm waiting +;;; for KMP's new reader to be installed. Once the labels +;;; associated with an expression can be read we can work out +;;; a way to have the possibly out-of-core symbol-table of +;;; index numbers. +;;; Maybe use some kind format which is FIXNUM-IO, and bumbed +;;; for the kind of expressions which the macsyma parser makes. +;;; That is, TYPEP of SYMBOL, LIST, FIXNUM, BIGNUM, FLONUM. +;;; Very reasonable to have an out-of-core symbol table, +;;; but with an in-core cache of the List's which are args to PNPUT. +;;; That would cut down on the amount of FILEPOSing needed to +;;; read-in a given expression. Uhm, maybe each entry +;;; should be where the subset +;;; vector tells which symbol's (numbered 0..N for that file), +;;; must be interned to "read" a given expression, which is +;;; located at . +;;; Everything at FILEPOS is then a vector of 36-bit-lisp-pointers +;;; Representation is . +;;; Symbol: is the symbol-number. +;;; Cons: is the filepos of the CAR? CDR follows? +;;; Fixnum/Bignum: gives number of words (following) to +;;; read to get the bits. +;;; Flonum: next word is it. +;;; () : is special maybe? well it is a symbol (sigh...) +;;; Anyway, this could make for some DAMN fast reading of +;;; expressions. + diff --git a/src/maxsrc/outmis.309 b/src/maxsrc/outmis.309 new file mode 100644 index 00000000..423bb160 --- /dev/null +++ b/src/maxsrc/outmis.309 @@ -0,0 +1,1025 @@ +;;; -*- Mode:LISP; Package:MACSYMA -*- + +; ** (c) Copyright 1982 Massachusetts Institute of Technology ** + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; Miscellaneous Out-of-core Files ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(macsyma-module outmis) + +(DECLARE (FIXNUM NN)) + +#+ITS (DECLARE (SPECIAL TTY-FILE)) + +(DECLARE (SPLITFILE STATUS)) + +#+(or ITS Multics TOPS-20) +(DECLARE (SPECIAL LINEL MATHLAB-GROUP-MEMBERS) + (*EXPR STRIPDOLLAR MEVAL) + (*LEXPR CONCAT)) + + + +#+(or ITS Multics TOPS-20) +(PROGN 'COMPILE + +;;; These are used by $SEND when sending to logged in Mathlab members +#-Multics +(SETQ MATHLAB-GROUP-MEMBERS + '(JPG ELLEN GJC RZ KMP WGD MERMAN)) + +;;; IOTA is a macro for doing file I/O binding, guaranteeing that +;;; the files it loads will get closed. +;;; Usage: (IOTA (( ) +;;; ( ) ...) +;;; ) +;;; Opens with binding it to . Closes +;;; any which still has an open file or SFA in it when +;;; PDL unwinding is done. +;;; No IOTA on Multics yet, +#-Multics +(EVAL-WHEN (EVAL COMPILE) + (COND ((NOT (STATUS FEATURE IOTA)) + (LOAD #+ITS '((DSK LIBLSP) IOTA FASL) + #-ITS '((LISP) IOTA FASL))))) + +;;; TEXT-OUT +;;; Prints a list of TEXT onto STREAM. +;;; +;;; TEXT must be a list of things to be printed onto STREAM. +;;; For each element in TEXT, A, if A is a symbol with first +;;; character "&", it will be fullstripped and PRINC'd into the +;;; stream; otherwise it will be $DISP'd onto STREAM (by binding +;;; OUTFILES and just calling $DISP normally). +;;; +;;; STREAM must be an already-open file object. + +(DEFUN TEXT-OUT (TEXT STREAM) + (DO ((A TEXT (CDR A)) + (/^R T) + (/^W T) + (LINEL 69.) + (OUTFILES (NCONS STREAM))) + ((NULL A)) + (COND ((AND (SYMBOLP (CAR A)) + (EQ (GETCHAR (CAR A) 1.) '/&)) + (PRINC (STRIPDOLLAR (CAR A)) STREAM)) + (T (TERPRI STREAM) + (MEVAL `(($DISP) ($STRING ,(CAR A)))))) + (TERPRI STREAM))) + +;;; MAIL +;;; Sends mail to a recipient, TO, via the normal ITS mail protocol +;;; by writing out to DSK:.MAIL.;MAIL > and letting COMSAT pick it +;;; up and deliver it. Format for what goes in the MAIL > file should +;;; be kept up to date with what is documented in KSC;?RQFMT > +;;; +;;; TO must be a name (already STRIPDOLLAR'd) to whom the mail should +;;; be delivered. +;;; +;;; TEXT-LIST is a list of Macsyma strings and/or general expressions +;;; which will compose the message. + +#+(OR LISPM ITS) ;Do these both at once. +(DEFUN MAIL (TO TEXT-LIST) + (IOTA ((STREAM "DSK:.MAIL.;MAIL >" 'OUT)) + (mformat stream + "FROM-PROGRAM:Macsyma +AUTHOR:~A +FROM-UNAME:~A +RCPT:~A +TEXT;-1~%" + (STATUS USERID) + (STATUS UNAME) + (NCONS TO)) + (TEXT-OUT TEXT-LIST STREAM))) + +;;; This code is new and untested. Please report bugs -kmp +#+TOPS-20 +(DEFUN MAIL (TO TEXT-LIST) + (IOTA ((STREAM "MAIL:/[--NETWORK-MAIL--/]..-1" + '(OUT ASCII DSK BLOCK NODEFAULT))) + (MFORMAT STREAM + "/ ~A +~A +/ +From: ~A at ~A~%" + (STATUS SITE) TO (STATUS USERID) (STATUS SITE)) + (COND ((NOT (EQ (STATUS USERID) (STATUS UNAME))) + (MFORMAT STREAM "Sender: ~A at ~A~%" (STATUS UNAME) (STATUS SITE)))) + (MFORMAT STREAM "Date: ~A +TO: ~A~%~%" + (TIME-AND-DATE) TO) + (TEXT-OUT TEXT-LIST STREAM))) + +#+Multics +(defvar macsyma-mail-count 0 "The number of messages sent so far") +#+Multics +(progn 'compile +(DEFUN MAIL (TO TEXT-LIST) + (let* ((open-file ()) + (macsyma-unique-id (macsyma-unique-id 'unsent + (increment macsyma-mail-count))) + (file-name (catenate (pathname-util "pd") + ">macsyma_mail." macsyma-unique-id))) + (unwind-protect + (progn + (setq open-file (open file-name '(out ascii block dsk))) + (text-out text-list open-file) + (close open-file) + (cline (catenate "send_mail " to " -input_file " file-name + " -no_subject"))) + (deletef open-file)))) + +(defun macsyma-unique-id (prefix number) + (implode (append (explode prefix) (list number)))) +) + +;;; $BUG +;;; With no args, gives info on itself. With any positive number of +;;; args, mails all args to MACSYMA via the MAX-MAIL command. +;;; Returns $DONE + +(DEFMSPEC $BUG (X) (SETQ X (CDR X)) + (COND ((NULL X) + (MDESCRIBE '$BUG)) + (T + (MAX-MAIL 'BUG X))) + '$DONE) + +#+MULTICS +(DEFMACRO CHECK-AND-STRIP-ADDRESS (ADDRESS) + `(COND ((EQUAL (GETCHARN ,ADDRESS 1) #/&) + (STRIPDOLLAR ,ADDRESS)) + (T (MERROR "Mail: Address field must be a string")))) +#-MULTICS +(DEFMACRO CHECK-AND-STRIP-ADDRESS (ADDRESS) + `(STRIPDOLLAR ,ADDRESS)) + +;;; $MAIL +;;; With no args, gives info on itself. +;;; With 1 arg, sends the MAIL to Macsyma. Like bug, only doesn't +;;; tag the mail as a bug to be fixed. +;;; With 2 or more args, assumes that arg1 is a recipient and other +;;; args are the text to be MAIL'd. +;;; Works for Multics, ITS, and TOPS-20. + +(DEFMSPEC $MAIL (X) (SETQ X (CDR X)) + (COND ((NULL X) + (MDESCRIBE '$MAIL)) + ((= (LENGTH X) 1.) + (MAX-MAIL 'MAIL X)) + (T (LET ((NAME (CHECK-AND-STRIP-ADDRESS (CAR X)))) + (MAIL NAME (CDR X)) + #-Multics(MFORMAT NIL "~&;MAIL'd to ~A~%" NAME)))) +;;;On Multics Mailer will do this. + '$DONE) + +;;; MAX-MAIL +;;; Mails TEXT-LIST to MACSYMA mail. Normal ITS mail header +;;; is suppressed. Header comes out as: +;;; From via command. +;;; +;;; SOURCE is the name of the originating command (eg, BUG or +;;; MAIL) to be printed in the header of the message. +;;; +;;; TEXT-LIST is a list of expressions making up the message. + +#+(OR LISPM ITS) +(DEFUN MAX-MAIL (SOURCE TEXT-LIST) + (IOTA ((MAIL-FILE "DSK:.MAIL.;_MAXIM >" '(OUT ASCII DSK BLOCK))) + (LINEL MAIL-FILE 69.) + (MFORMAT MAIL-FILE + "FROM-PROGRAM:Macsyma +HEADER-FORCE:NULL +TO:(MACSYMA) +SENT-BY:~A +TEXT;-1 +From ~A via ~A command. ~A~%" + (STATUS UNAME) + (STATUS USERID) + SOURCE + (TIME-AND-DATE)) + (TEXT-OUT TEXT-LIST MAIL-FILE) + (RENAMEF MAIL-FILE "MAIL >")) + (MFORMAT NIL "~&;Sent to MACSYMA~%") + '$DONE) + +;;; This code is new and untested. Please report bugs -kmp +#+TOPS-20 +(DEFUN MAX-MAIL (SOURCE TEXT-LIST) + (IOTA ((MAIL-FILE "MAIL:/[--NETWORK-MAIL--/]..-1" + '(OUT ASCII DSK BLOCK NODEFAULT))) + (MFORMAT MAIL-FILE + "/ MIT-MC +BUG-MACSYMA +/ From ~A at ~A via ~A command. ~A~%" + (STATUS USERID) (STATUS SITE) SOURCE (TIME-AND-DATE)) + (TEXT-OUT TEXT-LIST MAIL-FILE) + (MFORMAT NIL "~%;Sent to MACSYMA"))) + +#+Multics +(defun max-mail (source text-list) + (let ((address (cond ((eq source 'mail) + (setq source "Multics-Macsyma-Consultant -at MIT-MC")) + (t (setq source "Multics-Macsyma-Bugs -at MIT-MC"))))) + (mail address text-list))) + +); END of (or ITS Multics TOPS-20) conditionalization. + + +;; On ITS, this returns a list of user ids for some random reason. On other +;; systems, just print who's logged in. We pray that nobody uses this list for +;; value. + +#+ITS +(PROGN 'COMPILE +(DEFMFUN $who nil + (do ((tty*) + (wholist nil (cond ((eq (getchar tty* 1) ;just consoles, not device + '/D) + wholist) + (t (LET ((UNAME (READUNAME))) + (COND ((MEMQ UNAME WHOLIST) WHOLIST) + (T (CONS UNAME WHOLIST))))))) + (ur (crunit)) + (tty-file ((lambda (tty-file) + (readline tty-file) ;blank line + tty-file) ;get rid of cruft + (open '((tty) |.file.| |(dir)|) 'single)))) + ((progn (readline tty-file) + (setq tty* (read tty-file)) + (eq tty* 'free)) + (close tty-file) + (apply 'crunit ur) + (cons '(mlist simp) wholist)))) + +;;; $SEND +;;; With no args, gives info about itself. +;;; With one arg, sends the info to any logged in Macsyma users. +;;; With 2 or more args, assumes that arg1 is a recipient and +;;; args 2 on are a list of expressions to make up the message. + +(DEFMSPEC $SEND (X) (SETQ X (CDR X)) + (COND ((NULL X) + (MDESCRIBE '$SEND)) + ((= (LENGTH X) 1.) + (MAX-SEND X)) + (T + (MSEND (STRIPDOLLAR (CAR X)) (CDR X) T))) + '$DONE) + +;;; MSEND +;;; Sends mail to a recipient, TO, by opening the CLI: device on the +;;; recipient's HACTRN. +;;; +;;; TO must be a name (already FULLSTRIP'd) to whom the mail should +;;; be delivered. A header is printed of the form: +;;; [MESSAGE FROM MACSYMA USER