├── MYPACKAGE.texi ├── README.md ├── bertrand-teguia └── Hypergeometric-Term-Holonomic-REs │ ├── HyperTermHoloRE.dem │ ├── HyperTermHoloRE.mac │ ├── HyperTermHoloRE.texi │ ├── README.md │ ├── testREs.mac │ └── test_HyperTermHoloRE.mac ├── robert-dodier ├── boxcar_convolution │ ├── boxcar_convolution.log │ ├── boxcar_convolution.mac │ ├── boxcar_convolution_e50a.lisp │ ├── boxcar_convolution_simpler.log │ ├── boxcar_convolution_simpler.mac │ ├── e100.lisp │ ├── e100_Bterms.lisp │ ├── repeated_convolution.mac │ ├── repeated_convolution_plot.png │ └── trunc_mono.mac ├── catchable_syntax_error │ ├── README.md │ ├── catchable_syntax_error.lisp │ └── foo.mac ├── chebyshev_primality │ ├── README.md │ ├── chebyshev_primality.m │ ├── chebyshev_primality.m-original │ └── chebyshev_primality.mac ├── combining_diacritics │ ├── README.md │ └── combining_diacritics.lisp ├── complex_plots │ ├── README.md │ ├── complex_plot_2d.template │ ├── complex_plot_3d.template │ ├── complex_plots.mac │ └── slurp.lisp ├── constrained_mean_spline │ ├── constrained_mean_spline.mac │ ├── spline-and-mean-values.svg │ └── spline-segments.svg ├── diff_sum │ ├── diff_sum.mac │ ├── diff_sum2.mac │ ├── diff_sum_examples.txt │ └── rtest_diff_sum.mac ├── distribute_over_tranches │ ├── d00521032-eigenvalues-problem-parallel.mac │ ├── d00521032-eigenvalues-problem.mac │ ├── d00521032-with-For_loop_variables.mac │ ├── distribute_over_tranches.lisp │ ├── rtest_distribute_over_tranches.mac │ └── tick_tock.mac ├── excel_round │ ├── excel_round.mac │ └── rtest_excel_round.mac ├── expm │ └── expm.mac ├── fboundp │ ├── fboundp.mac │ └── rtest_fboundp.mac ├── from_wxmx │ ├── README.md │ ├── expressions_from_dom.lisp │ ├── expressions_from_dom.mac │ ├── from_wxmx.mac │ ├── output-examples-complex.xml │ ├── output-examples-diff.xml │ ├── output-examples-simple.xml │ ├── output-examples.xml │ └── parse_token_list.lisp ├── generalized_halley │ ├── README.md │ ├── generalized_halley.demo │ └── generalized_halley.mac ├── json_tools │ ├── README.md │ ├── flatten_json.mac │ ├── json_tools.mac │ ├── query_json.mac │ ├── read_json.mac │ ├── rtest_json_tools.mac │ └── tyi-raw.lisp ├── lexical_symbols │ ├── README.md │ ├── facexp.mac │ ├── find_dynamic_binding.mac │ ├── fourie.mac │ ├── lexical_symbols.demo │ ├── lexical_symbols.lisp │ ├── lexical_symbols.mac │ ├── meval.lisp │ ├── mlambda.lisp │ ├── mset.lisp │ ├── plan6.txt │ ├── rtest_lexical_symbols.mac │ ├── rtest_lexical_symbols_only.mac │ ├── simplify_product.mac │ ├── trgsmp.mac │ ├── trigrat.lisp │ └── with-lexical-environment.lisp ├── low_discrepancy │ ├── ACM-LICENSE.html │ ├── LowDiscrepancy.java │ ├── cacm647.mac │ ├── low_discrepancy-index.lisp │ ├── low_discrepancy.asd │ ├── low_discrepancy.info │ ├── low_discrepancy.texi │ └── rtest_cacm647.mac ├── more_ezunits │ ├── add_compatible_units.mac │ └── rtest_more_ezunits.mac ├── plottable_steps │ └── plottable_steps.mac ├── polyfit │ └── polyfit.mac ├── qmpe │ ├── qmpe.demo │ ├── qmpe.mac │ └── rtest_qmpe.mac ├── random_expression │ └── random_expression.mac ├── reshape │ ├── index-reshape.lisp │ ├── reshape-array.lisp │ ├── reshape.info │ ├── reshape.mac │ ├── reshape.texi │ └── rtest_reshape.mac ├── simplify_conditionals │ ├── rtest_simplify_conditionals.mac │ └── simplify_conditionals.mac ├── stackoverflow │ ├── histogram_sd.mac │ └── weibull_renewal_discrete.mac ├── subst_floats │ └── subst_floats.mac ├── sum_kron_delta │ ├── bolanios_sum_kron_delta.mac │ ├── bolanios_sum_kron_delta.mac-log │ ├── rtest_sum_kron.mac │ └── sum_kron_delta.mac ├── superq │ ├── rtest_superq.mac │ ├── superq-index.lisp │ ├── superq.asd │ ├── superq.info │ ├── superq.lisp │ └── superq.texi ├── tex_document │ ├── README.md │ ├── foo_bar.mac │ └── tex_document.mac └── tex_table │ ├── README.md │ ├── tex_table.lisp │ ├── tex_table.mac │ └── tex_table_example.mac ├── sdemarre ├── diophantine │ ├── README.md │ ├── dio_draw_example.png │ ├── dio_draw_example2.png │ ├── dio_draw_example3.png │ ├── dio_draw_example4.png │ ├── diophantine-index.lisp │ ├── diophantine.asd │ ├── diophantine.info │ ├── diophantine.mac │ ├── diophantine.texi │ ├── diophantine_devel.mac │ ├── diophantine_draw.mac │ ├── diophantine_lisp_helpers.lisp │ └── rtest_diophantine.mac └── diophantine_system │ ├── README.md │ ├── diophantine_system-index.lisp │ ├── diophantine_system.asd │ ├── diophantine_system.info │ ├── diophantine_system.mac │ ├── diophantine_system.texi │ ├── rtest_diophantine_system.mac │ └── smith_normal_form.mac └── yitzchak └── texify ├── CHANGELOG.md ├── LICENSE.md ├── README.md ├── nregex.lisp ├── texify.asd └── texify.lisp /MYPACKAGE.texi: -------------------------------------------------------------------------------- 1 | \input texinfo 2 | 3 | @c NOTE: This template-standalone.texi shows how to create a texinfo file 4 | @c that yields a stand-alone MYPACKAGE.info file. 5 | @c See template.texi for a texinfo file which is to be part of maxima.info. 6 | 7 | @c NOTE: The content of this file was determined by tedious trial and error. 8 | @c My advice is to keep all elements of this template, from \input to @bye, 9 | @c otherwise you'll experience cryptic error messages, hair loss, etc. 10 | 11 | @c makeinfo MYPACKAGE.texi to make .info 12 | @c texi2html MYPACKAGE.texi to make .html 13 | @c texi2pdf MYPACKAGE.texi to make .pdf 14 | 15 | @setfilename MYPACKAGE.info 16 | @settitle Package MYPACKAGE 17 | 18 | @ifinfo 19 | @macro var {expr} 20 | <\expr\> 21 | @end macro 22 | @end ifinfo 23 | 24 | @dircategory Mathematics/Maxima 25 | @direntry 26 | * Package MYPACKAGE: (maxima)Maxima share package MYPACKAGE for foo bar baz quux. 27 | @end direntry 28 | 29 | @node Top, Introduction to package MYPACKAGE, (dir), (dir) 30 | @top 31 | @menu 32 | * Introduction to package MYPACKAGE:: 33 | * Definitions for package MYPACKAGE:: 34 | * Function and variable index:: 35 | @end menu 36 | @chapter Package MYPACKAGE 37 | 38 | @node Introduction to package MYPACKAGE, Definitions for package MYPACKAGE, Top, Top 39 | @section Introduction to package MYPACKAGE 40 | 41 | Package @code{MYPACKAGE} is yadda yadda yadda, foo bar baz quux mumble blurf. 42 | 43 | @node Definitions for package MYPACKAGE, Function and variable index, Introduction to package MYPACKAGE, Top 44 | @section Definitions for package MYPACKAGE 45 | 46 | @deffn {Function} transmogrify (@var{foo}, @var{bar}) 47 | 48 | Returns the generalized transmogrificatin of @var{foo} and @var{bar}. 49 | See also @code{frotz}. 50 | 51 | @end deffn 52 | 53 | @defvr {Variable} frotz 54 | Default value: @code{true} 55 | 56 | When @code{frotz} is @code{true}, 57 | @code{transmogrify} computes the transmogrification by Smith's algorithm. 58 | Otherwise, the transmogrification is computed by Jones' algorithm. 59 | 60 | @end defvr 61 | 62 | @node Function and variable index, , Definitions for package MYPACKAGE, Top 63 | @appendix Function and variable index 64 | @printindex fn 65 | @printindex vr 66 | 67 | @bye 68 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## maxima-packages 2 | 3 | ### PREFACE ### 4 | 5 | maxima-packages is an experimental system for developing and distributing 6 | packages for Maxima. At this time (March 2018), there are still some issues to be 7 | resolved, and it is possible that maxima-packages might change very substantially 8 | or even might be discontinued in favor of some other system. 9 | 10 | ### OVERVIEW ### 11 | 12 | maxima-packages is a collection of packages for the Maxima computer algebra system 13 | which have been contributed by users. 14 | 15 | These packages have not been reviewed carefully, 16 | neither for correctness nor for security problems. 17 | Users accept all risk for using these packages. 18 | 19 | All packages in maxima-packages can be modified by others, 20 | via the same mechanism (a pull request) by which the package was originally created. 21 | Project administrators will give the original package author an opportunity 22 | to review pull requests for their packages, 23 | but if the original author does not take action to accept or reject the pull request, 24 | project administrators will take action, at their discretion. 25 | 26 | At this time (February 2018), there is not yet an automatic mechanism 27 | to download and install these packages, but such a mechanism is under development. 28 | 29 | ### CONTRIBUTION POLICY ### 30 | 31 | * Project administrators will accept almost any contribution made in good faith, 32 | although they reserve the right to reject any contribution. 33 | * The following are encouraged, but not required: 34 | - Contributors are encouraged to contribute under their real name, not a pseudonym 35 | - Contributors are encouraged to write documentation, preferably in Texinfo format 36 | * Contributors can adapt MYPACKAGE.texi for their own package 37 | - Contributors are encouraged to include a test script 38 | - Contributors are encouraged to keep the size of packages relatively small 39 | 40 | ### CONTRIBUTING TO MAXIMA-PACKAGES ### 41 | 42 | 1. The contributor must have a Github account. 43 | 2. The contributor creates a branch of the maxima-packages repository. 44 | 3. The contributor copies their branch to a local working copy. 45 | 4. The contributor creates new files and folder, or makes any other changes in their working copy. 46 | 5. The contributor commits their changes and pushes them to their branch of maxima-packages. 47 | 6. The contributor issues a pull request to the maxima-packages project administrators. 48 | 7. Project administrators review the pull request and accept or reject it, 49 | according to the criteria discussed above. 50 | 51 | In more detail: 52 | 53 | 1. The contributor must have a Github account. 54 | * Anyone can create a free Github account. 55 | 2. The contributor creates a branch of the maxima-packages repository. 56 | * After signing in to Github, navigate to the maxima-packages page. 57 | * Click the "Fork" button at upper right. 58 | 3. The contributor copies their branch to a local working copy. 59 | * Navigate to the branch of maxima-packages created by "Fork". 60 | * Click the "Clone or download" button 61 | * Copy the content of the text box "git clone ..." 62 | * Paste "git clone ..." to a command line and execute it 63 | 4. The contributor creates new files and folder, or makes any other changes in their working copy. 64 | * Create a top-level folder with the same name as your Github user name 65 | * Create a folder under the user name folder for each package you create 66 | * Create files and folders under the package folder as appropriate 67 | * Use whatever text editor or other means to create and modify files 68 | 5. The contributor commits their changes and pushes them to their branch of maxima-packages. 69 | * Execute git commands such as "git add" and "git commit" 70 | * An explanation of Git is beyond the scope of this document. 71 | You will find one tutorial introduction at: https://git-scm.com/docs/gittutorial 72 | There is a great deal of other information about Git, which a web search will find. 73 | 6. The contributor issues a pull request to the maxima-packages project administrators. 74 | * Navigate to your branch of maxima-packages at Github 75 | * Click the "Pull Request" button 76 | 7. Project administrators review the pull request and accept or reject it, 77 | according to the criteria discussed above. 78 | * If your pull request is accepted, delete your fork of maxima-packages 79 | (you will create a new fork each time you want to make a pull request) 80 | -------------------------------------------------------------------------------- /bertrand-teguia/Hypergeometric-Term-Holonomic-REs/HyperTermHoloRE.dem: -------------------------------------------------------------------------------- 1 | "This is a demo file for the package HyperTermHoloRE."$ 2 | 3 | load(HyperTermHoloRE)$ 4 | 5 | "HypervanHoeij for solutions over the rationals."$ 6 | 7 | HypervanHoeij(a[n+1]=a[n]/n, a[n]); 8 | HypervanHoeij(3*a[n+2]+4*a[n+1]+a[n]=0, a[n]); 9 | HypervanHoeij(2*a[n+2]-(4*n+5)*a[n+1]+(n+1)*(2*n+1)*a[n]=0, a[n]); 10 | HypervanHoeij(-24*(35*n+17)*a[n+3]+2*(1260*n^2+2747*n+1043)*a[n+2]-(2520*n^3+7244*n^2+6343*n+1668)*a[n+1]+(2*n+1)*(3*n+1)*(4*n+1)*(35*n+52)*a[n]=0, a[n]); 11 | HypervanHoeij(24*(840*n^7+7968*n^6+35522*n^5+88258*n^4+127887*n^3+106429*n^2+46264*n+7960)*a[n+4]-2*(10080*n^9+ 12 | 206496*n^8+1751040*n^7+8319264*n^6+24453158*n^5+45797110*n^4+54260055*n^3+38919163*n^2+15186598*n+ 13 | 2425156)*a[n+3]+(60480*n^10+1220496*n^9+10927632*n^8+57029548*n^7+191032780*n^6+426426196*n^5+638473602* 14 | n^4+629403993*n^3+388446536*n^2+134465443*n+19614654)*a[n+2]-(60480*n^11+1222176*n^10+11198376*n^9+ 15 | 60847160*n^8+216159310*n^7+523934990*n^6+879952943*n^5+1020211801*n^4+797677962*n^3+399381037*n^2+ 16 | 114855333*n+14307552)*a[n+1]+(n+1)^2*(2*n+1)*(3*n+1)*(4*n+1)* 17 | (840*n^7+13848*n^6+100970*n^5+414788*n^4+1024899*n^3+1512018*n^2+1227113*n+421128)*a[n]=0, a[n]); 18 | 19 | 20 | "HypervanHoeij for solutions over extension fields."$ 21 | 22 | HypervanHoeij((n+1)*(n+2)*a[n+2]+a[n]=0, a[n], C); 23 | HypervanHoeij(-(n+1)*(n+2)*a[n+2]+(n+1)*a[n+1]+a[n]=0, a[n],C); 24 | HypervanHoeij((3*n+7)*(9*n^2+15*n+13)*a[n+3]+3*(9*n^2+33*n+37)*a[n+2]+(3*n+7)*(9*n^2+15*n+13)*a[n+1]+3* 25 | (9*n^2+33*n+37)*a[n]=0, a[n], C); 26 | HypervanHoeij((c-1)*(c+1)^2*(c*n^2+n^2+c*n+5*n-c^3+3*c^2-5*c+7)*a[n+3]+(c+1)* 27 | (2*c*n^3+2*n^3-c^3*n^2+c^2*n^2+9*c*n^2+15*n^2-5*c^3*n+5*c^2*n+7*c*n+37*n+c^5-5*c^4+4*c^3-4*c^2-c+29)*a[n+2]-(n+2)* 28 | (c^2*n^3+2*c*n^3+n^3+6*c^2*n^2+12*c*n^2+6*n^2-c^4*n+2*c^3*n+7*c^2*n+28*c*n+8*n-5*c^4+14*c^3-18*c^2+38*c-5)*a[n+1]+ 29 | (c-1)*(n+1)*(n+2)*(c*n^2+n^2+3*c*n+7*n-c^3+3*c^2-3*c+13)*a[n]=0, a[n], C); 30 | HypervanHoeij((c^2+1)^2*(c^2*n^4+n^4-4*c^3*n^3+8*c^2*n^3+4*c*n^3+8*n^3+6*c^4*n^2-24*c^3*n^2+15*c^2*n^2+24*c*n^2+25*n^2-4*c^5*n+24* 31 | c^4*n-44*c^3*n+8*c^2*n+48*c*n+32*n+c^6-8*c^5+27*c^4-24*c^3+7*c^2+32*c+13)*a[n+4]-2*(c^2+1)*(c^3*n^5+c*n^5-3*c^4*n^4+12*c^3*n^4+4*c^2*n^4+12*c*n^4-n^4+2*c^5*n^3-30*c^4*n^3+55*c^3*n^3+40*c^2*n^3+53*c*n^3-10*n^3+2*c^6*n^2+18*c^5*n^2-119*c^4*n^2+120*c^3*n^2+154*c^2*n^2+102*c*n^2-37*n^2-3*c^7*n+6*c^6*n+59*c^5*n-192*c^4*n+131*c^3*n+242*c^2*n+69*c*n-56*n+c^8-6* 32 | c^7+6*c^6+62*c^5-100*c^4+62*c^3+122*c^2-6*c-29)*a[n+3]+(c^4*n^6+2*c^2*n^6+n^6+15*c^4*n^5+30*c^2*n^5+15*n^5-9*c^6*n^4+ 33 | 124*c^4*n^4+163*c^2*n^4+94*n^4+16*c^7*n^3-90*c^6*n^3-64*c^5*n^3+615*c^4*n^3+48*c^3*n^3+380*c^2*n^3+315*n^3-9*c^8*n^2+120*c^7* 34 | n^2-291*c^6*n^2-408*c^5*n^2+1653*c^4*n^2+264*c^3*n^2+287*c^2*n^2+24*c*n^2+592*n^2-45*c^8*n+296*c^7*n-330*c^6*n-824*c^5*n 35 | +2140*c^4*n+408*c^3*n-190*c^2*n+120*c*n+585*n+c^10-49*c^8+240*c^7-62*c^6-528*c^5+1030*c^4+144*c^3-259*c^2+144*c 36 | +235)*a[n+2]-2*(n+2)*(c^4*n^5-n^5-3*c^5*n^4+13*c^4*n^4+10*c^3*n^4-3*c*n^4-13*n^4+2*c^6*n^3-30*c^5*n^3+51*c^4*n^3+100*c^3*n^3+14*c^2*n^3-30*c*n^3-67*n^3+2*c^7*n^2+12*c^6*n^2-103*c^5*n^2+71*c^4*n^2+348*c^3*n^2+84*c^2*n^2-107*c*n^2-167*n^2-3*c^8*n+14 37 | *c^7*n+20*c^6*n-136*c^5*n+24*c^4*n+486*c^3*n+156*c^2*n-164*c*n-197*n+c^9-9*c^8+28*c^7+6*c^6-42*c^5+220*c^3+90*c^2- 38 | 95*c-87)*a[n+1]+(c^2+1)*(n+1)*(n+2)*(c^2*n^4+n^4-4*c^3*n^3+12*c^2*n^3+4*c*n^3+12*n^3+6*c^4*n^2-36*c^3*n^2+45*c^2*n^2+ 39 | 36*c*n^2+55*n^2-4*c^5*n+36*c^4*n-104*c^3*n+66*c^2*n+108*c*n+110*n+c^6-12*c^5+57*c^4-96*c^3+39*c^2+108*c+79)*a[n]= 40 | 0, a[n],C); 41 | 42 | "sumhyperRE to generate holonomic recurrence equations."$ 43 | 44 | sumhyperRE([n!],a[n]); 45 | sumhyperRE([(1+sqrt(5))^n/2^n,(1-sqrt(5))^n/2^n],a[n]); 46 | sumhyperRE([pochhammer(1/2,n),pochhammer(1/3,n),pochhammer(1/4,n)],a[n]); 47 | sumhyperRE([cos(x)^n,(-1)/n!,(3)^n*n!],a[n]); 48 | sumhyperRE([7^n,(-%i)^n/(2*n!),%i^n/(2*n!)],a[n]); 49 | 50 | "dispersionSet to compute the dispersion set of two polynomials."$ 51 | 52 | dispersionSet((n-1)*(n+2),(n+3)^2,n); 53 | dispersionSet(n-%i,n^2+1,n,C); 54 | -------------------------------------------------------------------------------- /bertrand-teguia/Hypergeometric-Term-Holonomic-REs/README.md: -------------------------------------------------------------------------------- 1 | A Maxima package to efficiently compute a basis of the subspace of hypergeometric term solutions of any holonomic recurrence equation. Recurrence equations with rational coefficients are also considered. 2 | 3 | The file HyperTermHoloRE.mac is the package (source code); 4 | 5 | The file HyperTermHoloRE.dem is a demo file; 6 | 7 | The file HyperTermHoloRE.texi is the texinfo source code of the package; 8 | 9 | The file HyperTermHoloRE.pdf is the pdf documentation obtained from HyperTermHoloRE.texi; 10 | 11 | The file test_HyperTermHoloRE.mac is a Maxima test file of the package; 12 | 13 | The file testREs.mac is a file of some recurrence equations used in test_HyperTermHoloRE.mac. 14 | -------------------------------------------------------------------------------- /bertrand-teguia/Hypergeometric-Term-Holonomic-REs/test_HyperTermHoloRE.mac: -------------------------------------------------------------------------------- 1 | (load("HyperTermHoloRE.mac"),o); 2 | o$ 3 | 4 | sumhyperRE([n!],a[n]); 5 | (n+1)*a[n]-a[n+1]=0$ 6 | sumhyperRE([n/n!,n^2/n!,n^3/n!],a[n]); 7 | -n*(n+1)*(n+2)*a[n+3]+3*n*(n+1)*a[n+2]-3*n*a[n+1]+a[n]=0$ 8 | sumhyperRE([pochhammer(1/2,n),pochhammer(1/3,n),pochhammer(1/4,n)],a[n]); 9 | (-24)*a[n+3]+2*(36*n+49)*a[n+2]+(-(72*n^2+124*n+59))*a[n+1] 10 | +(2*n+1)*(3*n+1)*(4*n+1)*a[n] 11 | = 0$ 12 | sumhyperRE([(1+%i)^n/(2*n!),(1-%i)^n/(2*n!)],a[n]); 13 | (n+1)*(n+2)*a[n+2]-2*(n+1)*a[n+1]+2*a[n]=0$ 14 | sumhyperRE([(-1/3)^n,(2*n+3)/(n+1)*(2/3)^n,n!],a[n]); 15 | 9*(n+4)*(54*n^4+441*n^3+1284*n^2+1569*n+664)*a[n+3]-3*(n+3)*(162*n^5+2025*n^4+9693*n^3+22101*n^2+23916*n+9760)*a[n+2]+(n+2)*(162*n^5+2025*n^4+9585*n^3+21300*n^2+21888*n+8104)*a[n+1]+2*(n+1)*(n+2)*(54*n^4+657*n^3+2931*n^2+5676*n+4012)*a[n]=0$ 16 | dispersionSet(n^2,n+1,n); 17 | {1}$ 18 | dispersionSet(n*(n-2)*(n-5),(n+1)*(n+4)^2,n); 19 | {1,3,4,6,9}$ 20 | dispersionSet(n^27-1,(n+2)^27-1,n); 21 | {2}$ 22 | dispersionSet((n+3)*(n+4)*(n+5),(n-1)*(n^2+2),n); 23 | {}$ 24 | dispersionSet(n-%i,n^2+1,n,C); 25 | {0}$ 26 | (load("testREs.mac"),o); 27 | o$ 28 | 29 | HypervanHoeij(RE[1],v[n]); 30 | {n/n!,n^2/n!,n^3/n!}$ 31 | HypervanHoeij(RE[2],v[n]); 32 | {((2*n+3)*2^(n-1))/((n+1)*3^n),(-1)^n/3^n}$ 33 | HypervanHoeij(RE[3],v[n]); 34 | {1/n!^2,1/n!,n!,n!^2}$ 35 | HypervanHoeij(RE[4],v[n]); 36 | {pochhammer(1/4,n),pochhammer(1/3,n),(2*n)!/(4^n*n!)}$ 37 | HypervanHoeij(RE[5],v[n]); 38 | {n+1,n!^2,(n^3+n^2+1)/(2*n)!}$ 39 | HypervanHoeij(RE[6],v[n]); 40 | {pochhammer(1/4,n)/(pochhammer(1/3,n)^4*n!^3),(2*n)!^5/(pochhammer(1/3,n)*pochhammer(3/4,n)^3*4^(5*n)*n!^4)}$ 41 | HypervanHoeij(RE[7],v[n]); 42 | {n!,(4^(3*n)*n!^5)/(2*n)!^3,((2*n+1)^3*(2*n+3)^3*4^(-3*n-3)*(2*n)!^3)/(pochhammer(1/3,n)^2*n!^3)}$ 43 | HypervanHoeij(RE[8],v[n]); 44 | {pochhammer(1/4,n)/(pochhammer(1/3,n)^4*n!^3),pochhammer(1/5,n)^2/(2*pochhammer(1/7,n)*(n+1)*n!),(2*n)!^5/(pochhammer(1/3,n)*pochhammer(3/4,n)^3*4^(5*n)*n!^4)}$ 45 | HypervanHoeij(RE[9],v[n]); 46 | {1/n!,(-1)^n/n!}$ 47 | HypervanHoeij(RE[10],v[n]); 48 | {}$ 49 | HypervanHoeij(RE[11],v[n],C); 50 | {(((-1)/a)^n*(2*n)!)/(4^n*n!^2)}$ 51 | HypervanHoeij(RE[12],v[n],C); 52 | {((-1)/(a+1))^n/((n-2)*(n-1)*n), 53 | (((-1)/a)^n*(n^2-2*a*n+(-3)*n+2*a^2+4*a+2))/((n-2)*(n-1)*n)}$ 54 | HypervanHoeij(RE[13],v[n],C); 55 | {((-1)/a)^n*(n+3*a+1)}$ 56 | HypervanHoeij(RE[14],v[n],C); 57 | {((-1)/(a+1))^n}$ 58 | HypervanHoeij(RE[15],v[n],C); 59 | {((-1)/(a-1))^n,((-1)/(a+1))^n,(((-a)-%i)/(a^2+1))^n,((%i-a)/(a^2+1))^n}$ 60 | HypervanHoeij(RE[16],v[n],C); 61 | {2^2*((-1)/a)^n,(4*((-1)/a)^n)/((n-1)*n)}$ 62 | HypervanHoeij(RE[17],v[n],C); 63 | {((-1)/a)^n/((n-4)*(n-3)*(n-2)*(n-1)*n)}$ 64 | HypervanHoeij(RE[18],v[n],C); 65 | {(-%i)^n/n!,(-1)^(n/2)/n!}$ 66 | HypervanHoeij(RE[19],v[n],C); 67 | {1/n!,(-%i)^n/n!,((sqrt(3)*%i-1)/2)^n/n!,((-(sqrt(3)*%i+1))/2)^n/n!,n/n!, 68 | (-1)^(n/2)/n!,(-1)^n/n!}$ 69 | HypervanHoeij(RE[20],v[n],C); 70 | {((-1)/(a-1))^n,((-1)/(a+1))^n}$ 71 | HypervanHoeij(RE[21],v[n],C); 72 | {(-%i)^n/n!,(-1)^(n/2)/n!}$ 73 | HypervanHoeij(RE[22],v[n],C); 74 | {((-1)/(a-1))^n,((-1)/(a+1))^n}$ 75 | HypervanHoeij(RE[23],v[n],C); 76 | {((-1)/(a-1))^n,((-1)/(a+1))^n,(-%i)^n/n!,(-1)^(n/2)/n!}$ 77 | HypervanHoeij(RE[24],v[n],C); 78 | {}$ 79 | HypervanHoeij(RE[25],v[n],C); 80 | {2*((-(sqrt(a)-a))/(sqrt(a)-1))^n*n!,(2*n!^2)/(n+1)}$ 81 | HypervanHoeij(RE[26],v[n],C); 82 | {(-sqrt(5))^n,3^(n/2),n!}$ 83 | HypervanHoeij(RE[27],v[n],C); 84 | {(2*(1-sqrt(7))^n*sqrt(7))/n!,(2*sqrt(7)*(sqrt(7)+1)^n)/((n+1)*n!)}$ 85 | 86 | -------------------------------------------------------------------------------- /robert-dodier/boxcar_convolution/boxcar_convolution.mac: -------------------------------------------------------------------------------- 1 | /* distribute 'integrate over "+" */ 2 | declare (nounify(integrate), linear); 3 | 4 | /* detect empty boxcars */ 5 | matchdeclare (cc1, constantp, cc2, lambda ([e], constantp(e) and e <= cc1)); 6 | matchdeclare (uu, mapatom); 7 | tellsimpafter (B[cc1, cc2](uu), 0); 8 | 9 | /* TO-DO: convert B[0, 1](x - t) --> B[x - 1, x](t) */ 10 | 11 | /* extract boxcars in integrand */ 12 | matchdeclare (aa, all); 13 | matchdeclare ([cc1, cc2], constantp); 14 | matchdeclare (uu, mapatom); 15 | matchdeclare (bb, lambda ([e], not freeof (B, e))); 16 | simp:false; 17 | tellsimpafter ('integrate(aa*bb, uu, cc1, cc2), FOO (aa, bb, uu, cc1, cc2)); 18 | simp:true; 19 | 20 | /* (1) collapse constant boxcars 21 | * (2) modify limits of integration using result of (1) 22 | * (3) extract variable boxcar and construct two integrals 23 | */ 24 | FOO (aa, bb, uu, cc1, cc2) := 25 | (collapse_Bconst (bb), 26 | if %% # false 27 | then [integrand, variable, lower_limit, upper_limit] : [aa*third(%%), uu, max (cc1, first (%%)), min (cc2, second (%%))] 28 | else [integrand, variable, lower_limit, upper_limit] : [aa*bb, uu, cc1, cc2], 29 | /* any remaining boxcars must be variable */ 30 | match_boxcar (integrand), 31 | if %% # false 32 | then extract_variable_boxcar (%%, variable, lower_limit, upper_limit) 33 | else 'integrate (integrand, variable, lower_limit, upper_limit)); 34 | 35 | Bconstp(e) := match_Bconst(e) # false; 36 | matchdeclare ([cc1, cc2], constantp); 37 | defmatch (match_Bconst, B[cc1, cc2](uu)); /* assume uu bound already */ 38 | matchdeclare (aa, all); 39 | matchdeclare (bb, Bconstp); 40 | /* return a list of [left, right, rest of stuff] */ 41 | defrule (collapse_Bconst, bb*aa, 42 | (if op(bb) = "*" then maplist (op, bb) else [op(bb)], 43 | [lmax (map (first, %%)), lmin (map (second, %%)), aa])); 44 | 45 | matchdeclare ([aa, bb, cc], all); 46 | defmatch (match_boxcar, aa*B[bb, cc](uu)); 47 | 48 | extract_variable_boxcar (eqns, variable, lower_limit, upper_limit) := block ([aa, bb, cc, uu, xx], 49 | [aa, bb, cc, uu] : map (lambda ([x], assoc (x, eqns)), '[aa, bb, cc, uu]), 50 | /* ASSUME CC - BB = UPPER_LIMIT - LOWER_LIMIT; SHOULD INCLUDE ALL CASES HERE !! */ 51 | /* ASSUME LINEAR EQUATIONS !! */ 52 | xx : first (listofvars ([bb, cc])), /* ASSUME EXACTLY ONE VARIABLE !! */ 53 | [[rhs (first (solve (lower_limit = cc, xx))), rhs (first (solve (upper_limit = cc, xx)))], 54 | [rhs (first (solve (lower_limit = bb, xx))), rhs (first (solve (upper_limit = bb, xx)))]], 55 | B[%%[1][1], %%[1][2]](xx) * 'integrate (aa, uu, lower_limit, cc) 56 | + B[%%[2][1], %%[2][2]](xx) * 'integrate (aa, variable, bb, upper_limit)); 57 | 58 | /* carry out iterations -- e = stuff already computed */ 59 | 60 | foo (e, n) := 61 | (for i thru n 62 | do 63 | (multthru (B[x - 1, x](t), subst (x=t, e)), 64 | integrate (%%, t, minf, inf), 65 | ev (%%, nouns), 66 | e : expand (%%)), 67 | e); 68 | -------------------------------------------------------------------------------- /robert-dodier/boxcar_convolution/boxcar_convolution_simpler.mac: -------------------------------------------------------------------------------- 1 | /* simpler approach for convolution of boxcar1*function1 with boxcar2*function2 */ 2 | 3 | declare (nounify (integrate), linear); 4 | 5 | matchdeclare ([aa, bb, cc, dd], freeof (vv)); 6 | matchdeclare ([uu, vv], mapatom); 7 | matchdeclare ([ee1, ee2], freeof (B)); 8 | 9 | /* this next rule might depends on "*" expressions being ordered a certain way, 10 | * such that B-stuff gets divided out before testing ee ... 11 | * as it stands it seems to work as expected, in limited testing, 12 | * but it is possible that it might stop working if the variables were named differently. 13 | */ 14 | 15 | tellsimpafter (conv (B[aa, bb](uu)*ee1, B[cc, dd](uu)*ee2)(vv), rewrite_conv (aa, bb, cc, dd, ee1, ee2, uu, vv)); 16 | 17 | rewrite_conv (a, b, c, d, e1, e2, u, v) := 18 | 19 | block ([new_integrand, left_boxcar, right_boxcar], 20 | /* apply 1-arg limit to clean up inf/minf */ 21 | left_boxcar: B[a, b](v - c)*B[a, limit (v - c)](u), 22 | right_boxcar: B[a, b](v - d)*B[limit (v - d), b](u), 23 | new_integrand: (left_boxcar + right_boxcar) * e1 * subst (u = v - u, e2), 24 | 'integrate (new_integrand, u, minf, inf)); 25 | 26 | /* not sure if this has the right effect -- might depend on the order 27 | * in which variables are matched, specifically because uu might not 28 | * be known when aa, bb, cc, and dd are matched 29 | */ 30 | matchdeclare ([aa, bb, cc, dd], freeof (uu)); 31 | 32 | simp: false; /* prevent ee1 from getting pulled out of 'integrate */ 33 | tellsimpafter ('integrate (B[aa, bb](uu)*ee1, uu, cc, dd), if aa <= dd and bb >= cc then 'integrate (ee1, uu, max (aa, cc), min (bb, dd)) else 0); 34 | simp: true; 35 | 36 | load ("multiadditive"); 37 | declare (conv, multiadditive); 38 | 39 | matchdeclare (cc, constantp); 40 | matchdeclare (aa, all); 41 | matchdeclare (xx, all); 42 | tellsimpafter ((aa + cc)(xx), cc + (if not atom(aa) and op(aa) = "+" then map (lambda ([e], e(xx)), aa) else aa(xx))); 43 | 44 | matchdeclare ([aa, bb], all); 45 | matchdeclare (yy, lambda ([e], e # 0 and constantp(e))); 46 | matchdeclare (xx, mapatom); 47 | /* apply 1-arg limit to clean up inf/minf */ 48 | tellsimpafter (B[aa, bb](xx + yy), B[limit (aa - yy), limit (bb - yy)](xx)); 49 | tellsimpafter (B[minf, inf](aa), 1); 50 | tellsimpafter (B[aa, aa](bb), 0); 51 | 52 | /* not sure yet if it makes sense to test assumptions on every resimplification. 53 | * maybe it does, I just don't know yet. 54 | * in the meantime, put it in a separate function. 55 | */ 56 | 57 | matchdeclare (xx, lambda ([e], e >= aa and e <= bb)); 58 | defrule (rule_simplify_boxcar, B[aa, bb](xx), 1); 59 | 60 | simplify_boxcar (e) := apply1 (e, rule_simplify_boxcar); 61 | 62 | /* 63 | * 64 | /* now try repeated convolution of B[0, 1](t) */ 65 | 66 | conv1: B[0, 1](x); 67 | conv (B[0, 1](t), B[0, 1](t))(x); 68 | conv2: expand (%, 0, 0); /* some rules didn't get applied so resimplify */ 69 | plot2d ([conv1, conv2], [x, -1, 3]), B[a, b](z) := if z >= a and z < b then 1 else 0; 70 | 71 | conv (subst (x = t, %), B[0, 1](t))(x); 72 | expand (%); 73 | %, nouns; 74 | conv3: expand (%); 75 | plot2d ([conv1, conv2, conv3], [x, -1, 4]), B[a, b](z) := if z >= a and z < b then 1 else 0; 76 | 77 | conv (subst (x = t, conv3), B[0, 1](t))(x); 78 | expand (%); 79 | %, nouns; 80 | conv4: expand (%); 81 | plot2d ([conv1, conv2, conv3, conv4], [x, -1, 5]), B[a, b](z) := if z >= a and z < b then 1 else 0; 82 | * 83 | */ 84 | -------------------------------------------------------------------------------- /robert-dodier/boxcar_convolution/repeated_convolution.mac: -------------------------------------------------------------------------------- 1 | /* recovered from https://maxima-discuss.narkive.com/t2FPfWJK/repeated-convolution-of-a-continous-uniform-distribution#post5 2 | * see also https://github.com/Observatorio-de-Matematica/Maxima-References/tree/main/mailing_list_2000-2016 3 | */ 4 | 5 | /* Copyright 2009-2024 by Robert Dodier. 6 | * I release this work under terms of the GNU General Public License, version 2. 7 | */ 8 | 9 | matchdeclare (aa,freeof(y), bb, freeof(y), nn, freeof(y), cc, freeof(y)); 10 | defmatch (trunc_mono, cc*y^nn*U(y - aa)*U(bb - y), y); 11 | 12 | hack (expr) := block ([m : length (expr), ss : 0], 13 | for k thru m do 14 | block ([term : part (expr, k), l], 15 | l : trunc_mono (term, x), 16 | new_term : cc*(bb^(nn + 1) - aa^(nn + 1))*U(bb - aa)/(nn + 1), 17 | /* print (k, l, new_term), */ 18 | ss : ss + new_term), 19 | return(ss)); 20 | 21 | f1(x) := U(x) - U(x-1); 22 | 23 | expr: expand (f1(x)*f1(y - x)); 24 | 25 | f2(y) := ''(hack (expr)); 26 | 27 | expr: expand (f2(x)*f2(y - x)); 28 | 29 | f4(y) := ''(hack (expr)); 30 | 31 | expr: expand (f4(x)*f4(y - x)); 32 | 33 | f8(y) := ''(hack (expr)); 34 | 35 | expr: expand (f8(x)*f8(y - x)) $ 36 | 37 | f16(y) := ''(hack (expr)) $ 38 | 39 | linel : 80; 40 | 41 | grind (ratsimp (f2 (x))); 42 | grind (ratsimp (f4 (x))); 43 | grind (ratsimp (f8 (x))); 44 | grind (ratsimp (f16 (x))); 45 | 46 | U(x) := if x >= 0 then 1 else 0; 47 | 48 | plot2d ([f2, f4, f8, f16], [x, 0, 16], [plot_format, gnuplot], [png_file, "./repeated_convolution_plot.png"]); 49 | -------------------------------------------------------------------------------- /robert-dodier/boxcar_convolution/repeated_convolution_plot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maxima-project-on-github/maxima-packages/6763e487b201eb00ab6e64d68087f184c6b31042/robert-dodier/boxcar_convolution/repeated_convolution_plot.png -------------------------------------------------------------------------------- /robert-dodier/boxcar_convolution/trunc_mono.mac: -------------------------------------------------------------------------------- 1 | /* Copyright 2009 by Robert Dodier. 2 | * I release this work under terms of the GNU General Public License. 3 | */ 4 | matchdeclare (aa,freeof(y), bb, freeof(y), nn, freeof(y), cc, freeof(y)); 5 | defmatch (trunc_mono, cc*y^nn*U(y - aa)*U(bb - y), y); 6 | 7 | hack (expr) := block ([m : length (expr), ss : 0], 8 | for k thru m do 9 | block ([term : part (expr, k), l], 10 | l : trunc_mono (term, x), 11 | new_term : cc*(bb^(nn + 1) - aa^(nn + 1))*U(bb - aa)/(nn + 1), 12 | /* print (k, l, new_term), */ 13 | ss : ss + new_term), 14 | return(ss)); 15 | 16 | f1(x) := U(x) - U(x-1); 17 | 18 | expr: expand (f1(x)*f1(y - x)); 19 | 20 | f2(y) := ''(hack (expr)); 21 | 22 | expr: expand (f2(x)*f2(y - x)); 23 | 24 | f4(y) := ''(hack (expr)); 25 | 26 | expr: expand (f4(x)*f4(y - x)); 27 | 28 | f8(y) := ''(hack (expr)); 29 | 30 | linel : 80; 31 | 32 | grind (ratsimp (f2 (x))); 33 | grind (ratsimp (f4 (x))); 34 | grind (ratsimp (f8 (x))); 35 | 36 | plot2d ([f2, f4, f8], [x, 0, 8], [plot_format, gnuplot]), U(x) := if x >= 0 then 1 else 0; 37 | 38 | -------------------------------------------------------------------------------- /robert-dodier/catchable_syntax_error/README.md: -------------------------------------------------------------------------------- 1 | ## About catchable\_syntax\_error 2 | 3 | This is an alternative implementation of the internal Lisp function 4 | MREAD-SYNERR, which is called by the Maxima parser to handle syntax 5 | errors. This implementation allows `errcatch` to catch syntax errors, 6 | while the default implementation of MREAD-SYNERR does not allow 7 | `errcatch` to catch syntax errors. 8 | 9 | This is just one possible implementation. It has the defect that it 10 | changes MREAD-SYNERR to not output line number information when a 11 | syntax error is detected. It seems plausible that the line number 12 | info could be preserved, but I couldn't figure it out. 13 | 14 | ### Examples 15 | 16 | Here's an example. The file `foo.mac` contains a syntax error: 17 | `2 x;` instead of `2*x;` 18 | 19 | ``` 20 | (%i1) load ("foo.mac"); 21 | incorrect syntax: x is not an infix operator 22 | 2 x; 23 | ^ 24 | (%i2) 25 | ``` 26 | 27 | OK, I'll try to catch the error with `errcatch`. 28 | 29 | ``` 30 | (%i2) errcatch (load ("foo.mac")); 31 | incorrect syntax: x is not an infix operator 32 | 2 x; 33 | ^ 34 | (%i3) 35 | ``` 36 | 37 | Rats! The syntax error has bypassed `errcatch` and gone straight back 38 | to the input prompt; I was hoping that `errcatch` would return `[]` as 39 | it always does when it catches an error. 40 | 41 | Now try it with the new implementation of MREAD-SYNERR. `errcatch` 42 | catches the syntax error. 43 | 44 | ``` 45 | (%i3) load ("catchable_syntax_error.lisp") $ 46 | (%i4) errcatch (load ("foo.mac")); 47 | syntax error: x is not an infix operator 48 | (%o4) [] 49 | ``` 50 | 51 | I'll use the catchable syntax error to create a function `safe_load` to 52 | return `OOPS()` to indicate an error. 53 | 54 | ``` 55 | (%i5) safe_load (f) := (errcatch (load (f)), if %% = [] then OOPS(f) else first(%%)); 56 | (%o5) safe_load(f) := (errcatch(load(f)), 57 | if %% = [] then OOPS(f) else first(%%)) 58 | (%i6) safe_load ("foo.mac"); 59 | syntax error: x is not an infix operator 60 | (%o6) OOPS(foo.mac) 61 | ``` 62 | 63 | Syntax errors can be caused by `parse_string` (and also `eval_string`) 64 | and `errcatch` catches them. 65 | 66 | ``` 67 | (%i7) errcatch (parse_string ("foo bar")); 68 | syntax error: bar is not an infix operator 69 | (%o7) [] 70 | ``` 71 | 72 | After a syntax error is detected (by any function), the global variable 73 | `error` contains the error message (which is also printed on the console 74 | when the error occurs). 75 | 76 | ``` 77 | (%i8) error; 78 | (%o8) [syntax error: bar is not an infix operator] 79 | ``` 80 | 81 | These examples were generated with Maxima 5.43.0. I think it this should 82 | work with any version which is not too old, but I didn't specifically 83 | test to see which versions work. 84 | -------------------------------------------------------------------------------- /robert-dodier/catchable_syntax_error/catchable_syntax_error.lisp: -------------------------------------------------------------------------------- 1 | ;; catchable_syntax_error.lisp 2 | ;; copyright 2019 by Robert Dodier 3 | ;; I release this work under terms of the GNU General Public License v2 4 | 5 | ;; Helper for MREAD-SYNERR. 6 | ;; Adapted from local function PRINTER in built-in MREAD-SYNERR. 7 | 8 | (defun mread-synerr-printer (x) 9 | (cond ((symbolp x) 10 | (print-invert-case (stripdollar x))) 11 | ((stringp x) 12 | (maybe-invert-string-case x)) 13 | (t x))) 14 | 15 | ;; Punt to Maxima function 'error' so that syntax errors can be caught by 'errcatch'. 16 | ;; This definition replaces the built-in MREAD-SYNERR 17 | ;; which throws to the top level of the interpreter in a way which cannot 18 | ;; be intercepted by 'errcatch'. 19 | ;; 20 | ;; After a syntax error is detected, the global variable 'error' 21 | ;; contains the error message (which is also printed on the console 22 | ;; when the error occurs). 23 | ;; 24 | ;; Aside from punting to 'error', this implementation doesn't try to 25 | ;; do anything else which the built-in MREAD-SYNERR does. In particular 26 | ;; this implementation doesn't try to output any input-line information. 27 | 28 | (defun mread-synerr (format-string &rest l) 29 | (let* 30 | ((format-string-1 (concatenate 'string "syntax error: " format-string)) 31 | (format-string-args (mapcar #'mread-synerr-printer l)) 32 | (message-string (apply #'format nil format-string-1 format-string-args))) 33 | (declare (special *parse-stream*)) 34 | (when (eql *parse-stream* *standard-input*) 35 | (read-line *parse-stream* nil nil)) 36 | ($error message-string))) 37 | -------------------------------------------------------------------------------- /robert-dodier/catchable_syntax_error/foo.mac: -------------------------------------------------------------------------------- 1 | 2 x; 2 | -------------------------------------------------------------------------------- /robert-dodier/chebyshev_primality/README.md: -------------------------------------------------------------------------------- 1 | ### Summary 2 | 3 | This package, `chebyshev_primality`, contains functions to experiment with a method 4 | of testing primality via Chebyshev polynomials. 5 | 6 | ### Usage 7 | 8 | Load `chebyshev_primality` and test some possible primes: 9 | 10 | ```{maxima} 11 | (%i1) load ("/home/robert/.maxima/mixima/mixima.mac"); 12 | mixima version 0.25 loaded. 13 | (%o1) /home/robert/.maxima/mixima/mixima.mac 14 | (%i2) load ("chebyshev_primality.mac"); 15 | (%o2) chebyshev_primality.mac 16 | (%i3) makelist (isprime (2^n - 1), n, 1, 20); 17 | (%o3) [false, true, true, false, true, false, true, false, 18 | false, false, false, false, true, false, false, false, true, 19 | false, true, false] 20 | ``` 21 | 22 | Compare the result to the built-in function `primep`: 23 | 24 | ```{maxima} 25 | (%i4) makelist (primep (2^n - 1), n, 1, 20); 26 | (%o4) [false, true, true, false, true, false, true, false, 27 | false, false, false, false, true, false, false, false, true, 28 | false, true, false] 29 | (%i5) is (%o4 = %o3); 30 | (%o5) true 31 | ``` 32 | 33 | ### Original Mathematica version 34 | 35 | The original version of this code was written for Mathematica by Mamuka Jibladze. 36 | See: https://mathoverflow.net/questions/286304/chebyshev-polynomials-of-the-first-kind-and-primality-testing 37 | and: https://mathoverflow.net/users/41291/%e1%83%9b%e1%83%90%e1%83%9b%e1%83%a3%e1%83%99%e1%83%90-%e1%83%af%e1%83%98%e1%83%91%e1%83%9a%e1%83%90%e1%83%ab%e1%83%94 38 | 39 | Copied here under terms of the Creative Commons Share-Alike license 40 | (https://creativecommons.org/licenses/by-sa/4.0/) 41 | as specified by the Stack Overflow Public Network Terms of Service 42 | (https://stackoverflow.com/legal/terms-of-service#licensing). 43 | 44 | ### Maxima translation 45 | 46 | This translation to Maxima was carried out by the Mixima translator, 47 | by John Lapeyre, with minor modifications by Robert Dodier; 48 | see: https://github.com/maxima-project-on-github/mixima 49 | As a derived work of the original Mathematica version, 50 | this translation is covered by the same license (namely CC-SA). 51 | 52 | ```{maxima} 53 | load ("/home/robert/.maxima/mixima/mixima.mac"); 54 | with_stdout ("chebyshev_primality.mac", 55 | miximaTransFile("chebyshev_primality.m")); 56 | ``` 57 | 58 | The function `miximaTransFile` prints the Maxima translation 59 | of the Mathematica file `chebyshev_primality.m"` 60 | and I collected that output to a file via `with_stdout`. 61 | I then loaded it into Maxima via `batch`, 62 | and reformatted it in a manner which is slightly easier to read via `grind` 63 | (these additional steps are not shown above). 64 | The output of `grind` is almost entirely what is found in `chebyshev_primality.mac`, 65 | with only a minor modification to change `n = 2` to `is(n = 2)` to ensure a Boolean result. 66 | -------------------------------------------------------------------------------- /robert-dodier/chebyshev_primality/chebyshev_primality.m: -------------------------------------------------------------------------------- 1 | (* Original from: https://mathoverflow.net/questions/286304/chebyshev-polynomials-of-the-first-kind-and-primality-testing 2 | * Written by Mamuka Jibladze 3 | * (https://mathoverflow.net/users/41291/%e1%83%9b%e1%83%90%e1%83%9b%e1%83%a3%e1%83%99%e1%83%90-%e1%83%af%e1%83%98%e1%83%91%e1%83%9a%e1%83%90%e1%83%ab%e1%83%94) 4 | * Copied here under terms of the Creative Commons Share-Alike license 5 | * (https://creativecommons.org/licenses/by-sa/4.0/) 6 | * as specified by the Stack Overflow Public Network Terms of Service 7 | * (https://stackoverflow.com/legal/terms-of-service#licensing) 8 | *) 9 | 10 | polmul[f_, g_, r_, n_] := Mod[f.NestList[RotateRight, g, r - 1], n] 11 | 12 | matmul[a_, b_, r_, n_] := Mod[ 13 | {{polmul[a[[1, 1]], b[[1, 1]], r, n] + polmul[a[[1, 2]], b[[2, 1]], r, n], 14 | polmul[a[[1, 1]], b[[1, 2]], r, n] + polmul[a[[1, 2]], b[[2, 2]], r, n]}, 15 | {polmul[a[[2, 1]], b[[1, 1]], r, n] + polmul[a[[2, 2]], b[[2, 1]], r, n], 16 | polmul[a[[2, 1]], b[[1, 2]], r, n] + polmul[a[[2, 2]], b[[2, 2]], r, n]}}, n] 17 | 18 | matsq[a_, r_, n_] := matmul[a, a, r, n] 19 | 20 | matpow[a_, k_, r_, n_] := If[k == 1, a, 21 | If[EvenQ[k], 22 | matpow[matsq[a, r, n], k/2, r, n], 23 | matmul[a, matpow[matsq[a, r, n], (k - 1)/2, r, n], r, n] 24 | ] 25 | ] 26 | 27 | xmat[r_, n_] := 28 | {{PadRight[{0, 2}, r], PadRight[{n - 1}, r]}, 29 | {PadRight[{1}, r], ConstantArray[0, r]}} 30 | 31 | isprime[n_] := With[{r = smallestr[n]}, 32 | If[r == 0, n == 2, 33 | With[{xp = matpow[xmat[r, n], n - 1, r, n]}, 34 | Mod[RotateRight[xp[[1, 1]]] + xp[[1, 2]], n] 35 | === PadRight[Append[ConstantArray[0, Mod[n, r]], 1], r] 36 | ] 37 | ] 38 | ] 39 | 40 | smallestr[n_] := Module[{r}, 41 | If[n==1 || EvenQ[n], Return[0]]; 42 | For[r = 3, MemberQ[{0, 1, r - 1}, Mod[n, r]], r = NextPrime[r + 1], 43 | If[r < n && Mod[n, r] == 0, Return[0]] 44 | ]; 45 | r 46 | ] 47 | -------------------------------------------------------------------------------- /robert-dodier/chebyshev_primality/chebyshev_primality.m-original: -------------------------------------------------------------------------------- 1 | (* Original from: https://mathoverflow.net/questions/286304/chebyshev-polynomials-of-the-first-kind-and-primality-testing 2 | * Written by Mamuka Jibladze 3 | * (https://mathoverflow.net/users/41291/%e1%83%9b%e1%83%90%e1%83%9b%e1%83%a3%e1%83%99%e1%83%90-%e1%83%af%e1%83%98%e1%83%91%e1%83%9a%e1%83%90%e1%83%ab%e1%83%94) 4 | * Copied here under terms of the Creative Commons Share-Alike license 5 | * (https://creativecommons.org/licenses/by-sa/4.0/) 6 | * as specified by the Stack Overflow Public Network Terms of Service 7 | * (https://stackoverflow.com/legal/terms-of-service#licensing) 8 | *) 9 | 10 | polmul[f_, g_, r_, n_] := Mod[f.NestList[RotateRight, g, r - 1], n] 11 | 12 | matmul[a_, b_, r_, n_] := Mod[ 13 | {{polmul[a[[1, 1]], b[[1, 1]], r, n] + polmul[a[[1, 2]], b[[2, 1]], r, n], 14 | polmul[a[[1, 1]], b[[1, 2]], r, n] + polmul[a[[1, 2]], b[[2, 2]], r, n]}, 15 | {polmul[a[[2, 1]], b[[1, 1]], r, n] + polmul[a[[2, 2]], b[[2, 1]], r, n], 16 | polmul[a[[2, 1]], b[[1, 2]], r, n] + polmul[a[[2, 2]], b[[2, 2]], r, n]}}, n] 17 | 18 | matsq[a_, r_, n_] := matmul[a, a, r, n] 19 | 20 | matpow[a_, k_, r_, n_] := If[k == 1, a, 21 | If[EvenQ[k], 22 | matpow[matsq[a, r, n], k/2, r, n], 23 | matmul[a, matpow[matsq[a, r, n], (k - 1)/2, r, n], r, n] 24 | ] 25 | ] 26 | 27 | xmat[r_, n_] := 28 | {{PadRight[{0, 2}, r], PadRight[{n - 1}, r]}, 29 | {PadRight[{1}, r], ConstantArray[0, r]}} 30 | 31 | isprime[n_] := With[{r = smallestr[n]}, 32 | If[r == 0, n == 2, 33 | With[{xp = matpow[xmat[r, n], n - 1, r, n]}, 34 | Mod[RotateRight[xp[[1, 1]]] + xp[[1, 2]], n] 35 | === PadRight[Append[ConstantArray[0, Mod[n, r]], 1], r] 36 | ] 37 | ] 38 | ] 39 | 40 | smallestr[n_] := Module[{r}, 41 | If[n==1 \[Or] EvenQ[n], Return[0]]; 42 | For[r = 3, MemberQ[{0, 1, r - 1}, Mod[n, r]], r = NextPrime[r + 1], 43 | If[r < n \[And] Mod[n, r] == 0, Return[0]] 44 | ]; 45 | r 46 | ] 47 | -------------------------------------------------------------------------------- /robert-dodier/chebyshev_primality/chebyshev_primality.mac: -------------------------------------------------------------------------------- 1 | /* Original from: https://mathoverflow.net/questions/286304/chebyshev-polynomials-of-the-first-kind-and-primality-testing 2 | * Written by Mamuka Jibladze 3 | * (https://mathoverflow.net/users/41291/%e1%83%9b%e1%83%90%e1%83%9b%e1%83%a3%e1%83%99%e1%83%90-%e1%83%af%e1%83%98%e1%83%91%e1%83%9a%e1%83%90%e1%83%ab%e1%83%94) 4 | * Copied here under terms of the Creative Commons Share-Alike license 5 | * (https://creativecommons.org/licenses/by-sa/4.0/) 6 | * as specified by the Stack Overflow Public Network Terms of Service 7 | * (https://stackoverflow.com/legal/terms-of-service#licensing) 8 | * 9 | * This translation to Maxima was carried out by the Mixima translator, 10 | * by John Lapeyre, with minor modifications by Robert Dodier; 11 | * see: https://github.com/maxima-project-on-github/mixima 12 | * As a derived work of the original Mathemtica version, 13 | * this translation is covered by the same license (namely CC-SA). 14 | */ 15 | 16 | polmul(f,g,r,n):=Mod(Dot(f,NestList(RotateRight,g,r-1)),n)$ 17 | 18 | matmul(a,b,r,n):=Mod( 19 | [[polmul(Part(a,1,1),Part(b,1,1),r,n) 20 | +polmul(Part(a,1,2),Part(b,2,1),r,n), 21 | polmul(Part(a,1,1),Part(b,1,2),r,n) 22 | +polmul(Part(a,1,2),Part(b,2,2),r,n)], 23 | [polmul(Part(a,2,1),Part(b,1,1),r,n) 24 | +polmul(Part(a,2,2),Part(b,2,1),r,n), 25 | polmul(Part(a,2,1),Part(b,1,2),r,n) 26 | +polmul(Part(a,2,2),Part(b,2,2),r,n)]],n)$ 27 | 28 | matsq(a,r,n):=matmul(a,a,r,n)$ 29 | 30 | matpow(a,k,r,n):=If(k = 1,a, 31 | If(EvenQ(k),matpow(matsq(a,r,n),(k*1)/2,r,n), 32 | matmul(a,matpow(matsq(a,r,n),((k-1)*1)/2,r,n),r,n)))$ 33 | 34 | xmat(r,n):=[[PadRight([0,2],r),PadRight([n-1],r)], 35 | [PadRight([1],r),ConstantArray(0,r)]]$ 36 | 37 | isprime(n):=With([r => smallestr(n)], 38 | If(r = 0, is(n = 2), 39 | With([xp => matpow(xmat(r,n),n-1,r,n)], 40 | SameQ(Mod(RotateRight(Part(xp,1,1))+Part(xp,1,2),n), 41 | PadRight(Append(ConstantArray(0,Mod(n,r)),1),r)))))$ 42 | 43 | smallestr(n):=Module([r], 44 | (If(n = 1 or EvenQ(n),Return(0)), 45 | For(r => 3,MemberQ([0,1,r-1],Mod(n,r)),r => NextPrime(r+1), 46 | If(r < n and Mod(n,r) = 0,Return(0))),r))$ 47 | -------------------------------------------------------------------------------- /robert-dodier/combining_diacritics/README.md: -------------------------------------------------------------------------------- 1 | % Package `combining_diacritics` 2 | % Robert Dodier 3 | % Aug. 26, 2024 4 | 5 | Package `combining_diacritics` implements a way to type in an ASCII-only name 6 | and get a name with a diacritical mark (accents, etc) in return. 7 | For example, to type in `yhat` and get `ŷ`. 8 | From that point forward, `yhat` is forgotten and only `ŷ` exists in the Maxima session. 9 | 10 | The diacritical marks are Unicode combining characters. 11 | The name of the symbol `ŷ` actually comprises two characters, `y` and the character known as `#\COMBINING_CIRCUMFLEX_ACCENT`. 12 | At present (August 2024), four diacritics are defined: 13 | circumflex, centered dot above, macron (short overline), and right arrow above. 14 | Each diacritic is represented as 1-character string, 15 | namely `combining_circumflex`, `combining_dot`, `combining_macron`, and `combining_arrow`. 16 | 17 | The function `define_input_alias` defines an input alias, 18 | taking three arguments: 19 | 20 | * `y`: symbol for the alias (this is the symbol which will appear in input) 21 | * `x`: symbol to which the diacritic will be applied 22 | * `diacritic`: one of the diacritic strings mentioned above 23 | 24 | E.g. `define_input_alias(yhat, y, combining_circumflex)` defines `yhat` as an input alias for `ŷ`. 25 | 26 | Example session: 27 | ```{maxima} 28 | (%i2) load ("combining_diacritics.lisp") $ 29 | (%i3) stringdisp: true $ 30 | (%i4) [combining_circumflex, combining_dot, combining_macron, combining_arrow]; 31 | (%o4) ["̂", "̇", "̄", "⃗"] 32 | (%i5) define_input_alias (yhat, y, combining_circumflex); 33 | (%o5) ŷ 34 | (%i6) define_input_alias (xbar, x, combining_macron); 35 | (%o6) x̄ 36 | (%i7) define_input_alias (zdot, z, combining_dot); 37 | (%o7) ż 38 | (%i8) define_input_alias (rarrow, r, combining_arrow); 39 | (%o8) r⃗ 40 | (%i9) yhat + xbar + zdot + rarrow; 41 | (%o9) ż + ŷ + x̄ + r⃗ 42 | (%i10) yhat: 123; 43 | (%o10) 123 44 | (%i11) xbar: 999; 45 | (%o11) 999 46 | (%i12) ''%o9; 47 | (%o12) ż + r⃗ + 1122 48 | (%i13) rarrow[n] - rarrow[1]^2; 49 | 2 50 | (%o13) r⃗ - r⃗ 51 | n 1 52 | ``` 53 | This last expression (%o13) illustrates a problem with the Maxima pretty printer console interface. 54 | The placement of elements within the display is determined from how many characters are in a symbol's name, 55 | not how much space the symbol actually occupies. 56 | For that reason, the superscript and subscripts are placed too far away from the symbols to which they pertain. 57 | 58 | Note that this scheme makes the input alias ephemeral and the symbol which has a name containing diacritics is permanent. 59 | It's also possible to preserve the input symbol throughout, and only change the way it is displayed to use diacritics. 60 | At this point, I believe it is too early to tell which scheme is more generally useful. 61 | 62 | This package requires a Unicode-aware Lisp. 63 | SBCL, ECL, Clozure CL, and CMUCL are Unicode-aware, 64 | and I believe this package will work with them. 65 | GCL is not Unicode-aware (as of GCL 2.6.14) so the package cannot work. 66 | -------------------------------------------------------------------------------- /robert-dodier/combining_diacritics/combining_diacritics.lisp: -------------------------------------------------------------------------------- 1 | ;; combining_diacritics.lisp -- create symbol containing a combining diacritic and an input alias for it 2 | ;; copyright 2024 by Robert Dodier 3 | ;; I release this work under terms of the GNU General Public License, Version 2. 4 | 5 | (defun stringify (c) (coerce (list c) 'string)) 6 | 7 | (defconstant $combining_circumflex (stringify #\combining_circumflex_accent)) 8 | (defconstant $combining_macron (stringify #\combining_macron)) 9 | (defconstant $combining_dot (stringify #\combining_dot_above)) 10 | (defconstant $combining_arrow (stringify #\combining_right_arrow_above)) 11 | 12 | (mfuncall '$declare $combining_circumflex '$alphabetic) 13 | (mfuncall '$declare $combining_macron '$alphabetic) 14 | (mfuncall '$declare $combining_dot '$alphabetic) 15 | (mfuncall '$declare $combining_arrow '$alphabetic) 16 | 17 | (defmfun $define_input_alias (y x diacritic) 18 | (let* 19 | ((x-diacritic-name ($sconcat x diacritic)) 20 | (x-diacritic-symbol (mfuncall '$parse_string x-diacritic-name))) 21 | (putprop y x-diacritic-symbol 'alias))) 22 | -------------------------------------------------------------------------------- /robert-dodier/complex_plots/README.md: -------------------------------------------------------------------------------- 1 | `complex_plots.mac` -- plot argument and magnitude via Gnuplot 2 | 3 | Template files adapted from examples at: `http://gnuplot.sourceforge.net/demo/complex_trig.html` 4 | slurp.lisp adapted from: `http://sodaware.sdf.org/notes/cl-read-file-into-string/` 5 | 6 | `complex_plots.mac` copyright 2020 by Robert Dodier 7 | I release this work under terms of the GNU General Public License. 8 | 9 | ### LIMITATIONS 10 | 11 | Current working directory when Maxima is launched must be the `complex_plots` directory. 12 | 13 | It is necessary to use 'batch' to read this file, not 'load'. 14 | This is due to the presence of :lisp in this file. 15 | 16 | Functions are specified in terms of `x + %i*y`, not a single variable z. 17 | 18 | Range is fixed at (-pi/2, pi/2) in x and in y. 19 | 20 | Some Maxima functions don't have an equivalent in Gnuplot, 21 | so attempting to plot those will cause an error in Gnuplot. 22 | 23 | Maxima doesn't clean up temporary files from complex plots upon program termination. 24 | 25 | All of this is really a proof of concept, no doubt there's more work to do. 26 | 27 | ### EXAMPLES 28 | 29 | ``` 30 | batch ("complex_plots.mac"); 31 | complex_plot_2d (atanh (x + %i*y)); 32 | complex_plot_3d (atanh (x + %i*y)); 33 | complex_plot_2d (2^(x + %i*y)); 34 | complex_plot_3d (2^(x + %i*y)); 35 | complex_plot_2d ((x + %i*y)^(5/2)); 36 | complex_plot_3d ((x + %i*y)^(5/2)); 37 | ``` 38 | 39 | -------------------------------------------------------------------------------- /robert-dodier/complex_plots/complex_plot_2d.template: -------------------------------------------------------------------------------- 1 | # Adapted from: http://gnuplot.sourceforge.net/demo/complex_trig.10.gnu 2 | # No license specified. 3 | # 4 | # set terminal pngcairo background "#ffffff" enhanced font "times" fontscale 1.0 size 640, 480 5 | # set output 'complex_trig.10.png' 6 | unset key 7 | set style increment default 8 | set view map scale 1 9 | set isosamples 100, 100 10 | set size ratio 1 1,1 11 | set style data lines 12 | set xtics norangelimit 13 | set xtics ("-π/2" -1.57080, "-π/4" -0.785398, "0" 0.00000, "π/4" 0.785398, "π/2" 1.57080) 14 | set ytics norangelimit 15 | set ytics ("-π/2" -1.57080, "-π/4" -0.785398, "0" 0.00000, "π/4" 0.785398, "π/2" 1.57080) 16 | set cbtics norangelimit 17 | set cbtics ("0" -3.14159, "2π" 3.14159) 18 | set title "~a" 19 | set urange [ -1.57080 : 1.57080 ] noreverse nowriteback 20 | set vrange [ -1.57080 : 1.57080 ] noreverse nowriteback 21 | set xrange [ -1.57080 : 1.57080 ] noreverse nowriteback 22 | set x2range [ * : * ] noreverse writeback 23 | set yrange [ -1.57080 : 1.57080 ] noreverse nowriteback 24 | set y2range [ * : * ] noreverse writeback 25 | set zrange [ * : * ] noreverse writeback 26 | set cblabel "Phase Angle" 27 | set cblabel offset character -2, 0, 0 font "" textcolor lt -1 rotate 28 | set cbrange [ -3.14159 : 3.14159 ] noreverse nowriteback 29 | set rrange [ * : * ] noreverse writeback 30 | set palette positive nops_allcF maxcolors 0 gamma 1.5 color model HSV 31 | set palette defined ( 0 0 1 1, 1 1 1 1 ) 32 | Hue(x,y) = (pi + atan2(-y,-x)) / (2*pi) 33 | phase(x,y) = hsv2rgb( Hue(x,y), sqrt(x**2+y**2), 1. ) 34 | rp(x,y) = real(f(x,y)) 35 | f(x,y) = ~a 36 | ip(x,y) = imag(f(x,y)) 37 | color(x,y) = hsv2rgb( Hue( rp(x,y), ip(x,y) ), abs(f(x,y)), 1. ) 38 | save_encoding = "utf8" 39 | ## Last datafile plotted: "++" 40 | splot '++' using 1:2:(color($1,$2)) with pm3d lc rgb variable 41 | -------------------------------------------------------------------------------- /robert-dodier/complex_plots/complex_plot_3d.template: -------------------------------------------------------------------------------- 1 | # Adapted from: http://gnuplot.sourceforge.net/demo/complex_trig.11.gnu 2 | # No license specified. 3 | # 4 | # set terminal pngcairo background "#ffffff" enhanced font "times" fontscale 1.0 size 640, 480 5 | # set output 'complex_trig.11.png' 6 | set border -1 front lt black linewidth 1.000 dashtype solid 7 | set grid nopolar 8 | set grid xtics nomxtics ytics nomytics noztics nomztics nortics nomrtics \ 9 | nox2tics nomx2tics noy2tics nomy2tics nocbtics nomcbtics 10 | set grid layerdefault lt 0 linecolor 0 linewidth 0.500, lt 0 linecolor 0 linewidth 0.500 11 | unset key 12 | set style increment default 13 | set view 66, 336, 1.2, 1.2 14 | set view equal xyz 15 | set isosamples 100, 100 16 | set size ratio 1 1,1 17 | set style data lines 18 | set xyplane at 0 19 | set xtics norangelimit 20 | set xtics ("-π/2" -1.57080, "-π/4" -0.785398, "0" 0.00000, "π/4" 0.785398, "π/2" 1.57080) 21 | set ytics norangelimit 22 | set ytics ("-π/2" -1.57080, "-π/4" -0.785398, "0" 0.00000, "π/4" 0.785398, "π/2" 1.57080) 23 | unset ztics 24 | set cbtics norangelimit 25 | set cbtics ("0" -3.14159, "2π" 3.14159) 26 | set title "~a" 27 | set urange [ -1.57080 : 1.57080 ] noreverse nowriteback 28 | set vrange [ -1.57080 : 1.57080 ] noreverse nowriteback 29 | set xlabel "Real" 30 | set xlabel offset character 0, -2, 0 font "" textcolor lt -1 rotate parallel 31 | set xrange [ -1.57080 : 1.57080 ] noreverse nowriteback 32 | set x2range [ * : * ] noreverse writeback 33 | set ylabel "Imaginary" 34 | set ylabel offset character 0, -2, 0 font "" textcolor lt -1 rotate parallel 35 | set yrange [ -1.57080 : 1.57080 ] noreverse nowriteback 36 | set y2range [ * : * ] noreverse writeback 37 | set zlabel "magnitude" 38 | set zlabel offset character 3, 0, 0 font "" textcolor lt -1 rotate 39 | set zrange [ * : * ] noreverse writeback 40 | set cblabel "Phase Angle" 41 | set cblabel offset character -2, 0, 0 font "" textcolor lt -1 rotate 42 | set cbrange [ -3.14159 : 3.14159 ] noreverse nowriteback 43 | set rrange [ * : * ] noreverse writeback 44 | set palette positive nops_allcF maxcolors 0 gamma 1.5 color model HSV 45 | set palette defined ( 0 0 1 1, 1 1 1 1 ) 46 | set colorbox user 47 | set colorbox vertical origin screen 0.85, 0.2 size screen 0.05, 0.6 front noinvert bdefault 48 | Hue(x,y) = (pi + atan2(-y,-x)) / (2*pi) 49 | phase(x,y) = hsv2rgb( Hue(x,y), sqrt(x**2+y**2), 1. ) 50 | rp(x,y) = real(f(x,y)) 51 | f(x,y) = ~a 52 | ip(x,y) = imag(f(x,y)) 53 | color(x,y) = hsv2rgb( Hue( rp(x,y), ip(x,y) ), abs(f(x,y)), 1. ) 54 | save_encoding = "utf8" 55 | ## Last datafile plotted: "++" 56 | splot '++' using 1:2:(abs(f($1,$2))):(color($1,$2)) with pm3d lc rgb variable 57 | -------------------------------------------------------------------------------- /robert-dodier/complex_plots/complex_plots.mac: -------------------------------------------------------------------------------- 1 | /* complex_plots.mac -- plot argument and magnitude via Gnuplot 2 | * 3 | * Template files adapted from examples at: http://gnuplot.sourceforge.net/demo/complex_trig.html 4 | * slurp.lisp adapted from: http://sodaware.sdf.org/notes/cl-read-file-into-string/ 5 | * 6 | * complex_plots.mac copyright 2020 by Robert Dodier 7 | * I release this work under terms of the GNU General Public License. 8 | * 9 | * LIMITATIONS: 10 | * 11 | * Current working directory when Maxima is launched must be the 'complex_plots' directory. 12 | * 13 | * It is necessary to use 'batch' to read this file, not 'load'. 14 | * This is due to the presence of :lisp in this file. 15 | * 16 | * Functions are specified in terms of x + %i*y, not a single variable z. 17 | * 18 | * Range is fixed at (-pi/2, pi/2) in x and in y. 19 | * 20 | * Some Maxima functions don't have an equivalent in Gnuplot, 21 | * so attempting to plot those will cause an error in Gnuplot. 22 | * 23 | * Maxima doesn't clean up temporary files from complex plots upon program termination. 24 | * 25 | * All of this is really a proof of concept, no doubt there's more work to do. 26 | * 27 | * EXAMPLES: 28 | * 29 | batch ("complex_plots.mac"); 30 | complex_plot_2d (atanh (x + %i*y)); 31 | complex_plot_3d (atanh (x + %i*y)); 32 | complex_plot_2d (2^(x + %i*y)); 33 | complex_plot_3d (2^(x + %i*y)); 34 | complex_plot_2d ((x + %i*y)^(5/2)); 35 | complex_plot_3d ((x + %i*y)^(5/2)); 36 | * 37 | */ 38 | 39 | complex_plot_2d (e) := 40 | block ([gnuplot_output_filename: complex_plot_generate_gnuplot (e, complex_plot_2d_template)], 41 | system (sconcat (gnuplot_command, " -persist ", gnuplot_output_filename)), 42 | gnuplot_output_filename); 43 | 44 | load ("slurp.lisp"); 45 | complex_plot_2d_template: slurp ("complex_plot_2d.template") $ 46 | 47 | complex_plot_generate_gnuplot (e, gnuplot_template) := 48 | block ([e1, gnuplot_output_filename], 49 | if symbolp(e) then e: fundef(e), 50 | e1: gnuplot_substitute (e), 51 | gnuplot_output_filename: sconcat (maxima_tempdir, "/", "maxima_complex_plot", 100 + random(900), ".gnuplot"), 52 | with_stdout (gnuplot_output_filename, 53 | printf (true, gnuplot_template, e, e1)), 54 | gnuplot_output_filename); 55 | 56 | gnuplot_substitute (e) := 57 | (subst (gnuplot_symbols, e), 58 | apply1 (%%, rbesj0, rbesj1, rbesy0, rbesy1, rexp, rexpt)); 59 | 60 | /* maybe there's more to be covered here */ 61 | gnuplot_symbols: '[%pi = pi, %i = {0, 1}, airy_ai = airy, carg = arg, 62 | elliptic_kc = EllipticK, elliptic_e = EllipticE, 63 | elliptic_pi = EllipticPi, ceiling = ceil, expintegral_e = expint, 64 | imagpart = imag, log_gamma = lgamma, /* right? */ 65 | realpart = real, signum = sgn, erf = cerf]; 66 | 67 | 68 | defrule (rbesj0, bessel_j (0, xx), besj0(xx)); 69 | defrule (rbesj1, bessel_j (1, xx), besj1(xx)); 70 | defrule (rbesy0, bessel_y (0, xx), besy0(xx)); 71 | defrule (rbesy1, bessel_y (1, xx), besy1(xx)); 72 | 73 | /* it's unreasonably difficult to convince Maxima to output %e^x as exp(x) */ 74 | /* plus a bug in parser: :lisp after comment causes error in batch(...) */ 75 | 123; 76 | :lisp (setf (get '$myexp 'reversealias) '$exp) 77 | matchdeclare (xx, all); 78 | defrule (rexp, %e^xx, myexp(x)); 79 | 80 | /* it's unreasonably difficult to convince Maxima to output x^y as x**y */ 81 | infix ("myexpt"); 82 | :lisp (setf (get '$myexpt 'dissym) '(#\* #\*)) 83 | matchdeclare ([xx, yy], all); 84 | defrule (rexpt, xx^yy, xx myexpt yy); 85 | 86 | complex_plot_3d_template: slurp ("complex_plot_3d.template") $ 87 | 88 | complex_plot_3d (e) := 89 | block ([gnuplot_output_filename: complex_plot_generate_gnuplot (e, complex_plot_3d_template)], 90 | system (sconcat (gnuplot_command, " -persist ", gnuplot_output_filename)), 91 | gnuplot_output_filename); 92 | 93 | -------------------------------------------------------------------------------- /robert-dodier/complex_plots/slurp.lisp: -------------------------------------------------------------------------------- 1 | ;; adapted from: http://sodaware.sdf.org/notes/cl-read-file-into-string 2 | (defun $slurp (filename) 3 | (with-open-file (stream filename) 4 | (let ((contents (make-string (file-length stream)))) 5 | (read-sequence contents stream) 6 | contents))) 7 | -------------------------------------------------------------------------------- /robert-dodier/constrained_mean_spline/constrained_mean_spline.mac: -------------------------------------------------------------------------------- 1 | /* constrained_mean_spline.mac -- construct a cubic spline to equal a specified mean value on each interval 2 | * 3 | * copyright 2024 by Robert Dodier 4 | * I release this work under terms of the GNU General Public License, version 2. 5 | */ 6 | 7 | S[i](u) := a[i] + b[i]*u + c[i]*u^2 + d[i]*u^3; 8 | 9 | /* data as stated in: https://stackoverflow.com/questions/79086802/monthly-data-to-daily-cubic-spline-interp */ 10 | 11 | x: [0, 31, 31 + 30, 31 + 30 + 31]; 12 | mu: [100, 150, 400]; 13 | n: length (mu); 14 | 15 | /* approximate data as shown in: https://stats.stackexchange.com/questions/263962/solid-line-from-a-local-average-series */ 16 | 17 | x: [0, 1/2, 1, 3/2, 2, 5/2, 3]; 18 | mu: [1, 9/10, 6/5, 9/5, 2, 7/5]; 19 | n: length (mu); 20 | 21 | /* mean value on each interval equals a specified value */ 22 | 23 | eqs_mu: ev (makelist ((integrate (S[i](u), u, x[i], x[i + 1]))/(x[i + 1] - x[i]) = mu[i], i, 1, n), expand); 24 | 25 | /* values at endpoints of intervals are equal */ 26 | 27 | eqs_0: makelist (S[i](x[i + 1]) = S[i + 1](x[i + 1]), i, 1, n - 1); 28 | 29 | /* first derivatives at endpoints of intervals are equal */ 30 | 31 | eqs_1: makelist (at (diff (S[i](u), u, 1), u = x[i + 1]) = at (diff (S[i + 1](u), u, 1), u = x[i + 1]), i, 1, n - 1); 32 | 33 | /* second derivatives at endpoints of intervals are equal */ 34 | 35 | eqs_2: makelist (at (diff (S[i](u), u, 2), u = x[i + 1]) = at (diff (S[i + 1](u), u, 2), u = x[i + 1]), i, 1, n - 1); 36 | 37 | /* At this point we have n + 3*(n - 1) = 4*n - 3 equations. 38 | * It's conventional to have second derivatives at the end equal to some value, such as zero. 39 | * That gives two more equations. 40 | */ 41 | 42 | eq_d2_0_left: at (diff (S[1](u), u, 2), u = x[1]) = 0; 43 | eq_d2_0_right: at (diff (S[n](u), u, 2), u = x[n + 1]) = 0; 44 | 45 | /* We're still short an equation. 46 | * Go ahead and solve the equations we have on hand; linsolve will introduce a free parameter that all the coeffcients depend on. 47 | * Augmented coefficient matrix isn't needed for linsolve, but it is interesting to examine. 48 | */ 49 | 50 | eqs: append (eqs_mu, eqs_0, eqs_1, eqs_2, [eq_d2_0_left, eq_d2_0_right]); 51 | 52 | listofvars (eqs); 53 | 54 | augcoefmatrix (eqs, listofvars (eqs)); 55 | 56 | solution: linsolve (eqs, listofvars (eqs)); 57 | 58 | free_parameter: first (listofvars (map (rhs, solution))); 59 | 60 | /* Let's say that the curvature must be minimal, curvature being defined as the integral of the square of the second derivative. 61 | */ 62 | 63 | curvature: expand (sum (integrate (diff (S[i](u), u, 2)^2, u, x[i], x[i + 1]), i, 1, n)); 64 | 65 | curvature_as_function_of_free_parameter: expand (subst (solution, curvature)); 66 | 67 | eq_curvature_minimum: diff (curvature_as_function_of_free_parameter, free_parameter) = 0; 68 | 69 | minimum_curvature_free_parameter: linsolve (eq_curvature_minimum, free_parameter); 70 | 71 | /* Now plot the solution assuming the free parameter minimizes curvature. 72 | */ 73 | 74 | legends: cons ('legend, map (lambda ([mu1, x1, x2], printf (false, "mean = ~a over [~a, ~a]", mu1, x1, x2)), mu, rest (x, -1), rest (x))); 75 | my_title: "Minimum-curvature cubic spline segments constrained to mean values"; 76 | 77 | minimum_curvature_solution: subst (minimum_curvature_free_parameter, solution); 78 | mininum_curvature_spline_segments: subst (minimum_curvature_solution, makelist (S[i](u), i, 1, n)); 79 | 80 | plot2d (mininum_curvature_spline_segments, [u, x[1], x[n + 1]], [title, my_title], legends, [svg_file, "./spline-segments.svg"]); 81 | 82 | spline_lambda_body: subst (minimum_curvature_solution, apply ("if", apply (append, makelist ([u >= x[i] and u < x[i + 1], S[i](u)], i, 1, n)))); 83 | minimum_curvature_spline_lambda: apply (lambda, [[u], spline_lambda_body]); 84 | 85 | steps_lambda_body: apply ("if", apply (append, makelist ([u >= x[i] and u < x[i + 1], mu[i]], i, 1, n))); 86 | steps_lambda: apply (lambda, [[u], steps_lambda_body]); 87 | 88 | plot2d ([minimum_curvature_spline_lambda, steps_lambda], [u, x[1], x[n + 1]], [title, "Minimum-curvature cubic spline constrained to mean values"], [legend, "Spline", "Mean values"], [svg_file, "./spline-and-mean-values.svg"]); 89 | -------------------------------------------------------------------------------- /robert-dodier/diff_sum/diff_sum.mac: -------------------------------------------------------------------------------- 1 | /* diff_sum.mac -- simplify 'diff('sum(f(x[i]), i,. ..), x[j]) 2 | * copyright 2013 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License 4 | */ 5 | 6 | put ('diff_sum, true, 'present); 7 | 8 | matchdeclare (mm, lambda ([e], not atom(e) and op(e)="*")); 9 | matchdeclare (xx, all); 10 | foo : 'diff(mm,xx); 11 | tellsimpafter (''foo, 12 | block([aa:args(mm), nn:length(mm)], 13 | sum (product (if jj=ii then 'diff(aa[ii], xx) else aa[jj], jj, 1, nn), ii, 1, nn))) ; 14 | 15 | find_subscripts (x, e) := block ([L : []], find_subscripts1 (x, e), unique (L)); 16 | find_subscripts1 (x, e) := block ([L1 : match_subscript (e, x)], 17 | if L1 = false 18 | then 19 | if not mapatom (e) 20 | then map (lambda ([ee], find_subscripts1 (x, ee)), e) 21 | else e 22 | else (push (rhs (first (L1)), L), e)); 23 | matchdeclare (xx, symbolp); 24 | matchdeclare (bb, all); 25 | defmatch (match_subscript, xx[bb], xx); 26 | push (a, b) ::= buildq ([a, b], b : cons (a, b)); 27 | 28 | matchdeclare (aa, all); 29 | matchdeclare (ii1, "<" (minf)); 30 | matchdeclare (nn, ">" (inf)); 31 | matchdeclare ([ii, xx], symbolp); 32 | matchdeclare (jj, all); 33 | 34 | simp : false $ 35 | 36 | tellsimpafter ('diff ('sum (aa, ii, ii1, nn), xx[jj], 1), 37 | block ([L, diff_summand], 38 | L : find_subscripts (xx, aa), 39 | /* diff_summand : apply ("+", makelist ('diff (aa, xx[j1], 1) * kron_delta (jj, j1), j1, L)), ?? */ 40 | diff_summand : apply ("+", makelist (diff (aa, xx[j1], 1) * kron_delta (jj, j1), j1, L)), 41 | buildq ([diff_summand, ii, ii1, nn], 42 | 'sum (diff_summand, ii, ii1, nn)))); 43 | 44 | simp : true $ 45 | 46 | /* Find subscripts of expressions such as x[i](t). 47 | * Dunno what to call it; "find_subscripts_with_function_calls" is clumsy and still not very precise. 48 | * "find_subscripts_2" it is, then. 49 | */ 50 | find_subscripts_2 (x, t, e) := block ([L : []], find_subscripts1_2 (x, t, e), unique (L)); 51 | find_subscripts1_2 (x, t, e) := block ([L1 : match_subscript_2 (e, x, t)], 52 | if L1 = false 53 | then 54 | if not mapatom (e) 55 | then map (lambda ([ee], find_subscripts1_2 (x, t, ee)), e) 56 | else e 57 | else (push (rhs (first (L1)), L), e)); 58 | matchdeclare ([xx, tt], symbolp); 59 | matchdeclare (bb, all); 60 | defmatch (match_subscript_2, xx[bb](tt), xx, tt); 61 | 62 | simp : false $ 63 | 64 | tellsimpafter ('diff ('sum (aa, ii, ii1, nn), xx[jj](tt), 1), 65 | block ([L, diff_summand], 66 | L : find_subscripts_2 (xx, tt, aa), 67 | /* diff_summand : apply ("+", makelist ('diff (aa, xx[j1](tt), 1) * kron_delta (jj, j1), j1, L)), ?? */ 68 | diff_summand : apply ("+", makelist (diff (aa, xx[j1](tt), 1) * kron_delta (jj, j1), j1, L)), 69 | buildq ([diff_summand, ii, ii1, nn], 70 | 'sum (diff_summand, ii, ii1, nn)))); 71 | 72 | simp : true $ 73 | -------------------------------------------------------------------------------- /robert-dodier/diff_sum/diff_sum2.mac: -------------------------------------------------------------------------------- 1 | /* diff_sum2.mac -- simplify 'diff('sum(sum(f(x[i, j]), i, ...), j, ...), x[i, j]) 2 | * copyright 2014 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License 4 | */ 5 | 6 | put ('diff_sum2, true, 'present); 7 | 8 | find_subscripts2 (x, e) := block ([L : []], find_subscripts21 (x, e), unique (L)); 9 | find_subscripts21 (x, e) := block ([L1 : match_subscript2 (e, x)], 10 | if L1 = false 11 | then 12 | if not mapatom (e) 13 | then map (lambda ([ee], find_subscripts21 (x, ee)), e) 14 | else e 15 | else (push ([assoc ('bb, L1), assoc ('cc, L1)], L), e)); 16 | matchdeclare (xx, symbolp); 17 | matchdeclare ([bb, cc], all); 18 | defmatch (match_subscript2, xx[bb, cc], xx); 19 | push (a, b) ::= buildq ([a, b], b : cons (a, b)); 20 | 21 | matchdeclare (aa, all); 22 | matchdeclare ([ii1, jj1], "<" (minf)); 23 | matchdeclare ([nn1, nn2], ">" (inf)); 24 | matchdeclare ([ii, jj, xx], symbolp); 25 | matchdeclare ([ii0, jj0], all); 26 | 27 | simp : false $ 28 | 29 | tellsimpafter ('diff ('sum ('sum (aa, ii, ii1, nn1), jj, jj1, nn2), xx[ii0, jj0], 1), 30 | block ([L, diff_summand], 31 | L : find_subscripts2 (xx, aa), 32 | diff_summand : apply ("+", makelist (diff (aa, xx[j1[1], j1[2]], 1) * kron_delta (ii0, j1[1]) * kron_delta (jj0, j1[2]), j1, L)), 33 | buildq ([diff_summand, ii, ii1, nn1, jj, jj1, nn2], 34 | 'sum ('sum (diff_summand, ii, ii1, nn1), jj, jj1, nn2)))); 35 | 36 | /* STILL NEED **@#*#$@*! CHAIN RULE TO WORK ON 'diff(f('sum(w[i,j]*x0[i], i, 1, M)), w[1,1], 1); */ 37 | 38 | tellsimpafter ('diff ('sum (aa, ii, ii1, nn1), xx[ii0, jj0], 1), 39 | block ([L, diff_summand], 40 | L : find_subscripts2 (xx, aa), 41 | diff_summand : apply ("+", makelist (diff (aa, xx[j1[1], j1[2]], 1) * kron_delta (ii0, j1[1]) * kron_delta (jj0, j1[2]), j1, L)), 42 | buildq ([diff_summand, ii, ii1, nn1], 43 | 'sum (diff_summand, ii, ii1, nn1)))); 44 | 45 | simp : true $ 46 | -------------------------------------------------------------------------------- /robert-dodier/diff_sum/rtest_diff_sum.mac: -------------------------------------------------------------------------------- 1 | (if not get ('diff_sum, 'present) 2 | then load ("diff_sum.mac") 3 | else print ("rtest_diff_sum: diff_sum already present."), 4 | if not get ('sum_kron_delta, 'present) 5 | then load ("../sum_kron_delta/sum_kron_delta.mac") 6 | else print ("rtest_diff_sum: sum_kron_delta already present."), 7 | 0); 8 | 0; 9 | 10 | 'diff ('sum (a[i] * x[i]^2, i, 1, n), x[j]); 11 | 2*(if 1 <= j and j <= n and %elementp(j,integers) then a[j]*x[j] else 0); 12 | 13 | while_assuming ([j >= 1, j <= n], 14 | while_declaring ([j, integer], 15 | 'diff ('sum (a[i] * x[i]^2, i, 1, n), x[j]))); 16 | 2*a[j]*x[j]; 17 | 18 | /* from the mailing list 2016-12-08: "Differentiation of indexed variables under sums" */ 19 | 20 | (L:(m*'sum(xdot[i](t)^2,i,1,n))/2+e*'sum(A[i]*xdot[i](t),i,1,n)+Phi*e, 21 | foo : 'diff (L, xdot[j](t))); 22 | 'diff((m*'sum(xdot[i](t)^2,i,1,n))/2+e*'sum(A[i]*xdot[i](t),i,1,n) 23 | +Phi*e,xdot[j](t),1); 24 | 25 | (declare ([m, e, Phi], constant), 26 | ev (foo, simp)); 27 | 'diff((m*'sum(xdot[i](t)^2,i,1,n))/2+e*'sum(A[i]*xdot[i](t),i,1,n) 28 | +Phi*e,xdot[j](t),1); 29 | 30 | while_declaring ([nounify(sum), linear], 31 | bar : ev (foo, simp)); 32 | 'diff((m*'sum(xdot[i](t)^2,i,1,n))/2+e*'sum(A[i]*xdot[i](t),i,1,n) 33 | +Phi*e,xdot[j](t),1); 34 | 35 | ev (bar, nouns); 36 | 0; 37 | 38 | while_declaring ([nounify(diff), linear], 39 | (baz : ev (foo, simp), 40 | string (baz))); 41 | "m*(if 1 <= j and j <= n and %elementp(j,integers) then xdot[j](t) else 0)\ 42 | +e*(if 1 <= j and j <= n and %elementp(j,integers) then A[j] else 0)"; 43 | 44 | (declare (j, integer), 45 | assume (j >= 1, j <= n), 46 | ev (baz, simp)); 47 | m*xdot[j](t)+e*A[j]; 48 | 49 | /* diff wrt specific index */ 50 | 51 | 'diff('sum(f(x[i]), i, 1, n), x[1]); 52 | if true then 'diff(f(x[1]),x[1],1) else 0; /* package boolsimp can simplify this to the 'then' clause */ 53 | 54 | 'diff('sum(f(x[i]), i, 1, n), x[2]); 55 | if 2 <= n then 'diff(f(x[2]),x[2],1) else 0; 56 | 57 | 'diff('sum((x[i])^i, i, 1, n), x[2]); 58 | if 2 <= n then 2*x[2] else 0; 59 | 60 | /* adapted from: https://stackoverflow.com/questions/77626748/dfferentiating-a-sum-in-sympy */ 61 | 62 | kill (q, t, u); 63 | done; 64 | 65 | foo: 'diff ('sum (q[t]*log(q[t]), t, 1, N), q[u]); 66 | if (1 <= u) and (u <= N) and %elementp(u, integers) then log(q[u]) + 1 else 0; 67 | 68 | foo1: block (assume (u >= 1, u <= N), ev (foo)); 69 | if %elementp(u, integers) then log(q[u]) + 1 else 0; 70 | 71 | block (declare (u, integer), ev (foo)); 72 | log(q[u]) + 1; 73 | 74 | (forget (facts (u)), kill (q, u)); 75 | done; 76 | -------------------------------------------------------------------------------- /robert-dodier/distribute_over_tranches/d00521032-eigenvalues-problem-parallel.mac: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | 德馬堤 (d00521032@ntu.edu.tw) via lists.sourceforge.net 4 | 5 | Thu, Jan 30, 10:46 AM (2 days ago) 6 | 7 | to maxima-discuss@lists.sourceforge.net 8 | A serial for-loop can be rewritten into a parallel for-loop. 9 | Ideally a speedup of approximately the number of cores of a computer is 10 | reached (provided heavy workloads, good ventilation of the computer, 11 | and loop cycles must be independent from each other (i.e. no communication 12 | between parallel tasks)). 13 | 14 | Example for Windows (adaption for Linux/BSD should be trivial): 15 | 16 | Original serial for-loop: 17 | 18 | */ 19 | 20 | /* 21 | load(lapack); 22 | power1:1.5$ 23 | X:round(makelist(i^power1,i,1,ceiling(500^(1/power1))))$ /* a number of x-values */ 24 | Y:round(makelist(i^power1,i,1,ceiling(600^(1/power1))))$ /* a number of y-values */ 25 | results:zeromatrix(length(X),length(Y))$ /* a matrix to store the results */ 26 | t0 : elapsed_real_time ()$ 27 | for k1:1 thru length(X) do /* a serial outer loop */ 28 | (dx:X[k1], 29 | for k2:1 thru length(Y) do /* a serial inner loop */ 30 | (dy:Y[k2], 31 | results[k1,k2]:lmax(abs(dgeev(subst([Δx=dx,Δy=dy],Matrix))[1]))))$ /* some task */ 32 | t1 : elapsed_real_time ()$ 33 | time: t1 - t0; 34 | */ 35 | 36 | /* Parallelized with distribute_over_tranches: */ 37 | 38 | set_random_state (make_random_state (1234)); 39 | Matrix: genmatrix (lambda ([i, j], random (2) * random (i + j) * Δx * Δy), 10, 10); 40 | 41 | load(lapack); 42 | power1:1.5$ 43 | X:round(makelist(i^power1,i,1,ceiling(500^(1/power1))))$ /* a number of x-values */ 44 | Y:round(makelist(i^power1,i,1,ceiling(600^(1/power1))))$ /* a number of y-values */ 45 | results:zeromatrix(length(X),length(Y))$ /* a matrix to store the results */ 46 | t0 : elapsed_real_time ()$ 47 | 48 | load ("distribute_over_tranches.lisp"); 49 | 50 | XY: cartesian_product_list (X, Y); 51 | 52 | results: distribute_over_tranches ('(block ([dx: XY[i][1], dy: XY[i][2]], lmax(abs(dgeev(subst([Δx=dx,Δy=dy],Matrix))[1])))), i, length (XY), 4) $ 53 | 54 | t1 : elapsed_real_time ()$ 55 | time: t1 - t0; 56 | 57 | fpprintprec: 8; 58 | print ("length(X) =", length (X), ", length(Y) =", length (Y)); 59 | print ("op(results) =", op (results), ", length(results) =", length (results)); 60 | ldisplay (results); 61 | -------------------------------------------------------------------------------- /robert-dodier/distribute_over_tranches/d00521032-eigenvalues-problem.mac: -------------------------------------------------------------------------------- 1 | /* 2 | 3 | 德馬堤 (d00521032@ntu.edu.tw) via lists.sourceforge.net 4 | 5 | Thu, Jan 30, 10:46 AM (2 days ago) 6 | 7 | to maxima-discuss@lists.sourceforge.net 8 | A serial for-loop can be rewritten into a parallel for-loop. 9 | Ideally a speedup of approximately the number of cores of a computer is 10 | reached (provided heavy workloads, good ventilation of the computer, 11 | and loop cycles must be independent from each other (i.e. no communication 12 | between parallel tasks)). 13 | 14 | Example for Windows (adaption for Linux/BSD should be trivial): 15 | 16 | Original serial for-loop: (with minor additions by R. Dodier) 17 | 18 | */ 19 | 20 | /* R. Dodier: make up a random value for Matrix since it was undefined otherwise */ 21 | set_random_state (make_random_state (1234)); 22 | Matrix: genmatrix (lambda ([i, j], random (2) * random (i + j) * Δx * Δy), 10, 10); 23 | 24 | load(lapack); 25 | power1:1.5$ 26 | X:round(makelist(i^power1,i,1,ceiling(500^(1/power1))))$ /* a number of x-values */ 27 | Y:round(makelist(i^power1,i,1,ceiling(600^(1/power1))))$ /* a number of y-values */ 28 | results:zeromatrix(length(X),length(Y))$ /* a matrix to store the results */ 29 | t0 : elapsed_real_time ()$ 30 | for k1:1 thru length(X) do /* a serial outer loop */ 31 | (dx:X[k1], 32 | for k2:1 thru length(Y) do /* a serial inner loop */ 33 | (dy:Y[k2], 34 | results[k1,k2]:lmax(abs(dgeev(subst([Δx=dx,Δy=dy],Matrix))[1]))))$ /* some task */ 35 | t1 : elapsed_real_time ()$ 36 | time: t1 - t0; 37 | 38 | /* R. Dodier: display results */ 39 | fpprintprec: 8; 40 | print ("length(X) =", length (X), ", length(Y) =", length (Y)); 41 | print ("op(results) =", op (results), ", length(results) =", length (results), ", length(first(results)) =", length (first (results))); 42 | ldisplay (results); 43 | -------------------------------------------------------------------------------- /robert-dodier/distribute_over_tranches/d00521032-with-For_loop_variables.mac: -------------------------------------------------------------------------------- 1 | load(lapack); 2 | 3 | load ("For_loop_variables.lisp"); 4 | 5 | load ("distribute_over_tranches.lisp"); 6 | 7 | DXDT: cartesian_product_list (DX, DT); 8 | 9 | t0 : elapsed_real_time ()$ 10 | 11 | results_flat: distribute_over_tranches ('(block ([dx: DXDT[i][1], dt: DXDT[i][2]], lmax (abs (dgeev (subst ([Δx = dx, Δt = dt], Iteration_matrix))[1])))), i, length (DXDT), 4) $ 12 | 13 | t1 : elapsed_real_time ()$ 14 | time: t1 - t0; 15 | 16 | fpprintprec: 8; 17 | print ("length(DX) =", length (DX), ", length(DT) =", length (DT)); 18 | print ("length(results_flat) =", length (results_flat)); 19 | ldisplay (results_flat); 20 | 21 | /* assemble results matrix from results list */ 22 | 23 | results_matrix: zeromatrix (length (DX), length (DT)) $ 24 | ij: cartesian_product_list (makelist (i, i, 1, length (DX)), makelist (i, i, 1, length (DT))); 25 | 26 | for k thru length (ij) 27 | do block ([i, j], 28 | [i, j]: ij[k], 29 | results_matrix[i, j]: results_flat[k]); 30 | 31 | ldisplay (results_matrix); 32 | 33 | d: decode_time (absolute_real_time (), 0); 34 | timestamp: printf (false, "~d-~02,'0d-~02,'0dT-~02,'0d-~02,'0d-~02,'0dZ", d[1], d[2], d[3], d[4], d[5], d[6]); 35 | session_name: printf (false, "d00521032-with-For_loop_variables-session-~a.lisp", timestamp); 36 | save (session_name, DXDT, ij, t0, t1, results_flat, results_matrix); 37 | -------------------------------------------------------------------------------- /robert-dodier/distribute_over_tranches/rtest_distribute_over_tranches.mac: -------------------------------------------------------------------------------- 1 | (if not ?fboundp ('distribute_over_tranches) 2 | then load ("distribute_over_tranches.lisp"), 3 | 0); 4 | 0; 5 | 6 | (kill (all), 7 | set_random_state (make_random_state (1234)), 8 | x: makelist (100000 + random (900000), 20), 9 | random_polynomial (l, m) := 10 | apply ("+", makelist ((random (2*m) - m) * apply ("*", map ("^", l, makelist (random (m + 1), length (l)))), 2*m)), 11 | y: makelist (random_polynomial ([u, v, w], 3), 24), 12 | 0); 13 | 0; 14 | 15 | xbaz: map (ifactors, x); 16 | [[[5, 2], [38791, 1]], 17 | [[949171, 1]], 18 | [[2, 1], [71, 2], [83, 1]], 19 | [[3, 1], [5, 1], [211, 1], [281, 1]], 20 | [[2, 2], [3, 5], [953, 1]], 21 | [[2, 2], [7, 1], [13, 1], [19, 1], [29, 1]], 22 | [[2, 3], [73, 1], [1523, 1]], 23 | [[5, 5], [53, 1]], 24 | [[5, 2], [79, 1], [137, 1]], 25 | [[167, 1], [2087, 1]], 26 | [[13, 1], [67411, 1]], 27 | [[13, 1], [67757, 1]], 28 | [[2, 1], [11, 1], [79, 1], [233, 1]], 29 | [[2, 1], [31, 1], [6961, 1]], 30 | [[7, 2], [29, 1], [503, 1]], 31 | [[2, 1], [7, 1], [14153, 1]], 32 | [[2, 2], [119299, 1]], 33 | [[2, 2], [397, 1], [571, 1]], 34 | [[2, 1], [101021, 1]], 35 | [[2, 1], [7, 1], [22013, 1]]]; 36 | 37 | /* ''(factor(...)) to resimplify the result of factor, 38 | * otherwise expected and actual results don't match. 39 | * I think the nuttiness is in factor so I'm going to let it be. 40 | */ 41 | ybaz: ''(map (factor, y)); 42 | [-(3*u^2*v^2*w^3)+2*v*w^3-3*u^2*v^3*w^2-u^3*w-3, 43 | -(v*(2*v^2*w^2+u^3*v^2-u^3*v-2*u^3)), 44 | v*(v*w^3+2*u^3*w^3-w-3*v-2), 45 | u*(u*v^3*w^3-3*u^2*w^3-2*v^2*w+u*v*w-u), 46 | u^2*v*w^2*(u*w+2), 47 | (u^3*v^3-u*v^2-3*u*v+1)*w, 48 | -(2*u^2*v^2*w^3)+2*w^2-2*v^2-1, 49 | 2*u^2*v^2*w^3+v*w^3+u*v*w-2, 50 | -(2*u^3*v^3*w^3)-2*v*w^3+3*u*v*w^2-2*u*w^2+2*u^3, 51 | -(v^3*w^3)+2*u*v*w^2-u^3*v^3*w-u^2*v-2, 52 | -(v^2*(u*v*w^3+2*u^3*w^3-2*u^2*v*w^2+w+u^3)), 53 | 2*u^2*v^2*w^3+2*u^2*w^3+u^2*v^3*w+v*w-2*u*v^3-2*u, 54 | -(u*v^3*w^3)+2*u*w^3-u^3*v*w^2+2*u^3*w^2+2*v^3*w-3*u*v, 55 | -(v*(u*v*w-w+2*u*v^2+v^2)), 56 | -(w*(u*v*w^2-2*u^3*w^2+3*w-2*v^2+2*u*v)), 57 | v*(u^2*v^2*w^3+2*u^2*v*w^3-2*u^3*v^2*w^2-3*v*w^2-2*u^2-3*u), 58 | v^3*w^3-3*u^3*v^2*w^3+u^3*v*w^2-3*u^3*w^2-v^3-3*v^2, 59 | -(w*(3*u^3*v^2*w^2-u^2*v-u^3-1)), 60 | -(v^3*w^3)-2*u*v^2*w^2+2*u*w-u^3*v-u^3, 61 | -(u^2*(u*v^2-1)*w^3), 62 | u*(v^3*w^2-u*w^2-u*v^2*w-3*v^2*w-3*u*v^3-2*u*v), 63 | 2*u*w^3+u*v^3*w^2-2*w-u^2*v, 64 | v*(u^3*v*w^3-2*v*w^2+2*u^3*w^2-3*u*v^2*w-3*u*v^2-2*u^2*v), 65 | -(v*(u^3*v*w^2+3*u^2*w^2+3*u^2*v^2*w+2*v^2-v))]; 66 | 67 | distribute_over_tranches ('(ifactors (x[k])), k, length (x), 1); 68 | ''xbaz; 69 | 70 | distribute_over_tranches ('(ifactors (x[k])), k, length (x), 2); 71 | ''xbaz; 72 | 73 | distribute_over_tranches ('(ifactors (x[k])), k, length (x), 3); 74 | ''xbaz; 75 | 76 | distribute_over_tranches ('(ifactors (x[k])), k, length (x), 7); 77 | ''xbaz; 78 | 79 | distribute_over_tranches ('(ifactors (x[k])), k, length (x), 13); 80 | ''xbaz; 81 | 82 | distribute_over_tranches ('(ifactors (x[k])), k, length (x), 20); 83 | ''xbaz; 84 | 85 | distribute_over_tranches ('(ifactors (x[k])), k, length (x), 29); 86 | ''xbaz; 87 | 88 | distribute_over_tranches ('(factor (y[n])), n, length (y), 1); 89 | ''ybaz; 90 | 91 | distribute_over_tranches ('(factor (y[n])), n, length (y), 2); 92 | ''ybaz; 93 | 94 | distribute_over_tranches ('(factor (y[n])), n, length (y), 3); 95 | ''ybaz; 96 | 97 | distribute_over_tranches ('(factor (y[n])), n, length (y), 7); 98 | ''ybaz; 99 | 100 | distribute_over_tranches ('(factor (y[n])), n, length (y), 13); 101 | ''ybaz; 102 | 103 | distribute_over_tranches ('(factor (y[n])), n, length (y), 24); 104 | ''ybaz; 105 | 106 | distribute_over_tranches ('(factor (y[n])), n, length (y), 29); 107 | ''ybaz; 108 | -------------------------------------------------------------------------------- /robert-dodier/distribute_over_tranches/tick_tock.mac: -------------------------------------------------------------------------------- 1 | tick_tock(e)::=buildq([e],block([tick:elapsed_real_time(),tock],e,tock:elapsed_real_time(),tock-tick))$ 2 | -------------------------------------------------------------------------------- /robert-dodier/excel_round/excel_round.mac: -------------------------------------------------------------------------------- 1 | /* excel_round -- round to specified number of decimal places, 2 | * rounding termminal 5 upwards, as in MS Excel, apparently. 3 | * Inspired by: https://stackoverflow.com/q/62533742/871096 4 | * 5 | * copyright 2020 by Robert Dodier 6 | * I release this work under terms of the GNU General Public License. 7 | */ 8 | 9 | matchdeclare (xx, numberp); 10 | matchdeclare (nn, integerp); 11 | tellsimpafter (excel_round (xx, nn), excel_round_numerical (xx, nn)); 12 | 13 | matchdeclare (xx, lambda ([e], block ([v: ev (e, numer)], numberp(v)))); 14 | tellsimpafter (excel_round (xx, nn), excel_round_numerical (ev (xx, numer), nn)); 15 | 16 | excel_round_numerical (x, n) := 17 | block ([r, r1, r2, l], 18 | /* rationalize returns exact rational equivalent of float */ 19 | r: rationalize (x), 20 | /* First round to 15 significant decimal places. 21 | * This is a heuristic to recover what a user "meant" 22 | * to type in, since many decimal numbers are not 23 | * exactly representable as floats. 24 | */ 25 | l: integer_log10 (abs (r)), 26 | r1: round (r*10^(15 - l)), 27 | /* Now begin rounding to n places. */ 28 | r2: r1/10^((15 - l) - n), 29 | /* If terminal digit is 5, then r2 is integer + 1/2. 30 | * If that's the case, round upwards and rescale, 31 | * otherwise, terminal digit is something other than 5, 32 | * round to nearest integer and rescale. 33 | */ 34 | if equal (r2 - floor(r2), 1/2) 35 | then ceiling(r2)/10.0^n 36 | else round(r2)/10.0^n); 37 | 38 | matchdeclare (xx, lambda ([e], numberp(e) and e > 0)); 39 | tellsimpafter (integer_log10 (xx), integer_log10_numerical (xx)); 40 | 41 | matchdeclare (xx, lambda ([e], block ([v: ev (e, numer)], numberp(v) and v > 0))); 42 | tellsimpafter (integer_log10 (xx), integer_log10_numerical (ev (xx, numer))); 43 | 44 | matchdeclare (xx, lambda ([e], not atom(e) and op(e) = "/" and numberp (denom (e)) and pow10p (denom (e)))); 45 | pow10p (e) := integerp(e) and e > 1 and (e = 10 or pow10p (e/10)); 46 | tellsimpafter (integer_log10 (xx), integer_log10 (num (xx)) - integer_log10_numerical (denom (xx))); 47 | 48 | integer_log10_numerical (x) := 49 | if x >= 10 50 | then (for i from 0 do 51 | if x >= 10 then x:x/10 else return(i)) 52 | elseif x < 1 53 | then (for i from 0 do 54 | if x < 1 then x:x*10 else return(-i)) 55 | else 0; 56 | 57 | -------------------------------------------------------------------------------- /robert-dodier/excel_round/rtest_excel_round.mac: -------------------------------------------------------------------------------- 1 | (if ?mget (excel_round, ?mexpr) = false 2 | then load ("excel_round.mac"), 3 | 0); 4 | 0; 5 | 6 | /* function to create test cases; 7 | * all values x returned by foo(r, n, m) should excel_round(x, n) to float(r) 8 | * number of values returned = 2*10^m 9 | */ 10 | 11 | (foo (r, n, m) := makelist (float (r + k/2/10^(n + m)), k, -10^m, 10^m - 1), 12 | foo (115/100, 2, 1)); 13 | [1.145, 1.1455, 1.146, 1.1465, 1.147, 1.1475, 1.148, 1.1485, 1.149, 14 | 1.1495, 1.15, 1.1505, 1.151, 1.1515, 1.152, 1.1525, 1.153, 1.1535, 1.154, 15 | 1.1545]; 16 | 17 | /* 18 | * these should all excel_round to 1.15; let's verify 19 | */ 20 | 21 | every (lambda ([x], excel_round (x, 2) = float(115/100)), foo (115/100, 2, 1)); 22 | true; 23 | 24 | /* let's package it up and try some different test values */ 25 | 26 | (bar (r, n, m) := every (lambda ([x], excel_round (x, n) = float(r)), foo (r, n, m)), 27 | bar (5/100, 2, 2)); 28 | true; 29 | 30 | bar (3856/1000, 3, 3); 31 | true; 32 | 33 | bar (3857/1000, 3, 3); 34 | true; 35 | 36 | bar (5666/100, 2, 2); 37 | true; 38 | 39 | bar (8228/100, 2, 2); 40 | true; 41 | 42 | bar (48995/100, 2, 2); 43 | true; 44 | 45 | 46 | bar (-5/100, 2, 2); 47 | true; 48 | 49 | bar (-3856/1000, 3, 3); 50 | true; 51 | 52 | bar (-3857/1000, 3, 3); 53 | true; 54 | 55 | bar (-5666/100, 2, 2); 56 | true; 57 | 58 | bar (-8228/100, 2, 2); 59 | true; 60 | 61 | bar (-48995/100, 2, 2); 62 | true; 63 | 64 | /* excel_round with nonnumeric argument */ 65 | 66 | kill(m, baz, quux); 67 | done; 68 | 69 | baz: excel_round (m/1000, 2); 70 | excel_round (m/1000, 2); 71 | 72 | ev (baz, m = 9876); 73 | 9.88; 74 | 75 | quux: excel_round_numerical (m/1000, 2); 76 | if equal(10^(integer_log10(abs(m))-16)*'round(m*10^(15-integer_log10(abs(m)))) 77 | -floor(10^(integer_log10(abs(m))-16) 78 | *'round(m*10^(15-integer_log10(abs(m))))),1/2) 79 | then 0.01*ceiling(10^(integer_log10(abs(m))-16) 80 | *'round(m*10^(15-integer_log10(abs(m))))) 81 | else 0.01*'round(10^(integer_log10(abs(m))-16) 82 | *'round(m*10^(15-integer_log10(abs(m))))); 83 | 84 | ev (quux, m = 9876); 85 | 9.88; 86 | -------------------------------------------------------------------------------- /robert-dodier/expm/expm.mac: -------------------------------------------------------------------------------- 1 | /* expm.mac -- matrix exponential 2 | * copyright 2023 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License 4 | */ 5 | 6 | /* Naive implementation of R[q,q](A) Padé approximation, 7 | * as stated by Moler and van Loan [1], "Method 2. Padé approximation." 8 | * Scaling and unscaling (e.g. via the scaling and squaring approach) 9 | * is omitted here in the interest of simplicity; that is the obvious 10 | * next step, if ever this function is revisited. 11 | * 12 | * Moler and van Loan state: 13 | * 14 | * 15 | * 16 | * The (p, q) Padé approximation to e^A is defined by 17 | * 18 | * R[p,q](A) = [D[p,q](A)]^-1 N[p,q](A), 19 | * 20 | * where 21 | * 22 | * N[p,q](A) = sum_{j=0}^p ((p + q - j)! p!) / ((p + q)! j! (p - j)!) A^j 23 | * 24 | * and 25 | * 26 | * D[p,q](A) = sum_{j=0}^q ((p + q - j)! q!) / ((p + q)! j! (q - j)!) (-A)^j 27 | * 28 | * 29 | * 30 | * 31 | * [1] C. Moler and C. van Loan. 32 | * "Nineteen Dubious Ways to Compute the Exponential of a Matrix, Twenty-Five Years Later." 33 | * SIAM Review, Vol. 45, No. 1 (2003). 34 | * Retrieved from: https://www.cs.jhu.edu/~misha/ReadingSeminar/Papers/Moler03.pdf 35 | */ 36 | 37 | expm (A) := expm_pade_R (11, 11, A); 38 | 39 | expm_pade_N (p, q, A) := sum (((p + q - j)! * p!) / ((p + q)! * j! * (p - j)!) * A^^j, j, 0, p); 40 | 41 | expm_pade_D (p, q, A) := sum (((p + q - j)! * q!) / ((p + q)! * j! * (q - j)!) * (-A)^^j, j, 0, q); 42 | 43 | expm_pade_R (p, q, A) := 44 | block ([N_matrix, D_matrix], 45 | N_matrix: expm_pade_N (p, q, A), 46 | D_matrix: expm_pade_D (p, q, A), 47 | invert_by_lu (D_matrix, complexfield) . N_matrix); 48 | 49 | -------------------------------------------------------------------------------- /robert-dodier/fboundp/fboundp.mac: -------------------------------------------------------------------------------- 1 | /* fboundp.mac -- detect different kinds of functions in Maxima 2 | * copyright 2020 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License 4 | * 5 | * Examples: 6 | * 7 | /* Name of an operator: */ 8 | fboundp("+"); 9 | true; 10 | fboundp_operator("+"); 11 | true; 12 | 13 | infix("//") $ 14 | fboundp("//"); 15 | false; 16 | fboundp_operator("//"); 17 | false; 18 | x // y := y - x $ 19 | fboundp("//"); 20 | true; 21 | fboundp_operator("//"); 22 | true; 23 | 24 | /* Simplifying function defined in Lisp: */ 25 | fboundp(sin); 26 | true; 27 | fboundp_simplifying(sin); 28 | true; 29 | 30 | /* DEFUN (ordinary argument-evaluating) function defined in Lisp: */ 31 | fboundp(expand); 32 | true; 33 | fboundp_ordinary_lisp(expand); 34 | true; 35 | 36 | /* DEFMSPEC (argument-quoting) function defined in Lisp: */ 37 | fboundp(kill); 38 | true; 39 | fboundp_quoting(kill); 40 | true; 41 | 42 | /* Maxima ordinary function: */ 43 | (kill(foo), 44 | foo(x) := x, 45 | fboundp(foo)); 46 | true; 47 | fboundp_ordinary_maxima(foo); 48 | true; 49 | 50 | /* Maxima array function: */ 51 | (kill(bar), 52 | bar[x](y) := x*y, 53 | fboundp(bar)); 54 | true; 55 | fboundp_array_function(bar); 56 | true; 57 | 58 | /* Maxima macro: */ 59 | (kill(baz), 60 | baz(x) ::= buildq([x], x), 61 | fboundp(baz)); 62 | true; 63 | fboundp_maxima_macro(baz); 64 | true; 65 | * 66 | */ 67 | 68 | fboundp(a) := 69 | fboundp_operator(a) 70 | or fboundp_simplifying(a) 71 | or fboundp_ordinary_lisp(a) 72 | or fboundp_quoting(a) 73 | or fboundp_ordinary_maxima(a) 74 | or fboundp_array_function(a) 75 | or fboundp_maxima_macro(a); 76 | 77 | fboundp_operator(a) := 78 | stringp(a) and fboundp (verbify (a)); 79 | 80 | fboundp_simplifying(a) := 81 | symbolp(a) and ?get(a, ?operators) # false; 82 | 83 | fboundp_ordinary_lisp(a) := 84 | symbolp(a) and ?fboundp(a) # false; 85 | 86 | fboundp_quoting(a) := 87 | symbolp(a) and ?get(a, ?mfexpr\*) # false; 88 | 89 | fboundp_ordinary_maxima(a) := 90 | symbolp(a) and ?mget(a, ?mexpr) # false; 91 | 92 | fboundp_array_function(a) := 93 | symbolp(a) and ?mget(a, ?aexpr) # false; 94 | 95 | fboundp_maxima_macro(a) := 96 | symbolp(a) and ?mget(a, ?mmacro) # false; 97 | -------------------------------------------------------------------------------- /robert-dodier/fboundp/rtest_fboundp.mac: -------------------------------------------------------------------------------- 1 | (if ?mget ('fboundp, '?mexpr) = false then load ("fboundp.mac"), 0); 2 | 0; 3 | 4 | /* Name of an operator: */ 5 | fboundp("+"); 6 | true; 7 | fboundp_operator("+"); 8 | true; 9 | 10 | (infix("//"), 0); 11 | 0; 12 | fboundp("//"); 13 | false; 14 | fboundp_operator("//"); 15 | false; 16 | (x // y := y - x, 0); 17 | 0; 18 | fboundp("//"); 19 | true; 20 | fboundp_operator("//"); 21 | true; 22 | 23 | /* Simplifying function defined in Lisp: */ 24 | fboundp(sin); 25 | true; 26 | fboundp_simplifying(sin); 27 | true; 28 | 29 | /* DEFUN (ordinary argument-evaluating) function defined in Lisp: */ 30 | fboundp(expand); 31 | true; 32 | fboundp_ordinary_lisp(expand); 33 | true; 34 | 35 | /* DEFMSPEC (argument-quoting) function defined in Lisp: */ 36 | fboundp(kill); 37 | true; 38 | fboundp_quoting(kill); 39 | true; 40 | 41 | /* Maxima ordinary function: */ 42 | (kill(foo), 43 | foo(x) := x, 44 | fboundp(foo)); 45 | true; 46 | fboundp_ordinary_maxima(foo); 47 | true; 48 | 49 | /* Maxima array function: */ 50 | (kill(bar), 51 | bar[x](y) := x*y, 52 | fboundp(bar)); 53 | true; 54 | fboundp_array_function(bar); 55 | true; 56 | 57 | /* Maxima macro: */ 58 | (kill(baz), 59 | baz(x) ::= buildq([x], x), 60 | fboundp(baz)); 61 | true; 62 | fboundp_maxima_macro(baz); 63 | true; 64 | -------------------------------------------------------------------------------- /robert-dodier/from_wxmx/README.md: -------------------------------------------------------------------------------- 1 | Package from\_wxmx for Maxima 2 | Robert Dodier 3 | 4 | from\_wxmx is a package to read .wxmx files (created by wxMaxima). 5 | 6 | Functions 7 | --------- 8 | 9 | parse\_xml -- parse XML input into a parse tree representation 10 | 11 | parse\_xml(f) where f is an XML string (containing XML, not a filename), input stream, or Lisp pathname 12 | 13 | Returns an XML parse tree (specific to the XML parser implementation, which is XMLS [1] at the moment.) 14 | 15 | expressions\_from\_dom -- convert an XML parse tree (domain object model, DOM) into a Maxima expression 16 | 17 | expressions\_from\_dom(e) where e is a text node or nesting node in an XML parse tree 18 | 19 | Returns a Maxima expression which is a verbatim reprepresentation of the parse tree 20 | 21 | tokens\_from -- extract a list of tokens from WHAT XML TAG?? 22 | 23 | tokens\_from(e) where e is a Maxima expression which is a verbatim representation of the parse tree rooted at an `` XML tag (CORRECT ??) 24 | 25 | Returns a list of tokens, e.g.: `[foo, \\(, x, \\+, 123, \\)]` 26 | 27 | parse\_token\_list -- reconstruct a Maxima expression from a list of tokens 28 | 29 | parse\_token\_list(l) where l is a list of tokens, e.g.: `[foo, \\(, x, \\+, 123, \\)]` 30 | 31 | Returns a Maxima expression reconstituted from the list of tokens, e.g. `foo(x + 123)` for the above list 32 | 33 | split\_mth -- divide mth expressions, with one expression per output label 34 | 35 | split\_mth(e) where e is a Maxima expression `mth()(...)` containing zero or more `lbl()(...)` expressions 36 | 37 | Returns a list of equations of the form `foo = bar` where ?? 38 | 39 | Example 40 | ------- 41 | 42 | ```{maxima} 43 | load ("from_wxmx.mac"); 44 | S: openr ("output-examples-simple.xml"); 45 | parse_tree: parse_xml (S); 46 | close (S); 47 | expr_verbatim: expressions_from_dom (parse_tree); 48 | /* COPY THIS TO LEXICAL_SYMBOLS TEST CASES */ 49 | extract_outputs (e) := 50 | block ([L: [], f], 51 | f: lambda ([e], if not atom(e) and not atom(op(e)) and op(op(e)) = 'output then push (e, L), e), 52 | scanmap (f, e), 53 | reverse (L)); 54 | outputs: extract_outputs (expr_verbatim); 55 | outputs_mths: map (first, outputs); /* ASSUMING EACH OUTPUT HAS EXACTLY ONE ARGUMENT, NAMELY MTH !! */ 56 | outputs_mths_lbls: apply (append, map (split_mth, outputs_mths)); 57 | /* NEXT ONE FAILS IF LAMBDA ARGUMENT IS E INSTEAD OF EQ !! LEXICAL SYMBOL FIXES IT !! */ 58 | outputs_tokens: map (lambda ([eq], lhs(eq) = tokens_from (rhs (eq))), outputs_mths_lbls); 59 | myf: lambda ([l], block ([e], if errcatch (e: parse_token_list (l)) = [] then l else e)); 60 | outputs_expressions: map (lambda ([eq], lhs(eq) = myf (rhs (eq))), outputs_tokens); 61 | strip_label (s) := parse_string (s); 62 | outputs_expressions_labeled: map (lambda ([eq], ?mlabel (strip_label (first (lhs(eq))), rhs(eq))), outputs_expressions); /* ASSUMING LHS(E) = LBL()("(%O1) ") OR STLT !! */ 63 | for x in outputs_expressions_labeled do ?displa(x); 64 | ``` 65 | 66 | References 67 | ---------- 68 | 69 | [1] https://github.com/rpgoldman/xmls 70 | -------------------------------------------------------------------------------- /robert-dodier/from_wxmx/expressions_from_dom.lisp: -------------------------------------------------------------------------------- 1 | ;; expressions_from_dom.lisp -- construct Maxima expressions from DOM parsed from XML 2 | ;; copyright 2021 by Robert Dodier 3 | ;; I release this work under terms of the GNU General Public License 4 | 5 | (ql:quickload "xmls") 6 | 7 | ;; about elements vs nodes, see for example: 8 | ;; https://stackoverflow.com/questions/132564/whats-the-difference-between-an-element-and-a-node-in-xml 9 | ;; 10 | ;; apparently element is the only kind of node which can contain child nodes and attributes. 11 | ;; probably need to think more carefully about elements, nodes, children, etc. 12 | 13 | (defmfun $expressions_from_dom (x) 14 | (cond 15 | ((stringp x) x) 16 | (x 17 | (let* 18 | ((op (mfuncall '$parse_string (xmls:node-name x))) 19 | (attribute-eqs (mapcar (lambda (pq) (cons '(mequal) pq)) (xmls:node-attrs x))) 20 | (children-exprs (mapcar (symbol-function '$expressions_from_dom) (xmls:node-children x)))) 21 | `((mqapply) ((,op) ,@attribute-eqs) ,@children-exprs))) 22 | (t x))) 23 | 24 | (defmfun $parse_xml (f) 25 | (cond 26 | ((stringp f) 27 | (xmls:parse f :compress-whitespace nil)) 28 | ((streamp f) 29 | (xmls:parse f :compress-whitespace nil)) 30 | ((pathnamep f) 31 | (with-open-file (s f) 32 | (xmls:parse s :compress-whitespace nil))) 33 | (t 34 | (merror "parse_xml: argument must be a string, stream, or Lisp pathname; found ~M~%" f)))) 35 | 36 | (ql:quickload "zippy") 37 | (ql:quickload "flexi-streams") 38 | 39 | (defun $open_zip_input_stream (zipfile-name entry-name) 40 | (let* 41 | ((z (org.shirakumo.zippy:open-zip-file zipfile-name)) 42 | (ee (mapcar (lambda (e) (list (org.shirakumo.zippy:file-name e) e)) (coerce (org.shirakumo.zippy:entries z) 'list))) 43 | (a (second (assoc entry-name ee :test #'string=))) 44 | (c (org.shirakumo.zippy:entry-to-vector a)) 45 | (s0 (flexi-streams:make-in-memory-input-stream c))) 46 | (flexi-streams:make-flexi-stream s0 :external-format :utf-8))) 47 | 48 | -------------------------------------------------------------------------------- /robert-dodier/from_wxmx/output-examples-complex.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | (%t73) ric1,1=−2·M·

M·r−2·M2

r3·

r2−2·M·r

−M·r−2·M2r4+Mr3 4 | 5 | 6 | (%t74) ric2,2=−2·Mr·

r2−2·M·r

+M·

2·r−2·M

r2−2·M·r

2−2·M2

r2−2·M·r

2 7 | 8 | 9 | (%t73) ric1,1=−2·M·

M·r−2·M2

r3·

r2−2·M·r

−M·r−2·M2r4+Mr3(%t74) ric2,2=−2·Mr·

r2−2·M·r

+M·

2·r−2·M

r2−2·M·r

2−2·M2

r2−2·M·r

2(%o74) done 10 | 11 | 12 | -------------------------------------------------------------------------------- /robert-dodier/from_wxmx/output-examples-diff.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | (%o1) d3d*x3*f

x

 4 | 5 | 6 | (%o2) d3d*x3*f

x,y

 7 | 8 | 9 | (%o3) dn+3d*x3*d*yn*f

x,y

 10 | 11 | 12 | -------------------------------------------------------------------------------- /robert-dodier/from_wxmx/output-examples-simple.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | (%o1) cc+bb+aa 4 | 5 | 6 | (%o2) cc-bb+aa 7 | 8 | 9 | (%o3) -cc-bb+aa 10 | 11 | 12 | (%o4) cc+bb-aa 13 | 14 | 15 | (%o5) abc123 16 | 17 | 18 | (%o5) aa*bb*cc 19 | 20 | 21 | (%o6) foo

abc,123

 22 | 23 | 24 | (%o6) cc*dd*ee+aa*bb 25 | 26 | 27 | (%o7) xyz+foo

abc,123

 28 | 29 | 30 | (%o7) 1234abcd 31 | 32 | 33 | (%o7) nn! 34 | 35 | 36 | (%o8) -aa 37 | 38 | 39 | -------------------------------------------------------------------------------- /robert-dodier/from_wxmx/parse_token_list.lisp: -------------------------------------------------------------------------------- 1 | ;; parse_token_list.lisp -- supply list of tokens to parser to construct Maxima expression 2 | ;; copyright 2021 by Robert Dodier 3 | ;; I release this work under terms of the GNU General Public License 4 | 5 | ;; It is assumed that the list of tokens IS NOT terminated by $; 6 | ;; therefore $; is appended to the list. 7 | 8 | (defparameter *token-list* nil) 9 | 10 | (let 11 | ((f (symbol-function 'peek-one-token)) 12 | (g (symbol-function 'scan-one-token))) 13 | (defun peek-one-token () 14 | (if *token-list* 15 | (car *token-list*) 16 | (funcall f))) 17 | (defun scan-one-token () 18 | (if *token-list* 19 | (pop *token-list*) 20 | (funcall g)))) 21 | 22 | (defun sanitize-unicode-ops (l) 23 | ( 24 | let* 25 | ((m (subst '$- '$− l)) 26 | (n (subst '$* '$· m))) 27 | ;; What else? Unicode plus sign? Other multiplication signs? 28 | n)) 29 | 30 | (defmfun $parse_token_list (l) 31 | (if (every #'atom (cdr l)) 32 | (let* 33 | ((sanitized-l (sanitize-unicode-ops (cdr l))) 34 | (*token-list* (append sanitized-l (list '$\;)))) 35 | (with-input-from-string (s "0") ;; token "0" just shows there is input present; it isn't used 36 | (third (mread s)))) 37 | (merror "parse_token_list: every token must be an atom; found: ~M" l))) 38 | 39 | ;; Spurious line info shows up in the values returned by this implementation. 40 | #+nil (defmfun $parse_token_list (l) 41 | (let ((*token-list* (append (cdr l) (list '$\;)))) 42 | (do 43 | ((input (parse '$any 0.) 44 | (parse '$any 0.))) 45 | (nil) 46 | (case (first-c) 47 | ((|$;| |$$|) 48 | (return (list (mheader (pop-c)) nil input))) 49 | (t (parse-bug-err '$parse_token_list)))))) 50 | -------------------------------------------------------------------------------- /robert-dodier/generalized_halley/README.md: -------------------------------------------------------------------------------- 1 | ### Summary 2 | 3 | This package, `generalized_halley`, contains functions to construct an iterator 4 | for a generalized Halley method to solve multidimensional nonlinear equations. 5 | 6 | This package only constructs the iterator; establishing a stopping criterion 7 | and calling the iterator is left to the caller. 8 | 9 | Code here follows the approach outlined by Gundersen and Steihaug. [1] 10 | 11 | [1] Geir Gundersen and Trond Steihaug. 12 | "On large scale unconstrained optimization problems and higher order methods." 13 | Optimization Methods & Software, vol. 25, issue 3 (June 2010), pp 337--358. 14 | https://doi.org/10.1080/10556780903239071 15 | Retrieved from: https://optimization-online.org/wp-content/uploads/2007/03/1610.pdf 16 | 17 | As described by Gundersen and Steihaug, 18 | the generalized Halley method is parametrized by a constant, namely `α`. 19 | Different values of `α` yield some methods known by name: 20 | `α = 0` yields Chebyshev's method, 21 | `α = 1/2` yields Halley's method, 22 | and `α = 1` yields the super-Halley method. 23 | 24 | ### Usage 25 | 26 | Load `generalized_halley` and construct an iterator for an example problem. 27 | Here `α = 1/2`, so this implements Halley's method. 28 | 29 | ```{maxima} 30 | (%i1) load ("generalized_halley.mac") $ 31 | 32 | (%i2) F: [2*3^u - v/u - 5, u + 2^v - 4]; 33 | v u v 34 | (%o2) [- ─ + 2 3 - 5, 2 + u - 4] 35 | u 36 | (%i3) halley_iterator: construct_generalized_halley_update (F, [u, v], 1/2); 37 | (%o3) lambda([x_k], block([u, v], [u, v] : x_k, 38 | 1 v u v 39 | generalized_halley_update(─, [- ─ + 2 3 - 5, 2 + u - 4], 40 | 2 u 41 | ┌ ┐ 42 | ┌ ┐ │ 2 u 2 v 1 │ 43 | │ v u 1 │ │ [2 log (3) 3 - ───, 0] [──, 0] │ 44 | │ ── + 2 log(3) 3 - ─ │ │ 3 2 │ 45 | │ 2 u │ │ u u │ 46 | │ u │, │ │, 47 | │ │ │ 1 2 v │ 48 | │ v │ │ [──, 0] [0, log (2) 2 ] │ 49 | │ 1 log(2) 2 │ │ 2 │ 50 | └ ┘ │ u │ 51 | └ ┘ 52 | x_k))) 53 | ``` 54 | 55 | Use the iterator to generate successive estimates of a solution. 56 | The initial point is `[2.0, 2.0]`. 57 | 58 | ```{maxima} 59 | (%i4) ev (halley_iterator ([2.0, 2.0]), numer); 60 | (%o4) [1.1117228381556121, 1.4849774563022784] 61 | (%i5) ev (halley_iterator (%), numer); 62 | (%o5) [1.0664132421723913, 1.5522505012801135] 63 | (%i6) ev (halley_iterator (%), numer); 64 | (%o6) [1.0666183918166123, 1.5525647566467795] 65 | (%i7) ev (halley_iterator (%), numer); 66 | (%o7) [1.0666183895954067, 1.5525647668417866] 67 | (%i8) ev (halley_iterator (%), numer); 68 | (%o8) [1.0666183895954067, 1.5525647668417863] 69 | ``` 70 | 71 | Just for fun, 72 | let's look at the code that's generated automatically by differentiating `F` twice. 73 | If we were going to generate code for Python, C/C++, Fortran, etc., 74 | this is the function that we would translate. 75 | 76 | ```{maxima} 77 | (%i9) grind (halley_iterator); 78 | 79 | lambda([x_k], 80 | block([u,v],[u,v]:x_k, 81 | generalized_halley_update(1/2,[-(v/u)+2*3^u-5,2^v+u-4], 82 | matrix([v/u^2+2*log(3)*3^u,-(1/u)], 83 | [1,log(2)*2^v]), 84 | matrix( 85 | [[2*log(3)^2*3^u-(2*v)/u^3,0], 86 | [1/u^2,0]], 87 | [[1/u^2,0],[0,log(2)^2*2^v]]),x_k)))$ 88 | (%o9) done 89 | ``` 90 | 91 | The function `generalized_halley_update` only carries out linear algebra calculations; 92 | no further symbolic operations are needed in the iterator. 93 | The symbolic functions such as differentiation are only needed to construct the iterator, 94 | and aren't needed for the numerical solution. 95 | -------------------------------------------------------------------------------- /robert-dodier/generalized_halley/generalized_halley.mac: -------------------------------------------------------------------------------- 1 | /* generalized_halley.mac -- implement generalized Halley's method for solving nonlinear equations 2 | * copyright 2024 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License, version 2 4 | * 5 | * Inspired by: 6 | * Geir Gundersen and Trond Steihaug. 7 | * "On large scale unconstrained optimization problems and higher order methods." 8 | * Optimization Methods & Software, vol. 25, issue 3 (June 2010), pp 337--358. 9 | * https://doi.org/10.1080/10556780903239071 10 | * Retrieved from: https://optimization-online.org/wp-content/uploads/2007/03/1610.pdf 11 | */ 12 | 13 | /* Eq. 3 from Gundersen and Steihaug. 14 | * Assume F is a list of expressions, vars is a list of mapatoms, alpha is a number, and x_k is a list. 15 | */ 16 | 17 | construct_generalized_halley_update (F, vars, alpha) := 18 | 19 | block ([J: jacobian (F, vars), H: hessian (F, vars)], 20 | 21 | buildq ([F, J, H, vars, alpha], 22 | lambda ([x_k], block (vars, vars: x_k, generalized_halley_update (alpha, F, J, H, x_k))))); 23 | 24 | 25 | substall (xx, yy, e) := subst (map (lambda ([x, y], y = x), xx, yy), e); 26 | 27 | 28 | generalized_halley_update (alpha, F_x_k, J_x_k, H_x_k, x_k) := 29 | 30 | x_k - generalized_halley_step (alpha, F_x_k, J_x_k, H_x_k, x_k); 31 | 32 | 33 | generalized_halley_step (alpha, F_x_k, J_x_k, H_x_k, x_k) := 34 | 35 | block ([scalarmatrixp: false, Jinv_x_k, I, L_x_k], 36 | 37 | Jinv_x_k: invert (J_x_k), 38 | 39 | I: ident (length (x_k)), 40 | 41 | L_x_k: generalized_halley_L (Jinv_x_k, H_x_k, F_x_k), 42 | 43 | (I + (1/2)*(L_x_k . invert (I - alpha*L_x_k))) . Jinv_x_k . F_x_k, 44 | 45 | flatten_step_to_list (%%)); 46 | 47 | 48 | /* Eq. 4 in Gundersen & Steihaug. 49 | */ 50 | 51 | generalized_halley_L (Jinv_x_k, H_x_k, F_x_k) := 52 | 53 | block ([L_x_k: Jinv_x_k . H_x_k . Jinv_x_k . F_x_k], 54 | 55 | /* H is a 3-dimensional matrix, 56 | * so product needs to be flattened into an ordinary 2-d matrix. 57 | */ 58 | 59 | flatten_L_to_simple_matrix (L_x_k)); 60 | 61 | 62 | /* This operation will probably take different forms depending on how H is constructed, 63 | * so this isn't a generic operation, but rather specific to this problem. 64 | * Assume for the moment that H is an n x n matrix containing n-length lists. 65 | */ 66 | 67 | flatten_L_to_simple_matrix (L_x_k) := apply (matrix, makelist (L_x_k[k, 1], k, 1, length (L_x_k))); 68 | 69 | 70 | /* e is a 1-column matrix; return a list of its elements 71 | * to make it comparable to x_k. 72 | */ 73 | 74 | flatten_step_to_list (e) := makelist (e[k, 1], k, 1, length (e)); 75 | -------------------------------------------------------------------------------- /robert-dodier/json_tools/README.md: -------------------------------------------------------------------------------- 1 | ### `json_tools` 2 | 3 | `json_tools` is a package to read and work with JSON data in Maxima. 4 | 5 | This package is experimental and subject to change. 6 | 7 | In order to load the package, either 8 | (1) one needs to launch Maxima from the `json_tools` folder, 9 | or (2) `push("path/to/json_tools/###.mac", file_search_maxima);` 10 | and also `push("path/to/json_tools/###.lisp", file_search_lisp);`. 11 | 12 | Then `load(json_tools);` loads it. 13 | 14 | #### Reading JSON data 15 | 16 | `read_json("mydata.json");` parses `"mydata.json"`. 17 | 18 | The curly braces `{ ... }` are replaced by `blob(...)` 19 | and the colon `:` is replaced by `=`, 20 | to avoid confusion with existing meaning of `{ ... }` and `:` in Maxima. 21 | 22 | Keys remain strings; they are not turned into symbols by `read_json`. 23 | 24 | Note that the input can also be a stream instead of a file, 25 | e.g.: `S: openr("mydata.json"); read_json(S);` 26 | 27 | #### Blob query operations 28 | 29 | The `//` operator selects the value of a key, 30 | e.g.: 31 | ```{maxima} 32 | x: blob("foo" = 123); 33 | x // "foo"; 34 | ``` 35 | yields `123`. 36 | 37 | `//` can be applied successively, 38 | e.g.: 39 | ```{maxima} 40 | x: blob("foo" = blob("bar" = blob("baz" = 456))); 41 | x // "foo" // "bar" // "baz"; 42 | ``` 43 | yields `456`. 44 | 45 | When the left-hand side of `//` is a list, 46 | then `//` is mapped over the elements of the list, 47 | e.g.: 48 | ```{maxima} 49 | x: [blob("aa" = 11), blob("aa" = 22), blob("aa" = 33)]; 50 | x // "aa"; 51 | ``` 52 | yields `[11, 22, 33]`. 53 | 54 | When there is only one key, the result is just the value. 55 | Multiple keys in a list on the right-hand side 56 | yield a result which is again a blob, having just the selected keys, 57 | e.g.: 58 | ```{maxima} 59 | x: blob("aa" = 11, "bb" = 22, "cc" = 33, "dd" = 44); 60 | x // ["bb", "dd"]; 61 | ``` 62 | yields `blob("bb" = 22, "dd" = 44)`. 63 | 64 | #### Flattening blobs 65 | 66 | `flatten_json` turns blobs into `foo.bar.baz = something`. 67 | That might or might not be useful; anyway there it is. 68 | 69 | E.g.: 70 | ```{maxima} 71 | x: blob("aa" = blob("bb" = 123)); 72 | flatten_json([foo, bar], x); 73 | ``` 74 | yields `foo . bar . aa . bb = 123` 75 | Here the keys have been turned into symbols. 76 | 77 | The first argument `[foo, bar]` are some additional symbols 78 | to put in front of any derived from the blobs. 79 | 80 | #### Writing blobs as JSON 81 | 82 | There is not yet a way to write blobs as JSON. 83 | I'll come up with something soon. 84 | -------------------------------------------------------------------------------- /robert-dodier/json_tools/flatten_json.mac: -------------------------------------------------------------------------------- 1 | /* flatten_json.mac -- flatten blob("foo" = blob("bar" = 123)) to foo.bar = 123 2 | * 3 | * copyright 2020 by Robert Dodier 4 | * I release this work under terms of the GNU GPL. 5 | */ 6 | 7 | /* return a symbol, given a string */ 8 | symbol (s) := parse_string (s); 9 | 10 | flatten_json (prefix_tags, e) := 11 | if listp(e) 12 | then flatten_json_list (prefix_tags, e) 13 | elseif equationp(e) 14 | then flatten_json_equation (prefix_tags, e) 15 | elseif blobp(e) 16 | then flatten_json_blob (prefix_tags, e) 17 | else 18 | apply (".", prefix_tags) = e; 19 | 20 | flatten_json_list (prefix_tags, l) := 21 | if some (blobp, l) 22 | then flatten_json_list_of_blobs (prefix_tags, l) 23 | else flatten_json_list_of_nonblobs (prefix_tags, l); 24 | 25 | flatten_json_list_of_blobs (prefix_tags, l) := 26 | block ([leading_tags: rest (prefix_tags, -1), 27 | trailing_tag: last (prefix_tags), 28 | revised_tags, 29 | kk: gensym ()], 30 | revised_tags: endcons (trailing_tag(kk), leading_tags), 31 | makelist (flatten_json (subst (kk = k, revised_tags), l[k]), k, 1, length(l))); 32 | 33 | /* assume that l is a list of numbers; 34 | * might want to verify that and handle other cases 35 | */ 36 | flatten_json_list_of_nonblobs (prefix_tags, l) := 37 | apply (".", prefix_tags) = l; 38 | 39 | equationp (e) := not atom(e) and op(e) = "="; 40 | 41 | flatten_json_equation (prefix_tags, e) := flatten_json (endcons (symbol (lhs(e)), prefix_tags), rhs(e)); 42 | 43 | blobp (e) := not atom(e) and op(e) = 'blob; 44 | 45 | flatten_json_blob (prefix_tags, b) := maplist (lambda ([e], flatten_json (prefix_tags, e)), b); 46 | -------------------------------------------------------------------------------- /robert-dodier/json_tools/json_tools.mac: -------------------------------------------------------------------------------- 1 | load ("read_json.mac"); 2 | load ("query_json.mac"); 3 | load ("flatten_json.mac"); 4 | -------------------------------------------------------------------------------- /robert-dodier/json_tools/query_json.mac: -------------------------------------------------------------------------------- 1 | /* query_json.mac -- select values from JSON blobs 2 | * 3 | * e.g.: given foo: blob("aa" = 123, "bb" = blob("cc" = [11, 22, 33])) 4 | * then foo // "aa" yields 123 5 | * foo // "bb" yields blob("cc" = [11, 22, 33]) 6 | * foo // "bb" // "cc" yields [11, 22, 33] 7 | * 8 | * given bar: [blob("xx" = 123), blob("xx" = 456), blob("xx" = 789)] 9 | * then bar // "xx" yields [123, 456, 789] 10 | * 11 | * "//~" selects all tags except one. 12 | * Continuing the example above: 13 | * 14 | * foo //~ "aa" yields blob("bb" = blob("cc" = [11, 22, 33])) 15 | * foo //~ "bb" yields blob("aa" = 123) 16 | * foo //~ "aa" //~ "bb" yields blob() 17 | * foo //~ ["aa", "bb"] yields blob() 18 | * foo //~ "zz" yields blob("aa" = 123, "bb" = blob("cc" = [11, 22, 33])) 19 | * 20 | * "//~" distributes over lists on either side of the operator: 21 | * 22 | * [foo, bar, baz] //~ "aa" yields the same as [foo //~ "aa", bar //~ "aa", baz //~ "aa"] 23 | * [foo, bar, baz] //~ ["aa", "bb"] yields the same as [foo //~ "aa" //~ "bb", bar //~ "aa" //~ "bb", baz //~ "aa" //~ "bb"] 24 | * 25 | * copyright 2020 by Robert Dodier 26 | * I release this work under terms of the GNU GPL. 27 | */ 28 | 29 | /* seems to cause interference between lassociative simplification and rules 30 | * 31 | nary ("//", 205, 205); 32 | declare ("//", lassociative); 33 | * 34 | */ 35 | /* try simple binary op instead */ 36 | infix ("//", 205, 205); 37 | 38 | matchdeclare ([ll, mm], listp); 39 | 40 | matchdeclare (tt, tagp); 41 | tagp (e) := stringp (e); 42 | 43 | matchdeclare (bb, blobp); 44 | blobp (e) := not atom(e) and op(e) = 'blob; 45 | 46 | matchdeclare (ss, slashslashp); 47 | slashslashp (e) := not atom(e) and op(e) = "//"; 48 | 49 | /* hmm, doesn't seem to work as expected 50 | * 51 | matchdeclare (vv, subvarp); 52 | :lisp (defun $array_op (e) (if ($subvarp e) (caar e) (merror "array_op: argument must a subscripted variable; found: ~M" e))) 53 | :lisp (defun $array_args (e) (if ($subvarp e) (cons '(mlist) (cdr e)) (merror "array_args: argument must a subscripted variable; found: ~M" e))) 54 | * 55 | */ 56 | 57 | simp: false $ 58 | 59 | tellsimp (bb // tt, assoc (tt, bb)); 60 | /* tellsimp (bb // vv, arrayapply (bb // array_op (vv), array_args (vv))); */ /* see remark above */ 61 | 62 | /* tellsimp (bb // ss, cons (bb, ss)); */ /* not sure if this version works; try next line */ 63 | tellsimp (bb // ss, lreduce ("//", cons (bb, args (ss)))); 64 | 65 | tellsimp (bb // ll, apply ('blob, map (lambda ([y], y = bb // y), ll))); 66 | tellsimp (ll // tt, map (lambda ([x], x // tt), ll)); 67 | tellsimp (ll // mm, map (lambda ([x], x // mm), ll)); 68 | 69 | matchdeclare (aa, all); 70 | tellsimp (false // aa, false); 71 | 72 | /* "//~" operator to omit tags */ 73 | 74 | infix ("//~", 205, 205); 75 | 76 | tellsimp (bb //~ tt, apply (op (bb), sublist (args (bb), lambda ([e], lhs (e) # tt)))); 77 | 78 | tellsimp (bb //~ ll, apply (op (bb), sublist (args (bb), lambda ([e], not member (lhs (e), ll))))); 79 | 80 | tellsimp (ll //~ tt, map (lambda ([x], x //~ tt), ll)); 81 | tellsimp (ll //~ mm, map (lambda ([x], x //~ mm), ll)); 82 | 83 | simp: true $ 84 | 85 | tags(b) := 86 | if listp(b) 87 | then unique (map (tags, b)) 88 | else maplist (lhs, b); 89 | -------------------------------------------------------------------------------- /robert-dodier/json_tools/read_json.mac: -------------------------------------------------------------------------------- 1 | /* read_json.mac -- read JSON data and return blob expression 2 | * 3 | * e.g.: { "aa": 123, "bb": { "cc": [11, 22, 33] } } 4 | * yields blob("aa" = 123, "bb" = blob("cc" = [11, 22, 33])) 5 | * 6 | * i.e. { ... } is replaced by blob(...), 7 | * ":" is replaced by "=", 8 | * and tags and [ ... ] are preserved. 9 | * 10 | * copyright 2020 by Robert Dodier 11 | * I release this work under terms of the GNU GPL. 12 | */ 13 | 14 | get_all_attributes (fpattern) := 15 | (read_json_all (fpattern), 16 | merge_data (%%), 17 | map (lambda ([b], assoc ("attributes", b)), %%)); 18 | 19 | get_attributes_by_name (all_attributes) := 20 | block ([use_fast_arrays: true, attributes_by_name], 21 | map (lambda ([b], assoc ("name", b)), all_attributes), 22 | unique (%%), 23 | for n in %% 24 | do (sublist (all_attributes , lambda ([b], assoc ("name", b) = n)), 25 | attributes_by_name[n]: map (lambda ([b], assoc ("data", b)), %%)), 26 | attributes_by_name); 27 | 28 | count_attributes_by_name (attributes_by_name) := 29 | block ([names: rest (arrayinfo (attributes_by_name), 2)], 30 | sort (makelist ([length (attributes_by_name[n]), n], n, names))); 31 | 32 | read_json_all (fpattern) := 33 | block ([l: directory (fpattern)], 34 | map (read_json, l)); 35 | 36 | merge_data (l) := apply (append, map (lambda ([b], assoc ("data", b)), l)); 37 | 38 | read_json (f) := subst (["{" = blob, ":" = "="], read_json_set (f)); 39 | 40 | read_json_set (f) := 41 | block ([combined_input_stream, 42 | primary_input_stream: if ?streamp(f) then f else openr (f, "UTF-8"), 43 | terminator_stream: make_string_input_stream ("$"), 44 | return_value], 45 | combined_input_stream: ?make\-concatenated\-stream (primary_input_stream, terminator_stream), 46 | return_value: second (?mread (combined_input_stream)), 47 | if not ?streamp(f) then close (primary_input_stream), 48 | return_value); 49 | 50 | /* work-around for bug in SBCL; 51 | * see: https://bugs.launchpad.net/sbcl/+bug/690408 52 | */ 53 | load ("tyi-raw.lisp"); 54 | 55 | read_json_list (f) := subst (["{" = "[", ":" = "="], read_json_set (f)); 56 | 57 | read_json_array (f) := json_list_to_array (read_json_list (f)); 58 | 59 | /* 60 | /* THIS DOESN'T WORK. */ 61 | json_list_to_array (json_list) := 62 | block ([json_array, use_fast_arrays: true], 63 | for x in json_list 64 | do block ([key: lhs(x), value: rhs(x)], 65 | json_array[key]: if atom(value) then value else json_list_to_array (value)), 66 | json_array); 67 | 68 | fast_array_p (e) := ?hash\-table\-p (e) # false; 69 | 70 | matchdeclare (aa, fast_array_p); 71 | matchdeclare (bb, all); 72 | 73 | tellsimp (aa . bb, if atom(bb) or op(bb) # "." then aa[bb] else aa[first (bb)] . second (bb)); 74 | */ 75 | -------------------------------------------------------------------------------- /robert-dodier/json_tools/rtest_json_tools.mac: -------------------------------------------------------------------------------- 1 | (if ?mget ('read_json, '?mexpr) = false 2 | then load ("json_tools.mac"), 3 | 0); 4 | 0; 5 | 6 | (S: "{ \"aa\": 123, \"bb\": { \"cc\": [11, 22, 33] } }", 7 | read_json (make_string_input_stream (S))); 8 | blob("aa" = 123, "bb" = blob("cc" = [11, 22, 33])); 9 | 10 | (foo: blob("aa" = 123, "bb" = blob("cc" = [11, 22, 33])), 11 | foo // "aa"); 12 | 123; 13 | 14 | foo // "bb"; 15 | blob("cc" = [11, 22, 33]); 16 | 17 | foo // "bb" // "cc"; 18 | [11, 22, 33]; 19 | 20 | kill(foo); 21 | done; 22 | 23 | flatten_json ([], blob ("foo" = 123, "bar" = 456)); 24 | [foo = 123, bar = 456]; 25 | 26 | flatten_json ([], blob ("foo" = blob ("bar" = 123))); 27 | [[foo.bar = 123]]; 28 | 29 | flatten_json ([bar], blob ("foo" = 123)); 30 | [bar . foo = 123]; 31 | 32 | flatten_json ([bar, baz], blob ("foo" = 123)); 33 | [bar . baz . foo = 123]; 34 | 35 | flatten_json ([baz, quux], blob ("mumble" = 456, "blurf" = 789)); 36 | [baz . quux . mumble = 456, baz . quux . blurf = 789]; 37 | 38 | flatten_json ([baz, quux], blob ("foo" = blob ("bar" = 123), "mumble" = 456, "blurf" = 789)); 39 | [[baz . quux . foo . bar = 123], baz . quux . mumble = 456, baz . quux . blurf = 789]; 40 | 41 | (foo: blob("aa" = 123, "bb" = blob("cc" = [11, 22, 33])), 42 | foo //~ "aa"); 43 | blob("bb" = blob("cc" = [11, 22, 33])); 44 | 45 | foo //~ "bb"; 46 | blob("aa" = 123); 47 | 48 | foo //~ "aa" //~ "bb"; 49 | blob(); 50 | 51 | foo //~ ["aa", "bb"]; 52 | blob(); 53 | 54 | foo //~ "zz"; 55 | blob("aa" = 123, "bb" = blob("cc" = [11, 22, 33])); 56 | 57 | (bar: blob("aa" = 789, "dd" = 111, "zz" = [1, 2, 3]), 58 | baz: blob("bb" = 777, "ee" = x - y), 59 | [foo, bar, baz] //~ "aa"); 60 | ''([foo //~ "aa", bar //~ "aa", baz //~ "aa"]); 61 | 62 | [foo //~ "aa", bar //~ "aa", baz //~ "aa"]; 63 | [blob("bb" = blob("cc" = [11, 22, 33])), blob("dd" = 111, "zz" = [1, 2, 3]), blob("bb" = 777, "ee" = x - y)]; 64 | 65 | [foo, bar, baz] //~ ["aa", "bb"]; 66 | ''([foo //~ "aa" //~ "bb", bar //~ "aa" //~ "bb", baz //~ "aa" //~ "bb"]); 67 | 68 | [foo //~ "aa" //~ "bb", bar //~ "aa" //~ "bb", baz //~ "aa" //~ "bb"]; 69 | [blob(), blob("dd" = 111, "zz" = [1, 2, 3]), blob("ee" = x - y)]; 70 | -------------------------------------------------------------------------------- /robert-dodier/json_tools/tyi-raw.lisp: -------------------------------------------------------------------------------- 1 | ;; work-around for bug in SBCL; 2 | ;; see: https://bugs.launchpad.net/sbcl/+bug/690408 3 | ;; This TYI-RAW is identical to the one in src/commac.lisp 4 | ;; except that the call to READ-CHAR-NO-HANG has been replaced by READ-CHAR. 5 | 6 | (defun tyi-raw (&optional (stream *standard-input*) eof-option) 7 | ;; Adding this extra EOF test, because the testsuite generates 8 | ;; unexpected end of input-stream with Windows XP and GCL 2.6.8. 9 | #+gcl 10 | (when (eql (peek-char nil stream nil eof-option) eof-option) 11 | (return-from tyi-raw eof-option)) 12 | 13 | (let ((ch (read-char stream nil eof-option))) 14 | (if ch 15 | ch 16 | (progn 17 | (when (and *prompt-on-read-hang* *read-hang-prompt*) 18 | (princ *read-hang-prompt*) 19 | (finish-output *standard-output*)) 20 | (read-char stream nil eof-option))))) 21 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/README.md: -------------------------------------------------------------------------------- 1 | ## Implementation of lexical symbols in Maxima language 2 | 3 | ### Status of this proposal 4 | 5 | This package, maxima-packages/robert-dodier/lexical\_symbols, 6 | is an unofficial, optional package to reimplement local variables as lexical symbols. 7 | 8 | I hope that the policies outlined here will be someday incorporated into Maxima, 9 | perhaps in the same way as they are implemented here, perhaps implemented in a way 10 | that differs in a small or large way. 11 | 12 | Everything here is subject to change, although some items seem more fixed than others. 13 | At this point, it seems unlikely that the large-scale policies 14 | (local variables are lexical symbols and functions and expressions are tied to their lexical environment) 15 | will change, but it's too soon to say so for sure. 16 | 17 | ### How to use this package 18 | 19 | ``` 20 | d: "path/to/maxima-packages/robert-dodier/lexical_symbols" $ 21 | push (sconcat (d, "/###.lisp"), file_search_lisp) $ 22 | push (sconcat (d, "/###.mac"), file_search_maxima) $ 23 | push (sconcat (d, "/###.demo"), file_search_demo) $ 24 | load ("lexical_symbols.mac"); 25 | ``` 26 | 27 | To get an overview, take a look at: 28 | ``` 29 | demo ("lexical_symbols.demo"); 30 | ``` 31 | 32 | To see the test cases, try: 33 | ``` 34 | batch ("rtest_lexical_symbols.mac", test); 35 | ``` 36 | 37 | ### Outline 38 | 39 | LEXICAL SYMBOLS 40 | 41 | * A lexical symbol is a symbol defined in a lexical extent. 42 | 43 | * A lexical extent is one of the following operators and its arguments: 44 | * `block` 45 | * `lambda` 46 | * named function 47 | * array function (both `f[x]` and `f[x](y)`) 48 | * `for` loop 49 | * macro (i.e., defined by `::=`) (*not implemented yet*) 50 | * `buildq` (*not implemented yet*) 51 | * `makelist` (*not implemented yet*) 52 | * `create_list` (*not implemented yet*) 53 | 54 | * Lexical symbols defined in different lexical extents are distinct, even if they have the same name. 55 | 56 | * Every symbol which is not a lexical symbol is a global symbol. 57 | * There is a unique global symbol for any given name. 58 | * Dynamic binding is applied to global symbols. 59 | 60 | * In addition, a symbol may be declared `global` so that it is a global symbol 61 | even if it is defined in a lexical extent. 62 | * A `global` declaration applies to any lexical extents parsed after the declaration is evaluated. (*subject to change*) 63 | 64 | EVALUATION IN A LEXICAL ENVIRONMENT 65 | 66 | * Function calls (named and unnamed) are evaluated in the lexical environment in which they were defined. 67 | 68 | * All functions (named and unnamed) defined in a lexical extent share the same lexical environment. 69 | * *unresolved question*: same environment, or similar, in the sense that the symbols are the same, 70 | but the values might be different? 71 | 72 | * A lexical environment is a list of pairs of symbols and values. 73 | * *unresolved question*: can a symbol appear in more than one environment? 74 | I suspect we want the answer to be yes, because then a closure can capture a specific value. 75 | But if so, then how to we get functions to share lexical variables? 76 | 77 | * An expression containing lexical symbols returned from a lexical extent 78 | is wrapped in an object, called a closure, comprising the lexical environment and the expression. 79 | 80 | * A closure is evaluated by evaluating its contained expression with the symbols 81 | in its contained environment bound to their current values. (*not implemented yet*) 82 | 83 | * A closure is simplified according to some rules specifically for closures. 84 | * closure([], expr) --> expr 85 | * closure([env], expr) --> expr when expr is free of all of the symbols in env 86 | * closure([env1], closure([env2], expr)) --> closure([env1, env2], expr) 87 | 88 | * Also any simplifications applicable to expr are applied. 89 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/lexical_symbols.demo: -------------------------------------------------------------------------------- 1 | if not member (global, features) then load ("lexical_symbols.mac") $ 2 | 3 | "A lexical symbol is a symbol defined in a lexical extent. 4 | A lexical extent is one of the following operators and its arguments: 5 | block, lambda, named function, array function (both f[x] and f[x](y)), for loop." $ 6 | 7 | "The lexical symbols defined in this lexical extent are a, b, and c." $ 8 | 9 | block([a, b, c], a: 11, b: 22, c: 44, a + b + c); 10 | 11 | "The lexical symbols defined in this lexical extent are x and y." $ 12 | 13 | lambda([x, y], x*y + 1); 14 | 15 | "The lexical symbols defined in this lexical extent are u, v, and w." $ 16 | 17 | foo(u, v, w) := u/v - w; 18 | 19 | "The lexical symbols defined in this lexical extent are baz and quux." $ 20 | 21 | bar[baz, quux] := quux - 2*baz; 22 | 23 | "The lexical symbols defined in this lexical extent are blurf, m, and n." $ 24 | 25 | mumble[blurf](m, n) := blurf^m - blurf^n; 26 | 27 | "The lexical symbol defined in this lexical extent is i." $ 28 | 29 | for i thru 3 do print(i); 30 | 31 | "The lexical symbol defined in this lexical extent is a." $ 32 | 33 | for a in [3, 4, 5] do print(a); 34 | 35 | "The lexical symbols defined in this lexical extent are a, b, and c. 36 | The symbols x, y, and z are not defined in this lexical extent." $ 37 | 38 | block([a: x, b: y - 1, c: 44], a + b + c + z); 39 | 40 | "The lexical symbols defined in this lexical extent are x and y. 41 | The symbols A and Z are not defined in this lexical extent." $ 42 | 43 | lambda([x, y], A*x*y + Z); 44 | 45 | "The lexical symbols defined in this lexical extent are u, v, and w. 46 | The symbol omega is not defined in this lexical extent." $ 47 | 48 | foo(u, v, w) := u*v^(-omega) - w; 49 | 50 | "The lexical symbols defined in this lexical extent are baz and quux. 51 | The symbols red and green are not defined in this lexical extent." $ 52 | 53 | bar[baz, quux] := red*quux - green*baz; 54 | 55 | "The lexical symbols defined in this lexical extent are blurf, m, and n. 56 | The symbols snort and sneeze are not defined in this lexical extent." $ 57 | 58 | mumble[blurf](m, n) := (blurf - snort)^m - (blurf - sneeze)^n; 59 | 60 | "The lexical symbol defined in this lexical extent is i. 61 | The symbols i0 and i1 are not defined in this lexical extent." $ 62 | 63 | 'for i:i0 thru i1 do print(i); 64 | 65 | "The lexical symbol defined in this lexical extent is a. 66 | The symbols b, c, and d are not defined in this lexical extent." $ 67 | 68 | for a in [b, c, d] do print(a); 69 | 70 | "Lexical symbols defined in different lexical extents are distinct, even if they have the same name." $ 71 | 72 | "a1 in the outer block is distinct from a1 in the inner block, 73 | so is('a1 = b1) is false." $ 74 | 75 | block([a1, b1], b1: 'a1, block([a1], is('a1 = b1))); 76 | 77 | "Any symbol which is not a lexical symbol is a global symbol. 78 | There is a unique global symbol for any given name. 79 | Dynamic binding is applied to global symbols." $ 80 | 81 | "a1 is a global symbol, so is('a1 = b1) is true." $ 82 | 83 | block([b1], b1: 'a1, block(is('a1 = b1))); 84 | 85 | "a1 is a global symbol, but a1 in the inner block is distinct, so is('a1 = b1) is false." $ 86 | 87 | block([b1], b1: 'a1, block([a1], is('a1 = b1))); 88 | 89 | "Function calls (named and unnamed) are evaluated in the lexical environment in which they were defined. 90 | All functions (named and unnamed) defined in a lexical extent share the same lexical environment." $ 91 | 92 | block([a], set_a(b) := a: b, inc_a() := a: a + 1, get_a() := a); 93 | 94 | set_a(100); 95 | get_a(); 96 | inc_a(); 97 | a: 999; 98 | get_a(); 99 | 100 | /* smashing lexical environment into lambda not implemented yet !! 101 | kill(set_a, inc_a, get_a); 102 | block([a], set_a: lambda([b], a: b), inc_a: lambda([], a: a + 1), get_a: lambda([], a)); 103 | 104 | set_a(200); 105 | get_a(); 106 | inc_a(); 107 | a: 999; 108 | get_a(); 109 | */ 110 | 111 | "A lexical environment is a list of pairs of symbols and values. 112 | An expression containing lexical symbols returned from a lexical extent 113 | is wrapped in an object, called a closure, comprising the lexical environment and the expression." $ 114 | 115 | block([a], set_a(b) := a: b, foo(x) := a*x); 116 | 117 | foo(z); 118 | set_a(1234); 119 | foo(z); 120 | 121 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/lexical_symbols.mac: -------------------------------------------------------------------------------- 1 | if featurep (global, feature) = false 2 | then (load ("lexical_symbols.lisp"), 3 | load ("with-lexical-environment.lisp"), 4 | load ("mlambda.lisp"), 5 | load ("meval.lisp")) 6 | else print ("lexical_symbols: appears to be loaded already, I won't do it again."); 7 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/meval.lisp: -------------------------------------------------------------------------------- 1 | (setf (symbol-function 'prev-meval) (symbol-function 'meval)) ;; traceable 2 | (defun meval (e) 3 | (if (and (consp e) (eq (caar e) '$closure)) 4 | (with-lexical-environment (rest (second e)) (prev-meval (third e))) 5 | (prev-meval e))) 6 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/mlambda.lisp: -------------------------------------------------------------------------------- 1 | ;; MLAMBDA COPIED VERBATIM FROM SRC/MLISP.LISP 2 | ;; WITH CHANGES FOR LEXICAL SYMBOLS AS NOTED 3 | 4 | (defun mlambda (lambda-or-closure args fnname noeval form) 5 | ; We assume that the lambda expression handed to us has been simplified, 6 | ; or at least that it's well-formed. This is because various checks are 7 | ; performed during simplification instead of every time lambda expressions 8 | ; are applied to arguments. 9 | (setq noevalargs nil) 10 | (let* ((closure-envs (if (eq (caar lambda-or-closure) '$closure) (rest (second lambda-or-closure)))) 11 | (fn (if (eq (caar lambda-or-closure) '$closure) (third lambda-or-closure) lambda-or-closure)) 12 | (params (cdadr fn)) 13 | (mlocp t)) 14 | (setq loclist (cons nil loclist)) 15 | (do ((a) (p)) 16 | ((or (null params) (and (null args) (not (mdeflistp params)))) 17 | (setq args (nreconc a args) params (nreconc p params))) 18 | (cond ((mdeflistp params) 19 | (setq params (cdar params) args (ncons (cons '(mlist) args))))) 20 | (cond ((and mfexprp (mquotep (car params))) 21 | (setq a (cons (car args) a) p (cons (cadar params) p))) 22 | ((atom (car params)) 23 | (setq p (cons (car params) p) 24 | a (cons (cond (noeval (car args)) 25 | (t (meval (car args)))) a))) 26 | (t (merror (intl:gettext "lambda: formal argument must be a symbol or quoted symbol; found: ~M") (car params)))) 27 | (setq args (cdr args) params (cdr params))) 28 | (let (finish2033 #+nil (finish2032 params) (ar *mlambda-call-stack*)) 29 | (declare (type (vector t) ar)) 30 | (unwind-protect 31 | (progn 32 | (unless (> (array-total-size ar) (+ (fill-pointer ar) 10)) 33 | (setq ar (adjust-array ar (+ (array-total-size ar) 50) :fill-pointer (fill-pointer ar)))) 34 | (vector-push bindlist ar) 35 | ;; rather than pushing all on *baktrcl* it might be good 36 | ;; to make a *last-form* global that is set in meval1 37 | ;; and is pushed here. 38 | (vector-push form ar) 39 | (vector-push params ar) 40 | (vector-push args ar) 41 | (vector-push fnname ar) 42 | #+nil (mbind finish2032 args fnname) 43 | (setq finish2033 t) 44 | (let ((aexprp (and aexprp (not (atom (caddr fn))) (eq (caar (caddr fn)) 'lambda)))) 45 | (let 46 | ((new-env (make-hash-table)) 47 | (new-env-id (gensym "ENV"))) 48 | ;; EXCLUDE NON-LEXICAL VARIABLES HERE ?? I DUNNO !! 49 | ;; DON'T BOTHER WITH NEW-ENV IF PARAMS IS EMPTY ?? MAYBE !! 50 | (mapcar #'(lambda (s v) (setf (gethash s new-env) v)) params args) 51 | (setf (get new-env-id 'env) new-env) 52 | (with-lexical-environment (cons new-env-id closure-envs) 53 | (cond ((null (cddr fn)) (merror (intl:gettext "lambda: no body present."))) 54 | ((cdddr fn) (mevaln (cddr fn))) 55 | (t (meval (caddr fn)))))))) 56 | (if finish2033 57 | (progn 58 | (incf (fill-pointer *mlambda-call-stack*) -5) 59 | (munlocal) 60 | #+nil (munbind finish2032))))))) 61 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/mset.lisp: -------------------------------------------------------------------------------- 1 | ;; intercept assignments and enclose values if a lexical environment is active 2 | ;; and the left-hand side is outside the environment. 3 | 4 | (defun get-innermost-op (x) 5 | ;; ASSUME WITHOUT CHECKING THAT X IS A CONS !! 6 | ;; MQAPPLY WITH ATOMIC ARGUMENT SIMPLIFIES TO NON-MQAPPLY !! 7 | ;; SO IT SEEMS IMPOSSIBLE THAT X IS NOT A CONS UNLESS X IS UNSIMPLIFIED !! 8 | ;; PROBABLY BEST TO GUARD AGAINST IT !! 9 | (if (eq (caar x) 'mqapply) 10 | (get-innermost-op (second x)) 11 | (caar x))) 12 | 13 | (let ((prev-mset (symbol-function 'mset))) 14 | (defun mset (x y) 15 | (declare (special *active-lexical-environments*)) 16 | (if *active-lexical-environments* 17 | (let ((x-symbol (if (symbolp x) x (get-innermost-op x)))) 18 | (if (every #'(lambda (e) (freeof-env (get e 'env) x-symbol)) *active-lexical-environments*) 19 | (funcall prev-mset x `(($closure) ((mlist) ,@*active-lexical-environments*) ,y)) 20 | (funcall prev-mset x y))) 21 | (funcall prev-mset x y)))) 22 | 23 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/plan6.txt: -------------------------------------------------------------------------------- 1 | Plan for implementing lexical symbols in Maxima 2 | Robert Dodier 3 | Nov. 4, 2021 4 | subject to revision 5 | 6 | 7 | Outline: 8 | 9 | * branch source code, leading to Maxima 6 10 | 11 | * implement lexical symbols first (Maxima 6.0) 12 | 13 | * ensure it doesn't break stuff 14 | 15 | * fix up stuff around the edges 16 | 17 | * upon releasing 6.0, switch general development to 6.nnn instead of 5.nnn 18 | 19 | * work on closures post-6.0 20 | 21 | 22 | Disclaimer: 23 | 24 | I refuse to consider having both lexical and dynamic symbols for the constructs which are getting lexical symbols in this implementation. 25 | 26 | 27 | Details: 28 | 29 | * I have been working in: 30 | https://github.com/maxima-project-on-github/maxima-packages 31 | See the folder: robert-dodier/lexical_symbols 32 | 33 | * The lexical symbols only implementation is in: lexical_symbols.lisp 34 | 35 | * lexical_symbols.lisp is a working implementation (via gensym + alias) for lexical symbols. It is pretty simplistic. If someone has an alternative, I'm all ears. 36 | 37 | * Lexical symbols are defined for these constructs: functions (named and unnamed, f(x), f[x], and f[x](y)), block, and for loops ('for i thru ...' and 'for i in ...'). 38 | 39 | * These constructs work as expected, according to test cases (rtest_lexical_symbols_only.mac). 40 | 41 | * I have experimented with closures but it doesn't really work yet. I'd like to get that working eventually too. We can work on closures post-Maxima 6.0. 42 | 43 | * I am proposing to make a branch in the Maxima Git repo for branch-maxima-6, to copy lexical_symbols.lisp there, and to work in the Maxima Git repo to continue development towards Maxima 6. 44 | 45 | * Unresolved issues. In the interest of brevity, I have omitted discussion of these items from this document. (a) Interaction with global constructs, (b) additional constructs for consideration, (c) interaction with debugger. 46 | 47 | * (a) Interaction with global constructs: assume database, declarations, infolists ('functions', 'arrays', etc.). 48 | 49 | * (b) Additional constructs for consideration: 'at', 'integrate', 'sum', 'lsum', 'makelist', 'create_list', possibly others. 50 | 51 | * (c) Interaction with debugger: how to refer to lexical symbols in debugging session, how to disambiguate multiple lexical symbols by same name. 52 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/simplify_product.mac: -------------------------------------------------------------------------------- 1 | simplify_product(myprod) := block( 2 | [term, %n, lo, hi, %kk : 0, nu, de, comm : [], p% : 1, 3 | deg : simplify_products_deg, %j1], 4 | if simplify_products=false then return(myprod), 5 | if atom(myprod) then return(myprod), 6 | if member(part(myprod, 0), ["+", "-", "*", "/", "^"]) then 7 | return(apply(part(myprod, 0), map('simplify_product, args(myprod)))), 8 | if part(myprod, 0)#nounify('product) then return(myprod), 9 | 10 | /* Read product arguments. */ 11 | %n : part(myprod, 2), 12 | lo : part(myprod, 3), 13 | hi : part(myprod, 4), 14 | term : factor(part(myprod, 1)), 15 | 16 | if lo#1 then return(simplify_product(changevar(myprod, %j1=%n-lo+1, %j1, %n))), 17 | 18 | /* Check for simple cases. */ 19 | if term=%n then return(hi!/(lo-1)!), 20 | 21 | if atom(term) or freeof(%n, term) then return(term^(hi-lo+1)), 22 | 23 | /* Distribute over products. */ 24 | if part(term, 0)="*" then ( 25 | p%*apply("*", map(lambda([u], simplify_product(apply(nounify('product), 26 | [u, %n, lo, hi]))), 27 | args(term))) 28 | ) 29 | /* Take care of fractions. */ 30 | else if part(term, 0)="/" then block( 31 | [nu : num(term), de : denom(term)], 32 | /* Check for cancellations. */ 33 | for %kk:-deg thru deg do block( 34 | [g], 35 | g : gcd(expand(subst(%n+%kk, %n, nu)), de), 36 | if not(freeof(%n, g)) then ( 37 | comm : append(comm, [[%kk, g, subst(%n-%kk, %n, g)]]), 38 | de : ratsimp(de/g), 39 | nu : ratsimp(nu/subst(%n-%kk, %n, g)) 40 | ) 41 | ), 42 | /* Cancel common terms. */ 43 | for c in comm do block( 44 | [kk : c[1], d], 45 | if kk<0 then ( 46 | p% : p%*my_prod(c[3], %n, hi+kk+1, hi), 47 | d : my_prod(c[2], %n, lo, lo-kk-1), 48 | p% : p%/d 49 | ) 50 | else ( 51 | p% : p%*1/my_prod(c[2], %n, hi-kk+1, hi), 52 | d : my_prod(c[3], %n, lo, lo+kk-1), 53 | p% : p%*d 54 | ) 55 | ), 56 | /* Distribute over fractions. */ 57 | nu : simplify_product(apply(nounify('product), [nu, %n, lo, hi])), 58 | de : simplify_product(apply(nounify('product), [de, %n, lo, hi])), 59 | p%*nu/de 60 | ) 61 | else if part(term, 0)="^" and integerp(part(term, 2)) then ( 62 | simplify_product(apply(nounify('product), [part(term, 1), %n, lo, hi]))^ 63 | part(term, 2) 64 | ) 65 | /* Assume we have a poly. */ 66 | else block( 67 | [aa, bb, lcoeff, %m], 68 | bb : bothcoef(term, %n), aa : bb[1], bb : bb[2], 69 | 70 | /* Take care of linear products. */ 71 | if freeof(%n, aa) and freeof(%n, bb) then ( 72 | if aa=1 then ( 73 | %m : term - %n, 74 | (hi+%m)!/(lo+%m-1)! 75 | ) 76 | else if aa=-1 then ( 77 | %m : term + %n, 78 | (%m-lo)!/(%m-hi-1)! 79 | ) 80 | else if product_use_gamma and integerp(aa) then 81 | gamma(subst(hi+1, %n, expand(term/aa)))/ 82 | gamma(subst(lo, %n, expand(term/aa)))*aa^(hi-lo+1) 83 | else 84 | myprod 85 | ) 86 | else if part(term, 0)="-" and length(args(term))=1 then 87 | (-1)^(hi-lo+1)*simplify_product(apply(nounify('product), [-term, %n, lo, hi])) 88 | /* Give up! */ 89 | else 90 | p%*apply(nounify('product), [factor(term), %n, lo, hi]) 91 | ) 92 | )$ 93 | -------------------------------------------------------------------------------- /robert-dodier/lexical_symbols/trigrat.lisp: -------------------------------------------------------------------------------- 1 | (in-package :maxima) 2 | 3 | (if #$member (global, features)$ 4 | (meval #$declare ([d2%, lg, lexp], global)$)) 5 | 6 | (defun $listofei (e ) 7 | (declare (special $d2% $lg $lexp)) 8 | (setq $d2% (copy-tree (car e))) 9 | (setq $lg ()) 10 | (setq $lexp ()) 11 | (do ((lvar (caddr $d2%) (cdr lvar)) 12 | (lg (cadddr $d2%) (cdr lg)) 13 | (var)) 14 | ((null lvar)(setq $lg (cons '(mlist) $lg)) 15 | (setq $lexp (cons '(mlist) $lexp)) 16 | (setq $d2% (cons $d2% (cdr e))) ) 17 | (setq var (car lvar)) 18 | (cond ((and (mexptp var) 19 | (equal (cadr var) '$%e) 20 | ; (mtimesp (caddr var)) 21 | ; (eq (cadr (caddr var)) '$%i) 22 | ;; Check that we have a factor of %i. This test includes 23 | ;; cases like %i, and %i*x/2, which we get for e.g. 24 | ;; sin(1) and sin(x/2). 25 | (eq '$%i (cdr (partition (if (atom (caddr var)) 26 | (list '(mtimes)(caddr var)) 27 | (caddr var)) 28 | '$%i 1)))) 29 | (setq $lexp (cons var $lexp)) 30 | (setq var (symbolconc "$_" (car lg))) 31 | (setq $lg (cons var $lg)) 32 | (rplaca lvar var))))) 33 | 34 | #$trigrat_equationp (e%) := 35 | not atom (e%) 36 | and member (op (e%), ["=", "#", "<", "<=", ">=", ">"])$ 37 | 38 | #$trigrat(exp):= 39 | if matrixp (exp) or listp (exp) or setp (exp) or trigrat_equationp (exp) 40 | then map (trigrat, exp) 41 | else block([e%,n%,d%,lg,f%,lexp,ls,d2%,l2%,alg,gcd1], 42 | alg:algebraic,gcd1:gcd, 43 | algebraic:true,gcd:subres, 44 | e%: rat(ratsimp(expand(exponentialize(exp)))), 45 | n%:num(e%),d%:denom(e%), 46 | listofei(d%), 47 | l2%:map(lambda([u%,v%],u%^((hipow(d2%,v%)+lopow(d2%,v%))/2)), 48 | lexp,lg), 49 | f%:if length(lexp)=0 then 1 50 | else if length(lexp)=1 then part(l2%,1) 51 | else apply("*",l2%), 52 | n%:rectform(ratexpand(n%/f%)), 53 | d%:rectform(ratexpand(d%/f%)), 54 | e%:ratsimp(n%/d%,%i), 55 | algebraic:alg,gcd:gcd1, 56 | e%)$ 57 | 58 | ; written by D. Lazard, august 1988 59 | 60 | -------------------------------------------------------------------------------- /robert-dodier/low_discrepancy/low_discrepancy-index.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-info) 2 | (let ( 3 | (deffn-defvr-pairs '( 4 | ; CONTENT: ( . ( )) 5 | ("cacm647_makelist_faure" . ("low_discrepancy.info" 1749 166 "Definitions for package low_discrepancy")) 6 | ("cacm647_makelist_halton" . ("low_discrepancy.info" 1916 170 "Definitions for package low_discrepancy")) 7 | )) 8 | (section-pairs '( 9 | ; CONTENT: ( . ( )) 10 | ("Definitions for package low_discrepancy" . ("low_discrepancy.info" 1661 425)) 11 | ("Introduction to package low_discrepancy" . ("low_discrepancy.info" 781 708)) 12 | ))) 13 | (load-info-hashtables (maxima::maxima-load-pathname-directory) deffn-defvr-pairs section-pairs)) 14 | -------------------------------------------------------------------------------- /robert-dodier/low_discrepancy/low_discrepancy.asd: -------------------------------------------------------------------------------- 1 | (defsystem low_discrepancy 2 | :defsystem-depends-on ("maxima-file" "info-index") 3 | :name "low_discrepancy" 4 | :maintainer "Robert Dodier" 5 | :author "Robert Dodier" 6 | :licence "ACM License" 7 | :description "Low-discrepancy sequences" 8 | :long-description "Maxima package for generating low-discrepancy (quasirandom) sequences, based on CACM Algorithm 647." 9 | 10 | :components 11 | ((:maxima-file "cacm647") 12 | (:info-index "low_discrepancy-index"))) 13 | -------------------------------------------------------------------------------- /robert-dodier/low_discrepancy/low_discrepancy.info: -------------------------------------------------------------------------------- 1 | This is low_discrepancy.info, produced by makeinfo version 5.2 from 2 | low_discrepancy.texi. 3 | 4 | INFO-DIR-SECTION Mathematics/Maxima 5 | START-INFO-DIR-ENTRY 6 | * Package low_discrepancy: (maxima)Maxima share package low_discrepancy for low-discrepancy (quasirandom) sequences. 7 | END-INFO-DIR-ENTRY 8 | 9 |  10 | File: low_discrepancy.info, Node: Top, Next: Introduction to package low_discrepancy, Prev: (dir), Up: (dir) 11 | 12 | Package low_discrepancy 13 | *********************** 14 | 15 | * Menu: 16 | 17 | * Introduction to package low_discrepancy:: 18 | * Definitions for package low_discrepancy:: 19 | * Function and variable index:: 20 | 21 | 1 Package low_discrepancy 22 | ************************* 23 | 24 |  25 | File: low_discrepancy.info, Node: Introduction to package low_discrepancy, Next: Definitions for package low_discrepancy, Prev: Top, Up: Top 26 | 27 | 1.1 Introduction to package low_discrepancy 28 | =========================================== 29 | 30 | Package 'low_discrepancy' contains functions to construct 31 | low-discrepancy sequences, also known as quasirandom sequences. 32 | 33 | At present there are functions to construct Faure and Halton 34 | sequences as prescribed by Algorithm 647 of the Collected Algorithms of 35 | the ACM (CACM). The Maxima code is a translation of a Java translation 36 | of the original Fortran code. CACM Algorithm 647 also contains code for 37 | Sobol sequences, which is not yet translated. 38 | 39 | It is foreseen that other algorithms for low-discrepancy sequences 40 | could be collected here, although there is no definite plan to do so at 41 | this time (January 2019). 42 | 43 |  44 | File: low_discrepancy.info, Node: Definitions for package low_discrepancy, Next: Function and variable index, Prev: Introduction to package low_discrepancy, Up: Top 45 | 46 | 1.2 Definitions for package low_discrepancy 47 | =========================================== 48 | 49 | -- Function: cacm647_makelist_faure (, ) 50 | 51 | Returns the first elements of the -dimensional Faure 52 | sequence, as prescribed by CACM Algorithm 647. 53 | 54 | -- Function: cacm647_makelist_halton (, ) 55 | 56 | Returns the first elements of the -dimensional Halton 57 | sequence, as prescribed by CACM Algorithm 647. 58 | 59 |  60 | File: low_discrepancy.info, Node: Function and variable index, Prev: Definitions for package low_discrepancy, Up: Top 61 | 62 | Appendix A Function and variable index 63 | ************************************** 64 | 65 | [index] 66 | * Menu: 67 | 68 | * cacm647_makelist_faure: Definitions for package low_discrepancy. 69 | (line 6) 70 | * cacm647_makelist_halton: Definitions for package low_discrepancy. 71 | (line 11) 72 | 73 | 74 |  75 | Tag Table: 76 | Node: Top285 77 | Node: Introduction to package low_discrepancy633 78 | Node: Definitions for package low_discrepancy1489 79 | Node: Function and variable index2086 80 |  81 | End Tag Table 82 | -------------------------------------------------------------------------------- /robert-dodier/low_discrepancy/low_discrepancy.texi: -------------------------------------------------------------------------------- 1 | \input texinfo 2 | 3 | @setfilename low_discrepancy.info 4 | @settitle Package low_discrepancy 5 | 6 | @ifinfo 7 | @macro var {expr} 8 | <\expr\> 9 | @end macro 10 | @end ifinfo 11 | 12 | @dircategory Mathematics/Maxima 13 | @direntry 14 | * Package low_discrepancy: (maxima)Maxima share package low_discrepancy for low-discrepancy (quasirandom) sequences. 15 | @end direntry 16 | 17 | @node Top, Introduction to package low_discrepancy, (dir), (dir) 18 | @top 19 | @menu 20 | * Introduction to package low_discrepancy:: 21 | * Definitions for package low_discrepancy:: 22 | * Function and variable index:: 23 | @end menu 24 | @chapter Package low_discrepancy 25 | 26 | @node Introduction to package low_discrepancy, Definitions for package low_discrepancy, Top, Top 27 | @section Introduction to package low_discrepancy 28 | 29 | Package @code{low_discrepancy} contains functions to construct low-discrepancy sequences, 30 | also known as quasirandom sequences. 31 | 32 | At present there are functions to construct Faure and Halton sequences 33 | as prescribed by Algorithm 647 of the Collected Algorithms of the ACM (CACM). 34 | The Maxima code is a translation of a Java translation of the original Fortran code. 35 | CACM Algorithm 647 also contains code for Sobol sequences, which is not yet translated. 36 | 37 | It is foreseen that other algorithms for low-discrepancy sequences 38 | could be collected here, 39 | although there is no definite plan to do so at this time (January 2019). 40 | 41 | @node Definitions for package low_discrepancy, Function and variable index, Introduction to package low_discrepancy, Top 42 | @section Definitions for package low_discrepancy 43 | 44 | @deffn {Function} cacm647_makelist_faure (@var{m}, @var{n}) 45 | 46 | Returns the first @var{n} elements of the @var{m}-dimensional Faure sequence, 47 | as prescribed by CACM Algorithm 647. 48 | 49 | @end deffn 50 | 51 | @deffn {Function} cacm647_makelist_halton (@var{m}, @var{n}) 52 | 53 | Returns the first @var{n} elements of the @var{m}-dimensional Halton sequence, 54 | as prescribed by CACM Algorithm 647. 55 | 56 | @end deffn 57 | 58 | @c @defvr {Variable} frotz 59 | @c Default value: @code{true} 60 | @c 61 | @c When @code{frotz} is @code{true}, 62 | @c @code{transmogrify} computes the transmogrification by Smith's algorithm. 63 | @c Otherwise, the transmogrification is computed by Jones' algorithm. 64 | @c 65 | @c @end defvr 66 | 67 | @node Function and variable index, , Definitions for package low_discrepancy, Top 68 | @appendix Function and variable index 69 | @printindex fn 70 | @printindex vr 71 | 72 | @bye 73 | -------------------------------------------------------------------------------- /robert-dodier/low_discrepancy/rtest_cacm647.mac: -------------------------------------------------------------------------------- 1 | cacm647_makelist_faure (2, 10); 2 | [[0.9375,0.0625],[0.03125,0.53125],[0.53125,0.03125],[0.28125,0.28125],[0.78125,0.78125],[0.15625,0.15625], 3 | [0.65625,0.65625],[0.40625,0.90625],[0.90625,0.40625],[0.09375,0.46875]]$ 4 | 5 | cacm647_makelist_faure (3, 10); 6 | [[0.9876543209876543,0.7654320987654321,0.2098765432098765],[0.004115226337448559,0.4609053497942386,0.5843621399176955], 7 | [0.3374485596707819,0.794238683127572,0.9176954732510287],[0.6707818930041152,0.1275720164609054,0.2510288065843621], 8 | [0.1152263374485597,0.9053497942386831,0.02880658436213991],[0.448559670781893,0.2386831275720165,0.3621399176954732], 9 | [0.7818930041152262,0.5720164609053499,0.6954732510288065],[0.2263374485596708,0.01646090534979424,0.8065843621399176], 10 | [0.559670781893004,0.3497942386831275,0.139917695473251],[0.8930041152263374,0.6831275720164608,0.4732510288065843]]$ 11 | 12 | cacm647_makelist_faure (4, 10); 13 | [[0.9984000000000001,0.3744000000000001,0.1504,0.04640000000000001], 14 | [3.200000000000002e-4,0.3747200000000001,0.3171200000000001,0.3555200000000001],[0.20032,0.57472,0.51712,0.55552], 15 | [0.40032,0.7747200000000001,0.7171200000000002,0.7555200000000001],[0.60032,0.97472,0.9171200000000002,0.95552], 16 | [0.80032,0.17472,0.11712,0.15552],[0.04032,0.41472,0.7571200000000001,0.9955200000000001], 17 | [0.24032,0.61472,0.9571200000000001,0.19552],[0.44032,0.81472,0.15712,0.39552], 18 | [0.64032,0.01472,0.3571200000000001,0.59552]]$ 19 | 20 | cacm647_makelist_faure (5, 10); 21 | [[0.9984000000000001,0.3744000000000001,0.1504,0.04640000000000001,0.1424], 22 | [3.200000000000002e-4,0.3747200000000001,0.3171200000000001,0.3555200000000001,0.24992], 23 | [0.20032,0.57472,0.51712,0.55552,0.44992], 24 | [0.40032,0.7747200000000001,0.7171200000000002,0.7555200000000001,0.6499200000000002], 25 | [0.60032,0.97472,0.9171200000000002,0.95552,0.8499200000000001],[0.80032,0.17472,0.11712,0.15552,0.04992000000000001], 26 | [0.04032,0.41472,0.7571200000000001,0.9955200000000001,0.08992000000000003], 27 | [0.24032,0.61472,0.9571200000000001,0.19552,0.28992],[0.44032,0.81472,0.15712,0.39552,0.48992], 28 | [0.64032,0.01472,0.3571200000000001,0.59552,0.6899200000000002]]$ 29 | 30 | cacm647_makelist_faure (6, 10); 31 | [[0.9995835068721366,0.4602249062890462,0.9412744689712619,0.3202832153269471,0.9850062473969179,0.8334027488546438], 32 | [5.949901826619859e-5,0.2437079788183495,0.376569286606771,0.6493722853572915,0.6685309692390076,0.3582435889807818], 33 | [0.1429166418754091,0.3865651216754923,0.5194264294639138,0.7922294282144343,0.8113881120961504,0.5011007318379247], 34 | [0.2857737847325519,0.5294222645326352,0.6622835723210566,0.9350865710715772,0.9542452549532933,0.6439578746950674], 35 | [0.4286309275896947,0.672279407389778,0.8051407151781994,0.07794371392872017,0.09710239781043611,0.7868150175522102], 36 | [0.5714880704468376,0.8151365502469208,0.9479978580353423,0.220800856785863,0.2399595406675789,0.9296721604093531], 37 | [0.7143452133039805,0.9579936931040637,0.09085500089248527,0.3636579996430059,0.3828166835247218,0.0725293032664961], 38 | [0.8572023561611233,0.1008508359612066,0.2337121437496281,0.5065151425001487,0.5256738263818648,0.2153864461236389], 39 | [0.02046766228357232,0.4069732849407984,0.6826917355863628,0.09835187719402629,0.2603677039328851,0.09293746653180222], 40 | [0.1633248051407152,0.5498304277979412,0.8255488784435056,0.2412090200511691,0.4032248467900279,0.235794609388945]]$ 41 | -------------------------------------------------------------------------------- /robert-dodier/more_ezunits/add_compatible_units.mac: -------------------------------------------------------------------------------- 1 | /* add_compatible_units -- add compatible units for ezunits 2 | * 3 | * Copyright 2022 by Robert Dodier 4 | * I release this work under terms of the GNU General Public License, v2. 5 | * 6 | * This program contains :lisp, so you have to use 'batch' to load it; 7 | * 'load' doesn't handle :lisp. 8 | */ 9 | 10 | if not featurep (dimensional, feature) then load (ezunits); 11 | 12 | add_compatible_units (e) := apply2 (e, compatible_units_r1, compatible_units_r2, compatible_units_r3); 13 | 14 | matchdeclare (aa, all, uu, unitop_p); 15 | 16 | defrule (compatible_units_r1a, aa + uu, compatible_units_foo (uu, aa)); 17 | 18 | "work-around for SF bug #3938 causing stack overflow"; 19 | :lisp (defun $compatible_units_r1 (e) (when (and (consp e) (eq (caar e) 'mplus)) ($compatible_units_r1a e))) 20 | 21 | matchdeclare (pp, lambda ([e], not atom(e) and op(e) = "+")); 22 | 23 | defrule (compatible_units_r2, compatible_units_foo (pp, aa), convert_compatible_units (args (pp)) + aa); 24 | 25 | defrule (compatible_units_r3, compatible_units_foo (uu, aa), uu + aa); 26 | 27 | convert_compatible_units (l) := 28 | block ([units_l: map (units, l)], 29 | if length (unique (map (dimensions, units_l))) = 1 30 | then apply ("+", l `` simplest_units (units_l)) 31 | else (print ("convert_compatible_units: can't convert incompatible units: ", units_l), 32 | apply ("+", l))); 33 | 34 | simplest_units (units_l) := 35 | block ([n: lmin (map (leaf_count, units_l)), uu, un], 36 | uu: unique (units_l), 37 | un: sublist (uu, lambda ([u], leaf_count (u) = n)), 38 | if length (un) = 1 39 | then un[1] 40 | else print ("simplest_units: found multiple equally-simple units among", unique (units_l), "; return ", un[1])); 41 | 42 | leaf_count (e) := 43 | if atom(e) then 1 44 | else apply ("+", map (leaf_count, args(e))); 45 | 46 | -------------------------------------------------------------------------------- /robert-dodier/more_ezunits/rtest_more_ezunits.mac: -------------------------------------------------------------------------------- 1 | (batch ("add_compatible_units.mac"), 0); 2 | 0; 3 | 4 | add_compatible_units (1`V/A + 1`Ohm); 5 | 2 ` Ohm; 6 | 7 | add_compatible_units (sqrt (1`V/A + 1`Ohm)); 8 | sqrt(2) ` sqrt(Ohm); 9 | 10 | add_compatible_units (sqrt (1`V/A + 1`Ohm)*sqrt (1`Ohm)); 11 | sqrt(2) ` Ohm; 12 | 13 | add_compatible_units ((x - y)/(a`inch + b`foot + c`mile)^2); 14 | /* assuming here that foot is chosen among the equally simple units */ 15 | ((x - y)/((a/12) + b + 5280*c)^2) ` 1/foot^2; 16 | 17 | add_compatible_units (sin ('foo (1000 ` kW/m^2 + 1000 ` Btu/hour/acre))); 18 | /* assuming here that Btu/hour/acre is chosen among the equally simple units */ 19 | sin('foo(2913736835128/211 ` Btu/(acre*hour))); 20 | 21 | add_compatible_units (sin ('foo (1000 ` kW/ha + 1000 ` Btu/hour/acre))); 22 | sin('foo(2847506468875/2845445922 ` kW/ha)); 23 | 24 | add_compatible_units (sin ('foo (500 ` kW/ha + 500/10^4 ` kJ/s/m^2 + 1000 ` Btu/hour/acre))); 25 | sin('foo(2847506468875/2845445922 ` kW/ha)); 26 | -------------------------------------------------------------------------------- /robert-dodier/plottable_steps/plottable_steps.mac: -------------------------------------------------------------------------------- 1 | /* plottable_steps: from a list of points or two separate lists of coordinates, 2 | * construct a single list of points which, when displayed by plot2d([discrete, ...]) 3 | * or draw2d(points(...)), shows stair steps which have the 4 | * "treads" represented by ((x1, y1), (x2, y1)), ((x2, y2), (x3, y2)), etc., 5 | * and the "risers" represented by ((x2, y1), (x2, y2)), ((x3, y2), (x3, y3)), etc. 6 | * 7 | * Only construct the list of stair-drawing points; do not display them. 8 | */ 9 | 10 | plottable_steps ([xy_or_x_and_y]) := 11 | if length (xy_or_x_and_y) = 1 12 | then plottable_steps1 (first (xy_or_x_and_y)) 13 | elseif length (xy_or_x_and_y) = 2 14 | then plottable_steps2 (first (xy_or_x_and_y), second (xy_or_x_and_y)) 15 | else error ("plottable_steps: expected 1 or 2 arguments."); 16 | 17 | /* plottable_steps1: extract separate lists of coordinates from a list of points 18 | * and construct plottable points. 19 | */ 20 | 21 | plottable_steps1 (xy) := 22 | plottable_steps2 (map (first, xy), map (second, xy)); 23 | 24 | /* plottable_steps2: from two lists, (x1, x2, x3, ...), (y1, y2, y3, ...), 25 | * construct plottable points. 26 | */ 27 | 28 | plottable_steps2 (x, y) := 29 | 30 | block ([xx, yy, nx: length (x), ny: length (y)], 31 | 32 | if ny # nx and ny # (nx - 1) 33 | then error ("plottable_steps: arguments not compatible lengths."), 34 | 35 | if ny = nx 36 | then block ([n: nx], 37 | 38 | xx: append ([x[1]], apply (append, makelist ([x[i], x[i]], i, 2, n))), 39 | yy: append ([y[1]], apply (append, makelist ([y[i - 1], y[i]], i, 2, n))), 40 | 41 | by_twos (xx, yy)) 42 | 43 | else rest (plottable_steps2 (x, endcons (false, y)), -1)); 44 | 45 | by_twos (a, b) := 46 | if length (b) # length (a) 47 | then error ("by_twos: arguments not the same length.") 48 | else map (lambda ([a1, b1], [a1, b1]), a, b); 49 | -------------------------------------------------------------------------------- /robert-dodier/polyfit/polyfit.mac: -------------------------------------------------------------------------------- 1 | if ?mget (mean, '?mexpr) = false then load (descriptive); 2 | 3 | polyfit (X, Y, N) := 4 | block ([Xtilde, Xmean, Xsd, X1, XX, Xvars, beta, Yhat, residuals, mse, f], 5 | Xmean: mean (X), 6 | Xsd: std (X), 7 | Xtilde: map (lambda([r], (r - Xmean)/Xsd), X), 8 | X1: apply (matrix, 9 | makelist (makelist (if j = 0 then 1 else Xtilde[i]^j, j, 0, N), 10 | i, 1, length(X))), 11 | XX: transpose(X1) . X1, 12 | beta: invert(XX) . transpose(X1) . Y, 13 | Yhat: X1 . beta, 14 | residuals: Y - Yhat, 15 | mse: (transpose (residuals) . residuals)/length (residuals), 16 | Xvars: makelist (if j = 0 then 1 else 'Xtilde^j, j, 0, N), 17 | f: buildq ([Xvars, Xmean, Xsd, beta], 18 | lambda ([X], block ([Xtilde: (X - Xmean)/Xsd, X1], 19 | X1: Xvars, X1 . beta))), 20 | ['beta = beta, 21 | 'Yhat = Yhat, 22 | 'residuals = residuals, 23 | 'mse = mse, 24 | 'Xmean = Xmean, 25 | 'Xsd = Xsd, 26 | 'f = f]); 27 | -------------------------------------------------------------------------------- /robert-dodier/qmpe/qmpe.demo: -------------------------------------------------------------------------------- 1 | "verify qmpe recovers parameters" $ 2 | 3 | load ("qmpe.mac") $ 4 | load ("distrib") $ 5 | 6 | "example with lognormal" $ 7 | 8 | if is_inf(u) then 1 else ''(cdf_lognormal (u, location, scale)); 9 | foo: construct_qmpe (%, 'u, '[location, scale], mle_lognormal, 1e-4, [1, 0]); 10 | 11 | [mu1, sigma1]: [2, 1]; 12 | 13 | (p: [0, 0.1, 0.2, 0.5, 0.8, 0.9, 1], 14 | q: ev (map (lambda ([p1], if p1 = 1 then inf else quantile_lognormal (p1, mu1, sigma1)), p), numer), 15 | [q, p]); 16 | 17 | baz: foo (q, p); 18 | 19 | plot_qmpe_comparison (q, p, cdf_lognormal (u, location, scale), u, '[location, scale], quantile_lognormal (0.99, location, scale), assoc ('initial, baz), assoc ('final, baz)); 20 | 21 | "example with weibull" $ 22 | 23 | (p: [0, 1/3, 2/3, 1], 24 | q: [0, 1, 2, inf], 25 | [q, p]); 26 | 27 | if is_inf(u) then 1 else ''(cdf_weibull (u, shape, scale)); 28 | quux: construct_qmpe (%, 'u, '[shape, scale], mle_weibull, 1e-4, [1, 0]); 29 | 30 | mumble: quux (q, p); 31 | 32 | plot_qmpe_comparison (q, p, cdf_weibull (u, shape, scale), u, '[shape, scale], quantile_weibull (0.99, shape, scale), assoc ('initial, mumble), assoc ('final, mumble)); 33 | -------------------------------------------------------------------------------- /robert-dodier/qmpe/rtest_qmpe.mac: -------------------------------------------------------------------------------- 1 | (load ("qmpe.mac"), 2 | if get ('descriptive, 'version) = false 3 | then load ("descriptive"), 4 | 0); 5 | 0; 6 | 7 | mle_gaussian_weighted ([1, 2, 3, 4, 5], [1, 1, 1, 1, 1]); 8 | ''([mean ([1, 2, 3, 4, 5]), std ([1, 2, 3, 4, 5])]); 9 | 10 | mle_gaussian_weighted ([1, 2, 3, 4, 5], [2, 2, 2, 2, 2]); 11 | ''([mean ([1, 2, 3, 4, 5]), std ([1, 2, 3, 4, 5])]); 12 | 13 | mle_gaussian_weighted ([1, 2, 3, 4, 5], [1/5, 1/5, 1/5, 1/5, 1/5]); 14 | ''([mean ([1, 2, 3, 4, 5]), std ([1, 2, 3, 4, 5])]); 15 | 16 | mle_gaussian_weighted ([10, 20, 30, 40, 50], [1/10, 1/10, 1/10, 1/10, 6/10]); 17 | ''([mean ([10, 20, 30, 40, 50, 50, 50, 50, 50, 50]), std ([10, 20, 30, 40, 50, 50, 50, 50, 50, 50])]); 18 | 19 | (data: makelist (random (5), 20), 20 | unique_data: unique (data), 21 | weights: map (length, map (lambda ([u], sublist (data, lambda ([v], v = u))), unique_data)), 22 | mle_gaussian_weighted (unique_data, weights)); 23 | ''([mean (data), std (data)]); 24 | 25 | approximate_mle_by_bins ([10, 20, 30, 40, 50], [0, 1/10, 6/10, 8/10, 1], mle_gaussian_weighted); 26 | ''(mle_gaussian_weighted ([15, 25, 35, 45], [1/10, 5/10, 2/10, 2/10])); 27 | 28 | mle_lognormal_weighted (exp ([1/4, 1/2, 1, 2, 4]), [1, 1, 1, 1, 1]); 29 | ''([mean ([1/4, 1/2, 1, 2, 4]), std ([1/4, 1/2, 1, 2, 4])]); 30 | 31 | mle_lognormal_weighted (exp ([10, 20, 30, 40, 50]), [1/10, 1/10, 1/10, 1/10, 6/10]); 32 | ''([mean ([10, 20, 30, 40, 50, 50, 50, 50, 50, 50]), std ([10, 20, 30, 40, 50, 50, 50, 50, 50, 50])]); 33 | -------------------------------------------------------------------------------- /robert-dodier/random_expression/random_expression.mac: -------------------------------------------------------------------------------- 1 | /* random_expression.mac -- generate a random expression 2 | * copyright 2023 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License, v2 4 | */ 5 | 6 | /* test: 7 | 8 | L:makelist (random_expression (random_expression_ops_arithmetic, 6), 100) $ 9 | 10 | for i thru length(L) do block ([x:L[i]], if not equal (x, parse_string (string (x))) then (print ("i=",i), grind(x))); 11 | 12 | should not display anything (just "done"). 13 | 14 | */ 15 | 16 | random_expression_args_max["+"]: 4; 17 | random_expression_args_max["*"]: 3; 18 | random_expression_args_max["and"]: 3; 19 | random_expression_args_max["or"]: 4; 20 | 21 | random_expression_ops_arithmetic: 22 | [["+", lambda ([], 2 + random (random_expression_args_max["+"] - 1))], 23 | ["-", lambda ([], 1)], 24 | ["*", lambda ([], 2 + random (random_expression_args_max["*"] - 1))], 25 | ["/", lambda ([], 2)], 26 | ["^", lambda ([], 2)] 27 | /* (n!)! displayed as n!! which means double factorial */ 28 | /* , ["!", lambda ([], 1)] */ 29 | ]; 30 | 31 | random_expression_ops_logical: 32 | [["=", lambda ([], 2)], 33 | [equal, lambda ([], 2)], 34 | ["<", lambda ([], 2)], 35 | ["<=", lambda ([], 2)], 36 | [">=", lambda ([], 2)], 37 | [">", lambda ([], 2)], 38 | ["and", lambda ([], 2 + random (random_expression_args_max["and"] - 1))], 39 | ["or", lambda ([], 2 + random (random_expression_args_max["or"] - 1))], 40 | ["not", lambda ([], 1)]]; 41 | 42 | random_expression_ops_programmatic: 43 | [[":", lambda ([], 2)]]; 44 | 45 | random_expression (ops, depth) := 46 | block ([e: next_variable ()], 47 | for k thru depth do e: maybe_expand_random_expression (ops, e), 48 | e); 49 | 50 | maybe_expand_random_expression (ops, e) := 51 | scanmap (lambda ([x], maybe_replace_symbol (ops, x)), e, bottomup); 52 | 53 | maybe_replace_symbol (ops, e) := 54 | if symbolp(e) then maybe_generate_expression (ops, e) else e; 55 | 56 | random_expression_expansion_probability: 0.5; 57 | 58 | maybe_generate_expression (ops, e) := 59 | if random (1.0) < random_expression_expansion_probability 60 | then generate_expression (ops) 61 | else e; 62 | 63 | generate_expression (ops) := 64 | block ([op1, args1, nargs], 65 | [op1, nargs_func]: choose_at_random (ops), 66 | args1: makelist (next_variable (), nargs_func ()), 67 | apply (op1, args1)); 68 | 69 | choose_at_random (l) := l [1 + random (length (l))]; 70 | 71 | letters: makelist (ascii (k), k, 97, 97 + 25); 72 | strings: map (lambda ([l], apply (sconcat, l)), cartesian_product_list (letters, letters)); 73 | random_expressions_variables: 74 | (map (lambda ([s], if (s: errcatch (parse_string (s))) # [] then s[1]), strings), 75 | sublist (%%, lambda ([x], x # false))); 76 | prev_variable_index: -1; 77 | 78 | next_variable () := 79 | random_expressions_variables [1 + mod (prev_variable_index: prev_variable_index + 1, length (random_expressions_variables))]; 80 | 81 | -------------------------------------------------------------------------------- /robert-dodier/reshape/index-reshape.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-info) 2 | (let ( 3 | (deffn-defvr-pairs '( 4 | ; CONTENT: ( . ( )) 5 | ("flatten_array" . ("reshape.info" 7420 1490 "Definitions for package reshape")) 6 | ("get_array_from_declared_array" . ("reshape.info" 6654 753 "Definitions for package reshape")) 7 | ("reshape" . ("reshape.info" 995 5564 "Definitions for package reshape")) 8 | )) 9 | (section-pairs '( 10 | ; CONTENT: ( . ( )) 11 | ("Definitions for package reshape" . ("reshape.info" 923 7881)) 12 | ("Introduction to package reshape" . ("reshape.info" 242 527)) 13 | ))) 14 | (load-info-hashtables (maxima::maxima-load-pathname-directory) deffn-defvr-pairs section-pairs)) 15 | -------------------------------------------------------------------------------- /robert-dodier/reshape/reshape-array.lisp: -------------------------------------------------------------------------------- 1 | (defmfun $declared_arrayp (a) 2 | (and (symbolp a) (mget a 'array) (symbolp (mget a 'array)) (arrayp (get (mget a 'array) 'array)))) 3 | 4 | (defmfun $get_array_from_declared_array (x) 5 | (if ($declared_arrayp x) 6 | (get (mget x 'array) 'array) 7 | (merror "get_array_from_declared_array: argument must be a declared array; found: ~M" x))) 8 | 9 | (defmfun $reshape_array_by_rows (a new-dims) 10 | (cond 11 | ((arrayp a) (reshape-lisp-array-by-rows a (rest new-dims))) 12 | (($declared_arrayp a) 13 | (reshape-declared-maxima-array a (rest new-dims) 'by-rows)) 14 | (t 15 | (merror "reshape_array_by_rows: first argument must be an array value or declared array symbol; found: ~M" a)))) 16 | 17 | (defun reshape-lisp-array-by-rows (a new-dims &optional b) 18 | (let 19 | ((n-elements (apply '* new-dims))) 20 | (when (null b) 21 | (setq b (apply '$make_array '$any new-dims))) 22 | (dotimes (i n-elements) (setf (row-major-aref b i) (row-major-aref a i))) 23 | b)) 24 | 25 | (defun reshape-declared-maxima-array (a new-dims rows-or-columns) 26 | ;; A is a declared Maxima array. 27 | ;; Construct another declared array which is the reshaped array. 28 | ;; This involves putting a gensym on the arrays infolist, 29 | ;; which seems slightly terrible. I guess an alternative is to 30 | ;; return an array value. I've chosen to go down the road of 31 | ;; constructing a declared array for consistency with the idea 32 | ;; that the return value is the same kind of thing as the argument. 33 | (let* 34 | ((reshaped-a-symbol ($gensym "a")) 35 | (a-array ($get_array_from_declared_array a)) 36 | reshaped-a-array) 37 | (meval `(($array) ,reshaped-a-symbol ,@(mapcar #'1- new-dims))) 38 | (setq reshaped-a-array ($get_array_from_declared_array reshaped-a-symbol)) 39 | (if (eq rows-or-columns 'by-rows) 40 | (reshape-lisp-array-by-rows a-array new-dims reshaped-a-array) 41 | (reshape-lisp-array-by-columns a-array new-dims reshaped-a-array)) 42 | reshaped-a-symbol)) 43 | 44 | (defmfun $reshape_array_by_columns (a new-dims) 45 | (cond 46 | ((arrayp a) (reshape-lisp-array-by-columns a (rest new-dims))) 47 | (($declared_arrayp a) 48 | (reshape-declared-maxima-array a (rest new-dims) 'by-columns)) 49 | (t 50 | (merror "reshape_array_by_columns first argument must be an array value or declared array symbol; found: ~M" a)))) 51 | 52 | (defun reshape-lisp-array-by-columns (a new-dims &optional b) 53 | (let 54 | ((n-elements (apply '* new-dims))) 55 | (when (null b) 56 | (setq b (apply '$make_array '$any new-dims))) 57 | (dotimes (i n-elements) 58 | (let (ii (j i) (n n-elements)) 59 | (loop for k in (reverse new-dims) do (setq n (/ n k)) (push (floor j n) ii) (setq j (mod j n))) 60 | #+nil (format t "HEY n-elements = ~d, i = ~d, ii = ~d~%" n-elements i ii) 61 | (setf (apply #'aref b ii) (row-major-aref a i)))) 62 | b)) 63 | 64 | (defmfun $flatten_array (x) 65 | (cond 66 | ((arrayp x) 67 | (let ((y ($make_array '$any (array-total-size x)))) 68 | (dotimes (i (array-total-size x)) (setf (aref y i) (row-major-aref x i))) 69 | y)) 70 | (($declared_arrayp x) 71 | (reshape-declared-maxima-array x (list (array-total-size ($get_array_from_declared_array x))) 'by-rows)) 72 | (t 73 | (merror "flatten_array: argument must be an array; found: ~M" x)))) 74 | -------------------------------------------------------------------------------- /robert-dodier/simplify_conditionals/simplify_conditionals.mac: -------------------------------------------------------------------------------- 1 | /* simplify_conditionals.mac 2 | * copyright 2022 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License, v2 4 | */ 5 | 6 | flatten_conditionals (e) := applyb1 (e, rule_flatten_conditional); 7 | 8 | matchdeclare (cc, lambda ([e], not atom(e) and op(e) = "if")); 9 | defrule (rule_flatten_conditional, cc, flatten_conditional (cc)); 10 | 11 | flatten_conditional (c) := 12 | (by_twos (args (c)), 13 | map (lambda ([e], if not atom(e[2]) and op(e[2]) = "if" 14 | then makelist ([e[1] and a[1], a[2]], a, by_twos (args (e[2]))) 15 | else [e]), 16 | %%), 17 | funmake ("if", apply (append, apply (append, %%)))); 18 | 19 | by_twos (l) := by_tuples (l, 2); 20 | 21 | by_tuples (l, m) := 22 | block ([n], 23 | if atom(l) then error ("by_tuples: first argument must be a nonatomic expression; found:", l), 24 | n: length (l), 25 | if mod (n, m) # 0 then error ("by_tuples: length of first argument not a multiple of", m), 26 | if listp(l) 27 | then by_tuples_list (l, m, n) 28 | else map (lambda ([u], funmake (op(l), u)), by_tuples_list (args (l), m, n))); 29 | 30 | by_tuples_list (l, m, n) := 31 | makelist (makelist (l[i], i, 1 + (j - 1)*m, j*m), j, 1, n/m); 32 | 33 | arithmetic_with_conditionals (e) := apply1 (e, rule_multiply_conditional, rule_add_to_conditional); 34 | 35 | /* PART+ matches cc first, then aa, so when matching aa, 36 | * refuse to match 0 if cc is not a "+" expression. 37 | * The effect is that aa = 0 is matched if cc matches multiple "if" expressions, 38 | * or cc matches just one "if" if aa # 0, 39 | * but not both aa = 0 and cc matches just one "if". 40 | */ 41 | matchdeclare (aa, lambda ([e], op(cc) = "+" or e # 0)); 42 | defrule (rule_add_to_conditional, aa + cc, add_to_conditional (aa, add_conditionals (cc))); 43 | 44 | add_to_conditional (x, c) := nonconditional_conditional_op (x, c, "+"); 45 | 46 | nonconditional_conditional_op (x, c, myop) := 47 | (by_twos (args (c)), 48 | map (lambda ([e], [e[1], myop (x, e[2])]), %%), 49 | funmake ("if", apply (append, %%))); 50 | 51 | add_conditionals (cc) := conditionals_op (cc, "+"); 52 | 53 | conditionals_op (cc, myop) := 54 | if op(cc) = "if" then cc else conditionals_op_list (args (cc), myop); 55 | 56 | conditionals_op_list (cc_list, myop) := 57 | block ([all_args, conditions_args, conditions_combos, conditions, 58 | results_args, results_combos, results], 59 | all_args: map (lambda ([c], by_twos (args (c))), cc_list), 60 | conditions_args: map (lambda ([l], map (first, l)), all_args), 61 | conditions_combos: apply (cartesian_product_list, conditions_args), 62 | conditions: map (lambda ([l], apply ("and", l)), conditions_combos), 63 | results_args: map (lambda ([l], map (second, l)), all_args), 64 | results_combos: apply (cartesian_product_list, results_args), 65 | results: map (lambda ([l], apply (myop, l)), results_combos), 66 | join (conditions, results), 67 | funmake ("if", %%)); 68 | 69 | /* PART* matches cc first, then aa, so when matching aa, 70 | * refuse to match 0 if cc is not a "*" expression. 71 | * The effect is that aa = 0 is matched if cc matches multiple "if" expressions, 72 | * or cc matches just one "if" if aa # 0, 73 | * but not both aa = 0 and cc matches just one "if". 74 | */ 75 | matchdeclare (aa, lambda ([e], op(cc) = "*" or e # 0)); 76 | defrule (rule_multiply_conditional, aa*cc, multiply_conditional (aa, multiply_conditionals (cc))); 77 | 78 | multiply_conditional (x, c) := nonconditional_conditional_op (x, c, "*"); 79 | 80 | multiply_conditionals (cc) := conditionals_op (cc, "*"); 81 | 82 | -------------------------------------------------------------------------------- /robert-dodier/stackoverflow/histogram_sd.mac: -------------------------------------------------------------------------------- 1 | /* inspired by https://stackoverflow.com/questions/48997277/standard-deviation-of-binned-values 2 | * copyright 2018 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License 4 | * 5 | * This is a program for Maxima, a computer algebra system. 6 | * http://maxima.sourceforge.net/ 7 | */ 8 | 9 | /* Given histogram specified as: 10 | * number of bins m 11 | * list of disjoint bins [a[i], b[i]], i = 1, ..., m 12 | * number of data in each bin n[i], i = 1, ..., m 13 | * total number of data N = sum(n[i], i, 1, m) 14 | * 15 | * It might or might not be the case that a[i] = b[i - 1]; 16 | * what's important is that bins are disjoint. 17 | * 18 | * Density in each bin is p[i] = (n[i]/N)/(b[i] - a[i]) 19 | * Mass fraction in each bin is n[i]/N = p[i]*(b[i] - a[i]) 20 | * 21 | * k'th moment for density is 22 | * 23 | * sum(integrate(p[i]*x^k, x, a[i], b[i]), i, 1, m) 24 | * 25 | * Now 26 | * 27 | * integrate(p[i]*x^k, x, a[i], b[i]) 28 | * = p[i]*(1/(k + 1))*(b[i]^(k + 1) - a[i]*(k + 1)) 29 | * = p[i]*(b[i] - a[i])*(1/(k + 1))*(b[i]^k + ... + a[i]^k) (terms vary depending on k) 30 | * = n[i]/N*(1/(k + 1))*(b[i]^k + ... + a[i]^k) 31 | * 32 | * Specifically for k = 1, 33 | * 34 | * integrate(p[i]*x, x, a[i], b[i]) 35 | * = p[i]*(1/2)*(b[i]^2 - a[i]^2) 36 | * = n[i]/N*(a[i] + b[i])/2 37 | * = n[i]/N*(mean of i'th bin) (incidentally) 38 | * 39 | * and for k = 2, 40 | * 41 | * integrate(p[i]*x^2, x, a[i], b[i]) 42 | * = p[i]*(1/3)*(b[i]^3 - a[i]^3) 43 | * = p[i]*(1/3)*(b[i] - a[i])*(a[i]^2 + a[i]*b[i] + b[i]^2) 44 | * = n[i]/N*(a[i]^2 + a[i]*b[i] + b[i]^2)/3 45 | * 46 | */ 47 | 48 | histogram_mean (a, b, n) := 49 | block ([N : lsum (n1, n1, n), 50 | m : length (a)], /* SHOULD ENSURE A, B, N ALL SAME LENGTH */ 51 | sum (n[i]/N*(a[i] + b[i])/2, i, 1, m)); 52 | 53 | histogram_var (a, b, n) := 54 | histogram_mean2 (a, b, n) - (histogram_mean (a, b, n))^2; 55 | 56 | histogram_mean2 (a, b, n) := 57 | block ([N : lsum (n1, n1, n), 58 | m : length (a)], /* SHOULD ENSURE A, B, N ALL SAME LENGTH */ 59 | sum (n[i]/N*(a[i]^2 + a[i]*b[i] + b[i]^2)/3, i, 1, m)); 60 | 61 | histogram_sd (a, b, n) := 62 | sqrt (histogram_var (a, b, n)); 63 | -------------------------------------------------------------------------------- /robert-dodier/subst_floats/subst_floats.mac: -------------------------------------------------------------------------------- 1 | /* subst_floats.mac 2 | * copyright 2019 by Robert Dodier 3 | * I release this work under terms of the GNU GPL v2 4 | */ 5 | 6 | use_fast_arrays: true $ 7 | float_substitutions: make_array (hashed, 1); 8 | 9 | matchdeclare (xx, floatnump); 10 | defrule (subst_floats, xx, 11 | if float_substitutions[xx] # false 12 | then float_substitutions[xx] 13 | elseif float_substitutions[- xx] # false 14 | then - float_substitutions[- xx] 15 | else block ([yy: gensym ()], 16 | float_substitutions[xx]: yy, 17 | assume (equal (yy, xx)), 18 | yy)); 19 | 20 | resubst_floats (e) := 21 | block ([keys: rest (arrayinfo (float_substitutions), 2), eqs], 22 | eqs: makelist (float_substitutions[key] = key, key, keys), 23 | subst (eqs, e)); 24 | 25 | /* SF bug report #3030: "solve entering endless loop on a kind of simple task" 26 | * https://sourceforge.net/p/maxima/bugs/3030/ 27 | */ 28 | 29 | m1:0.1593017578125; 30 | m2:78.84375; 31 | c1:0.8359375; 32 | c2:18.8515625; 33 | c3:18.6875; 34 | 35 | assume(L>0); 36 | assume(N>0); 37 | 38 | eq: L= ((N^(1/m2)-c1) / (c2-c3*N^(1/m2)))^(1/m1); 39 | 40 | apply1 (eq, subst_floats); 41 | solve (%, N); 42 | resubst_floats (%); 43 | 44 | arrayinfo (float_substitutions); 45 | listarray (float_substitutions); 46 | -------------------------------------------------------------------------------- /robert-dodier/sum_kron_delta/bolanios_sum_kron_delta.mac: -------------------------------------------------------------------------------- 1 | /* adapted from mailing list 2015-06-10 "Help with huge calculation" */ 2 | 3 | display2d : false $ 4 | load("sum_kron_delta.mac")$ 5 | 6 | ρ2:'sum('sum('sum('sum(sqrt(n)*h1*kron_delta(n-1,n_)*kron_delta(α-1,α_) 7 | *kron_delta(β+1,β_)*kron_delta(γ,γ_) *c[α,β,γ,n](t) 8 | +h2*sqrt(n+1)*kron_delta(n+1,n_) *kron_delta(α+1,α_)*kron_delta(β-1,β_) 9 | *kron_delta(γ,γ_)*c[α,β,γ,n](t),γ,0,-β-α+N),β, -α,α),α,0,N),n,0,Nmax); 10 | 11 | declare(sum,additive)$ 12 | Nmax:3$ N:3$ 13 | h1:0.6$ h2:0.4$ 14 | 15 | showtime:true $ 16 | 17 | ev(ρ2), α_:1, β_:-1, γ_:0, n_:1,eval,numer; 18 | for i thru 1000 do ev(ρ2), α_:1, β_:-1, γ_:0, n_:1,eval,numer; 19 | 20 | ρ2_simp1 : ''ρ2; 21 | 22 | ev(ρ2_simp1), α_:1, β_:-1, γ_:0, n_:1, numer; 23 | for i thru 1000 do ev(ρ2_simp1), α_:1, β_:-1, γ_:0, n_:1, numer; 24 | 25 | declare ([α_, β_, γ_, n_], integer); 26 | 27 | ρ2_simp2 : ''ρ2; 28 | 29 | ev(ρ2_simp2), α_:1, β_:-1, γ_:0, n_:1, numer; 30 | for i thru 1000 do ev(ρ2_simp2), α_:1, β_:-1, γ_:0, n_:1, numer; 31 | -------------------------------------------------------------------------------- /robert-dodier/sum_kron_delta/rtest_sum_kron.mac: -------------------------------------------------------------------------------- 1 | /* sum of kron_delta expressions gleaned from mailing list 2010--2013 2 | * copyright 2013 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License 4 | */ 5 | 6 | (if get ('sum_kron_delta, 'present) = false then load ("sum_kron_delta.mac"), 0); 7 | 0; 8 | 9 | (load (boolsimp), 0); 10 | 0; 11 | 12 | sum (kron_delta (i, j), i, 1, N), N=10, j=5; 13 | 1; 14 | 15 | sum (kron_delta (i, j), i, 1, N), j = 5; 16 | if 5 <= N then 1 else 0; 17 | 18 | while_assuming ([5 <= N], 19 | ev (sum (kron_delta (i, j), i, 1, N), j = 5)); 20 | 1; 21 | 22 | sum (kron_delta (i, j), i, 1, N); 23 | if 1 <= j and j <= N and %elementp(j,integers) 24 | then 1 else 0; 25 | 26 | while_declaring ([j, integer], 27 | sum (kron_delta (i, j), i, 1, N)); 28 | if 1 <= j and j <= N then 1 else 0; 29 | 30 | while_assuming ([j >= 1, j <= N], 31 | sum (kron_delta (i, j), i, 1, N)); 32 | if %elementp(j, integers) then 1 else 0; 33 | 34 | while_assuming ([j >= 1, j <= N], 35 | while_declaring ([j, integer], 36 | sum (kron_delta (i, j), i, 1, N))); 37 | 1; 38 | 39 | while_declaring ([j, integer], 40 | sum (f (i) * kron_delta (i, j), i, 3, N)); 41 | if 3 <= j and j <= N then f(j) else 0; 42 | 43 | while_declaring ([j, integer], 44 | sum (i^2 * kron_delta (i, j), i, 3, N)); 45 | if 3 <= j and j <= N then j^2 else 0; 46 | 47 | while_assuming ([N > 4, 4 < j, j < N], 48 | while_declaring ([j, integer], 49 | sum(i^2*kron_delta(i,j),i,3,N))); 50 | j^2; 51 | 52 | while_declaring ([[b, j], integer], 53 | sum (f(i) * kron_delta (i, j), i, 3, N)); 54 | if 3 <= j and j <= N then f(j) else 0; 55 | 56 | while_assuming ([3 <= j, j <= N], 57 | while_declaring ([[b, j], integer], 58 | sum (f(i) * kron_delta (i, j), i, 3, N))); 59 | f(j); 60 | 61 | while_assuming ([N > 1, b > 1, b < N], 62 | while_declaring ([[b, j], integer], 63 | sum (a^y * kron_delta (a, b), a, 1, N))); 64 | b^y; 65 | 66 | sum(a(k) * kron_delta(k,l),k,minf,inf); 67 | if %elementp(l,integers) then a(l) else 0; 68 | 69 | while_declaring ([l, integer], 70 | sum(a(k) * kron_delta(k,l),k,minf,inf)); 71 | a(l); 72 | 73 | sum(a(k)*kron_delta(k,l),k,0,inf) + sum(a(-k)*kron_delta(-k,l),k,1,inf); 74 | (if 1 <= -l and %elementp(-l,integers) then a(l) else 0) 75 | +(if 0 <= l and %elementp(l,integers) then a(l) else 0); 76 | 77 | while_declaring ([nounify(sum), linear, [j, n], integer], 78 | while_assuming ([j >= 1, j <= n], 79 | 'sum(kron_delta(i,j)*x[n-i+1]+x[i]*kron_delta(n-i+1,j),i,1,n))); 80 | 2*x[n - j + 1]; 81 | 82 | 'sum (kron_delta (i, j) * kron_delta (i, k), i, 1, n); 83 | if (1 <= j) and (j <= n) and %elementp(j, integers) then kron_delta(j, k) else 0; 84 | 85 | 'sum (kron_delta (i, j) * kron_delta (i, k), i, 1, n), j=1, k=2; 86 | 0; 87 | 88 | sum('diff(p[i] * x[i]^2, x[i]) * kron_delta(i,k), i, 1, I); 89 | if 1 <= k and k <= I and %elementp(k,integers) 90 | then 'diff(p[k]*x[k]^2,x[k],1) else 0$ 91 | 92 | while_declaring ([k, integer], 93 | sum('diff(p[i] * x[i]^2, x[i]) * kron_delta(i,k), i, 1, I)); 94 | if 1 <= k and k <= I 95 | then 'diff(p[k]*x[k]^2,x[k],1) else 0$ 96 | 97 | while_declaring ([k, integer], 98 | if 1 <= k and k <= I and %elementp(k,integers) 99 | then 'diff(p[k]*x[k]^2,x[k],1) else 0)$ 100 | if 1 <= k and k <= I 101 | then 'diff(p[k]*x[k]^2,x[k],1) else 0$ 102 | 103 | while_declaring ([k, integer], 104 | while_assuming ([k >= 1, k <= I], 105 | sum('diff(p[i] * x[i]^2, x[i]) * kron_delta(i,k), i, 1, I))); 106 | 'diff(p[k]*x[k]^2,x[k],1); 107 | 108 | while_declaring ([k, integer], 109 | while_assuming ([k >= 1, k <= I], 110 | if 1 <= k and k <= I and %elementp(k,integers) 111 | then 'diff(p[k]*x[k]^2,x[k],1) else 0))$ 112 | 'diff(p[k]*x[k]^2,x[k],1); 113 | 114 | sum(diff(p[i] * x[i]^2, x[i]) * kron_delta(i,k), i, 1, I); 115 | 2 * (if 1 <= k and k <= I and %elementp(k,integers) then p[k]*x[k] else 0)$ 116 | 117 | sum (kron_delta (i, k) * kron_delta (j, k) * kron_delta (k, l, m, n) * A(k)^2, k, 0, inf); 118 | if 0 <= i and %elementp(i,integers) then A(i)^2*kron_delta(i,j,l,m,n) else 0; 119 | 120 | sum(kron_delta(i,3)*f(i),i,1,n); 121 | if 3 <= n then f(3) else 0; 122 | -------------------------------------------------------------------------------- /robert-dodier/sum_kron_delta/sum_kron_delta.mac: -------------------------------------------------------------------------------- 1 | /* sum_kron_delta.mac -- simplify 'sum(f(i)*kron_delta(i, j), i, ...) 2 | * copyright 2013 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License 4 | */ 5 | 6 | put ('sum_kron_delta, true, 'present); 7 | 8 | matchdeclare (kk, kron_delta_p); 9 | kron_delta_p (e) := not atom(e) and op(e) = 'kron_delta; 10 | matchdeclare (xx, lambda ([e], not kron_delta_p (e))); 11 | matchdeclare (ii, symbolp); 12 | matchdeclare ([ii1, iin], all); 13 | 14 | simp : false; 15 | tellsimpafter ('sum (kk, ii, ii1, iin), FOO (kk, 1, ii, ii1, iin)); 16 | tellsimpafter ('sum (kk * xx, ii, ii1, iin), FOO (kk, xx, ii, ii1, iin)); 17 | simp:true; 18 | 19 | FOO (kk, xx, ii, ii1, iin) := block ([ii_args], 20 | kk : kron_delta_product (kk), 21 | if atom(kk) or not (op(kk) = 'kron_delta) 22 | then 'sum (kk*xx, ii, ii1, iin) 23 | else 24 | (ii_args : sublist (args (kk), lambda ([e], not freeof (ii, e))), 25 | /* just take the first kron_delta variable other than ii -- this is not unique when there are 3 or more variables!! */ 26 | block ([a], 27 | a : first (delete_all (ii_args, args (kk))), 28 | /* oops -- what if ii_args has more (or less) than 1 element?? */ 29 | eq : solve (first (ii_args) = a, ii), 30 | /* oops -- what if eq has more (or less) than 1 element?? */ 31 | buildq 32 | ([eq, 33 | S : index_set (ii1, iin), 34 | kk_xx : subst (eq, kk * xx), 35 | rhs_eq : rhs (first (eq))], 36 | if %elementp (rhs_eq, S) then kk_xx else 0)))); 37 | 38 | kron_delta_product (k) := if op(k) = "*" then apply (append, args (k)) else k; 39 | delete_all (L1, L2) := (for x in L1 do L2 : delete (x, L2), L2); 40 | index_set (i, j) := %intersection (%range (i, j), 'integers); 41 | 42 | matchdeclare (xx, all); 43 | matchdeclare (%ii, lambda ([e], not atom(e) and op(e) = '%intersection)); 44 | tellsimp (%elementp (xx, %ii), apply ("and", map (lambda ([S], %elementp (xx, S)), args (%ii)))); 45 | 46 | matchdeclare (ii, lambda ([e], integerp (e) or featurep (e, 'integer))); 47 | tellsimp (%elementp (ii, 'integers), true); 48 | matchdeclare ([aa, bb], all); 49 | tellsimp (%elementp (xx, %range (aa, bb)), aa <= xx and xx <= bb); 50 | 51 | /* a couple of macros which may be often helpful when working with kron_delta */ 52 | 53 | load (unwind_protect); 54 | while_declaring (L, e) ::= 55 | buildq ([L, e], unwind_protect (block (apply (declare, L), e), apply (remove, L))); 56 | while_assuming (L, e) ::= 57 | buildq ([L, e, ctxt : gensym ()], unwind_protect (block (supcontext (ctxt), apply (assume, L), e), killcontext (ctxt))); 58 | -------------------------------------------------------------------------------- /robert-dodier/superq/rtest_superq.mac: -------------------------------------------------------------------------------- 1 | /* a standard mechanism to determine whether a package is loaded would be terrific */ 2 | (if ?get ('superq, '?operators) = false 3 | then load ("superq.lisp"), 4 | 0); 5 | 0; 6 | 7 | /* BATCH-EQUAL-CHECK applies simplification (via SIMPLE-EQUAL-P) 8 | * so compare strings instead of expressions. 9 | */ 10 | 11 | string ('(1 + 1)); 12 | "2"; 13 | string (superq (1 + 1)); 14 | "superq(1+1)"; 15 | string ('(5!)); 16 | "120"; 17 | string (superq (5!)); 18 | "superq(5!)"; 19 | string ('(sin (0))); 20 | "0"; 21 | string (superq (sin (0))); 22 | "superq(sin(0))"; 23 | string ('('diff (x, x, 1))); 24 | "1"; 25 | string (superq('diff (x, x, 1))); 26 | "superq('diff(x,x,1))"; 27 | 28 | tex1 ('(1 + 1)); 29 | "2"; 30 | tex1 (superq (1 + 1)); 31 | "1+1"; 32 | tex1 ('(5!)); 33 | "120"; 34 | tex1 (superq (5!)); 35 | "5!"; 36 | tex1 ('(sin (0))); 37 | "0"; 38 | tex1 (superq (sin (0))); 39 | "\\sin 0"; 40 | tex1 ('('diff (x, x, 1))); 41 | "1"; 42 | tex1 (superq('diff (x, x, 1))); 43 | "{{d}\\over{d\\,x}}\\,x"; 44 | 45 | block ([x:111], 46 | string ('(x + x))); 47 | "2*x"; 48 | 49 | block ([x:111], 50 | string (superq (x + x))); 51 | "superq(x+x)"; 52 | -------------------------------------------------------------------------------- /robert-dodier/superq/superq-index.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-info) 2 | (let ( 3 | (deffn-defvr-pairs '( 4 | ; CONTENT: ( . ( )) 5 | ("superq" . ("superq.info" 1153 2495 "Definitions for package superq")) 6 | )) 7 | (section-pairs '( 8 | ; CONTENT: ( . ( )) 9 | ("Definitions for package superq" . ("superq.info" 1083 2565)) 10 | ("Introduction to package superq" . ("superq.info" 640 298)) 11 | ))) 12 | (load-info-hashtables (maxima::maxima-load-pathname-directory) deffn-defvr-pairs section-pairs)) 13 | -------------------------------------------------------------------------------- /robert-dodier/superq/superq.asd: -------------------------------------------------------------------------------- 1 | (defsystem superq 2 | :defsystem-depends-on ("info-index") 3 | :name "superq" 4 | :maintainer "Robert Dodier" 5 | :author "Robert Dodier" 6 | :licence "GNU General Public License" 7 | :description "'super' quoting mechanism" 8 | :long-description "Maxima package for 'super' quoting, that is to say, preventing both simplification and evaluation." 9 | 10 | :components 11 | ((:file "superq") 12 | (:info-index "superq-index"))) 13 | -------------------------------------------------------------------------------- /robert-dodier/superq/superq.lisp: -------------------------------------------------------------------------------- 1 | ;; superq.lisp -- "super" quoting for Maxima 2 | ;; Copyright 2008 by Robert Dodier 3 | ;; I release this work under the terms of the GNU General Public License 4 | 5 | ;; Examples: 6 | 7 | ;; load (superq); 8 | 9 | ;; '(1 + 1); 10 | ;; => 2 11 | ;; superq (1 + 1); 12 | ;; => superq(1 + 1) 13 | ;; '(5!); 14 | ;; => 120 15 | ;; superq (5!); 16 | ;; => superq(5!) 17 | ;; '(sin (0)); 18 | ;; => 0 19 | ;; superq (sin (0)); 20 | ;; => superq(sin(0)) 21 | ;; '('diff (x, x, 1)); 22 | ;; => 1 23 | ;; superq('diff (x, x, 1)); 24 | ;; => superq('diff(x,x,1)) 25 | 26 | ;; tex ('(1 + 1)); 27 | ;; => $$2$$ 28 | ;; tex (superq (1 + 1)); 29 | ;; => $$1+1$$ 30 | ;; tex ('(5!)); 31 | ;; => $$120$$ 32 | ;; tex (superq (5!)); 33 | ;; => $$5!$$ 34 | ;; tex ('(sin (0))); 35 | ;; => $$0$$ 36 | ;; tex (superq (sin (0))); 37 | ;; => $$\sin 0$$ 38 | ;; tex ('('diff (x, x, 1))); 39 | ;; => $$1$$ 40 | ;; tex (superq('diff (x, x, 1))); 41 | ;; => $${{d}\over{d\,x}}\,x$$ 42 | 43 | (defmspec $superq (e) e) 44 | 45 | (defun simp-$superq (x y z) (declare (ignore y z)) x) 46 | 47 | (setf (get '$superq 'operators) 'simp-$superq) 48 | 49 | (defun tex-$superq (x l r) (tex (second x) l r 'mparen 'mparen)) 50 | 51 | (setf (get '$superq 'tex) 'tex-$superq) 52 | -------------------------------------------------------------------------------- /robert-dodier/superq/superq.texi: -------------------------------------------------------------------------------- 1 | \input texinfo 2 | 3 | @setfilename superq.info 4 | @settitle Package superq 5 | 6 | @ifinfo 7 | @macro var {expr} 8 | <\expr\> 9 | @end macro 10 | @end ifinfo 11 | 12 | @dircategory Mathematics/Maxima 13 | @direntry 14 | * Package superq: (maxima-packages/robert-dodier/superq). Maxima package for "super" quoting 15 | @end direntry 16 | 17 | @node Top, Introduction to package superq, (dir), (dir) 18 | @top 19 | @menu 20 | * Introduction to package superq:: 21 | * Definitions for package superq:: 22 | * Function and variable index:: 23 | @end menu 24 | @chapter Package superq 25 | 26 | @node Introduction to package superq, Definitions for package superq, Top, Top 27 | @section Introduction to package superq 28 | 29 | @code{superq} is a Maxima package for "super" quoting: 30 | @code{superq} prevents simplification as well as evaluation. 31 | 32 | It is anticipated that @code{superq} may have some use for problems 33 | which require working with unsimplified expressions. 34 | 35 | @node Definitions for package superq, Function and variable index, Introduction to package superq, Top 36 | @section Definitions for package superq 37 | 38 | @deffn {Function} superq (@var{expr}) 39 | 40 | @code{superq} ("superquote") protects @var{expr} against evaluation and simplification. 41 | 42 | In contrast, single quote @code{'} protects against evaluation, 43 | but not simplification; 44 | expressions quoted by single quote are simplified but not evaluated. 45 | 46 | @code{load(superq)} loads this function. 47 | 48 | Examples: 49 | 50 | Comparison of quoted and superquoted expressions. 51 | 52 | @example 53 | (%i1) load ("superq.lisp"); 54 | (%o1) superq.lisp 55 | (%i2) '(1 + 1); 56 | (%o2) 2 57 | (%i3) superq (1 + 1); 58 | (%o3) superq(1 + 1) 59 | (%i4) '(5!); 60 | (%o4) 120 61 | (%i5) superq (5!); 62 | (%o5) superq(5!) 63 | (%i6) '(sin (0)); 64 | (%o6) 0 65 | (%i7) superq (sin (0)); 66 | (%o7) superq(sin(0)) 67 | (%i8) '('diff (x, x, 1)); 68 | (%o8) 1 69 | (%i9) superq('diff (x, x, 1)); 70 | dx 71 | (%o9) superq(--) 72 | dx 73 | @end example 74 | 75 | Comparison of TeX output for quoted and superquoted expressions. 76 | 77 | @example 78 | (%i1) load ("superq.lisp"); 79 | (%o1) superq.lisp 80 | (%i2) stringdisp : true $ 81 | (%i3) tex1 ('(1 + 1)); 82 | (%o3) "2" 83 | (%i4) tex1 (superq (1 + 1)); 84 | (%o4) "1+1" 85 | (%i5) tex1 ('(5!)); 86 | (%o5) "120" 87 | (%i6) tex1 (superq (5!)); 88 | (%o6) "5!" 89 | (%i7) tex1 ('(sin (0))); 90 | (%o7) "0" 91 | (%i8) tex1 (superq (sin (0))); 92 | (%o8) "\sin 0" 93 | (%i9) tex1 ('('diff (x, x, 1))); 94 | (%o9) "1" 95 | (%i10) tex1 (superq('diff (x, x, 1))); 96 | (%o10) "@{@{d@}\over@{d\,x@}@}\,x" 97 | @end example 98 | 99 | Single quote prevents evaluation but not simplification. 100 | Superquote prevents simplification as well as evaluation. 101 | 102 | @example 103 | (%i1) load ("superq.lisp") $ 104 | (%i2) x : 111 $ 105 | (%i3) x + x; 106 | (%o3) 222 107 | (%i4) '(x + x); 108 | (%o4) 2 x 109 | (%i5) superq (x + x); 110 | (%o5) superq(x + x) 111 | @end example 112 | @end deffn 113 | 114 | @node Function and variable index, , Definitions for package superq, Top 115 | @appendix Function and variable index 116 | @printindex fn 117 | @printindex vr 118 | 119 | @bye 120 | -------------------------------------------------------------------------------- /robert-dodier/tex_document/README.md: -------------------------------------------------------------------------------- 1 | % Maxima package tex\_document 2 | 3 | `tex_document` is a Maxima package to generate a simple LaTeX document from a Maxima batch script: 4 | 5 | + Stand-alone comments become text sections 6 | + Expressions in the script become \\verbatim sections 7 | + Results of evaluation (displayed only if an expression is terminated by semicolon) become typeset equations 8 | 9 | Example using `foo\_bar.mac` which is in this folder. 10 | 11 | ```{maxima} 12 | load ("tex_document.mac"); 13 | 14 | tex_document ("foo_bar.mac", "tmp-foo_bar.tex"); 15 | ``` 16 | 17 | -------------------------------------------------------------------------------- /robert-dodier/tex_document/foo_bar.mac: -------------------------------------------------------------------------------- 1 | /* First establish the equation which we are going to work with. 2 | * This is a second order (quadratic) polynomial 3 | * in one variable $x$. 4 | */ 5 | 6 | /* Here's a second comment block. 7 | * I wonder 8 | * how many lines will appear. 9 | */ 10 | 11 | e: a*x^2 + b*x + c; 12 | 13 | /* Solving for $x$ yields the well-known ``quadratic formula.'' */ 14 | 15 | /* Another all-in-one-line comment. */ 16 | 17 | solve(e, x); 18 | 19 | /* We can also solve for one of the coefficients. */ 20 | 21 | solve(e, b); 22 | 23 | /* Look for an extremum by differentiating and solving for the derivative equal to zero. 24 | * I 25 | * have 26 | * put 27 | * one 28 | * word 29 | * per 30 | * line. 31 | */ 32 | 33 | /* And then 34 | a comment which 35 | doesn't have the 36 | asterisk at the start 37 | of the line, 38 | how does that 39 | turn out? */ 40 | 41 | diff (e, x); 42 | 43 | solve (%, x); 44 | 45 | /* All done for now. No more expressions, no more comments. */ 46 | -------------------------------------------------------------------------------- /robert-dodier/tex_table/README.md: -------------------------------------------------------------------------------- 1 | ### tex\_table 2 | 3 | `tex_table` is a function to generate LaTeX output for a table, 4 | as defined by `defstruct(table(header, rows, outline, hsep, vsep))`. 5 | 6 | * `header` is a list comprising the labels to put on the top of each column 7 | * `rows` is a list of lists, one for each row of the table. All rows must have the same length. 8 | * `outline` is a Boolean value, which tells whether the table is outlined 9 | * `hsep` is a Boolean value, which tells whether the table has horizontal separators 10 | * `vsep` is a Boolean value, which tells whether the table has vertical separators 11 | 12 | Example: 13 | Let `t` be a table, e.g. `t: table([a, b, c], [[1, 2, 3], [4, 5, 6], [7, 8, 9]], false, true, true)`. 14 | 15 | * `t@header` is `[a, b, c]` 16 | * `t@rows` is `[[1, 2, 3], [4, 5, 6], [7, 8, 9]]` 17 | * `t@outline` is `false` 18 | * `t@hsep` is `true` 19 | * `t@vsep` is `true` 20 | 21 | Table instances such as `t` are displayed by Maxima's 2-d pretty printer 22 | as a matrix in which the header is pasted onto the rows of the table. 23 | No attempt is made to honor the Boolean options. 24 | 25 | Given `t`, then `tex_table(t)` returns a string containing LaTeX `\begin{tabular} ... \end{tabular}`, 26 | and `print(tex_table(t))` prints the LaTeX output. 27 | 28 | The script `tex_table_example.mac` shows an example of constructing a 29 | LaTeX document containing a collection of tables with different options. 30 | In the example, `tex_table` output is wrapped in `\begin{table} ... \end{table}` 31 | so that a caption can be associated with the table. 32 | 33 | Although it would be possible to associate `tex_table` with `table` via `texput`, 34 | so that `tex_table` would be called automatically from `tex`, 35 | I chose not to do that, because that introduces messy hassles about the TeX environment 36 | (equation versus table). 37 | -------------------------------------------------------------------------------- /robert-dodier/tex_table/tex_table.lisp: -------------------------------------------------------------------------------- 1 | ;; tex_table -- define table structure and LaTeX output 2 | ;; copyright 2019 by Robert Dodier 3 | ;; I release this work under terms of the GNU General Public License, version 2 4 | 5 | (defun dimension-$table (a b) 6 | (let* 7 | ((a-header ($@-function a '$header)) 8 | (a-rows ($@-function a '$rows)) 9 | (m (if a-header `(($matrix) ,a-header ,@(cdr a-rows)) `(($matrix) ,@(cdr a-rows))))) 10 | (dim-\$matrix m b))) 11 | 12 | (setf (get '$table 'dimension) 'dimension-$table) 13 | 14 | -------------------------------------------------------------------------------- /robert-dodier/tex_table/tex_table.mac: -------------------------------------------------------------------------------- 1 | /* tex_table -- define table structure and LaTeX output 2 | * copyright 2019 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License, version 2 4 | */ 5 | 6 | tex_decimal_significant_figures: 4 $ 7 | tex_decimal_f_threshold_upper: 1000.0 $ 8 | tex_decimal_f_threshold_lower: 0.001 $ 9 | 10 | texput (decimal, tex_decimal); 11 | 12 | tex_decimal(e):= tex_decimal1(first(e)); 13 | 14 | tex_decimal1(x):= 15 | if x > tex_decimal_f_threshold_upper or x < tex_decimal_f_threshold_lower 16 | then tex_decimal_e(x) else tex_decimal_f(x)$ 17 | 18 | tex_decimal_f(x):= 19 | block ([m: tex_decimal_significant_figures, 20 | n: ceiling(log(x)/log(10.0))], 21 | printf(false, "~,vf", m - n, x)); 22 | 23 | tex_decimal_e(x):= 24 | block([m: tex_decimal_significant_figures, 25 | n: floor(log(x)/log(10.0))], 26 | printf(false, "~,vf \\times 10^{~d}", m - 1, x*10.0^(-n), n))$ 27 | 28 | round_significant_figures(x,m):= 29 | block([n: ceiling(log(x)/log(10.0))], 30 | floor(x*10^(m - n))/10.0^(m - n))$ 31 | 32 | defstruct (table (header = [], rows = [], outline = false, hsep = false, vsep = false)); 33 | 34 | load ("tex_table.lisp"); 35 | 36 | tex_table (t) := 37 | if t@header = [] and t@rows = [] 38 | then "" 39 | else 40 | block ([ncolumns, spec, tex_header, tex_rows1, tex_rows_rest, hsep, tabular_begin, tabular_end], 41 | ncolumns: if t@header # [] 42 | then length (t@header) 43 | else length (t@rows[1]), 44 | if t@vsep 45 | then printf (false, "~{~a~^|~}", makelist ("c", ncolumns)) 46 | else printf (false, "~{~a~}", makelist ("c", ncolumns)), 47 | spec: if t@outline then sconcat ("|", %%, "|") else %%, 48 | hsep: if t@hsep then "\\hline" else "", 49 | tex_header: if t@header # [] 50 | then printf (false, "~{$~a$~^ & ~} \\\\~a~a~%", map (tex1, t@header), hsep, hsep) 51 | else "", 52 | tex_rows1: if t@rows # [] then printf (false, "~{$~a$~^ & ~} \\\\~%", map (tex1, t@rows[1])) else "", 53 | tex_rows_rest: map (lambda ([r], printf (false, "~a ~{$~a$~^ & ~} \\\\~%", hsep, map (tex1, r))), rest (t@rows)), 54 | tabular_begin: printf (false, "\\begin{tabular}{~a}~a~%", spec, if t@outline then "\\hline" else ""), 55 | tabular_end: printf (false, "~a~%\\end{tabular}~%", if t@outline then "\\hline" else ""), 56 | sconcat (tabular_begin, 57 | tex_header, 58 | tex_rows1, 59 | apply (sconcat, tex_rows_rest), 60 | tabular_end)); 61 | 62 | -------------------------------------------------------------------------------- /robert-dodier/tex_table/tex_table_example.mac: -------------------------------------------------------------------------------- 1 | /* tex_table -- define table structure and LaTeX output 2 | * copyright 2019 by Robert Dodier 3 | * I release this work under terms of the GNU General Public License, version 2 4 | */ 5 | 6 | load ("tex_table.mac"); 7 | 8 | rows: [[1, 2, 3], [x, y, z], [a - b, c + 3*%pi*d, e^2 + f/4]]; 9 | 10 | /* value assigned to options below is same as 11 | * cartesian_product_list ([[], [p, q, r]], [false, true], [false, true], [false, true]) 12 | * but that's a recently-introduced function, so just spell it out 13 | * for the sake of older (pre-5.43) versions. 14 | */ 15 | options: 16 | [[[],false,false,false],[[],false,false,true],[[],false,true,false], 17 | [[],false,true,true],[[],true,false,false],[[],true,false,true], 18 | [[],true,true,false],[[],true,true,true],[[p,q,r],false,false,false], 19 | [[p,q,r],false,false,true],[[p,q,r],false,true,false], 20 | [[p,q,r],false,true,true],[[p,q,r],true,false,false], 21 | [[p,q,r],true,false,true],[[p,q,r],true,true,false],[[p,q,r],true,true,true]]$ 22 | 23 | with_stdout ("tmp_tex_table.tex", 24 | print ("\\documentclass{article}"), 25 | print ("\\title{\\TeX\\ output for tables in Maxima}"), 26 | print ("\\begin{document}"), 27 | print ("\\maketitle"), 28 | for o in options 29 | do block ([t: table (o[1], rows, o[2], o[3], o[4])], 30 | print ("\\begin{table}"), 31 | print (tex_table (t)), 32 | printf (true, "\\caption{Header = ~a, outline = ~a, hsep = ~a, vsep = ~a.}~%", 33 | t@header, t@outline, t@hsep, t@vsep), 34 | print ("\\end{table}")), 35 | print ("\\end{document}")); 36 | -------------------------------------------------------------------------------- /sdemarre/diophantine/README.md: -------------------------------------------------------------------------------- 1 | Maxima program to solve diophantine equations of the form ax^2+bxy+cy^2+dx+ey+f=0 with a,b,c,d,e,f constant integers. 2 | Based on Dario Alpern's solution/code found at https://www.alpertron.com.ar/QUAD.HTM 3 | 4 | 1. [Installing](README.md#install) 5 | 1. [Usage](README.md#usage) 6 | 1. [Limitations](README.md#limitations) 7 | 1. [Tests](README.md#tests) 8 | 1. [Graphical examples](README.md#graphical-examples) 9 | 10 | ## Install 11 | Put the source in some folder, and in maxima do the following: 12 | 13 | ``` 14 | (%i1) diophantine_source_dir:""$ 15 | (%i2) push(sconcat(diophantine_source_dir, "$$$.mac"), file_search_maxima)$ 16 | (%i3) push(sconcat(diophantine_source_dir, "$$$.lisp"), file_search_lisp)$ 17 | ``` 18 | 19 | Putting these lines in your maxima-init.mac saves you from having to type this in every new maxima session. 20 | 21 | Alternatively, if you're using Robert Dodier's [asdf loader](https://github.com/robert-dodier/maxima-asdf), you can do the following: 22 | 23 | ``` 24 | (%i1) install_github("sdemarre", "diophantine", "master")$ 25 | (%i2) asdf_load_source("diophantine")$ 26 | ``` 27 | 28 | ## Usage 29 | 30 | ``` 31 | (%i1) load(diophantine)$ 32 | 33 | (%i2) diophantine_solve(-9*x+11*y=5); 34 | (%o2) [[x = 11*%z1 - 3,y = 9*%z1 - 2]] 35 | ``` 36 | 37 | The result is always a (possibly empty) list of solutions. When there are infinitely many solutions, solutions use a parameter %z1 or %n1, which means "any integer" or "any natural number" respectively. Some equations have several sets of those, e.g. 38 | 39 | ``` 40 | (%i3) diophantine_solve(18*y^2-24*x*y+7*y+8*x^2+5*x+16); 41 | (%o3) [[x = (-174*%z1^2)+17*%z1-2,y = (-116*%z1^2)+21*%z1-2], 42 | [x = (-174*%z1^2)+41*%z1-4,y = (-116*%z1^2)+37*%z1-4]] 43 | ``` 44 | 45 | Generating some specific values when the solution contains such a parameter can be done like this 46 | 47 | ``` 48 | (%i4) diophantine_solve(3*x+2*y-8); 49 | (%o4) [[x=2*%z1+2,y=1-3*%z1]] 50 | 51 | (%i5) diophantine_instantiate_solutions(%o4,-3,3); 52 | (%o5) [[x = - 4, y = 10], [x = - 2, y = 7], [x = 0, y = 4], [x = 2, y = 1], 53 | [x = 4, y = - 2], [x = 6, y = - 5], [x = 8, y = - 8]] 54 | ``` 55 | 56 | ## Limitations 57 | 58 | The test file (rtest_diophantine.mac) contains possibly interesting examples and examples that show the following issues: 59 | * Even apparently simple equations can take a very long time to solve (one of the reasons is trying to factor large integers). 60 | 61 | ## Tests 62 | 63 | There is a file with tests available, run it like this: 64 | 65 | ``` 66 | (%i6) batch(rtest_diophantine, test); 67 | ``` 68 | 69 | ## Graphical examples: 70 | 71 | ``` 72 | (%i7) load(diophantine_draw)$ 73 | (%i8) diophantine_draw_example(); 74 | ``` 75 | 76 | ![Graphical example](dio_draw_example.png) 77 | 78 | ``` 79 | (%i9) diophantine_draw_example2(); 80 | ``` 81 | 82 | ![Graphical example 2](dio_draw_example2.png) 83 | 84 | ``` 85 | (%i10) diophantine_draw_example3(); 86 | ``` 87 | 88 | ![Graphical example 3](dio_draw_example3.png) 89 | 90 | ``` 91 | (%i11) diophantine_draw_example4(); 92 | ``` 93 | 94 | ![Graphical example 4](dio_draw_example4.png) 95 | 96 | In general, you can use diophantine_draw() to draw the equation with (some of) its solutions: 97 | 98 | ``` 99 | (%i17) diophantine_draw(x^2-7*y^2=-3); 100 | ``` 101 | -------------------------------------------------------------------------------- /sdemarre/diophantine/dio_draw_example.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maxima-project-on-github/maxima-packages/6763e487b201eb00ab6e64d68087f184c6b31042/sdemarre/diophantine/dio_draw_example.png -------------------------------------------------------------------------------- /sdemarre/diophantine/dio_draw_example2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maxima-project-on-github/maxima-packages/6763e487b201eb00ab6e64d68087f184c6b31042/sdemarre/diophantine/dio_draw_example2.png -------------------------------------------------------------------------------- /sdemarre/diophantine/dio_draw_example3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maxima-project-on-github/maxima-packages/6763e487b201eb00ab6e64d68087f184c6b31042/sdemarre/diophantine/dio_draw_example3.png -------------------------------------------------------------------------------- /sdemarre/diophantine/dio_draw_example4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/maxima-project-on-github/maxima-packages/6763e487b201eb00ab6e64d68087f184c6b31042/sdemarre/diophantine/dio_draw_example4.png -------------------------------------------------------------------------------- /sdemarre/diophantine/diophantine-index.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-info) 2 | (let ( 3 | (deffn-defvr-pairs '( 4 | ; CONTENT: ( . ( )) 5 | ("diophantine_instantiate_solutions" . ("diophantine.info" 3144 1271 "Functions and Variables for package diophantine")) 6 | ("diophantine_solve" . ("diophantine.info" 1265 1878 "Functions and Variables for package diophantine")) 7 | )) 8 | (section-pairs '( 9 | ; CONTENT: ( . ( )) 10 | ("Functions and Variables for package diophantine" . ("diophantine.info" 1161 3254)) 11 | ("Introduction to package diophantine" . ("diophantine.info" 734 289)) 12 | ))) 13 | (load-info-hashtables (maxima::maxima-load-pathname-directory) deffn-defvr-pairs section-pairs)) 14 | -------------------------------------------------------------------------------- /sdemarre/diophantine/diophantine.asd: -------------------------------------------------------------------------------- 1 | (defsystem diophantine 2 | :defsystem-depends-on ("maxima-file" "info-index") 3 | :name "diophantine" 4 | :maintainer "Serge De Marre" 5 | :author "Serge De Marre" 6 | :licence "" 7 | :description "diophantine equation solver" 8 | :long-description "Maxima program to solve diophantine equations of the form ax^2+bxy+cy^2+dx+ey+f=0 with a,b,c,d,e,f constant integers. 9 | Based on Dario Alpern's solution/code found at https://www.alpertron.com.ar/QUAD.HTM" 10 | 11 | :components 12 | ((:file "diophantine_lisp_helpers") 13 | (:info-index "diophantine-index") 14 | (:maxima-file "diophantine") 15 | (:maxima-file "diophantine_draw"))) 16 | -------------------------------------------------------------------------------- /sdemarre/diophantine/diophantine_draw.mac: -------------------------------------------------------------------------------- 1 | load(draw); 2 | 3 | diophantine_make_points_data(diophantine_points_result):=block( 4 | map(lambda([p],[rhs(p[1]),rhs(p[2])]), diophantine_points_result)); 5 | 6 | diophantine_make_points_labels(point_data, dx, dy):=block( 7 | apply(label,map(lambda([p],[string(p), p[1]+dx, p[2]+dy]), point_data))); 8 | 9 | diophantine_draw_data(eq, xmin, xmax, ymin, ymax, label_dx, label_dy, point_data, label_data):=block([], 10 | wxdraw2d(font="Helvetica", font_size=20, yrange=[ymin, ymax], title=string(eq), xaxis=true, yaxis=true, ip_grid=[200,200],ip_grid_in=[10,10], 11 | implicit(eq, listofvars(eq)[1], xmin, xmax, listofvars(eq)[2], ymin, ymax), 12 | point_size=5, color=red, point_type=circle, points(point_data), 13 | point_size=2, color=green, point_type=filled_circle, points(point_data), 14 | color=black, label_data)); 15 | 16 | diophantine_draw_finite(eq, xmin, xmax, ymin, ymax, label_dx, label_dy):=block([solutions, point_data, label_data], 17 | solutions:diophantine_solve(eq), 18 | point_data:diophantine_make_points_data(solutions), 19 | label_data:diophantine_make_points_labels(point_data, label_dx, label_dy), 20 | diophantine_draw_data(eq, xmin, xmax, ymin, ymax, label_dx, label_dy, point_data, label_data)); 21 | 22 | diophantine_draw_infinite(eq, nmin, nmax, label_dx, label_dy, border):=block([solutions, point_data, label_data, point_ranges], 23 | solutions:diophantine_solve(eq), 24 | point_data:diophantine_make_points_data(diophantine_instantiate_solutions(solutions, nmin, nmax,integer)), 25 | label_data:diophantine_make_points_labels(point_data, label_dx, label_dy), 26 | point_ranges:[-border,border,-border,border]+diophantine_point_ranges(point_data), 27 | diophantine_draw_data(eq, point_ranges[1], point_ranges[2], point_ranges[3], point_ranges[4], label_dx, label_dy, point_data, label_data)); 28 | 29 | diophantine_scale_range(range,scale):=block([xsize:range[2]-range[1],ysize:range[4]-range[3],xmid,ymid], 30 | xmid:range[1]+xsize/2, 31 | ymid:range[3]+ysize/2, 32 | [xmid - xsize/2*scale, xmid + xsize/2*scale, ymid - ysize/2*scale, ymid + ysize/2*scale]); 33 | diophantine_draw(eq,[rest]):=block([sols:diophantine_solve(eq)], 34 | if not diophantine_infinite_solutions(sols) then block([point_ranges:diophantine_point_ranges(diophantine_make_points_data(sols)),new_range], 35 | new_range:diophantine_scale_range(point_ranges,1.2), 36 | diophantine_draw_finite(eq,new_range[1],new_range[2],new_range[3],new_range[4],(new_range[2]-new_range[1])/30,(new_range[4]-new_range[3])/25)) 37 | else block([limits:if length(rest)=2 then rest else [-1,1],pts,range,new_range], 38 | pts:diophantine_instantiate_solutions(sols,limits[1],limits[2],integer), 39 | range:diophantine_point_ranges(diophantine_make_points_data(pts)), 40 | diophantine_draw_infinite(eq,limits[1],limits[2],(range[2]-range[1])/30,(range[4]-range[3])/25,(range[2]-range[1])/10))); 41 | 42 | diophantine_draw_example():=diophantine_draw(2*x*y+56*y+5*x+7=0); 43 | 44 | diophantine_draw_example2():=diophantine_draw_finite(42*x*x+8*x*y+15*y*y+23*x+17*y-4915=0, -12, 12, -20, 20, 1, 2); 45 | 46 | diophantine_draw_example3():=diophantine_draw_finite(-2*y^2-5*x*y+3*x^2-6=0, -4, 4, -4, 4, 1/2, 1/2); 47 | 48 | diophantine_draw_example4():=diophantine_draw_infinite(18*y^2-24*x*y+7*y+8*x^2+5*x+16=0, -3, 3, 150, 10, 100); 49 | 50 | diophantine_draw_example5():=diophantine_draw_infinite(x^2-5*y^2=-1,-2,1,1,1,10); 51 | 52 | diophantine_draw_example6():=diophantine_draw_infinite(x^2-5*y^2=1,-1,1,1,1,10); 53 | 54 | diophantine_draw_example7():=diophantine_draw(13*y^2+16*x*y-306*y+5*x^2-190*x+1214); 55 | 56 | diophantine_draw_example8():=diophantine_draw((-11*y^2)+6*x*y-70*y-x^2+24*x+169); -------------------------------------------------------------------------------- /sdemarre/diophantine_system/README.md: -------------------------------------------------------------------------------- 1 | Solver for systems of linear diophantine equations. 2 | At the core of the algorithm is the computation of the smith normal form of the system matrix. 3 | We can describe the system as A.x = b, with all entries of A, b and x integers. 4 | The smith normal S has the property that A = U . S . V', S a diagonal matrix, which allows us to easily solve the original system. 5 | 6 | * _smith_normal_form.mac_ 7 | maxima implementation of smith normal form 8 | 9 | how to use: 10 | put the _smith_normal_form.mac_ in a folder that's in your _file_search_maxima_ path, or extend _file_search_maxima_ with the path where you have put the .mac file. 11 | ``` 12 | (%i1) load(smith_normal_form); 13 | (%o1) smith_normal_form.mac 14 | 15 | (%i2) smith_normal_form(matrix([1,2,3,4],[5,6,7,8])); 16 | 17 | [ 1 1 0 0 ] 18 | [ ] 19 | [ 1 0 ] [ 1 0 0 0 ] [ 2 1 0 0 ] 20 | (%o2) [[ ], [ ], [ ]] 21 | [ 1 - 1 ] [ 0 - 4 0 0 ] [ 3 1 1 0 ] 22 | [ ] 23 | [ 4 1 0 1 ] 24 | 25 | ``` 26 | 27 | * _diophantine_system.mac_ 28 | maxima implementation of a solver for systems of linear diophantine equations. 29 | how to use: 30 | put the _diophantine_system.mac_ in a folder that's in your _file_search_maxima_ path, or extend _file_search_maxima_ with the path where you have put the .mac file. 31 | ``` 32 | (%i1) load(diophantine_system); 33 | (%o1) diophantine_system 34 | 35 | (%i2) eq: [(-8*x5)+22*x4+4*x2+3*x1 = 25, 36 | (-12*x5)+46*x4+6*x1 = 2, 37 | 9*x5-x4+3*x3+4*x2 = 26]$ 38 | 39 | (%i3) solve_linear_diophantine(eq); 40 | (%o3) [x1 = 92 %z2 + 3444 %z1 - 617, 41 | x2 = (- 3 %z2) - 114 %z1 + 25, 42 | x4 = (- 12 %z2) - 450 %z1 + 80, 43 | x5 = (- 3 %z1) - 2, 44 | x3 = 11 %z1 + 8] 45 | 46 | (%i4) %o3,%z1=0,%z2=0; 47 | (%o4) [x1 = - 617, x2 = 25, x4 = 80, x5 = - 2, x3 = 8] 48 | 49 | (%i5) eq,%o3,ratsimp; 50 | (%o5) [25=25, 2=2, 26=26] 51 | ``` 52 | 53 | -------------------------------------------------------------------------------- /sdemarre/diophantine_system/diophantine_system-index.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-info) 2 | (let ( 3 | (deffn-defvr-pairs '( 4 | ; CONTENT: ( . ( )) 5 | ("smith_normal_form" . ("diophantine_system.info" 2565 1275 "Functions and Variables for package diophantine_system")) 6 | ("solve_linear_diophantine" . ("diophantine_system.info" 1410 1154 "Functions and Variables for package diophantine_system")) 7 | )) 8 | (section-pairs '( 9 | ; CONTENT: ( . ( )) 10 | ("Functions and Variables for package diophantine_system" . ("diophantine_system.info" 1292 2548)) 11 | ("Introduction to package diophantine_system" . ("diophantine_system.info" 850 283)) 12 | ))) 13 | (load-info-hashtables (maxima::maxima-load-pathname-directory) deffn-defvr-pairs section-pairs)) 14 | -------------------------------------------------------------------------------- /sdemarre/diophantine_system/diophantine_system.asd: -------------------------------------------------------------------------------- 1 | (defsystem diophantine_system 2 | :defsystem-depends-on ("maxima-file" "info-index") 3 | :name "diophantine_system" 4 | :maintainer "Serge De Marre" 5 | :author "Serge De Marre" 6 | :licence "" 7 | :description "diophantine system of linear equations solver" 8 | :long-description "Maxima program to solve a system of linear diophantine equations A.x=b with integer elements of A,x and b." 9 | 10 | :components 11 | ((:info-index "diophantine_system-index") 12 | (:maxima-file "smith_normal_form") 13 | (:maxima-file "diophantine_system"))) 14 | -------------------------------------------------------------------------------- /sdemarre/diophantine_system/diophantine_system.texi: -------------------------------------------------------------------------------- 1 | \input texinfo 2 | 3 | @setfilename diophantine_system.info 4 | @settitle Package diophantine_system 5 | 6 | @ifinfo 7 | @macro var {expr} 8 | <\expr\> 9 | @end macro 10 | @end ifinfo 11 | 12 | @dircategory Mathematics/Maxima 13 | @direntry 14 | * Package diophantine_system: (maxima-packages/sdemarre)Maxima package for solving systems of linear Diophantine equations 15 | @end direntry 16 | 17 | @node Top, Introduction to package diophantine_system, (dir), (dir) 18 | @top 19 | @menu 20 | * Introduction to package diophantine_system:: 21 | * Functions and Variables for package diophantine_system:: 22 | * Function and variable index:: 23 | @end menu 24 | @chapter Package diophantine_system 25 | 26 | @node Introduction to package diophantine_system, Functions and Variables for package diophantine_system, Top, Top 27 | @section Introduction to package diophantine_system 28 | 29 | @code{diophantine_system} is a package to solve systems of linear Diophantine equations of the form @math{A.x=b} in which @math{A,x} and @math{b} are integer matrices/vectors, and @math{A} and @math{b} are known, @math{x} is unknown. 30 | 31 | @node Functions and Variables for package diophantine_system, Introduction to package diophantine_system, Top 32 | @section Functions and Variables for package diophantine_system 33 | 34 | @deffn {Function} solve_linear_diophantine (@var{equations}) 35 | 36 | Computes solutions for the @code{equations}, which has to be a list of linear equations with integer coefficients. Every equation is @math{a_{1i}x_1+a_{2i}x_2+\cdots+a_{ni}x_n+c_i=0} with @math{a_{ij}} and @math{c_i} integer coefficients, @math{x_i} the variables which can only take integer values. The result is always a list. If an empty list is returned, it means no solutions exist. Sometimes, there are infinitely many solutions, but those infinite solutions can be described by a parametrized representation. The parameter is of the form @math{%zi} for an integer parameter, suitably declared with @code{new_variable('integer)} from the @code{to_poly_solve} package. 37 | 38 | Examples: 39 | 40 | @c ===beg=== 41 | @c load(diophantine_system)$ 42 | @c eq: [(-8*x5)+22*x4+4*x2+3*x1 = 25, (-12*x5)+46*x4+6*x1 = 2, 9*x5-x4+3*x3+4*x2 = 26]$ 43 | @c solve_linear_diophantine(eq); 44 | @c ===end=== 45 | @example 46 | (%i1) load(diophantine_system)$ 47 | @group 48 | (%i2) eq: [(-8*x5)+22*x4+4*x2+3*x1 = 25, (-12*x5)+46*x4+6*x1 = 2, 9*x5-x4+3*x3+4*x2 = 26]$ 49 | (%i3) solve_linear_diophantine(eq); 50 | (%o3) [x1 = 92 %z2 + 3444 %z1 - 617, 51 | x2 = (- 3 %z2) - 114 %z1 + 25, 52 | x4 = (- 12 %z2) - 450 %z1 + 80, 53 | x5 = (- 3 %z1) - 2, 54 | x3 = 11 %z1 + 8] 55 | @end group 56 | @end example 57 | @end deffn 58 | 59 | @deffn {Function} smith_normal_form (@var{matrix}) 60 | 61 | Given an integer @code{matrix} @math{A}, computes 3 integer matrices @math{U,S,V} such that @math{A=U.S.V'}, with @math{S} a diagonal integer matrix, @math{U} an invertible integer matrix and @math{V'} an integer matrix. 62 | 63 | 64 | Examples: 65 | 66 | @c ===beg=== 67 | @c load(smith_normal_form)$ 68 | @c m:matrix([-3,4,4,0,-4],[1,4,-5,-4,5],[3,3,-2,3,-1])$ 69 | @c smith_normal_form(m); 70 | @c ===end=== 71 | @example 72 | (%i1) load(smith_normal_form)$ 73 | @group 74 | (%i2) m:matrix([-3,4,4,0,-4],[1,4,-5,-4,5],[3,3,-2,3,-1])$ 75 | (%i3) smith_normal_form(m); 76 | [ 2 1 - 1 0 0 ] 77 | [ ] 78 | [ 20 - 7 - 36 ] [ 1 0 0 0 0 ] [ 7 4 - 3 0 0 ] 79 | [ ] [ ] [ ] 80 | (%o3) [[ 1 0 - 1 ], [ 0 1 0 0 0 ], [ - 57 104 52 - 19 0 ]] 81 | [ ] [ ] [ ] 82 | [ - 10 4 19 ] [ 0 0 - 1 0 0 ] [ - 65 128 61 - 23 0 ] 83 | [ ] 84 | [ 78 - 152 - 73 0 1 ] 85 | 86 | @end group 87 | @end example 88 | 89 | @end deffn 90 | 91 | @node Function and variable index, , Functions and Variables for package diophantine_system, Top 92 | @appendix Function and variable index 93 | @printindex fn 94 | @printindex vr 95 | 96 | @bye 97 | -------------------------------------------------------------------------------- /sdemarre/diophantine_system/rtest_diophantine_system.mac: -------------------------------------------------------------------------------- 1 | kill(values)$ 2 | done$ 3 | 4 | /* This business about ?mget(..., ?mexpr) = false is to test for the presence of a function definition. 5 | * It probably makes sense to have a direct way to test that. 6 | * Another suboptimal way is errcatch(fundef(...)) = []. 7 | */ 8 | (if ?mget ('solve_linear_diophantine, ?mexpr) = false then load("diophantine_system.mac"),0)$ 9 | 0$ 10 | 11 | block([m,u,s,v], 12 | m:matrix([1,2,3,4,5,6,7],[1,0,1,0,1,0,1],[2,4,5,6,1,1,1],[1,4,2,5,2,0,0],[0,0,1,1,2,2,3]), 13 | [u,s,v]:smith_normal_form(m), 14 | zeromatrixp(u.s.transpose(v)-m))$ 15 | true$ 16 | 17 | block([m,u,s,v], 18 | m:matrix([-6, 111, -36, 6],[ 5, -672, 210, 74],[ 0, -255, 81, 24],[-7, 255, -81, -10]), 19 | [u,s,v]:smith_normal_form(m), 20 | zeromatrixp(u.s.transpose(v)-m))$ 21 | true$ 22 | 23 | block([m,u,s,v], 24 | m:matrix([9,23,1,0],[3,4,-40,33],[1,0,-28,23],[31,79,1,2]), 25 | [u,s,v]:smith_normal_form(m), 26 | zeromatrixp(u.s.transpose(v)-m))$ 27 | true$ 28 | 29 | block([eq:[9*x+3=21],sol], 30 | sol:solve_linear_diophantine(eq), 31 | every(subst(sol,eq)))$ 32 | true$ 33 | 34 | block([eq:[9*M+16*L+10*K+36*J-624,113*M+152*L+80*K+102*J-4818, 147*M+188*L+95*K+63*J-5667],sol], 35 | sol:solve_linear_diophantine(eq), 36 | every(subst(sol,eq)))$ 37 | true$ 38 | 39 | block([eq:[(-2*x3)+3*x2-1,(-5*x3)-4],sol], 40 | sol:solve_linear_diophantine(eq))$ 41 | []$ 42 | 43 | /* not handled yet: more equations than unknowns. 44 | solution could exist if equations are not contradictory 45 | block([eq:[x2-x1+2,(-3*x2)+2*x1-1,(-5*x2)+x1-1,2*x2-2*x1,(-4*x2)-2*x1],sol], 46 | sol:solve_linear_diophantine(eq), 47 | every(subst(sol,eq)))$ 48 | true$ */ 49 | 50 | block([eq:[(-4*x3)-x2-4],sol], 51 | sol:solve_linear_diophantine(eq), 52 | every(subst(sol,eq)))$ 53 | true$ 54 | 55 | block([eq:[23*k2+9*k1+7 = 12-%z1,4*k2+3*k1+2 = (-33*%z2)+40*%z1-660, k1 = (-23*%z2)+28*%z1-462,79*k2+31*k1+23 = (-2*%z2)-%z1],sol], 56 | sol:solve_linear_diophantine(eq), 57 | every(subst(sol,eq)))$ 58 | true$ 59 | 60 | block([eq:[(10*z-7*y+17*x = -12)],sol], 61 | sol:solve_linear_diophantine(eq), 62 | every(subst(sol,eq)))$ 63 | true$ 64 | 65 | block([eq:[(-2*z)-7*y+5*x+6*w = 6,(-3*z)+6*y-4*x+11*w = 0],sol], 66 | sol:solve_linear_diophantine(eq), 67 | every(subst(sol,eq)))$ 68 | true$ 69 | 70 | block([eq:[9*z-7*y+12*x = 12,8*z-5*y+10*w = 0,21*z+15*x+69*w = 3],sol], 71 | sol:solve_linear_diophantine(eq), 72 | every(subst(sol,eq)))$ 73 | true$ 74 | 75 | block([eq:[(-8*x5)+22*x4+4*x2+3*x1 = 25,(-12*x5)+46*x4+6*x1 = 2,9*x5-x4+3*x3+4*x2 = 26],sol], 76 | sol:solve_linear_diophantine(eq), 77 | every(subst(sol,eq)))$ 78 | true$ 79 | 80 | block([eq:[6*x4-7*x3+3*x1 = -2,(-5*x5)+6*x4+3*x2+4*x1 = 19],sol], 81 | sol:solve_linear_diophantine(eq), 82 | every(subst(sol,eq)))$ 83 | true$ 84 | 85 | block([eq:[2*x4+6*x3+3*x1 = 0,(-7*x5)-2*x3+4*x2 = -1],sol], 86 | sol:solve_linear_diophantine(eq), 87 | every(subst(sol,eq)))$ 88 | true$ 89 | -------------------------------------------------------------------------------- /sdemarre/diophantine_system/smith_normal_form.mac: -------------------------------------------------------------------------------- 1 | /* decomposes a matrix A into [U, S, V] so that 2 | A = U . S . V' 3 | S is the smith normal form */ 4 | 5 | /* TODO */ 6 | /* handle case where there are more equations than unknowns: snf doesn't handle it, but we could just try to solve for a normal square system, and then fill it in the full system, checking if it is consistent */ 7 | /* handle the case where some of the unknowns in the given equations are %zi that we are using as parameters describing the full solution */ 8 | /* handle case where only a single equation is given */ 9 | 10 | leftmult2(m,i0,i1,a,b,c,d):=block([num_rows,num_cols,pr], 11 | [num_rows, num_cols]:matrix_size(m), 12 | for j:1 thru num_cols do block([x,y], 13 | [x,y]:[m[i0,j],m[i1,j]], 14 | m[i0, j]: a*x+b*y, 15 | m[i1, j]: c*x+d*y), 16 | m); 17 | 18 | rightmult2(m, j0, j1, a, b, c, d):=block([num_rows, num_cols, pr], 19 | [num_rows, num_cols]:matrix_size(m), 20 | for i:1 thru num_rows do block([x,y], 21 | [x,y]:[m[i, j0], m[i, j1]], 22 | m[i, j0]: a*x+c*y, 23 | m[i, j1]: b*x+d*y), 24 | m); 25 | 26 | col_is_zero(M,j):=block([m,n,i,r], 27 | [m,n]:matrix_size(M), 28 | r:(for i:1 thru m do ( 29 | if is(M[i,j]#0) then return(true) 30 | )), 31 | is(r=done)); 32 | 33 | find_nonzero_column(m,start,num_cols):=block([r], 34 | r:(for i:start thru num_cols do ( 35 | if not col_is_zero(m,i) then return(i))), 36 | if is(r=done) then num_cols else r); 37 | 38 | find_nonzero_element(m,column,num_rows):=block([r], 39 | r:(for i:1 thru num_rows do ( 40 | if is(m[i,column]#0) then return(i))), 41 | if is(r=done) then num_rows else r); 42 | 43 | smith_normal_form(M):=block([m,s,t, num_rows, num_cols], 44 | m:copymatrix(M), 45 | [num_rows, num_cols]:matrix_size(m), 46 | s:ident(num_rows), 47 | t:ident(num_cols), 48 | block([last_j:0], 49 | for i:1 thru num_rows do ( 50 | j:find_nonzero_column(m, last_j+1, num_cols), 51 | if is(m[i,j] = 0) then block([ii], 52 | ii:find_nonzero_element(m, j, num_rows), 53 | leftmult2(m,i,ii,0,1,1,0), 54 | rightmult2(s,i,ii,0,1,1,0)), 55 | rightmult2(m,j,i,0,1,1,0), 56 | leftmult2(t,j,i,0,1,1,0), 57 | j:i, 58 | block([upd:true, coef1, coef2, coef3, coef4, g, coef5, cnt], 59 | for cnt:1 while upd do block([], 60 | upd:false, 61 | for ii:1+i thru num_rows do ( 62 | if is(m[ii,j]#0) then ( 63 | upd:true, 64 | if is(remainder(m[ii,j],m[i,j])#0) then ( 65 | [coef1, coef2, g] : gcdex(m[i,j], m[ii,j]), 66 | coef3: quotient(m[ii, j], g), 67 | coef4: quotient(m[i, j], g), 68 | leftmult2(m, i, ii, coef1, coef2, -coef3, coef4), 69 | rightmult2(s, i, ii, coef4, -coef2, coef3, coef1)), 70 | coef5:quotient(m[ii, j], m[i, j]), 71 | leftmult2(m, i, ii, 1, 0, -coef5, 1), 72 | rightmult2(s, i, ii, 1, 0, coef5, 1))), 73 | for jj: j + 1 thru num_cols do ( 74 | if is(m[i, jj]#0) then ( 75 | upd:true, 76 | if is(remainder(m[i, jj], m[i, j])#0) then ( 77 | [coef1, coef2, g]:gcdex(m[i, j], m[i, jj]), 78 | coef3: quotient(m[i, jj], g), 79 | coef4:quotient(m[i, j], g), 80 | rightmult2(m, j, jj, coef1, -coef3, coef2, coef4), 81 | leftmult2(t, j, jj, coef4, coef3, -coef2, coef1)), 82 | coef5:quotient(m[i, jj], m[i, j]), 83 | rightmult2(m, j, jj, 1, -coef5, 0, 1), 84 | leftmult2(t, j, jj, 1, coef5, 0, 1)))), 85 | last_j: j)), 86 | for i1:1 thru min(num_rows, num_cols) do ( 87 | for i0:i1-1 step -1 thru 1 do block([coef1, coef2, g, coef3, coef4], 88 | [coef1, coef2, g]: gcdex(m[i0, i0], m[i1, i1]), 89 | if is(g#0) then block([], 90 | coef3: quotient(m[i1, i1], g), 91 | coef4: quotient(m[i0, i0], g), 92 | leftmult2(m, i0, i1, 1, coef2, coef3, coef2*coef3-1), 93 | rightmult2(s, i0, i1, 1-coef2*coef3, coef2, coef3, -1), 94 | rightmult2(m, i0, i1, coef1, 1-coef1*coef4, 1, -coef4), 95 | leftmult2(t, i0, i1, coef4, 1-coef1*coef4, 1, -coef1))))), 96 | [s,m,transpose(t)]); 97 | 98 | 99 | -------------------------------------------------------------------------------- /yitzchak/texify/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Changes 2 | 3 | All significant changes to this project will be documented in the notes below. 4 | 5 | ## 2018-06-04 6 | 7 | ### Added 8 | 9 | - `tex_no_math_delimiters` style for no math delimeters or labels. 10 | - Support for big floats. 11 | 12 | ### Changes 13 | 14 | - The functions `texify` and `texify_inline` are now backward compatible with 15 | Maxima's function `tex`. 16 | 17 | ### Fixed 18 | 19 | - Remove unneeded math delimiters in LaTeX `mlabel` format. 20 | - Avoid using `mathop` in Euler notation for correct placement of subscript. 21 | - Wrapping with parenthesis is now done based on normalized expression. This 22 | fixes some issues with `mrat`. 23 | - Digit extraction from symbols like `a0` or `a_1_2` is now done by function 24 | included in texify, not `extract-trailing-digits` from `mactex.lisp`. This 25 | avoids issues in loading order. 26 | 27 | ## 2017-05-30 28 | 29 | Initial release 30 | -------------------------------------------------------------------------------- /yitzchak/texify/texify.asd: -------------------------------------------------------------------------------- 1 | (defsystem texify 2 | :name "texify" 3 | :maintainer "Tarn W. Burton" 4 | :author "Tarn W. Burton" 5 | :licence "GNU General Public License" 6 | :description "Flexible Maxima to TeX/LaTeX converter with styles." 7 | :long-description "Flexible Maxima to TeX/LaTeX converter with styles." 8 | 9 | :components 10 | ((:file "texify"))) 11 | --------------------------------------------------------------------------------