pax_global_header00006660000000000000000000000064135626741060014524gustar00rootroot0000000000000052 comment=df8eb6655eb6752f8832308c100b8fe8a6179106 libctl-4.4.0/000077500000000000000000000000001356267410600130025ustar00rootroot00000000000000libctl-4.4.0/.gitignore000066400000000000000000000010441356267410600147710ustar00rootroot00000000000000*.tar.gz *.exe *.dll *.do *.o *.lo *.a *.la *.dylib *.dSYM *.zip *.native *.log *.trs _build # autotools stuff Makefile Makefile.in .deps .libs stamp-h* install-sh libtool ltmain.sh m4/libtool.m4 m4/ltoptions.m4 m4/ltsugar.m4 m4/ltversion.m4 m4/lt~obsolete.m4 configure config.* autom4te.cache INSTALL aclocal.m4 depcomp missing py-compile compile test-driver # other generated files example.scm example ctl.h gen-ctl-io ctl-io.c ctl-io.h examples/geom.c examples/main.c ctlgeom-types.h geom-ctl-io.c geomtst nlopt-constants.scm utils/test-prism libctl-4.4.0/.mailmap000066400000000000000000000006511356267410600144250ustar00rootroot00000000000000Steven G. Johnson Steven G. Johnson Steven G. Johnson Steven G. Johnson Steven G. Johnson Steven G. Johnson Steven G. Johnson libctl-4.4.0/.travis.yml000066400000000000000000000012331356267410600151120ustar00rootroot00000000000000language: c sudo: false matrix: include: - os: linux addons: apt: packages: - autoconf - automake - libtool - guile-2.0-dev script: - sh autogen.sh --prefix=`pwd`/.local - make && make check && make install - rm -rf * ~/.local - os: osx install: - brew update - brew install guile script: - sh autogen.sh --prefix=`pwd`/.local - make && make check && make install - rm -rf * ~/.local after_script: - PRISM_LOG=${TRAVIS_BUILD_DIR}/utils/test-prism.log - if [[ -e ${PRISM_LOG} ]]; then cat ${PRISM_LOG}; fi libctl-4.4.0/AUTHORS000066400000000000000000000006311356267410600140520ustar00rootroot00000000000000libctl was written by Steven G. Johnson (stevenj@alum.mit.edu) with contributions by: M.T. Homer Reid Christopher Hogan Ardavan Oskooi The multidimensional integration routines in src/integrator.c were adapted from the HIntlib Library by Rudolf Schuerer and from the GNU Scientific Library (GSL) by Brian Gough; both of these libraries are licensed under the GNU General Public License, version 2 or later. libctl-4.4.0/COPYING000066400000000000000000000432541356267410600140450ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. libctl-4.4.0/COPYRIGHT000066400000000000000000000017131356267410600142770ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ libctl-4.4.0/Makefile.am000066400000000000000000000007611356267410600150420ustar00rootroot00000000000000SUBDIRS = src utils if WITH_GUILE SUBDIRS += examples endif EXTRA_DIST = COPYRIGHT doc base README.md NEWS.md ACLOCAL_AMFLAGS = -I m4 BASE_SCM = base/class.scm base/ctl.scm base/extern-funcs.scm \ base/help.scm base/include.scm base/interaction.scm base/io-vars.scm \ base/math-utils.scm base/matrix3x3.scm base/simplex.scm base/utils.scm \ base/vector3.scm nobase_dist_pkgdata_DATA = $(BASE_SCM) base/main.c utils/ctl-io.scm utils/geom.c utils/geom.scm utils/nlopt-constants.scm utils/nlopt.c libctl-4.4.0/NEWS.md000066400000000000000000000302351356267410600141030ustar00rootroot00000000000000# Libctl Release Notes ## libctl 4.4.0 11/12/19 * `geom_object_volume` function to get the volume of a 3d object (accelerates `box_overlap_with_object` for objects completely within a box) (#45). * Bugfix to geometry tree search for empty dimensions. ## libctl 4.3.0 4/17/19 * `ctl_printf_callback` so that callers can capture stdout (#39). ## libctl 4.2.0 1/7/19 * Better handling of `center` parameter of prisms, allowing this to be optionally specified (#35). Deprecates old `geom_fix_object` and `geom_fix_objects0` functions in favor of `geom_fix_object_ptr` and `geom_fix_object_list`. (In particular, the old `geom_fix_object` routine will not work properly for prisms in which the center was not computed.) ## libctl 4.1.4 11/16/18 * Work around gcc bug (closes #32). * Allow subclass properties to override defaults (or lack thereof) in parent class. ## libctl 4.1.3 9/7/2018 * Improved prism handling of points on prism faces (#23) and various cosmetic improvements (#22, #24, #25). ## libctl 4.1.2 7/27/2018 * Bug fix in prism subpixel averaging (#19 and #20), thanks to @DerekK88 for the bug report. ## libctl 4.1.1 6/29/2018 * Bug fix in prism bounding boxes (#17). * Build fix for systems with an old `ctlgeom.h` file installed (#16). ## libctl 4.1 6/7/2018 * New "prism" geometric-object type for polygonal prisms (#13). ## libctl 4.0.1 4/18/2018 * Changed header file to use `const char *` rather than `char *` for constant string arguments, since C++ deprecated passing literal strings to `char *` arguments. * Various minor build and compilation improvements. ## libctl 4.0 1/18/2018 * Building `--without-guile` is now possible to build only `libctlgeom`, which no longer depends on Guile. * In libctlgeom, material is no represented by a `void*` rather than by a `struct` wrapping a `void*`. * Migrate docs to github/markdown/readthedocs. ## libctl 3.2.2 3/28/2014. * Bug fix to interpolate-uniform for guile 1.8+. ## libctl 3.2.1 8/8/2012. * Fix incorrect gh_symbol2newstr macro replacement. ## libctl 3.2 7/20/2012. * Now works with Guile version 2.x (older versions are still supported). * Add `libctl_quiet` variable to main.c so that libctl-using programs can suppress all output if desired (e.g. to avoid duplicate outputs on parallel machines). * Added `wedge` object type for circular/cylindrical wedges, as a subclass of cylinder: `(make wedge (center ...) (axis ...) (radius ...) ...)` with two new properties: `(wedge-angle ...)` for the angle in radians, and `(wedge-start v)` for a vector v such that the wedge angles start at zero in the (v, axis) plane. (Caveat: subpixel averaging is currently inaccurate for the flat wedge edges.) * list-type constructors now accept either `(name ...elements...)` or `(name (list ...elements...))`. * Add `vector3->exact` function for to-integer rounding. Otherwise, ensure that interpolation results are floating-point to prevent type-conversion errors. * Added `ctl-set-prompt!` to set interactive prompt in both old and new Guile versions. * Rename `string` to `char*` in ctl-io.h for C++ compatibility. * Bug fix in `normal-to-object` near corners of blocks. ## libctl 3.1 6/5/2009. * Support specifying the location of the guile and guile-config programs with GUILE and GUILE_CONFIG environment variables in the configure script. * Support for calling NLopt optimization library (also requires the program using libctl to be changed to link nlopt). * New ellipsoid_overlap_with_object function, analogous to box_overlap_with_object function. * Bug fix in `include` function for recent versions of Guile, to properly keep track of the current include directory. * Bug fix in `numerical-derivative` routine, which didn't converge when the error was exactly zero. ## libctl 3.0.3 2/27/2008. * Added `begin-timed` function, which is similar to `begin-time` except that it returns the value of the last statement (like `begin`) rather than the time. * Bug fix: allow classes to have boolean properties. * Bug fixes for compilation under C++, thanks to David Foster: include missing string.h header and fixed gh_new_procedure prototype. ## libctl 3.0.2 8/22/2006. * Fix minor Guile incompatibility on some systems. ## libctl 3.0.1 5/1/2006. * Change shared-library version to 3:0:0 instead of 0:0:0. This avoids conflicts with shared library version numbers that has been assigned to earlier versions of libctl for Debian; thanks to Josselin Mouette for the suggestion. ## libctl 3.0 4/1/2006. * Switch to use automake and libtool. Can now install shared libraries with `--enable-shared`. * License is now GNU GPL (v2 or later) rather than the GNU LGPL, due to use of third-party GPL code for multi-dimensional integration (below). * `gen-ctl-io` now supports separate generation of code and header files via `--code` and `--header` arguments. (Better for parallel make.) Also support a -o option to give a different output file name. * gen-ctl-io can now export C++ code by using the `--cxx` flag. * `gen-ctl-io` can now export SWIG `.i` files for automatic type conversion in SWIG wrapper generation, using the --swig flag. * Backwards incompatible change: users must include their own ctl-io.h *before* ctlgeom.h, or you get ctlgeom-types.h instead (this is for use with the `stand-alone` libctlgeom.a library below. * New multi-dimensional integration routines using adaptive cubature. (Much more efficient than nested 1d integrations.) Adapted in part from the HIntlib Library by Rudolf Schuerer and from the GNU Scientific Library (GSL) by Brian Gough. * New `interpolate-uniform` function that tries to maintain a uniform distance between points (i.e. variable number of interpolated points between different list elements, as needed). * Now install a `stand-alone` libctlgeom.a library to make it easier to call geometry routines from non-Scheme code. * New routines to compute overlap fraction of box with object, compute analytical normal vectors, etcetera. (For upcoming version of MPB.) Also new routines to get the object of a point, not just the material. Also new routines to operate on a supplied geometry list parameter instead of using the global; unlike the old `material_of_point_in_tree` functions, these functions do not shift the argument to the unit cell, but you can use the new function shift_to_unit_cell to get this behavior. * `gen-ctl-io` now generates object equal/copy functions. * In `unit-vector3`, only return 0 when norm==0, not merely if it is small. * Added one-sided numerical derivative routine. * Define `verbose?` variable corresponding to main.c variable. * `(print)` calls `(flush-all-ports)` to keep C and Scheme I/O in sync. * Fix in `find-root-deriv` to prevent infinite loop in some cases where the root does not exist; thanks to XiuLun Yang for the bug report. * Bug fix in `make_hermitian_cmatrix3x3`; thanks to Mischa Megens. ## libctl 2.2 9/12/2002. * Added simple trapezoidal-rule adaptive numeric integration routine. * Numerical derivative routines now allow numerical differentation of vector-valued function. Added deriv2 convenience routine. * Added `find-root-deriv` functions for faster root-finding of functions for which the derivative is also available. * Added missing `(cvector3 ...)` constructor, and fixed corresponding constructor for `cvector3` object properties; thanks to Doug Allan for the bug report. * Added generic `memoize` function. * libctl programs now print out command-line parameters when they run. * Fixed incomplete support for generic SCM type. * Fixed to work with Guile 1.5+ (thanks to Mike Watts for the bug report). ## libctl 2.1 3/21/2002. * Bug fix: complex-number input variables were read as garbage if they had imaginary parts; does not affect complex-number outputs. * Added generic SCM type for i/o variables and parameters, as a catch-all for other Scheme objects. * main.c now has `ctl_export_hook` (enabled by defining CTL_HAVE_EXPORT_HOOK) with which to define additional Guile symbols. * gen-ctl-io: converts `!` in symbols to `B` in C identifiers. ## libctl 2.0 3/10/2002. * New `set-param!` function, analogous to define-param, that allows you to change the value of a parameter in a way that can still be overridden from the command line. * In libgeom, allow user to specify the `resolution` instead of the `grid-size`. New `no-size` support in lattice class to reduce dimensionality, and new `(get-grid-size)` function. * Support for Scheme complex numbers, along with a few new associated functions: `conj`, `vector3-cdot`, `matrix3x3-adjoint`. * New functions to compute numerical derivatives using Ridder's method of polynomial extrapolation. * Documented `object-property-value`; thanks to Theis Peter Hansen for the suggestion. * Get rid of unneeded `make-default`, and use consistent syntax for `define-property` and `define-post-processed-property`, compared to `define-input-var`. NOT BACKWARD COMPATIBLE (for developers; users are not affected). Thanks to Theis Peter Hansen for the suggestion. * Call ctl_stop_hook even with `--help`, `--version`, etcetera; this makes the behavior nicer e.g. with MPI. ## libctl 1.5 11/15/2001. * geometry-lattice now has a separate basis-size property, so that you can specify the basis vectors as being something other than unit vectors. * More functions are tail-recursive, helping to prevent stack overflows; thanks to Robert Sheldon for the bug report. * New fold-left and fold-right functions, documented in the manual. * The configure script now checks that guile is in the $PATH. Thanks to Bing Li and Giridhar Malalahalli for their bug reports. ## libctl 1.4.1 7/4/2001. * Support function lists. ## libctl 1.4 2/23/2001. * Renamed `display-many` function to more felicitous `print` and added `print-ok?` global variable that allows you to disable program output. * Added support for passing `'function` types back and forth (just a SCM object pointing to a Scheme function). * Cosmetic fixes to yes/no? and menu-choice interaction functions. * Support start/exit hooks for use e.g. with MPI. ## libctl 1.3 1/7/2001. * Added improved `subplex` multidimensional optimization algorithm (for maximize-multiple and minimize-multiple). * Documented vector3-x, vector3-y, vector3-z functions for extracting vector3 components. ## libctl 1.2 7/9/2000. * Added new `cone` geometric object type. * Added reciprocal->cartesian, cartesian->lattice, lattice->reciprocal, etcetera functions to libgeom for converting vectors between bases. * Added routines rotate-vector3 and rotation-matrix3x3 for rotating vectors. * Added support for returning lists from external functions. * Fixed bug in matrix3x3-inverse function. * Fixed bug in find-root for converging to negative roots. * Use Nelder-Mead simplex algorithm for multi-dimensional minimization (it seems to be more robust than the old routine). ## libctl 1.1.1 1/28/2000. * Use CPPFLAGS environment variable instead of the less-standard INCLUDES to pass -I flags to the configure script (for header files in non-standard locations). * Compilation fixes. We need to set SHELL in the Makefile for make on some systems. Also added rule to insure ctl-io.h is created before main.c is compiled. Thanks to Christoph Becher for the bug reports. ## libctl 1.1 1/2/2000. * geom: radius and height of objects is now permitted to be zero. * geom: `material_of_point_*` routines now report whether the point is in any object; necessary for use with MPB 0.9. * Added man page for `gen-ctl-io`, based on a contribution by James R. Van Zandt. ## libctl 1.0.1 11/22/1999. * geom: handle case where `ensure-periodicity` is `false`. * geom: bug fix in `geometric-objects-lattice-duplicates` for non-orthogonal lattices; thanks to Karl Koch for the bug report. ## libctl 1.0 11/19/1999. * Initial public release. libctl-4.4.0/README.md000066400000000000000000000034661356267410600142720ustar00rootroot00000000000000[![Latest Docs](https://readthedocs.org/projects/pip/badge/?version=latest)](http://libctl.readthedocs.io/en/latest/) [![Build Status](https://travis-ci.org/NanoComp/libctl.svg?branch=master)](https://travis-ci.org/NanoComp/libctl) This is libctl, a [Guile](http://www.gnu.org/software/guile/)-based library for supporting flexible control files in scientific simulations. The official released versions of Libctl can be found in the [releases page](https://github.com/NanoComp/libctl/releases). See the [Installation section of the manual](http://libctl.readthedocs.io/en/latest/Installation/) for more information, but to install libctl from an official release, one normally only needs to do: ./configure make make install Files are installed under `/usr/local` by default, but this can be changed by passing `--prefix=` to `configure`. (To build from a git clone, you first need to run the `autogen.sh` script.) Documentation can be found in [the Libctl manual](https://libctl.readthedocs.io), and an example program is located in the `examples/ directory`. The main source code for libctl is in the `base/` and `utils/` directories. In `utils/geom.*`, you can find specification files and functions for dealing with structures consisting of solid geometric objects in some lattice basis. The example program uses this code. This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. libctl-4.4.0/autogen.sh000077500000000000000000000004351356267410600150050ustar00rootroot00000000000000#!/bin/sh mkdir -p m4 # paranoia: sometimes autoconf doesn't get things right the first time autoreconf --verbose --install --symlink --force autoreconf --verbose --install --symlink --force autoreconf --verbose --install --symlink --force ./configure --enable-maintainer-mode "$@" libctl-4.4.0/base/000077500000000000000000000000001356267410600137145ustar00rootroot00000000000000libctl-4.4.0/base/class.scm000066400000000000000000000303751356267410600155350ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; Functions for creating and manipulating classes, objects, types, ; and properties. (define class-list '()) (define (make-property-value-pair name value) (cons name value)) (define (make-object type-names property-values) (cons type-names property-values)) (define (object-type-names object) (car object)) (define (object-property-values object) (cdr object)) (define (object-member? type-name object) (and (pair? object) (list? (object-type-names object)) (member type-name (object-type-names object)))) (define (object-property-value object property-name) (assoc-ref (object-property-values object) property-name)) (define (object-memberp type-name) (lambda (object) (object-member? type-name object))) ; (I wish Scheme had implicit currying like ML.) (define (extend-object object type-name property-values) (make-object (cons type-name (object-type-names object)) (combine-alists property-values (object-property-values object)))) (define (modify-object object . property-values) (make-object (object-type-names object) (combine-alists property-values (object-property-values object)))) (define null-object (make-object '() '())) (define no-default '(no-default)) (define (has-default? default) (not (eq? default no-default))) (define (make-derived derive-func) (cons true derive-func)) (define not-derived (cons false '())) (define (derived? derived) (car derived)) (define (derive-func derived) (cdr derived)) (define (make-property name type-name default derived . constraints) (list name type-name default constraints derived)) (define no-constraints '()) (define (property-name property) (first property)) (define (property-type-name property) (second property)) (define (property-default property) (third property)) (define (property-constraints property) (fourth property)) (define (property-derived property) (fifth property)) (define (property-has-default? property) (has-default? (property-default property))) (define (property-default-value property) (property-default property)) (define (property-derived? property) (derived? (property-derived property))) (define (derive-property property object) (make-property-value-pair (property-name property) ((derive-func (property-derived property)) object))) (define (check-constraints constraints value) (for-all? constraints (lambda (c) (c value)))) (define (make-list-type el-type-name) (cons 'list el-type-name)) (define (list-type-name? type-name) (and (pair? type-name) (eq? (car type-name) 'list))) (define (list-el-type-name type-name) (cdr type-name)) (define exported-type-list '()) (define (export-type type-name) (set! exported-type-list (cons type-name exported-type-list))) (define (make-type-descriptor kind name name-str predicate) (list kind name name-str predicate)) (define type-descriptor-kind first) (define type-descriptor-name second) (define type-descriptor-name-str third) (define type-descriptor-predicate fourth) (define (make-simple-type-descriptor name predicate) (make-type-descriptor 'simple name (symbol->string name) predicate)) (define (make-object-type-descriptor name) (make-type-descriptor 'object name (symbol->string name) (object-memberp name))) (define (make-list-type-descriptor name) (make-type-descriptor 'uniform-list name "list" list?)) (define (get-type-descriptor type-name) (cond ((eq? type-name 'number) (make-simple-type-descriptor 'number real?)) ((eq? type-name 'cnumber) (make-simple-type-descriptor 'cnumber complex?)) ((eq? type-name 'integer) (make-simple-type-descriptor 'integer integer?)) ((eq? type-name 'boolean) (make-simple-type-descriptor 'boolean boolean?)) ((eq? type-name 'string) (make-simple-type-descriptor 'string string?)) ((eq? type-name 'SCM) (make-simple-type-descriptor 'SCM (lambda (x) true))) ((eq? type-name 'function) (make-simple-type-descriptor 'function procedure?)) ((eq? type-name 'vector3) (make-simple-type-descriptor 'vector3 real-vector3?)) ((eq? type-name 'cvector3) (make-simple-type-descriptor 'cvector3 vector3?)) ((eq? type-name 'matrix3x3) (make-simple-type-descriptor 'matrix3x3 real-matrix3x3?)) ((eq? type-name 'cmatrix3x3) (make-simple-type-descriptor 'cmatrix3x3 matrix3x3?)) ((eq? type-name 'list) (make-simple-type-descriptor 'list list?)) ((symbol? type-name) (make-object-type-descriptor type-name)) ((list-type-name? type-name) (make-list-type-descriptor type-name)) (else (error "unknown type" type-name)))) (define (primitive-type? type-name) (or (eq? type-name 'number) (eq? type-name 'integer) (eq? type-name 'boolean) (eq? type-name 'function) (eq? type-name 'SCM))) (define (type-string type-name) (let ((desc (get-type-descriptor type-name))) (cond ((or (eq? (type-descriptor-kind desc) 'simple) (eq? (type-descriptor-kind desc) 'object)) (type-descriptor-name-str desc)) ((eq? (type-descriptor-kind desc) 'uniform-list) (string-append (type-string (list-el-type-name type-name)) " list")) (else (error "unknown type" type-name))))) (define (type-predicate type-name) (let ((desc (get-type-descriptor type-name))) (cond ((or (eq? (type-descriptor-kind desc) 'simple) (eq? (type-descriptor-kind desc) 'object)) (type-descriptor-predicate desc)) ((eq? (type-descriptor-kind desc) 'uniform-list) (lambda (val) (and ((type-descriptor-predicate desc) val) (for-all? val (type-predicate (list-el-type-name type-name)))))) (else (error "unknown type" type-name))))) (define (check-type type-name value) ((type-predicate type-name) value)) (define (get-property-value property property-values) (let ((val (assoc (property-name property) property-values))) (let ((newval (if (pair? val) val (if (property-has-default? property) (make-property-value-pair (property-name property) (property-default-value property)) (error "no value for property" (property-name property)))))) (if (check-constraints (property-constraints property) (cdr newval)) (if (check-type (property-type-name property) (cdr newval)) newval (error "wrong type for property" (property-name property) 'type (property-type-name property))) (error "invalid value for property" (property-name property)))))) (define (make-class type-name parent . properties) (let ((new-class (list type-name parent properties))) (set! class-list (cons new-class class-list)) new-class)) (define (class-type-name class) (first class)) (define (class-parent class) (second class)) (define (class-properties class) (third class)) (define (class-properties-all class) (append (class-properties class) (let ((parent (class-parent class))) (if parent (class-properties parent) '())))) (define (class-member? type-name class) (if (list? class) (or (eq? type-name (class-type-name class)) (class-member? type-name (class-parent class))) false)) (define no-parent false) (define (make class . property-values) (if (list? class) (let* ((newprops (map (lambda (property) (get-property-value property property-values)) (list-transform-negative (class-properties class) property-derived?))) (o (extend-object (apply make (cons (class-parent class) (append newprops property-values))) (class-type-name class) newprops))) (fold-left (lambda (o p) (modify-object o (derive-property p o))) o (list-transform-positive (class-properties class) property-derived?))) null-object)) ; **************************************************************** ; Defining property values. (define (property-value-constructor name) (lambda (x) (make-property-value-pair name x))) (define (vector3-property-value-constructor name) (lambda x (make-property-value-pair name (if (and (= (length x) 1) (vector3? (car x))) (car x) (apply vector3 x))))) (define (list-property-value-constructor name type-name) (lambda x (make-property-value-pair name (if (and (= (length x) 1) (check-type type-name (car x))) (car x) x)))) (define (type-property-value-constructor type-name name) (cond ((or (eq? type-name 'vector3) (eq? type-name 'cvector3)) (vector3-property-value-constructor name)) ((list-type-name? type-name) (list-property-value-constructor name type-name)) (else (property-value-constructor name)))) (define (post-processing-constructor post-process-func constructor) (lambda x (let ((value-pair (apply constructor x))) (make-property-value-pair (car value-pair) (post-process-func (cdr value-pair)))))) (defmacro-public define-property (name default type-name . constraints) `(begin (define ,name (type-property-value-constructor ,type-name (quote ,name))) (make-property (quote ,name) ,type-name ,default not-derived ,@constraints))) (defmacro-public define-post-processed-property (name default type-name post-process-func . constraints) `(begin (define ,name (post-processing-constructor ,post-process-func (type-property-value-constructor ,type-name (quote ,name)))) (make-property (quote ,name) ,type-name ,default not-derived ,@constraints))) (defmacro-public define-derived-property (name type-name derive-func) `(make-property (quote ,name) ,type-name no-default (make-derived ,derive-func))) ; **************************************************************** ; Define classes. A bit ugly since we support (define-property ...) ; in the property list, but Guile 2.x doesn't allow (define ...) to ; be used in the middle of a list expression. So, we need to extract ; those definitions first and duplicate some of the define-property ; code above. (defmacro-public define-class (class-name parent . properties) (let ((pdefs (map (lambda (p) (let ((name (cadr p)) (type-name (cadddr p))) `(define ,name (type-property-value-constructor ,type-name (quote ,name))))) (list-transform-positive properties (lambda (p) (eq? (car p) 'define-property))))) (ppdefs (map (lambda (p) (let ((name (cadr p)) (type-name (cadddr p)) (post-process-func (list-ref p 4))) `(define ,name (post-processing-constructor ,post-process-func (type-property-value-constructor ,type-name (quote ,name)))))) (list-transform-positive properties (lambda (p) (eq? (car p) 'define-post-processed-property))))) (props (map (lambda (p) (cond ((eq? (car p) 'define-property) (let ((name (cadr p)) (default (caddr p)) (type-name (cadddr p)) (constraints (cddddr p))) `(make-property (quote ,name) ,type-name ,default not-derived ,@constraints))) ((eq? (car p) 'define-post-processed-property) (let ((name (cadr p)) (default (caddr p)) (type-name (cadddr p)) (post-process-func (list-ref p 4)) (constraints (cdr (cddddr p)))) `(make-property (quote ,name) ,type-name ,default not-derived ,@constraints))) (else p))) properties))) `(begin ,@pdefs ,@ppdefs (define ,class-name (make-class (quote ,class-name) ,parent ,@props))))) libctl-4.4.0/base/ctl.scm000066400000000000000000000027511356267410600152070ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; Include other files that we need. Note that the include.scm ; file must already have been loaded, since we need the include ; function it defines! (include "utils.scm") (include "vector3.scm") (include "matrix3x3.scm") (include "class.scm") (include "io-vars.scm") (include "extern-funcs.scm") (include "help.scm") (include "simplex.scm") (include "math-utils.scm") (include "interaction.scm") (define-param interactive? #t) ; **************************************************************** libctl-4.4.0/base/extern-funcs.scm000066400000000000000000000055411356267410600170460ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; Defining external functions. (define (make-external-function name read-inputs? write-outputs? return-type-name arg-type-names) (list name read-inputs? write-outputs? return-type-name arg-type-names)) (define external-function-name first) (define external-function-read-inputs? second) (define external-function-write-outputs? third) (define external-function-return-type-name fourth) (define external-function-arg-type-names fifth) (define no-return-value 'none) (define external-function-list '()) (define (external-function! name read-inputs? write-outputs? return-type-name . arg-type-names) (set! external-function-list (cons (make-external-function name read-inputs? write-outputs? return-type-name arg-type-names) external-function-list))) (define (external-function-aux-name name) (symbol-append name '-aux)) (define (check-arg-types name args . arg-type-names) (if (not (= (length args) (length arg-type-names))) (begin (print "Expecting " (length arg-type-names) " arguments for " name) (print "\n") (error "Wrong number of arguments for function" name)) (for-each (lambda (arg arg-type-name) (if (not (check-type arg-type-name arg)) (error "wrong type for argument" 'type arg-type-name 'in name))) args arg-type-names))) (defmacro-public define-external-function (name read-inputs? write-outputs? return-type-name . arg-type-names) `(begin (define ,name (lambda args (check-arg-types (quote ,name) args ,@arg-type-names) (if ,read-inputs? (read-input-vars)) (let ((return-value (apply ,(external-function-aux-name name) args))) (if ,write-outputs? (write-output-vars)) return-value))) (external-function! (quote ,name) ,read-inputs? ,write-outputs? ,return-type-name ,@arg-type-names))) ; **************************************************************** libctl-4.4.0/base/help.scm000066400000000000000000000040421356267410600153500ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** (define (display-class indentby class) (indent indentby) (print "Class " (class-type-name class) ": ") (print "\n") (if (class-parent class) (display-class (+ indentby 4) (class-parent class))) (for-each (lambda (property) (if (not (property-derived? property)) (begin (indent (+ indentby 4)) (print (type-string (property-type-name property)) " " (property-name property)) (if (property-has-default? property) (print " = " (property-default-value property))) (print "\n")))) (class-properties class))) (define (class-help class) (display-class 0 class)) (define (variable-help var) (print (type-string (var-type-name var)) " " (var-name var) " = " (var-value var)) (print "\n")) (define (help) (for-each class-help class-list) (print "\n") (print "Input variables: ") (print "\n") (for-each variable-help input-var-list) (print "\n") (print "Output variables: ") (print "\n") (for-each variable-help output-var-list)) ; **************************************************************** libctl-4.4.0/base/include.scm000066400000000000000000000071331356267410600160470ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; File inclusion. ; Here, we supply an (include "") utility that is similar to ; C's #include "". We need this because Guile's load ; function is broken--it doesn't allow you to use relative paths. If ; you use (load ""), the filename is interpreted relative to ; the path of the top-level Guile invocation, which may not be the ; same as the path of the current Scheme file. Our include function ; remembers the path of the current file and loads relative to this. ; ; Note that this problem of Guile's "load" function was fixed a long ; time ago, apparently. But I still find it useful to have my own ; "include" function to keep track of the currently-loaded filename, ; which is used to prepend the ctl filename to output files. (define (string-suffix? suff s) (if (> (string-length suff) (string-length s)) #f (string=? suff (substring s (- (string-length s) (string-length suff)) (string-length s))))) (define (string-find-previous-char s c) (if (= (string-length s) 0) #f (let ((last-index (- (string-length s) 1))) (if (eq? (string-ref s last-index) c) last-index (string-find-previous-char (substring s 0 last-index) c))))) (define (strip-suffix suff s) (if (string-suffix? suff s) (substring s 0 (- (string-length s) (string-length suff))) s)) (define (strip-trailing-slashes s) (if (string-suffix? "/" s) (strip-trailing-slashes (substring s 0 (- (string-length s) 1))) s)) (define (pathname-absolute? s) (and (> (string-length s) 0) (eq? (string-ref s 0) #\/))) (define (split-pathname s) (let ((s2 (strip-trailing-slashes s))) (let ((last-slash (string-find-previous-char s2 #\/))) (if (not last-slash) (cons "" s2) (cons (substring s2 0 (+ 1 last-slash)) (substring s2 (+ 1 last-slash) (string-length s2))))))) (define include-dir "") (define include-files '()) ; a list of included files, most recent first (define (include pathname) (set! include-files (cons pathname include-files)) (let ((save-include-dir include-dir) (pathpair (split-pathname pathname))) (if (pathname-absolute? (car pathpair)) (begin (set! include-dir (car pathpair)) (primitive-load pathname)) (begin (set! include-dir (string-append include-dir (car pathpair))) (primitive-load (string-append include-dir (cdr pathpair))))) (set! include-dir save-include-dir)) (set! include-files (cdr include-files))) (define (fix-path pathname) (if (pathname-absolute? pathname) pathname (string-append include-dir pathname))) ; **************************************************************** libctl-4.4.0/base/interaction.scm000066400000000000000000000046331356267410600167450ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; Utilities to make it easier to interact with the user. (define (yes/no? question) (print question " (y/n) ") (flush-all-ports) (let ((input (read-line))) (let ((c (if (string-null? input) #f (string-ref input 0)))) (cond ((or (eq? c #\y) (eq? c #\Y)) #t) ((or (eq? c #\n) (eq? c #\N)) #f) (else (print " -- please enter y or n\n") (yes/no? question)))))) (define (menu-choice . items) (define (display-items index items) (if (not (null? items)) (begin (print " " index ". " (car items) "\n") (display-items (+ index 1) (cdr items))))) (define (get-choice n) (print "Enter your selection (1.." n ") ==> ") (flush-all-ports) (let ((input (read-line))) (let ((choice (string->positive-integer input))) (if (or (eq? choice #f) (< choice 1) (> choice n)) (begin (print " -- invalid selection!\n") (get-choice n)) choice)))) (if (null? items) #f (begin (display-items 1 items) (- (get-choice (length items)) 1)))) ; **************************************************************** ; utility to set the Scheme prompt, since they changed the interface in guile 2 (define (ctl-set-prompt! p) (if (defined? 'scm-repl-prompt) (set! scm-repl-prompt p) ((module-ref (resolve-interface '(system repl common)) 'repl-default-prompt-set!) p))) ; **************************************************************** libctl-4.4.0/base/io-vars.scm000066400000000000000000000065641356267410600160130ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; define-param: defining local variables that can be set easily ; from the command-line (or assume a default value if not set). (define params-set-list '()) (defmacro-public define-param (name value) `(define ,name (if (defined? (quote ,name)) ,name ,value))) (defmacro-public set-param! (name value) `(if (not (memq (quote ,name) params-set-list)) (set! ,name ,value))) ; **************************************************************** ; Input/Output variables. (define input-var-list '()) (define output-var-list '()) (define (make-var value-thunk var-name var-type-name var-constraints) (list var-name var-type-name var-constraints value-thunk)) (define (var-name var) (first var)) (define (var-type-name var) (second var)) (define (var-constraints var) (third var)) (define (var-value-thunk var) (fourth var)) (define (var-value var) ((var-value-thunk var))) (define (input-var! value-thunk var-name var-type-name . var-constraints) (let ((new-var (make-var value-thunk var-name var-type-name var-constraints))) (set! input-var-list (cons new-var input-var-list)) new-var)) (define (output-var! value-thunk var-name var-type-name) (let ((new-var (make-var value-thunk var-name var-type-name no-constraints))) (set! output-var-list (cons new-var output-var-list)) new-var)) (defmacro-public define-input-var (name init-val var-type-name . var-constraints) `(begin (define-param ,name ,init-val) (input-var! (lambda () ,name) (quote ,name) ,var-type-name ,@var-constraints))) (defmacro-public define-input-output-var (name init-val var-type-name . var-constraints) `(begin (define ,name ,init-val) (input-var! (lambda () ,name) (quote ,name) ,var-type-name ,@var-constraints) (output-var! (lambda () ,name) (quote ,name) ,var-type-name))) (defmacro-public define-output-var (name var-type-name) `(begin (define ,name 'no-value) (output-var! (lambda () ,name) (quote ,name) ,var-type-name))) (define (check-vars var-list) (for-all? var-list (lambda (v) (if (not (check-type (var-type-name v) (var-value v))) (error "wrong type for variable" (var-name v) 'type (var-type-name v)) (if (not (check-constraints (var-constraints v) (var-value v))) (error "failed constraint for" (var-name v)) true))))) ; **************************************************************** libctl-4.4.0/base/main.c000066400000000000000000000241151356267410600150070ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2014 Massachusetts Institute of Technology and Steven G. Johnson * * This file may be used without restriction. It is in the public * domain, and is NOT restricted by the terms of any GNU license. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ /**************************************************************************/ /* main program for a simulation that uses libctl. You should not need to modify this file. The resulting program will run any Scheme files that are passed as parameters on the command line. It will automatically load ctl.scm and the specification file if the CTL_SCM and SPEC_SCM preprocessor symbols are defined to the corresponding filenames (e.g. see the accompanying Makefile). */ /**************************************************************************/ #include #include #include /* for basename and dirname functions */ #include #include "ctl-io.h" #ifdef CXX_CTL_IO using namespace ctlio; #endif /* define a global "verbose" variable set by the --verbose command-line opt. */ int verbose = 0; /* a "quiet" variable, that if nonzero suppresses all non-error output... this is used by parallel software to suppress output from processes other than the master process */ int libctl_quiet = 0; /**************************************************************************/ /* Handle command-line args, returning first arg not handled. Also return, in spec_file_loaded, whether we have loaded the specifications file due to a command-line arg. Also return, in continue_run, whether or not to continue the run. */ int handle_args(int argc, char *argv[], boolean *spec_file_loaded, boolean *continue_run) { int i; *continue_run = 1; *spec_file_loaded = 0; for (i = 1; i < argc; ++i) { if (argv[i][0] != '-') break; if (!strcmp(argv[i], "--version") || !strcmp(argv[i], "-V")) { if (!libctl_quiet) { char *guile_vers; #ifdef VERSION_STRING /* print version string, if defined: */ printf(VERSION_STRING); #endif #ifdef LIBCTL_VERSION printf("\nUsing libctl %s", LIBCTL_VERSION); #else printf("\nUsing libctl"); #endif guile_vers = ctl_convert_string_to_c( gh_eval_str("(version)")); printf(" and Guile %s.\n", guile_vers); free(guile_vers); } *continue_run = 0; } else if (!strcmp(argv[i], "--verbose") || !strcmp(argv[i], "-v")) verbose = 1; else if (!strncmp(argv[i], "--spec-file=", strlen("--spec-file="))) { ctl_include(argv[i] + strlen("--spec-file=")); *spec_file_loaded = 1; } else if (!strcmp(argv[i], "--help") || !strcmp(argv[i], "-h")) { char *slash = strrchr(argv[0], '/'); if (!libctl_quiet) printf("Usage: %s [options] [definitions] [ctl files]\n" "options:\n" " --help, -h: this help\n" " --version, -V: display version information\n" " --verbose, -v: enable verbose output\n" " --spec-file=: use for spec. file\n" "definitions: assignments of the form " "=\n" "ctl files: zero or more Scheme/ctl files to execute\n", slash ? slash + 1 : argv[0]); *continue_run = 0; } else { if (!libctl_quiet) fprintf(stderr, "Unknown option %s! Use the --help option" " for more information.\n", argv[i]); exit(EXIT_FAILURE); } } return i; } /**************************************************************************/ static int exists(const char *fname) { FILE *f = fopen(fname, "r"); if (f) { fclose(f); return 1; } return 0; } static char *make_name(const char *for_dir, const char *for_base) { char *dir0, *dir, *base0, *base, *name = 0; size_t ndir; dir0 = (char *) malloc(sizeof(char) * (strlen(for_dir) + 1)); base0 = (char *) malloc(sizeof(char) * (strlen(for_base) + 1)); strcpy(dir0, for_dir); dir = dirname(dir0); ndir = strlen(dir); if (ndir > 0) { if (ndir > 5 && !strcmp(".libs", dir+ndir-5)) dir[ndir-5] = 0; /* ignore ".libs" directory suffix from libtool */ strcpy(base0, for_base); base = basename(base0); name = (char *) malloc(sizeof(char) * (strlen(dir) + 1 + strlen(base) + 1)); strcpy(name, dir); strcat(name, "/"); strcat(name, base); free(base0); } free(dir0); return name; } /**************************************************************************/ #ifdef HAVE_CTL_HOOKS static int ctl_stop_hook_called = 0; extern void ctl_start_hook(int *argc, char **argv[]); extern void ctl_stop_hook(void); #endif #ifdef HAVE_CTL_EXPORT_HOOK extern void ctl_export_hook(void); #endif extern SCM nlopt_minimize_scm(SCM algorithm_scm, SCM f_scm, SCM lb_scm, SCM ub_scm, SCM x_scm, SCM minf_max_scm, SCM ftol_rel_scm, SCM ftol_abs_scm, SCM rest); /* Main program. Start up Guile, declare functions, load any scripts passed on the command-line, and drop into interactive mode if read-input-vars was never called. */ void main_entry( #ifdef HAVE_NO_GH void *main_entry_data, /* unused, required by scm_boot_guile */ #endif int argc, char *argv[]) { int i; boolean spec_file_loaded, continue_run; SCM interactive; #ifdef HAVE_NO_GH (void) main_entry_data; /* unused */ #endif /* Notify Guile of functions that we are making callable from Scheme. These are defined in the specifications file, from which the export_external_functions routine is automatically generated. */ export_external_functions(); /* Also export the read_input_vars and write_output_vars routines that are automatically generated from the specifications file: */ gh_new_procedure ("read-input-vars", read_input_vars, 0, 0, 0); gh_new_procedure ("write-output-vars", write_output_vars, 0, 0, 0); /* Export the subplex minimization routine: */ gh_new_procedure ("subplex", (SCM (*)(void)) subplex_scm, 7, 0, 0); #ifdef HAVE_NLOPT /* Export the nlopt minimization routine, if available: */ gh_new_procedure ("nlopt-minimize", (SCM (*)(void)) nlopt_minimize_scm, 8, 0, 1); #endif /* Export the adaptive integration routines: */ gh_new_procedure ("adaptive-integration", (SCM (*)(void)) adaptive_integration_scm, 6, 0, 0); #ifdef CTL_HAS_COMPLEX_INTEGRATION gh_new_procedure ("cadaptive-integration", (SCM (*)(void)) cadaptive_integration_scm, 6, 0, 0); #endif #ifdef HAVE_CTL_EXPORT_HOOK ctl_export_hook(); #endif /* load include.scm if it was given at compile time */ #ifdef INCLUDE_SCM gh_load(INCLUDE_SCM); #endif /* load ctl.scm if it was given at compile time */ #ifdef CTL_SCM ctl_include(CTL_SCM); #endif i = handle_args(argc, argv, &spec_file_loaded, &continue_run); { char definestr[] = "(define verbose? false)"; strcpy(definestr, "(define verbose? "); strcat(definestr, verbose ? "true)" : "false)"); gh_eval_str(definestr); } if (!continue_run) goto done; /* load the specification file if it was given at compile time, and if it wasn't specified on the command-line: */ #ifdef SPEC_SCM if (!spec_file_loaded) { /* try first to load it in the program directory if it was specified explicitly (e.g. "./foo"), for cases where we are running a program that has not been installed */ char *spec_name = make_name(argv[0], SPEC_SCM); if (spec_name && exists(spec_name)) ctl_include(spec_name); else ctl_include(SPEC_SCM); free(spec_name); } #endif /* define any variables and load any scheme files specified on the command line: */ for (; i < argc; ++i) { if (strchr(argv[i],'=')) { char *eq; char *definestr = (char*) malloc(sizeof(char) * (strlen("(define ") + strlen(argv[i]) + 2)); if (!definestr) { fprintf(stderr, __FILE__ ": out of memory!\n"); exit(EXIT_FAILURE); } strcpy(definestr,"(define "); strcat(definestr,argv[i]); strcat(definestr,")"); eq = strchr(definestr,'='); *eq = ' '; if (!libctl_quiet) printf("command-line param: %s\n", argv[i]); gh_eval_str(definestr); { /* add the name of the defined variable to params-set-list */ char *remember_define; strcpy(definestr,argv[i]); eq = strchr(definestr,'='); *eq = 0; remember_define = (char*) malloc(sizeof(char) * (strlen("(set! params-set-list (cons (quote x) params-set-list))") + strlen(definestr))); if (!remember_define) { fprintf(stderr, __FILE__ ": out of memory!\n"); exit(EXIT_FAILURE); } strcpy(remember_define, "(set! params-set-list (cons (quote "); strcat(remember_define, definestr); strcat(remember_define, ") params-set-list))"); gh_eval_str(remember_define); free(remember_define); } free(definestr); argv[i][0] = 0; } else if (argv[i][0]) ctl_include(argv[i]); } /* Check if we should run an interactive prompt. We do this if either the Scheme variable "interactive?" is true, or if it is not defined. */ interactive = gh_lookup("interactive?"); if (interactive != SCM_BOOL_F) gh_repl(argc - i, argv + i); /* skip already-handled args */ done: ; #ifdef HAVE_CTL_HOOKS /* Note that the stop hook will never be called if we are in interactive mode, because gh_repl calls exit(). Oh well. */ ctl_stop_hook_called = 1; ctl_stop_hook(); #endif } int main (int argc, char *argv[]) { #ifdef HAVE_CTL_HOOKS ctl_start_hook(&argc, &argv); #endif #ifdef HAVE_NO_GH scm_boot_guile (argc, argv, main_entry, NULL); #else gh_enter (argc, argv, main_entry); #endif #ifdef HAVE_CTL_HOOKS if (!ctl_stop_hook_called) ctl_stop_hook(); #endif return EXIT_SUCCESS; } libctl-4.4.0/base/math-utils.scm000066400000000000000000000550151356267410600165150ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; Miscellaneous math utilities ; Return the arithmetic sequence (list): start start+step ... (n values) (define (arith-sequence start step n) (define (s x n L) ; tail-recursive helper function (if (= n 0) L (s (binary+ x step) (- n 1) (cons x L)))) (reverse (s start n '()))) ; Given a list of numbers, linearly interpolates n values between ; each pair of numbers. (define (interpolate n nums) (map unary->inexact (cons (car nums) (fold-right append '() (map (lambda (x y) (reverse (arith-sequence y (binary/ (binary- x y) (+ n 1)) (+ n 1)))) (reverse (cdr (reverse nums))) ; nums w/o last value (cdr nums)))))) ; nums w/o first value ; Like interpolate, except only interpolates n values *on average* ; between each pair of numbers. The actual number of interpolated ; points varies for each pair to try to keep the density of points ; uniform. (define (interpolate-uniform n nums) (define meandiff (/ (fold-left + 0 (map unary-abs (map binary- (cdr nums) (reverse (cdr (reverse nums)))))) (length (cdr nums)))) (map unary->inexact (if (zero? n) nums (cons (car nums) (fold-right append '() (map (lambda (x y) (let ((m (inexact->exact (round (+ -0.5 (* (+ n 1) (/ (unary-abs (binary- x y)) meandiff))))))) (reverse (arith-sequence y (binary/ (binary- x y) (+ m 1)) (+ m 1))))) (reverse (cdr (reverse nums))) ; nums w/o last value (cdr nums))))))) ; nums w/o first value ; **************************************************************** ; Minimization and root-finding utilities (useful in ctl scripts) ; The routines are: ; minimize: minimize a function of one argument ; minimize-multiple: minimize a function of multiple arguments ; maximize, maximize-multiple : as above, but maximize ; find-root: find the root of a function of one argument ; All routines use quadratically convergent methods. ; **************************************************************** (define min-arg car) (define min-val cdr) (define max-arg min-arg) (define max-val min-val) ; One-dimensional minimization (using Brent's method): ; (minimize f tol) : minimize (f x) with fractional tolerance tol ; (minimize f tol guess) : as above, but gives starting guess ; (minimize f tol x-min x-max) : as above, but gives range to optimize in ; (this is preferred) ; All variants return a result that contains both the argument and the ; value of the function at its minimum. ; (min-arg result) : the argument of the function at its minimum ; (min-val result) : the value of the function at its minimum (define (minimize f tol . min-max) (define (midpoint a b) (* 0.5 (+ a b))) (define (quadratic-min-denom x a b fx fa fb) (magnitude (* 2.0 (- (* (- x a) (- fx fb)) (* (- x b) (- fx fa)))))) (define (quadratic-min-num x a b fx fa fb) (let ((den (* 2.0 (- (* (- x a) (- fx fb)) (* (- x b) (- fx fa))))) (num (- (* (- x a) (- x a) (- fx fb)) (* (- x b) (- x b) (- fx fa))))) (if (> den 0) (- num) num))) (define (tol-scale x) (* tol (+ (magnitude x) 1e-6))) (define (converged? x a b) (<= (magnitude (- x (midpoint a b))) (- (* 2 (tol-scale x)) (* 0.5 (- b a))))) (define golden-ratio (* 0.5 (- 3 (sqrt 5)))) (define (golden-interpolate x a b) (* golden-ratio (if (>= x (midpoint a b)) (- a x) (- b x)))) (define (sign x) (if (< x 0) -1 1)) (define (brent-minimize x a b v w fx fv fw prev-step prev-prev-step) (define (guess-step proposed-step) (let ((step (if (> (magnitude proposed-step) (tol-scale x)) proposed-step (* (tol-scale x) (sign proposed-step))))) (let ((u (+ x step))) (let ((fu (f u))) (if (<= fu fx) (if (> u x) (brent-minimize u x b w x fu fw fx step prev-step) (brent-minimize u a x w x fu fw fx step prev-step)) (let ((new-a (if (< u x) u a)) (new-b (if (< u x) b u))) (if (or (<= fu fw) (= w x)) (brent-minimize x new-a new-b w u fx fw fu step prev-step) (if (or (<= fu fv) (= v x) (= v w)) (brent-minimize x new-a new-b u w fx fu fw step prev-step) (brent-minimize x new-a new-b v w fx fv fw step prev-step))))))))) (if (converged? x a b) (cons x fx) (if (> (magnitude prev-prev-step) (tol-scale x)) (let ((p (quadratic-min-num x v w fx fv fw)) (q (quadratic-min-denom x v w fx fv fw))) (if (or (>= (magnitude p) (magnitude (* 0.5 q prev-prev-step))) (< p (* q (- a x))) (> p (* q (- b x)))) (guess-step (golden-interpolate x a b)) (guess-step (/ p q)))) (guess-step (golden-interpolate x a b))))) (define (bracket-minimum a b c fa fb fc) (if (< fb fc) (list a b c fa fb fc) (let ((u (/ (quadratic-min-num b a c fb fa fc) (max (quadratic-min-denom b a c fb fa fc) 1e-20))) (u-max (+ b (* 100 (- c b))))) (cond ((positive? (* (- b u) (- u c))) (let ((fu (f u))) (if (< fu fc) (bracket-minimum b u c fb fu fc) (if (> fu fb) (bracket-minimum a b u fa fb fu) (bracket-minimum b c (+ c (* 1.6 (- c b))) fb fc (f (+ c (* 1.6 (- c b))))))))) ((positive? (* (- c u) (- u u-max))) (let ((fu (f u))) (if (< fu fc) (bracket-minimum c u (+ c (* 1.6 (- c b))) fc fu (f (+ c (* 1.6 (- c b))))) (bracket-minimum b c u fb fc fu)))) ((>= (* (- u u-max) (- u-max c)) 0) (bracket-minimum b c u-max fb fc (f u-max))) (else (bracket-minimum b c (+ c (* 1.6 (- c b))) fb fc (f (+ c (* 1.6 (- c b)))))))))) (if (= (length min-max) 2) (let ((x-min (first min-max)) (x-max (second min-max))) (let ((xm (midpoint x-min x-max))) (let ((fm (f xm))) (brent-minimize xm x-min x-max xm xm fm fm fm 0 0)))) (let ((a (if (= (length min-max) 1) (first min-max) 1.0))) (let ((b (if (= a 0) 1.0 0))) (let ((fa (f a)) (fb (f b))) (let ((aa (if (> fb fa) b a)) (bb (if (> fb fa) a b)) (faa (max fa fb)) (fbb (max fa fb))) (let ((bracket (bracket-minimum aa bb (+ bb (* 1.6 (- bb aa))) faa fbb (f (+ bb (* 1.6 (- bb aa))))))) (brent-minimize (second bracket) (min (first bracket) (third bracket)) (max (first bracket) (third bracket)) (first bracket) (third bracket) (fifth bracket) (fourth bracket) (sixth bracket) 0 0)))))))) ; **************************************************************** ; (minimize-multiple f tol arg1 arg2 ... argN) : ; Minimize a function f of N arguments, given the fractional tolerance ; desired and initial guesses for the arguments. ; ; (min-arg result) : list of argument values at the minimum ; (min-val result) : list of function values at the minimum (define (minimize-multiple-expert f tol max-iters fmin guess-args arg-scales) (let ((best-val 1e20) (best-args '())) (subplex (lambda (args) (let ((val (apply f args))) (if (or (null? best-args) (< val best-val)) (begin (print "extremization: best so far is " val " at " args "\n") (set! best-val val) (set! best-args args))) val)) guess-args tol max-iters (if fmin fmin 0.0) (if fmin true false) arg-scales))) (define (minimize-multiple f tol . guess-args) (minimize-multiple-expert f tol 999999999 false guess-args '(0.1))) ; Yet another alternate multi-dimensional minimization (Simplex algorithm). (define (simplex-minimize-multiple f tol . guess-args) (let ((simplex-result (simplex-minimize f guess-args tol))) (cons (simplex-point-x simplex-result) (simplex-point-val simplex-result)))) ; Alternate multi-dimensional minimization (using Powell's method): ; (not the default since it seems to have convergence problems sometimes) (define (powell-minimize-multiple f tol . guess-args) (define (create-unit-vector i n) (let ((v (make-vector n 0))) (vector-set! v i 1) v)) (define (initial-directions n) (make-initialized-list n (lambda (i) (create-unit-vector i n)))) (define (v- v1 v2) (vector-map - v1 v2)) (define (v+ v1 v2) (vector-map + v1 v2)) (define (v* s v) (vector-map (lambda (x) (* s x)) v)) (define (v-dot v1 v2) (vector-fold-right + 0 (vector-map * v1 v2))) (define (v-norm v) (sqrt (v-dot v v))) (define (unit-v v) (v* (/ (v-norm v)) v)) (define (fv v) (apply f (vector->list v))) (define guess-vector (list->vector guess-args)) (define (f-dir p0 dir) (lambda (x) (fv (v+ p0 (v* x dir))))) (define (minimize-dir p0 dir) (let ((min-result (minimize (f-dir p0 dir) tol))) (cons (v+ p0 (v* (min-arg min-result) dir)) (min-val min-result)))) (define (minimize-dirs p0 dirs) (if (null? dirs) (cons p0 '()) (let ((min-result (minimize-dir p0 (car dirs)))) (let ((min-results (minimize-dirs (min-arg min-result) (cdr dirs)))) (cons (min-arg min-results) (cons (min-val min-result) (min-val min-results))))))) (define (replace= val vals els el) (if (null? els) '() (if (= (car vals) val) (cons el (cdr els)) (cons (car els) (replace= val (cdr vals) (cdr els) el))))) ; replace direction where largest decrease occurred: (define (update-dirs decreases dirs p0 p) (replace= (apply max decreases) decreases dirs (v- p p0))) (define (minimize-aux p0 fp0 dirs) (let ((min-results (minimize-dirs p0 dirs))) (let ((decreases (map (lambda (val) (- fp0 val)) (min-val min-results))) (p (min-arg min-results)) (fp (first (reverse (min-val min-results))))) (if (<= (v-norm (v- p p0)) (* tol 0.5 (+ (v-norm p) (v-norm p0) 1e-20))) (cons (vector->list p) fp) (let ((min-result (minimize-dir p (v- p p0)))) (minimize-aux (min-arg min-result) (min-val min-result) (update-dirs decreases dirs p0 p))))))) (minimize-aux guess-vector (fv guess-vector) (initial-directions (length guess-args)))) ; Maximization variants of the minimize functions: (define (maximize f tol . min-max) (let ((result (apply minimize (append (list (compose - f) tol) min-max)))) (cons (min-arg result) (- (min-val result))))) (define (maximize-multiple f tol . guess-args) (let ((result (apply minimize-multiple (append (list (compose - f) tol) guess-args)))) (cons (min-arg result) (- (min-val result))))) ; **************************************************************** ; Find a root of a function of one argument using Ridder's method. ; (find-root f tol x-min x-max) : returns the root of the function (f x), ; within a fractional tolerance tol. x-min and x-max must bracket the ; root; that is, (f x-min) must have a different sign than (f x-max). (define (find-root f tol x-min x-max) (define (midpoint a b) (* 0.5 (+ a b))) (define (sign x) (if (< x 0) -1 1)) (define (best-bracket a b x1 x2 fa fb f1 f2) (if (positive? (* f1 f2)) (if (positive? (* fa f1)) (list (max x1 x2) b (if (> x1 x2) f1 f2) fb) (list a (min x1 x2) fa (if (< x1 x2) f1 f2))) (if (< x1 x2) (list x1 x2 f1 f2) (list x2 x1 f2 f1)))) (define (converged? a b x) (< (min (magnitude (- x a)) (magnitude (- x b))) (* tol (magnitude x)))) ; find the root by Ridder's method: (define (ridder a b fa fb) (if (or (= fa 0) (= fb 0)) (if (= fa 0) a b) (begin (if (> (* fa fb) 0) (error "x-min and x-max in find-root must bracket the root!")) (let ((m (midpoint a b))) (let ((fm (f m))) (let ((x (+ m (/ (* (- m a) (sign (- fa fb)) fm) (sqrt (- (* fm fm) (* fa fb))))))) (if (or (= fm 0) (converged? a b x)) (if (= fm 0) m x) (let ((fx (f x))) (apply ridder (best-bracket a b x m fa fb fx fm)))))))))) (ridder x-min x-max (f x-min) (f x-max))) ; **************************************************************** ; Find a root by Newton's method with bounds and bisection, ; given a function f that returns a pair of (value . derivative) (define (find-root-deriv f tol x-min x-max . x-guess) ; Some trickiness: we only need to evaluate the function at x-min and ; x-max if a Newton step fails, and even then only if we haven't already ; bracketed the root, so do this via lazy evaluation. (define f-memo (memoize f)) (define (lazy x) (if (number? x) x (x))) (define (pick-bound which?) (lambda () (let ((fmin-pair (f-memo x-min)) (fmax-pair (f-memo x-max))) (let ((fmin (car fmin-pair)) (fmax (car fmax-pair))) (if (which? fmin) x-min (if (which? fmax) x-max (error "failed to bracket the root in find-root-deriv"))))))) (define (in-bounds? x f df a b) (negative? (* (- f (* df (- x a))) (- f (* df (- x b)))))) (define (newton x a b dx) (if (< (abs dx) (abs (* tol x))) x (let ((fx-pair (f-memo x))) (let ((f (car fx-pair)) (df (cdr fx-pair))) (if (= f 0) x (let ((a' (if (< f 0) x a)) (b' (if (> f 0) x b))) (if (and (not (= dx (- x-max x-min))) (negative? (* dx (/ f df))) (positive? (* (car (f-memo (lazy a'))) (car (f-memo (lazy b')))))) (error "failed to bracket the root in find-root-deriv")) (if (and (if (and (number? a) (number? b)) (in-bounds? x f df a b) (in-bounds? x f df x-min x-max)) ; (> (abs (* 0.5 dx df)) (abs f)) ) (newton (- x (/ f df)) a' b' (/ f df)) (let ((av (lazy a)) (bv (lazy b))) (let ((dx' (* 0.5 (- bv av))) (a'' (if (eq? a a') av a')) (b'' (if (eq? b b') bv b'))) (newton (* (+ av bv) 0.5) a'' b'' dx')))))))))) (newton (if (null? x-guess) (* (+ x-min x-max) 0.5) (car x-guess)) (pick-bound negative?) (pick-bound positive?) (- x-max x-min))) ; **************************************************************** ; Numerical differentiation: ; Compute the numerical derivative of a function f at x, using ; Ridder's method of polynomial extrapolation, described e.g. in ; Numerical Recipes in C (section 5.7). ; This is the basic routine, but we wrap it in another interface below ; so that dx and tol can be optional arguments. (define (do-derivative f x dx tol) ; Using Neville's algorithm, compute successively higher-order ; extrapolations of the derivative (the "Neville tableau"): (define (deriv-a a0 prev-a fac fac0) (if (null? prev-a) (list a0) (cons a0 (deriv-a (binary/ (binary- (binary* a0 fac) (car prev-a)) (- fac 1)) (cdr prev-a) (* fac fac0) fac0)))) (define (deriv dx df0 err0 prev-a fac0) (let ((a (deriv-a (binary/ (binary- (f (+ x dx)) (f (- x dx))) (* 2 dx)) prev-a fac0 fac0))) (if (null? prev-a) (deriv (/ dx (sqrt fac0)) (car a) err0 a fac0) (let* ((errs (map max (map unary-abs (map binary- (cdr a) (reverse (cdr (reverse a))))) (map unary-abs (map binary- (cdr a) prev-a)))) (errmin (apply min errs)) (err (min errmin err0)) (df (if (> err err0) df0 (cdr (assoc errmin (map cons errs (cdr a))))))) (if (or (<= err (* tol (unary-abs df)) ) (> (unary-abs (binary- (car (reverse a)) (car (reverse prev-a)))) (* 2 err))) (list df err) (deriv (/ dx (sqrt fac0)) df err a fac0)))))) (deriv dx 0 1e30 '() 2)) (define (do-derivative-wrap do-deriv f x dx-and-tol) (let ((dx (if (> (length dx-and-tol) 0) (car dx-and-tol) (max (magnitude (* x 0.01)) 0.01))) (tol (if (> (length dx-and-tol) 1) (cadr dx-and-tol) 0))) (do-deriv f x dx tol))) (define derivative-df car) (define derivative-df-err cadr) (define derivative-d2f caddr) (define derivative-d2f-err cadddr) (define (derivative f x . dx-and-tol) (do-derivative-wrap do-derivative f x dx-and-tol)) (define (deriv f x . dx-and-tol) (derivative-df (do-derivative-wrap do-derivative f x dx-and-tol))) ; Compute both the first and second derivatives at the same time ; (using minimal extra function evaluations). (define (derivative2 f x . dx-and-tol) (define f-memo (memoize f)) (define (f-deriv y) (binary* (binary- (f-memo y) (f-memo x)) (/ 2 (- y x)))) (append (do-derivative-wrap do-derivative f-memo x dx-and-tol) (do-derivative-wrap do-derivative f-deriv x dx-and-tol))) (define (deriv2 f x . dx-and-tol) (derivative-d2f (apply derivative2 (cons f (cons x dx-and-tol))))) ; Below, we have variants of the above routine which only compute the ; *one-sided* derivative df/dx for dx > 0. (Adapted from Ridder's ; algorithm by SGJ. Note that these are generally less accurate ; than the ordinary two-sided derivative, above.) (define (do-derivative+ f x dx tol) ; Using Neville's algorithm, compute successively higher-order ; extrapolations of the derivative (the "Neville tableau"): (define (deriv-a a0 prev-a fac fac0) (if (null? prev-a) (list a0) (cons a0 (deriv-a (binary/ (binary- (binary* a0 fac) (car prev-a)) (- fac 1)) (cdr prev-a) (* fac fac0) fac0)))) (define fx (f x)) (define (deriv dx df0 err0 prev-a fac0) (let ((a (deriv-a (binary/ (binary- (f (+ x dx)) fx) dx) prev-a fac0 fac0))) (if (null? prev-a) (deriv (/ dx fac0) (car a) err0 a fac0) (let* ((errs (map max (map unary-abs (map binary- (cdr a) (reverse (cdr (reverse a))))) (map unary-abs (map binary- (cdr a) prev-a)))) (errmin (apply min errs)) (err (min errmin err0)) (df (if (> err err0) df0 (cdr (assoc errmin (map cons errs (cdr a))))))) (if (or (< err (* tol (unary-abs df)) ) (> (unary-abs (binary- (car (reverse a)) (car (reverse prev-a)))) (* 2 err))) (list df err) (deriv (/ dx fac0) df err a fac0)))))) (deriv dx 0 1e30 '() (sqrt 2))) ; Compute both the first and second derivatives at the same time ; (using minimal extra function evaluations). (define (do-derivative-wrap2+ do-deriv only2? f x dx-and-tol) (define f-memo (memoize f)) (define (f-deriv y) (if (= y x) 0.0 (binary* (binary+ (f-memo y) (binary- (f-memo x) (binary* 2.0 (f-memo (* 0.5 (+ x y)))))) (/ 4 (- y x))))) (append (if only2? (list 0 0) (do-derivative-wrap do-deriv f-memo x dx-and-tol)) (do-derivative-wrap do-deriv f-deriv x dx-and-tol))) (define (derivative+ f x . dx-and-tol) (do-derivative-wrap do-derivative+ f x dx-and-tol)) (define (deriv+ f x . dx-and-tol) (derivative-df (do-derivative-wrap do-derivative+ f x dx-and-tol))) (define (derivative2+ f x . dx-and-tol) (do-derivative-wrap2+ do-derivative+ false f x dx-and-tol)) (define (deriv2+ f x . dx-and-tol) (derivative-d2f (do-derivative-wrap2+ do-derivative+ true f x dx-and-tol))) ; as do-derivative+, but taking derivative from left (define (do-derivative- f x dx tol) (do-derivative+ f x (- dx) tol)) (define (derivative- f x . dx-and-tol) (do-derivative-wrap do-derivative- f x dx-and-tol)) (define (deriv- f x . dx-and-tol) (derivative-df (do-derivative-wrap do-derivative- f x dx-and-tol))) (define (derivative2- f x . dx-and-tol) (do-derivative-wrap2+ do-derivative- false f x dx-and-tol)) (define (deriv2- f x . dx-and-tol) (derivative-d2f (do-derivative-wrap2+ do-derivative- true f x dx-and-tol))) ; **************************************************************** ; Some simple integration routines using an adaptive trapezoidal rule ; (see e.g. Numerical Recipes, Sec. 4.2). It might be nice to have ; Gaussian quadratures and what-not, but on the other hand the ; functions we are integrating may well be the result of a computation ; on a finite grid (somehow interpolated), and so will not be smooth. ; Also, implementing thse simple algorithms in Scheme lets us use our ; polymorphic arithmetic functions so that we can easily integrate ; real, complex, and vector-valued functions. ; ; UPDATE: quadrature/cubature rules are now implemented via C ; Integrate the 1d function (f x) from x=a..b to within the specified ; fractional tolerance. (define (integrate-1d f a b tol) (define (pow2 n) (if (<= n 0) 1 (* 2 (pow2 (- n 1))))) ; 2^n (define (trap0 n sum) (binary* 0.5 (binary+ sum (if (<= n 1) (binary* (- b a) (binary+ (f a) (f b))) (let ((steps (pow2 (- n 2)))) (let ((dx (/ (- b a) steps))) (binary* dx (do ((cur-sum 0) (i 0 (+ i 1)) (x (+ a dx) (+ x dx))) ((>= i steps) cur-sum) (set! cur-sum (binary+ cur-sum (f x))))))))))) (define (trap n sum) (let ((newsum (trap0 n sum))) (if (and (> n 5) (or (> n 20) (binary= newsum sum) (< (unary-abs (binary- newsum sum)) (* tol (unary-abs newsum))))) newsum (trap (+ n 1) newsum)))) (trap 1 0.0)) ; Integrate the multi-dimensional function f from a..b, within the ; specified tolerance. a and b are either numbers (for 1d integrals), ; or vectors/lists of the same length giving the bounds in each dimension. ; NOTE: this is our *old* routine that uses the trapezoidal rule (define (integrate-old f a b tol) (define (int f a b) (if (null? a) (f) (integrate-1d (lambda (x) (int (lambda (. y) (apply f (cons x y))) (cdr a) (cdr b))) (car a) (car b) tol))) (cond ((and (vector? a) (vector? b)) (integrate-old f (vector->list a) (vector->list b) tol)) ((and (number? a) (number? b)) (integrate-old f (list a) (list b) tol)) (else (int f a b)))) ; As above, but use adaptive cubature rules in integrator.c ; Optionally, can take absolute tolerance and max # function evals as args. (define (integrate f a b reltol . abstol-and-maxnfe) (define (to-list x) (cond ((number? x) (list x)) ((vector? x) (vector->list x)) (else x))) ((if (defined? 'cadaptive-integration) cadaptive-integration ; only compiled when complex nums are available adaptive-integration) (lambda (x) (apply f x)) (to-list a) (to-list b) (if (null? abstol-and-maxnfe) 0.0 (car abstol-and-maxnfe)) reltol (if (< (length abstol-and-maxnfe) 2) 0 (cadr abstol-and-maxnfe)))) ; **************************************************************** libctl-4.4.0/base/matrix3x3.scm000066400000000000000000000123011356267410600162570ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; matrix3x3 and associated functions (a type to represent 3x3 matrices) ; we represent a matrix3x3 by a vector of 3 columns, each of which ; is a 3-vector. (define (matrix3x3 c1 c2 c3) (vector c1 c2 c3)) (define cmatrix3x3 matrix3x3) (define (matrix3x3? m) (and (vector? m) (= (vector-length m) 3) (vector-for-all? m vector3?))) (define (real-matrix3x3? m) (and (matrix3x3? m) (vector-for-all? m real-vector3?))) (define (matrix3x3-col m col) (vector-ref m col)) (define (matrix3x3-ref m row col) (vector-ref (matrix3x3-col m col) row)) (define (matrix3x3-row m row) (vector3 (matrix3x3-ref m row 0) (matrix3x3-ref m row 1) (matrix3x3-ref m row 2))) (define (matrix3x3-transpose m) (matrix3x3 (matrix3x3-row m 0) (matrix3x3-row m 1) (matrix3x3-row m 2))) (define (matrix3x3-conj m) (vector-map vector3-conj m)) (define (matrix3x3-adjoint m) (matrix3x3-conj (matrix3x3-transpose m))) (define (matrix3x3+ m1 m2) (vector-map vector3+ m1 m2)) (define (matrix3x3- m1 m2) (vector-map vector3- m1 m2)) (define (matrix3x3-scale s m) (vector-map (lambda (v) (vector3-scale s v)) m)) (define (matrix3x3-mv-mult m v) (vector3 (vector3-dot (matrix3x3-row m 0) v) (vector3-dot (matrix3x3-row m 1) v) (vector3-dot (matrix3x3-row m 2) v))) (define (matrix3x3-vm-mult v m) (vector3 (vector3-dot (matrix3x3-col m 0) v) (vector3-dot (matrix3x3-col m 1) v) (vector3-dot (matrix3x3-col m 2) v))) (define (matrix3x3-mm-mult m1 m2) (matrix3x3 (vector3 (vector3-dot (matrix3x3-row m1 0) (matrix3x3-col m2 0)) (vector3-dot (matrix3x3-row m1 1) (matrix3x3-col m2 0)) (vector3-dot (matrix3x3-row m1 2) (matrix3x3-col m2 0))) (vector3 (vector3-dot (matrix3x3-row m1 0) (matrix3x3-col m2 1)) (vector3-dot (matrix3x3-row m1 1) (matrix3x3-col m2 1)) (vector3-dot (matrix3x3-row m1 2) (matrix3x3-col m2 1))) (vector3 (vector3-dot (matrix3x3-row m1 0) (matrix3x3-col m2 2)) (vector3-dot (matrix3x3-row m1 1) (matrix3x3-col m2 2)) (vector3-dot (matrix3x3-row m1 2) (matrix3x3-col m2 2))))) (define (matrix3x3* a b) (cond ((number? a) (matrix3x3-scale a b)) ((number? b) (matrix3x3-scale b a)) ((vector3? a) (matrix3x3-vm-mult a b)) ((vector3? b) (matrix3x3-mv-mult a b)) (else (matrix3x3-mm-mult a b)))) (define (matrix3x3-determinant m) (- (+ (* (matrix3x3-ref m 0 0) (matrix3x3-ref m 1 1) (matrix3x3-ref m 2 2)) (* (matrix3x3-ref m 0 1) (matrix3x3-ref m 1 2) (matrix3x3-ref m 2 0)) (* (matrix3x3-ref m 1 0) (matrix3x3-ref m 2 1) (matrix3x3-ref m 0 2))) (+ (* (matrix3x3-ref m 0 2) (matrix3x3-ref m 1 1) (matrix3x3-ref m 2 0)) (* (matrix3x3-ref m 0 1) (matrix3x3-ref m 1 0) (matrix3x3-ref m 2 2)) (* (matrix3x3-ref m 1 2) (matrix3x3-ref m 2 1) (matrix3x3-ref m 0 0))))) (define (matrix3x3-inverse m) (matrix3x3-scale (/ (matrix3x3-determinant m)) (matrix3x3 (vector3 (- (* (matrix3x3-ref m 1 1) (matrix3x3-ref m 2 2)) (* (matrix3x3-ref m 1 2) (matrix3x3-ref m 2 1))) (- (* (matrix3x3-ref m 1 2) (matrix3x3-ref m 2 0)) (* (matrix3x3-ref m 1 0) (matrix3x3-ref m 2 2))) (- (* (matrix3x3-ref m 1 0) (matrix3x3-ref m 2 1)) (* (matrix3x3-ref m 1 1) (matrix3x3-ref m 2 0)))) (vector3 (- (* (matrix3x3-ref m 2 1) (matrix3x3-ref m 0 2)) (* (matrix3x3-ref m 0 1) (matrix3x3-ref m 2 2))) (- (* (matrix3x3-ref m 0 0) (matrix3x3-ref m 2 2)) (* (matrix3x3-ref m 0 2) (matrix3x3-ref m 2 0))) (- (* (matrix3x3-ref m 0 1) (matrix3x3-ref m 2 0)) (* (matrix3x3-ref m 0 0) (matrix3x3-ref m 2 1)))) (vector3 (- (* (matrix3x3-ref m 0 1) (matrix3x3-ref m 1 2)) (* (matrix3x3-ref m 1 1) (matrix3x3-ref m 0 2))) (- (* (matrix3x3-ref m 1 0) (matrix3x3-ref m 0 2)) (* (matrix3x3-ref m 0 0) (matrix3x3-ref m 1 2))) (- (* (matrix3x3-ref m 1 1) (matrix3x3-ref m 0 0)) (* (matrix3x3-ref m 1 0) (matrix3x3-ref m 0 1))))))) ; **************************************************************** ; Return the rotation matrix for rotating by theta around axis: (define (rotation-matrix3x3 axis theta) (matrix3x3 (rotate-vector3 axis theta (vector3 1 0 0)) (rotate-vector3 axis theta (vector3 0 1 0)) (rotate-vector3 axis theta (vector3 0 0 1)))) ; **************************************************************** libctl-4.4.0/base/simplex.scm000066400000000000000000000120151356267410600161000ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; The Nelder-Mead simplex algorithm for multidimensional minimization. ; See the simplex-minimize function, below. (define (ax+by a x b y) (define (cdr-null x) (if (null? x) '() (cdr x))) (if (and (null? x) (null? y)) '() (let ((ax (if (null? x) 0 (* a (car x)))) (by (if (null? y) 0 (* b (car y))))) (cons (+ ax by) (ax+by a (cdr-null x) b (cdr-null y)))))) (define (simplex-point x val) (cons x val)) (define simplex-point-x car) (define simplex-point-val cdr) (define (simplex-high s) (car (sort s (lambda (s1 s2) (> (simplex-point-val s1) (simplex-point-val s2)))))) (define (simplex-high2 s) (cadr (sort s (lambda (s1 s2) (> (simplex-point-val s1) (simplex-point-val s2)))))) (define (simplex-low s) (car (sort s (lambda (s1 s2) (< (simplex-point-val s1) (simplex-point-val s2)))))) (define (simplex-replace s s-old s-new) (if (null? s) '() (if (eq? (car s) s-old) (cons s-new (cdr s)) (cons (car s) (simplex-replace (cdr s) s-old s-new))))) (define (simplex-sum-x s) (if (null? s) '() (ax+by 1 (simplex-point-x (car s)) 1 (simplex-sum-x (cdr s))))) (define (simplex-centroid-x s) (let ((sum (ax+by 1 (simplex-sum-x s) -1 (simplex-point-x (simplex-high s))))) (ax+by (/ (- (length s) 1)) sum 0.0 '()))) (define (simplex-shrink s-min f s) (if (null? s) '() (if (eq? s-min (car s)) (cons (car s) (simplex-shrink s-min f (cdr s))) (let ((x (ax+by 0.5 (simplex-point-x s-min) 0.5 (simplex-point-x (car s))))) (cons (simplex-point x (apply f x)) (simplex-shrink s-min f (cdr s))))))) (define simplex-reflect-ratio 1.0) (define simplex-expand-ratio 2.0) (define simplex-contract-ratio 0.5) (define (simplex-contract f s) (let ((s-h (simplex-high s)) (s-l (simplex-low s)) (x0 (simplex-centroid-x s))) (let ((xc (ax+by (- 1 simplex-contract-ratio) x0 simplex-contract-ratio (simplex-point-x s-h)))) (let ((vc (apply f xc))) (if (< vc (simplex-point-val s-h)) (simplex-replace s s-h (simplex-point xc vc)) (simplex-shrink s-l f s)))))) (define (simplex-iter f s) (let ((s-h (simplex-high s)) (s-h2 (simplex-high2 s)) (s-l (simplex-low s)) (x0 (simplex-centroid-x s))) (let ((xr (ax+by (+ 1 simplex-reflect-ratio) x0 (- simplex-reflect-ratio) (simplex-point-x s-h)))) (let ((vr (apply f xr))) (if (and (<= vr (simplex-point-val s-h2)) (>= vr (simplex-point-val s-l))) (simplex-replace s s-h (simplex-point xr vr)) (if (< vr (simplex-point-val s-l)) (let ((xe (ax+by (- 1 simplex-expand-ratio) x0 simplex-expand-ratio xr))) (let ((ve (apply f xe))) (if (>= ve vr) (simplex-replace s s-h (simplex-point xr vr)) (simplex-replace s s-h (simplex-point xe ve))))) (if (and (< vr (simplex-point-val s-h)) (> vr (simplex-point-val s-h2))) (simplex-contract f (simplex-replace s s-h (simplex-point xr vr))) (simplex-contract f s)))))))) (define (simplex-iterate f s tol) (let ((s-h (simplex-high s)) (s-l (simplex-low s))) (if (<= (magnitude (- (simplex-point-val s-h) (simplex-point-val s-l))) (* 0.5 tol (+ tol (magnitude (simplex-point-val s-h)) (magnitude (simplex-point-val s-l))))) s-l (begin (print "extremization: best so far is " s-l "\n") (simplex-iterate f (simplex-iter f s) tol))))) (define (simplex-shift-x x i) (let ((xv (list->vector x))) (let ((xv-i (vector-ref xv i))) (if (< (magnitude xv-i) 1e-6) (vector-set! xv i 0.1) (vector-set! xv i (* 0.9 xv-i))) (vector->list xv)))) (define (simplex-shift-list x) (define (ssl-aux i) (if (< i 0) '() (cons (simplex-shift-x x i) (ssl-aux (- i 1))))) (cons x (ssl-aux (- (length x) 1)))) ; Use the Simplex method to minimize the function (f . x), where ; the initial guess is x0 and the fractional tolerance on the value ; of the solution is tol. (define (simplex-minimize f x0 tol) (let ((s0 (map (lambda (x) (simplex-point x (apply f x))) (simplex-shift-list x0)))) (simplex-iterate f s0 tol))) libctl-4.4.0/base/utils.scm000066400000000000000000000154551356267410600155720ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; Replacements for MIT Scheme functions missing from Guile 1.2. (define true #t) (define false #f) (define (list-transform-positive l pred) (define (tp Lrest Lpos) (if (null? Lrest) Lpos (if (pred (car Lrest)) (tp (cdr Lrest) (cons (car Lrest) Lpos)) (tp (cdr Lrest) Lpos)))) (reverse (tp l '()))) (define (list-transform-negative l pred) (list-transform-positive l (lambda (x) (not (pred x))))) (define (alist-copy al) (if (null? al) '() (cons (cons (caar al) (cdar al)) (alist-copy (cdr al))))) (define (for-all? l pred) (if (null? l) true (if (pred (car l)) (for-all? (cdr l) pred) false))) (define (first list) (list-ref list 0)) (define (second list) (list-ref list 1)) (define (third list) (list-ref list 2)) (define (fourth list) (list-ref list 3)) (define (fifth list) (list-ref list 4)) (define (sixth list) (list-ref list 5)) ; fold-left and fold-right: combine elements of list using an operator ; op, with initial element init, associating from the right or from ; the left. These two are equivalent if op is associative. (define (fold-left op init list) (if (null? list) init (fold-left op (op init (car list)) (cdr list)))) (define (fold-right op init list) (fold-left (lambda (x y) (op y x)) init (reverse list))) ; **************************************************************** ; Miscellaneous utility functions. (define (compose f g) (lambda args (f (apply g args)))) (define (car-or-x p) (if (pair? p) (car p) p)) (define (sqr x) (* x x)) ; complex conjugate of x: (define (conj x) (make-rectangular (real-part x) (- (imag-part x)))) ; combine 2 alists. returns a list containing all of the associations ; in a1 and any associations in a2 that are not in a1 (define (combine-alists a1 a2) (if (null? a2) a1 (combine-alists (if (assoc (caar a2) a1) a1 (cons (car a2) a1)) (cdr a2)))) (define (vector-for-all? v pred) (for-all? (vector->list v) pred)) (define (vector-fold-right op init v) (fold-right op init (vector->list v))) (define (vector-fold-left op init v) (fold-left op init (vector->list v))) (define (vector-map func . v) (list->vector (apply map (cons func (map vector->list v))))) (define (indent indentby) (print (make-string indentby #\space))) (define print-ok? true) ; so that the user can disable output (define (print . items) (if print-ok? (begin (for-each (lambda (item) (display item)) items) (flush-all-ports)))) (define display-many print) ; backwards compatibility with earlier libctl (define (make-initialized-list size init-func) (define (aux i) (if (>= i size) '() (cons (init-func i) (aux (+ i 1))))) (aux 0)) ; **************************************************************** ; Some string utilities: (define (string-find-next-char-in-list s l) (define (aux index s) (if (string-null? s) #f (if (member (string-ref s 0) l) index (aux (+ index 1) (substring s 1 (string-length s)))))) (aux 0 s)) (define (string-find-next-char-not-in-list s l) (define (aux index s) (if (string-null? s) #f (if (not (member (string-ref s 0) l)) index (aux (+ index 1) (substring s 1 (string-length s)))))) (aux 0 s)) (define (string->positive-integer s) (let ((non-blank (string-find-next-char-not-in-list s '(#\space #\ht #\vt #\nl #\cr)))) (let ((s2 (if (eq? non-blank #f) s (substring s non-blank (string-length s))))) (let ((int-start (string-find-next-char-in-list s2 (string->list "0123456789")))) (if (eq? int-start 0) (let ((int-end (string-find-next-char-not-in-list (substring s2 1 (string-length s2)) (string->list "0123456789")))) (if (eq? int-end #f) (eval-string s2) (if (string-find-next-char-not-in-list (substring s2 (+ 1 int-end) (string-length s2)) '(#\space #\ht #\vt #\nl #\cr)) #f (eval-string s2)))) #f))))) ; **************************************************************** ; timing functions ; Display the message followed by the time t in minutes and seconds, ; returning t in seconds. (define (display-time message t) (let ((hours (quotient t 3600)) (minutes (remainder (quotient t 60) 60)) (seconds (remainder t 60))) (print message) (if (> hours 1) (print hours " hours, ") (if (> hours 0) (print hours " hour, "))) (if (> minutes 1) (print minutes " minutes, ") (if (> minutes 0) (print minutes " minute, "))) (print seconds " seconds.\n")) t) ; (begin-time message ...statements...) works just like (begin ; ...statements...) except that it also displays 'message' followed by ; the elapsed time to execute the statements. Additionally, it returns ; the elapsed time in seconds, rather than the value of the last statement. (defmacro-public begin-time (message . statements) `(begin (let ((begin-time-start-t (current-time))) ,@statements (display-time ,message (- (current-time) begin-time-start-t))))) ; like begin-time, but returns the value of the last statement, ; similar to (begin ...). In retrospect, returning the time by ; default was probably a mistake. (defmacro-public begin-timed (message . statements) `(let ((begin-time-start-t (current-time))) (let ((val (begin "no statements" ,@statements))) (display-time ,message (- (current-time) begin-time-start-t)) val))) ; **************************************************************** ; Return a 'memoized' version of the function f, which caches its ; arguments and return values so as never to compute the same thing twice. (define (memoize f) (let ((f-memo-tab '())) (lambda (. y) (let ((tab-val (assoc y f-memo-tab))) (if tab-val (cdr tab-val) (let ((fy (apply f y))) (set! f-memo-tab (cons (cons y fy) f-memo-tab)) fy)))))) ; **************************************************************** libctl-4.4.0/base/vector3.scm000066400000000000000000000113761356267410600160150ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** ; vector3 and associated operators. (a type to represent 3-vectors) ; Guile 1.6 does not support exact->inexact on complex numbers, grrr (define (ctl-exact->inexact x) (if (real? x) (exact->inexact x) x)) (define (vector3->inexact v) (vector-map ctl-exact->inexact v)) (define (vector3->exact v) (vector-map inexact->exact v)) (define (vector3 . args) (vector3->inexact (if (= (length args) 0) (vector 0 0 0) (if (= (length args) 1) (vector (first args) 0 0) (if (= (length args) 2) (vector (first args) (second args) 0) (vector (first args) (second args) (third args))))))) (define cvector3 vector3) (define (vector3? v) (and (vector? v) (= (vector-length v) 3) (vector-for-all? v number?))) (define (real-vector3? v) (and (vector3? v) (vector-for-all? v real?))) (define (vector3-x v) (vector-ref v 0)) (define (vector3-y v) (vector-ref v 1)) (define (vector3-z v) (vector-ref v 2)) (define (vector3+ v1 v2) (vector-map + v1 v2)) (define (vector3- v1 v2) (vector-map - v1 v2)) (define (vector3-dot v1 v2) (vector-fold-left + 0 (vector-map * v1 v2))) (define (vector3-conj v) (vector-map conj v)) (define (vector3-cdot v1 v2) (vector3-dot (vector3-conj v1) v2)) (define (vector3-scale s v) (vector-map (lambda (x) (* s x)) v)) (define (vector3* a b) (if (number? a) (vector3-scale a b) (if (number? b) (vector3-scale b a) (vector3-dot a b)))) (define (vector3-cross v1 v2) (vector3 (- (* (vector-ref v1 1) (vector-ref v2 2)) (* (vector-ref v1 2) (vector-ref v2 1))) (- (* (vector-ref v1 2) (vector-ref v2 0)) (* (vector-ref v1 0) (vector-ref v2 2))) (- (* (vector-ref v1 0) (vector-ref v2 1)) (* (vector-ref v1 1) (vector-ref v2 0))))) (define (vector3-norm v) (sqrt (magnitude (vector3-cdot v v)))) (define (unit-vector3 . args) (let ((v (if (and (= (length args) 1) (vector3? (car args))) (car args) (apply vector3 args)))) (vector3-scale (/ (vector3-norm v)) v))) (define (vector3-close? v1 v2 tolerance) (and (<= (magnitude (- (vector-ref v1 0) (vector-ref v2 0))) tolerance) (<= (magnitude (- (vector-ref v1 1) (vector-ref v2 1))) tolerance) (<= (magnitude (- (vector-ref v1 2) (vector-ref v2 2))) tolerance))) (define (vector3= v1 v2) (vector3-close? v1 v2 0.0)) ; Define polymorphic operators (work on both vectors and numbers): (define (binary+ x y) (cond ((and (number? x) (zero? x)) y) ((and (number? y) (zero? y)) x) ((and (vector3? x) (vector3? y)) (vector3+ x y)) (else (+ x y)))) (define (binary- x y) (if (and (vector3? x) (vector3? y)) (vector3- x y) (- x y))) (define (binary* x y) (if (or (vector3? x) (vector3? y)) (vector3* x y) (* x y))) (define (binary/ x y) (if (and (vector3? x) (number? y)) (vector3-scale (/ y) x) (/ x y))) (define (binary= x y) (cond ((and (vector3? x) (vector3? y)) (vector3= x y)) ((and (number? x) (number? y)) (= x y)) (else false))) (define (unary-abs x) (if (vector3? x) (vector3-norm x) (magnitude x))) (define (unary->inexact x) (if (vector3? x) (vector3->inexact x) (ctl-exact->inexact x))) ; **************************************************************** ; Rotating a vector (see also rotation-matrix3x3 in matrix3x3.scm): (define (deg->rad theta) (* theta (/ 3.141592653589793238462643383279502884197 180.0))) (define (rad->deg theta) (* theta (/ 180.0 3.141592653589793238462643383279502884197))) (define (rotate-vector3 axis theta v) (let ((u (unit-vector3 axis))) (let ((vpar (vector3-scale (vector3-dot u v) u)) (vcross (vector3-cross u v))) (let ((vperp (vector3- v vpar))) (vector3+ vpar (vector3+ (vector3-scale (cos theta) vperp) (vector3-scale (sin theta) vcross))))))) ; **************************************************************** libctl-4.4.0/configure.ac000066400000000000000000000176541356267410600153050ustar00rootroot00000000000000# Process this file with autoconf to produce a configure script. AC_INIT(libctl, 4.4.0, stevenj@alum.mit.edu) AC_CONFIG_SRCDIR([src/ctl.c]) AC_CONFIG_HEADERS([config.h src/ctl.h]) AC_CONFIG_MACRO_DIR([m4]) AM_MAINTAINER_MODE # Shared-library version number; indicates api compatibility, and is # not the same as the "public" version number. (Don't worry about this # except for public releases.) SHARED_VERSION_INFO="9:0:2" # CURRENT:REVISION:AGE AM_INIT_AUTOMAKE([foreign]) AC_SUBST(SHARED_VERSION_INFO) AM_ENABLE_SHARED(no) dnl shared libs cause too many headaches to be default AC_PROG_LIBTOOL ########################################################################### LIBCTL_VERSION=$PACKAGE_VERSION AC_DEFINE_UNQUOTED(LIBCTL_VERSION, "$LIBCTL_VERSION", [Define to version string for libctl.]) AC_SUBST(LIBCTL_VERSION) LIBCTL_MAJOR_VERSION=`echo $LIBCTL_VERSION |cut -d. -f1` LIBCTL_MINOR_VERSION=`echo $LIBCTL_VERSION |cut -d. -f2` LIBCTL_BUGFIX_VERSION=`echo $LIBCTL_VERSION |cut -d. -f3` test "x$LIBCTL_BUGFIX_VERSION" = x && LIBCTL_BUGFIX_VERSION=0 AC_DEFINE_UNQUOTED(LIBCTL_MAJOR_VERSION, $LIBCTL_MAJOR_VERSION, [major v.]) AC_DEFINE_UNQUOTED(LIBCTL_MINOR_VERSION, $LIBCTL_MINOR_VERSION, [minor v.]) AC_DEFINE_UNQUOTED(LIBCTL_BUGFIX_VERSION, $LIBCTL_BUGFIX_VERSION, [bugfix v.]) ########################################################################### # Checks for programs. AC_PROG_CC AM_PROG_CC_C_O AC_CHECK_PROGS(INDENT, indent gindent, echo) AC_SUBST(INDENT) # check how to transform the name of the installed program: AC_ARG_ENABLE(debug, [ --enable-debug compile for debugging], ok=$enableval, ok=no) if test "$ok" = "yes"; then CFLAGS="-g" AC_DEFINE(DEBUG, 1, [Define to enable debugging checks.]) fi # Checks for header files. AC_HEADER_STDC ########################################################################### # Find Guile library, flags, etcetera: AC_ARG_WITH(guile, [AC_HELP_STRING([--without-guile],[disable use of Guile])], with_guile=$withval, with_guile=yes) if test x"$with_guile" = xyes; then AC_CHECK_PROG(GUILE, guile, guile, unknown) if test x"$guile_ok" = xunknown; then AC_MSG_WARN([could not find guile program; check your PATH ... disabling guile]) with_guile=no fi fi AC_SUBST(GUILE) # seems to be needed on ubuntu (issue #1): AC_CHECK_LIB(m, sqrt) noguile_LIBS=$LIBS LIBGUILE="" if test x"$with_guile" = xyes; then AC_CHECK_PROG(GUILE_CONFIG, guile-config, guile-config, unknown) if test "x$GUILE_CONFIG" = "xunknown"; then AC_CHECK_LIB(readline, readline) AC_CHECK_LIB(dl, dlopen) ok=no AC_CHECK_LIB(guile, gh_eval_str, [ok=yes], [AC_CHECK_LIB(guile, scm_eval_string, [ok=yes])]) if test $ok = yes; then LIBGUILE="-lguile -ldl -lreadline" LIBS="-lguile $LIBS" AC_DEFINE(HAVE_LIBGUILE, 1, [Define if we have -lguile]) else with_guile=no fi else CPPFLAGS="$CPPFLAGS `$GUILE_CONFIG compile`" LIBGUILE=`$GUILE_CONFIG link` LIBS="$LIBS $LIBGUILE" fi fi if test x"$with_guile" = xyes; then AC_MSG_CHECKING([if linking to guile works]) AC_TRY_LINK_FUNC(gh_enter, AC_MSG_RESULT(yes), [AC_TRY_LINK_FUNC(scm_boot_guile, AC_MSG_RESULT(yes), [AC_MSG_RESULT(no) AC_MSG_ERROR(Guile linking failed)])]) AC_CHECK_HEADERS([libguile.h guile/gh.h]) fi AC_SUBST(LIBGUILE) AM_CONDITIONAL(WITH_GUILE, test "x$with_guile" != xno) ########################################################################### # Checks for Guile features: if test x"$with_guile" = xyes; then AC_MSG_CHECKING([for modern non-gh interface]) ok=yes AC_TRY_LINK([#include ], [scm_from_double(0.0);scm_from_int(0);scm_boot_guile(0,0,0,0);scm_c_define_gsubr(0,0,0,0,0);], [AC_DEFINE(HAVE_NO_GH, 1, [Define if we can avoid the gh interface])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([for gh_enter]) ok=yes AC_TRY_LINK([#include ], [gh_enter(0,0,0);], [AC_DEFINE(HAVE_GH_ENTER, 1, [Define if we have gh_enter.])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([for gh_eval_str]) ok=yes AC_TRY_LINK([#include ], [gh_eval_str(0);], [AC_DEFINE(HAVE_GH_EVAL_STR, 1, [Define if we have gh_eval_str.])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([for gh_load]) ok=yes AC_TRY_LINK([#include ], [gh_load(0);], [AC_DEFINE(HAVE_GH_LOAD, 1, [Define if we have gh_load.])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([for gh_bool2scm]) ok=yes AC_TRY_LINK([#include ], [gh_bool2scm(0);], [AC_DEFINE(HAVE_GH_BOOL2SCM, 1, [Define if we have gh_bool2scm])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([for gh_vector_ref]) ok=yes AC_TRY_LINK([#include ], [gh_vector_ref(0,0);], [AC_DEFINE(HAVE_GH_VECTOR_REF, 1, [Define if we have gh_vector_ref])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([for gh_list_ref]) ok=yes AC_TRY_LINK([#include ], [gh_list_ref(0,0);], [AC_DEFINE(HAVE_GH_LIST_REF, 1, [Define if we have gh_list_ref])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([for gh_length]) ok=yes AC_TRY_LINK([#include ], [gh_length(0);], [AC_DEFINE(HAVE_GH_LENGTH, 1, [Define if we have gh_length])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([for scm_flush_all_ports]) ok=yes AC_TRY_LINK([#if defined(HAVE_LIBGUILE_H) # include #else # include #endif ], [scm_flush_all_ports();], [AC_DEFINE(HAVE_SCM_FLUSH_ALL_PORTS, 1, [Define if we have scm_flush_all_ports])], ok=no) AC_MSG_RESULT($ok) AC_CHECK_FUNCS(scm_make_complex scm_c_make_rectangular scm_variable_set_x scm_c_lookup scm_c_make_vector scm_variable_ref) AC_MSG_CHECKING([for SCM_COMPLEXP]) ok=yes AC_TRY_LINK([#if defined(HAVE_LIBGUILE_H) # include #else # include #endif ], [SCM x; SCM_COMPLEXP(x);], [AC_DEFINE(HAVE_SCM_COMPLEXP, 1, [Define if we have SCM_COMPLEXP])], ok=no) AC_MSG_RESULT($ok) AC_MSG_CHECKING([whether gh_lookup works properly]) ok=yes AC_TRY_RUN([ #include #include void main_entry(int argc, char *argv[]) { gh_eval_str("(define foo 3.14159)"); if (SCM_UNDEFINED == gh_lookup("foo")) exit(EXIT_FAILURE); } int main (int argc, char *argv[]) { gh_enter (argc, argv, main_entry); return EXIT_SUCCESS; } ], [AC_DEFINE(GH_LOOKUP_OK, 1, [Define if gh_lookup works])], ok=no, ok=no) AC_MSG_RESULT($ok) fi # with_guile LIBS=$noguile_LIBS ########################################################################### # Find Fortran name-mangling routines, for wrapper functions AC_PROG_F77 if test -z "$F77"; then AC_MSG_WARN([Fortran wrapper functions will not be included]) else AC_F77_WRAPPERS fi ########################################################################### # Check for C99 complex-number support, for cintegrate.c AC_CHECK_HEADERS(complex.h) AC_CACHE_CHECK([for C complex keyword], acx_cv_c_complex, [acx_cv_c_complex=unsupported for acx_kw in complex _Complex __complex__; do AC_TRY_COMPILE([#include ], [float $acx_kw foo;], [acx_cv_c_complex=$acx_kw; break]) done ]) if test "$acx_cv_c_complex" = "unsupported"; then AC_MSG_WARN([C doesn't support complex numbers; disabling complex integration.]) else AC_DEFINE([CTL_HAS_COMPLEX_INTEGRATION], [1], [If we have C99 complex nums]) fi ########################################################################### # Check for nlopt, or at least its header, and extract Scheme constants AC_PROG_EGREP AC_CHECK_HEADERS(nlopt.h) ########################################################################### libctl_dir=$srcdir case $libctl_dir in .*) libctl_dir=`pwd`/$libctl_dir ;; esac LIBCTL_DIR="$libctl_dir" AC_SUBST(LIBCTL_DIR) GEN_CTL_IO="`pwd`/utils/gen-ctl-io" AC_SUBST(GEN_CTL_IO) # On IRIX, basename/dirname functions require -lgen AC_CHECK_LIB(gen, basename) ########################################################################### AC_CONFIG_FILES([Makefile src/Makefile utils/Makefile examples/Makefile examples/example.scm]) AC_CONFIG_FILES([utils/gen-ctl-io], [chmod u+x utils/gen-ctl-io]) AC_OUTPUT libctl-4.4.0/doc/000077500000000000000000000000001356267410600135475ustar00rootroot00000000000000libctl-4.4.0/doc/README000066400000000000000000000013371356267410600144330ustar00rootroot00000000000000This is the documentation tree for libctl. Markdown (.md) files for libctl documentation live in $(top_src_dir)/doc/docs. To build and visualize the HTML documentation locally using the mkdocs package (useful for verifying on your local machine before committing), install the `mkdocs` package, then run the following command from the top-level meep repository tree: % mkdocs serve and then open the following URL in a browser window: http://127.0.0.1:8000/libctl This launches a little web server on your local machine plus a filesystem hook for rebuilding the documentation tree automatically whenever any .md file is modified, so you can see what the actual HTML documentation looks like in real time as you edit the source. libctl-4.4.0/doc/docs/000077500000000000000000000000001356267410600144775ustar00rootroot00000000000000libctl-4.4.0/doc/docs/Advanced_User_Experience.md000066400000000000000000000122431356267410600216750ustar00rootroot00000000000000--- # Advanced User Experience --- Many more things can be accomplished in a control file besides simply specifying the parameters of a computation, and even that can be done in a more sophisticated way than we have already described. The key to this functionality is the fact that the ctl file is actually written in a full programming language, called Scheme. This language is interpreted and executed at run-time using an interpreter named Guile. The fact that it is a full programming language means that you can do practically anything — the only limitations are in the degree of interaction supported by the simulation program. In a [later section](Guile_and_Scheme_Information.md), we provide links to more information on Scheme and Guile. [TOC] Interactive Mode ---------------- The easiest way to learn Scheme is to experiment. Guile supports an interactive mode where you can type in commands and have them executed immediately. To get into this mode, you can just type `guile` at the command-line. If you run your libctl program without passing any arguments, or pass a ctl file that never invokes `(run)`, this will also drop you into a Guile interactive mode. What's more, all the special features supported by libctl and your program are available from this interactive mode. So, you can set parameters of your program, invoke it with `(run)`, get help with `(help)`, and do anything else you might otherwise do in a ctl file. It is possible that your program supports other calls than just `(run)`, in which case you could control it on an even more detailed level. There is a boolean variable called `interactive?` that controls whether interactive mode will be entered. This variable is `true` initially, but is typically set to `false` by `(run)`. You can force interactive mode to be entered or not by `set!`-ing this variable to `true` or `false`, respectively. Command-Line Parameters ----------------------- It is often useful to be able to set parameters of your ctl file from the command-line when you run the program. For example, you might want to vary the radius of some object with each run. To do this, you would define a parameter `R` in your ctl file: ``` (define-param R 0.2) ``` You would then use `R` instead of a numeric value whenever you wanted this radius. If nothing is specified on the command-line, `R` will take on a default value of 0.2. However, you can change the value of `R` on a particular run by specifying `R=value` on the command-line. For instance, to set `R` to 0.3, you would use: `program R=0.3 ctl-file` You can have as many command-line parameters as you want. In fact, all of the predefined input variables for a program are defined via `define-param` already, so you can set them via the command line too. To change the parameter once it is defined, but to still allow it to be overridden from the command line, you can use ``` (set-param! R 0.5) ``` where the above command line would change the value of `R` to 0.3. If you want to change the parameter to a new value *regardless* of what appears on the command line, you can just use `set!`: ``` (set! R 1.3) ``` Note that the predefined input variables for a typical libctl-using program are all created via `define-param`, so they can be overridden using `set-param!`. Programmatic Parameter Control ------------------------------ A simple use of the programmatic features of Scheme is to give you more power in assigning the variables in the control file. You can use arithmetic expressions, loops and functions, or define your own variables and functions. For example, consider the following case where we set the `k-points` of a band-structure computation such as [MPB](https://mpb.readthedocs.io/). We define the corners of the Brillouin zone, and then call a libctl-provided function, `interpolate`, to linearly interpolate between them. ```scm (define Gamma-point (vector3 0 0)) (define X-point (vector3 0.5 0)) (define M-point (vector3 0.5 0.5)) (set! k-points (list Gamma-point X-point M-point Gamma-point)) (set! k-points (interpolate 4 k-points)) ``` The resulting list has 4 points interpolated between each pair of corners: `> (0,0,0) (0.1,0,0) (0.2,0,0) (0.3,0,0) (0.4,0,0) (0.5,0,0) (0.5,0.1,0) (0.5,0.2,0) (0.5,0.3,0) (0.5,0.4,0) (0.5,0.5,0) (0.4,0.4,0) (0.3,0.3,0) (0.2,0.2,0) (0.1,0.1,0) (0,0,0)` The `interpolate` function is provided as a convenience by libctl, but you could have written it yourself if it weren't. With past programs, it has often been necessary to write a program to generate control files — now, the program can be in the control file itself. Interacting with the Simulation ------------------------------- So far, the communication with the simulation program has been one-way, with us passing information to the simulation. It is possible, however, to get information back. The `(help)` command lists not only input variables, but also *output* variables — these variables are set by the simulation and are available for the ctl program to examine after `(run)` returns. For example, a band-structure computation might return a list of the band-gaps. Using this, the ctl file could vary, say, the radius of a sphere and loop until a band-gap is maximized.libctl-4.4.0/doc/docs/Basic_User_Experience.md000066400000000000000000000167061356267410600212210ustar00rootroot00000000000000--- # Basic User Experience --- At their most basic level, **ctl** files are simply a collection of values for parameters required by the simulation. The ctl syntax for all programs using libctl is similar, although the specific parameters needed will vary. The following examples are given for a fictitious libctl-using program, in order to illustrate its general style. [TOC] A Fictitious Example -------------------- For example, suppose that the simulation solves a one-dimensional (1d) differential equation and requires an input called "grid-size" specifying the number of grid points used in the discretization of the problem. We might specify this in a ctl file by the statement: ```scm (set! grid-size 128) ``` All input variable settings can follow the format `(set! variable value)`. The parentheses are important, but white space is ignored. Alternatively, we can use: ```scm (set-param! grid-size 128) ``` which works exactly like `set!` except that now `grid-size` can be overridden from the command-line. For this reason, `set-param!` (a libctl extension to Scheme) is usually preferred. See also [Command-Line Parameters](Advanced_User_Experience.md#command-line-parameters). Settings of input variables can appear in any order in the file. They can even be omitted completely in many cases, and a reasonable default will be used. Variables can be of many different types, including integers, real numbers, boolean values (`true` and `false`), strings, 3-vectors, and lists. Here is how we might set some parameters of various types: ```scm (set-param! time-step-dt 0.01) ; a real number (set-param! output-file-name "data.hdf") ; a string (set-param! propagation-direction (vector3 0 0.2 7)) ; a 3-vector (set! output-on-time-steps ; a list of integers... (list 25 1000 257 128 4096)) ``` Everything appearing on a line after a semicolon (";") is a **comment** and is ignored. Note also that we are free to split inputs over several lines — as we mentioned earlier, white space is ignored. 3-vectors are constructed using `(vector3 x [y [z]])`. If the *y* or *z* components are omitted, they are set to zero. Lists may contain any number of items (including zero items), and are constructed with `(list [item1 item2 ...])`. A typical control file is terminated with a single statement, something like: ``` (run) ; run the computation ``` This tells the program to run its computation with whatever parameter values have been specified up to the point of the `(run)`. This command can actually appear multiple times in the ctl file, causing multiple runs, or not at all, which drops the user into an interactive mode that we will discuss later. Running a Simulation -------------------- The user runs the simulation program simply by: *program ctl-files* Here, *`program`* is the name of the simulation program executable and *ctl-files* are any ctl files that you want to use for the run. The result is as if all the *ctl-files* were concatenated, in sequence, into a single file. Structured Data Types --------------------- For many programs, it is useful to structure the input into more complicated data types than simple numbers, vectors, and lists. For example, an electromagnetic simulation might take as input a list of geometric objects specifying the dielectric structure. Each object might have several parameters — for example, a sphere might have a radius, a center, and a dielectric constant. libctl allows programs to specify structured datatypes, called **classes**, that have various properties which may be set. Here is what a list of geometric objects for a dielectric structure might look like: ```scm (set! geometry (list (make sphere (epsilon 2.8) (center 0 0 1) (radius 0.3)) (make block (epsilon 1.7) (center 0 0 1) (size 1 3.5 2))))  ``` In this case, the list consists of two objects of classes called `sphere` and `block`. The general format for constructing an object (instance of a class) is `(make class properties)`. *Properties* is a sequence of `(property value)` items setting the properties of the object. Properties may have default values that they assume if nothing is specified. For example, the `block` class might have properties `e1`, `e2`, and `e3` that specify the directions of the block edges, but which default to the coordinate axes if they are not specified. Typically, each class will have some properties that have defaults, and some that you are required to specify. Property values can be any of the primitive types mentioned earlier, but they can also be other objects. For example, instead of specifying a dielectric constant, you might instead supply an object describing the material type: ```scm (define Si (make material-type (epsilon 11.56))) (define SiO2 (make material-type (epsilon 2.1))) (set! geometry    (list       (make sphere (material Si) (center 0 0 1) (radius 0.3))       (make block (material SiO2) (center 0 0 1) (size 1 3.5 2)))) ``` We have snuck in another feature here: `(define new-variable value)` is a way of defining new variables for our own use in the control file. This and other features of the Scheme language are discussed in the next section. What Do I Enter? ---------------- Every program will have a different set of variables that it expects you to set, and a different set of classes with different properties. Whatever program you are using should come with documentation saying what it expects. You can also get the program to print out help by inserting the `(help)` command in your ctl file, or by entering it in [interactive mode](Advanced_User_Experience.md#interactive-mode). You can also simply enter the following command in your shell: `echo "(help)" | program` For example, the output of `(help)` in the electromagnetic simulation we have been using in our examples might look like: ``` Class block:     Class geometric-object:         material-type material         vector3 center     vector3 e1 = #(1 0 0)     vector3 e2 = #(0 1 0)     vector3 e3 = #(0 0 1)     vector3 size Class sphere:     Class geometric-object:         material-type material         vector3 center     number radius Class geometric-object:     material-type material     vector3 center Class material-type:     number epsilon     number conductivity = 0.0 ``` ``` Input variables: vector3 list k-points = () geometric-object list geometry = () integer dimensions = 3 ``` ``` Output variables: number list gaps = () number mean-dielectric = 0.0 ``` As can be seen from above, the help output lists all of the classes and their properties, along with the input and output variables (the latter will be described later). Any default values for properties are also given. Along with each variable or property is given its type. You should also notice that the class `geometric-object` is listed as a part of the classes `block` and `sphere`. These two classes are **subclasses** of `geometric-object`. A subclass inherits the property list of its superclass and can be used any place its superclass is allowed. So, for example, both spheres and blocks can be used in the `geometry` list, which is formally a list of geometric-objects. The astute reader will notice the object-oriented-programming origins of our class concept; our classes, however, differ from OOP in that they have no methods. libctl-4.4.0/doc/docs/Developer_Experience.md000066400000000000000000000371571356267410600211320ustar00rootroot00000000000000--- # Developer Experience --- If you are thinking of using libctl in a program that you are writing, you might be rolling your eyes at this point, thinking of all the work that it will be. A full programming language? Complicated data structures? Information passing back and forth? Surely, it will be a headache to support all of these things. In fact, however, using libctl is much easier than writing your program for a traditional, fixed-format input file. You simply describe in an abstract specifications file the variables and data types that your program expects to exchange with the ctl file, and the functions by which it is called. From these specifications, code is automatically generated to export and import the information to and from Guile. The specifications file is written in Scheme, and consists of definitions for the classes and input/output variables the program expects. It may also contain any predefined functions or variables that might be useful in ctl files for the program, and says which functions in your program are callable from the ctl script. [TOC] Defining input variables ------------------------ To define an input variable (a variable specified by the ctl file and input into the program), use the following construction: ```scm (define-input-var name value type [ constraints ... ]) ``` Here, `name` is the name of the variable, and `value` is its initial value — so far, this is just like a normal `define` statement. However, input variables have constraints on them, the simplest of which is that they have a specific type. The *`type`* parameter can be one of: - `'number` — a real number - `'cnumber` — a complex number - `'integer` — an integer - `'vector3` — a real 3-vector - `'matrix3x3` — a real 3x3 matrix - `'cvector3` — a complex 3-vector - `'cmatrix3x3` — a complex 3x3 matrix - `'boolean` — a boolean value, `true` or `false` - `'string` — a string - `'function` — a function (in C, a Guile SCM function pointer) - `'class` — an member of `class` - `(make-list-type el-type)` — a list of elements of type `el-type` - `'SCM` — a generic Scheme object Note that the quote before a type name is Scheme's way of constructing a **symbol**, which is somewhat similar to a C enumerated constant. The final argument is an optional sequence of constraints. Each constraint is a function that, given a value, returns `true` or `false` depending on whether that value is valid. For example, if an input variable is required to be positive, one of the constraints would be the `positive?` function (predefined by Guile). More complicated functions can, of course, be constructed. Here are a few examples: ``` (define-input-var dimensions 3 'integer positive?) (define-input-var default-epsilon 1.0 'number positive?) (define-input-var geometry '() (make-list-type 'geometric-object)) (define-input-var k-points '() (make-list-type 'vector3)) ``` Notice that all input variables have initial values, meaning that a user need not specify a value in the ctl file if the default value is acceptable. If you want to force the user to explicitly give a value to a variable, set the initial value to `'no-value`. This way, if the variable is not set by the user, it will fail the type-constraint and an error will be flagged. Such behavior is deprecated, however. Defining output variables ------------------------- Output variables, which are passed from the simulation to the ctl script, are defined in a manner similar to input variables: ```scm (define-output-var name type) ``` Notice that output variables have no initial value and no constraints. Your C program is responsible for assigning the output variables when it is called (as discussed below). A variable can be both an input variable and an output variable at the same time. Such input-output variables are defined with the same parameters as an input variable: ``` (define-input-output-var name value type [constraints]) ``` Defining classes ---------------- To define a class, one has to supply the parent class and the properties: ```scm (define-class name parent [ properties... ]) ``` `name` is the name of the new class and `parent` is the name of the parent class, or `no-parent` if there is none. The `properties` of the class are zero or more of the following definitions, which give the name, type, default value, and (optional) constraints for a property: ```scm (define-property name default-value type [ constraints... ]) ``` `name` is the name of the property. It is okay for different classes to have properties with the same name (for example, both a sphere and a cylinder class might have `radius` properties) — however, it is important that properties with the same name have the same type. The `type` and optional `constraints` are the same as for `define-input-var`, described earlier. If `default-value` is `no-default`, then the property has no default value and users are required to specify it. To give a property a default value, `default-value` should simply be that default value. For example, this is how we might define classes for materials and dielectric objects in an electromagnetic simulation: ```scm (define-class material-type no-parent   (define-property epsilon no-default 'number positive?)   (define-property conductivity 0.0 'number)) ``` ``` (define-class geometric-object no-parent   (define-property material no-default 'material-type)   (define-property center no-default 'vector3)) ``` ``` (define-class cylinder geometric-object   (define-property axis (vector3 0 0 1) 'vector3)   (define-property radius no-default 'number positive?)   (define-property height no-default 'number positive?)) ``` ``` (define-class sphere geometric-object   (define-property radius no-default 'number positive?)) ``` ### Derived Properties Sometimes, it is convenient to store other properties with an object that are not input by the user, but which instead are computed based on the other user inputs. A mechanism is provided for this called "derived" properties, which are created by: ``` (define-derived-property name type derive-func) ``` Here, `derive-func` is a function that takes an object of the class the property is in, and returns the value of the property. See below for an example. `derive-func` is called after all of the non-derived properties of the object have been assigned their values. ### Post-Processed Properties It is often useful to store a function of the user input into a property, instead of just storing the input itself. For example, you might want to scale an input vector so that it is stored as a unit vector. The syntax for defining such a property is the same as `define-property` except that it has one extra argument: ```scm (define-post-processed-property name default-value type process-func [ constraints... ]) ``` `process-func` is a function that takes one argument and returns a value, both of the same type as the property. Any user-specified value for the property is passed to `process-func`, and the result is assigned to the property. Here is an example that defines a new type of geometric object, a `block`. Blocks have a `size` property that specifies their dimensions along three unit vectors, which are post-processed properties (with default values of the coordinate axes). When computing whether a point falls within a block, it is necessary to know the projection matrix, which is the inverse of the matrix whose columns are the basis vectors. We make this projection matrix a derived property, computed via the libctl-provided matrix routines, freeing us from the necessity of constantly recomputing it. ```scm (define-class block geometric-object   (define-property size no-default 'vector3) ``` ```scm   ; the basis vectors, which are forced to be unit-vectors   ; by the unit-vector3 post-processing function:   (define-post-processed-property e1 (vector3 1 0 0) 'vector3 unit-vector3)   (define-post-processed-property e2 (vector3 0 1 0) 'vector3 unit-vector3)   (define-post-processed-property e3 (vector3 0 0 1) 'vector3 unit-vector3) ``` ```scm   ; the projection matrix, which is computed from the basis vectors   (define-derived-property projection-matrix 'matrix3x3     (lambda (object)       (matrix3x3-inverse        (matrix3x3         (object-property-value object 'e1)         (object-property-value object 'e2)         (object-property-value object 'e3)))))) ``` Exporting Your Subroutines -------------------------- In order for the ctl script to do anything, one of your C routines will eventually have to be called. To export a C routine, you write the C routine as you would normally, using the data types defined in ctl.h and ctl-io.h (see below) for parameters and return value. All parameters must be passed by value (with the exception of strings, which are of type `char *`). Then, in your specifications file, you must add a declaration of the following form: ``` (define-external-function name read-inputs? write-outputs? return-type [ arg0-type arg1-type ... ]) ``` `name` is the name of the function, and is the name by which it will be called in a ctl script. This should be identical to the name of the C subroutine, with the exception that underscores are turned into hyphens (this is not required, but is the convention we adopt everywhere else). If `read-inputs?` is `true`, then the input variables will be automatically imported into C global variables before the subroutine is called each time. If you don't want this to happen, this argument should be `false`. Similarly, `write-outputs?` says whether or not the output variables will be automaticaly exported from the C globals after the subroutine is called. All of this code, including the declarations of the C input/output globals, is generated automatically (see below). So, when your function is called, the input variables will already contain all of their values, and you need only assign/allocate data to the output variables to send data back to Guile. If `write-outputs?` is `true`, the output variables **must** have valid contents when your routine exits. `return-type` is the return type of the subroutine, or `no-return-value` if there is no return value (i.e. the function is of type `void`). The remaining arguments are the types of the parameters of the C subroutine. Usually, your program will export a `run` subroutine that performs the simulation given the input variables, and returns data to the ctl script through the output variables. Such a subroutine would be declared in C as: ``` void run(void); ``` and in the specifications file by: ``` (define-external-function run true true no-return-value) ``` As another example, imagine a subroutine that takes a geometric object and returns the fraction of electromagnetic energy in the object. It does not use the input/output global variables, and would be declared in C and in the specifications file by: ```  /* C declaration: */  number energy_in_object(geometric_object obj);  ; Specifications file:  (define-external-function energy-in-object false false                            'number 'geometric-object)   ``` ### Data Structures and Types The data structures for holding classes and other variable types are defined automatically in the generated file `ctl-io.h` (see below). They are fairly self-explanatory, but it should be noted that they use some data types defined in `src/ctl.h`, mostly mirrors of the corresponding Scheme types. (e.g. `number` is a synonym for `double`, and `vector3` is a structure with `x`, `y`, and `z` fields.) `ctl.h` also declares several functions for manipulating vectors and matrices, e.g. `vector3_plus`. ### Allocating and Deallocating Data The input variables are allocated and deallocated automatically, as necessary, but you are responsible for allocating and deallocating the output data. As a convenience, the function `destroy_output_vars()` is defined, which deallocates all of the output data pointed to by the output variables. You are responsible for calling this when you want to deallocate the output. Often, after each run, you will simply want to (re)allocate and assign the output variables. To avoid memory leaks, however, you should first deallocate the old output variables on runs after the first. To do this, use the following code: ``` if (num_write_output_vars > 0) destroy_output_vars(); /* ... allocate & assign the output variables ... */ ``` The global variable `num_write_output_vars` is automatically set to the number of times the output variables have been written. Remember, you are **required** to assign all of the output variables to legal values, or the resulting behavior will be undefined. Other Useful Things to Put in a Specifications File --------------------------------------------------- The specifications file is loaded before any user ctl file, making it a good place to put definitions of variables and functions that will be useful for your users. For example, the electromagnetic simulation might define a default material, `air`: ``` (define air (make material-type (epsilon 1.0))) ``` You can also define functions (or do anything else that Scheme allows), e.g. a function to duplicate geometric objects on a grid. (See the `examples/` directory of libctl for an example of this.) To change the Guile prompt in interactive mode to your own prompt, do: ``` (ctl-set-prompt! "my prompt string") ``` We defined our own function so that we have something that works in both Guile 1.x and 2.x. Writing your Program -------------------- Once the specifications have been written, you have to do very little to support them in your program. First, you need to generate C code to import/export the input/output variables from/to Guile. This is done automatically by the `gen-ctl-io` script in the `utils/` directory (installed into a `bin` directory by `make install`): `gen-ctl-io --code specifications-file` `gen-ctl-io --header specifications-file` The `gen-ctl-io` commands above generate two files, `ctl-io.h` and `ctl-io.c`. The former defines global variables and data structures for the input/output variables and classes, and the latter contains code to exchange this data with Guile. Second, you should use the `main.c` file from the `base/` directory; if you use the example `Makefile` (see below), this is done automatically for you. This file defines a main program that starts up Guile, declares the routines that you are exporting, and loads control files from the command line. You should not need to modify this file, but you should define preprocessor symbols telling it where libctl and your specification file are (again, this is done for you automatically by the example `Makefile`). For maximum convenience, if you are wisely using GNU autoconf, you should also copy the `Makefile.in` from `examples/`; you can use the `Makefile` otherwise. At the top of this file, there are places to specify your object files, specification file, and other information. The `Makefile` will then generate the `ctl-io` files and do everything else needed to compile your program. You then merely need to write the functions that you are exporting (see above for how to export functions). This will usually include, at least, a `run` function (see above). The default `main.c` handles a couple of additional command-line options, including `--verbose` (or `-v`), which sets a global variable `verbose` to 1 (it is otherwise 0). You can access this variable (it is intended to enable verbose output in programs) by declaring the global `extern int verbose` in your program. libctl-4.4.0/doc/docs/Guile_and_Scheme_Information.md000066400000000000000000000114371356267410600225470ustar00rootroot00000000000000--- # Guile and Scheme Information --- There are many places you can go to find out more regarding Guile and the Scheme programming language. We list a few of them here. [TOC] Scheme ------- Scheme is a simplified derivative of [Lisp](https://en.wikipedia.org/wiki/Lisp), and is a small and beautiful dynamically typed, [lexically scoped](https://en.wikipedia.org/wiki/Lexical_variable_scoping), [functional](https://en.wikipedia.org/wiki/Functional_programming_language) language. - A [history and introduction to Scheme](https://en.wikipedia.org/wiki/Scheme_programming_language) - [R5RS](http://www.swiss.ai.mit.edu/ftpdir/scheme-reports/r5rs-html/r5rs_toc.html) is the official Scheme language definition and reference. - A classic [introduction](ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/pubs/intro.txt) to Scheme by Ken Dickey. - [Structure and Interpretation of Computer Programs](http://mitpress.mit.edu/sicp/sicp.html) by Abelson, Sussman, and Sussman (full text online). - [Introduction to Scheme and its Implementation](ftp://ftp.cs.utexas.edu/pub/garbage/cs345/schintro-v14/schintro_toc.html) (the complete book on-line) by Prof. Paul R. Wilson ([Univ. of Texas](http://www.cs.utexas.edu/)). - [Teach Yourself Scheme](http://ds26gte.github.io/tyscheme/index.html) is a nice tutorial-style introduction to Scheme programming. - The [MIT Scheme Home Page](http://www.swiss.ai.mit.edu/projects/scheme/index.html) (where do you think Scheme was invented?) - also check out the MIT [Scheme Underground](http://www.ai.mit.edu/projects/su/su.html) - There is the [comp.lang.scheme](news:comp.lang.scheme) newsgroup, and its [FAQ](http://www.faqs.org/faqs/by-newsgroup/comp/comp.lang.scheme.html). - The [Internet Scheme Repository](http://www.cs.indiana.edu/scheme-repository/) has a lot of code and documentation. - [schemers.org](http://www.schemers.org/) is another Scheme site and collection of resources. Guile ------ Guile is a free/open-source implementation of Scheme, designed to be plugged in to other programs as a scripting language. - The [homepage](http://www.gnu.org/software/guile/) for the GNU Guile project. - See parts IV and V of the [Guile Reference Manual](http://www.gnu.org/software/guile/manual/html_node/index.html) for additional Scheme functions and types defined within the Guile environment. How to Write a Loop in Scheme ----------------------------- The most frequently asked question seems to be: **how do I write a loop in Scheme?** We give a few answers to that here, supposing that we want to vary a parameter *x* from *a* to *b* in steps of *dx*, and do something for each value of *x*. The classic way, in Scheme, is to write a [tail-recursive](https://en.wikipedia.org/wiki/Tail_call) function: `(define (doit x x-max dx)` `   (if (<= x x-max)` `      (begin` `         `*`...perform` `loop` `body` `with` `x...`* `         (doit (+ x dx) x-max dx))))` `(doit a b dx) ; execute loop from a to b in steps of dx` There is also a [do-loop construct](http://www.swiss.ai.mit.edu/ftpdir/scheme-reports/r5rs-html/r5rs_6.html#SEC36) in Scheme that you can use `(do ((x a (+ x dx))) ((> x b)) `*`...perform` `loop` `body` `with` `x...`*`)` If you have a list of values of *x* that you want to loop over, then you can use `map`: `(map (lambda (x) `*`...do` `stuff` `with` `x...`*`) `*`list-of-x-values`*`)` How to Read In Values from a Text File in Scheme ------------------------------------------------ A simple command to read a text file and store its values within a variable in Scheme is `read`. As an example, suppose a file *foo.dat* contains the following text, including parentheses: `(1 3 12.2 14.5 16 18)` In Scheme, we would then use `(define port (open-input-file "foo.dat"))` `(define foo (read port))` `(close-input-port port)` The variable *foo* would then be a list of numbers '(1 3 12.2 14.5 16 18). Libctl Tricks Specific to [Meep](https://meep.readthedocs.io) and [MPB](https://mpb.readthedocs.io) -------------------------------------------------------------------------------- libctl has a couple of built-in functions `arith-sequence` and `interpolate` (see the [User Reference](User_Reference.md)) to construct lists of a regular sequence of values, which you can use in conjunction with `map` as above: `(map (lambda (x) `*`...do` `stuff` `with` `x...`*`) (arith-sequence x-min dx num-x))` or `(map (lambda (x) `*`...do` `stuff` `with` `x...`*`) (interpolate num-x (list a b)))` Finally, if you have an entire libctl input file `myfile.ctl` that you want to loop, varying over some parameter *x*, you can do so by writing a loop on the Unix command-line. Using the [bash](https://en.wikipedia.org/wiki/bash) shell, you could do: ``for x in `seq a dx b`; do meep x=$x myfile.ctl; done`` libctl-4.4.0/doc/docs/Installation.md000066400000000000000000000217161356267410600174710ustar00rootroot00000000000000--- # Installation --- The main effort in installing libctl lies in installing the prerequisite packages. This requires some understanding of how to install software on Unix systems. The official releases of Libctl can be found on the [releases page on github](https://github.com/NanoComp/libctl/releases), and the changes in each version are summarized in the [NEWS file](https://github.com/NanoComp/libctl/blob/master/NEWS.md). [TOC] Installation on Linux ------------------------- For most [Linux distributions](https://en.wikipedia.org/wiki/Linux_distribution), there should be precompiled packages for most of libctl's prerequisites below, and we *highly* recommend installing those prerequisites using the available packages for your system whenever possible. Using precompiled packages means that you don't have to worry about how to install things manually. You are using packages which have already been tweaked to work well with your system, and usually your packages will be automatically upgraded when you upgrade the rest of your system. Guile is available as a precompiled package. One thing to be careful of is that many distributions split packages into two parts: one main package for the libraries and programs, and a **devel** package for [header files](https://en.wikipedia.org/wiki/Header_file) and other things needed to compile software using those libraries. You will need to install **both**. So, for example, you will probably need both a `guile` package (probably installed by default) and a `guile-dev` or `guile-devel` package (probably *not* installed by default). The easiest installation is on [Ubuntu](https://en.wikipedia.org/wiki/Ubuntu_(operating_system)) which has precompiled packages for libctl: ```sh apt-get install libctl-dev ``` Installation on macOS ----------------------- Since [macOS](https://en.wikipedia.org/wiki/macOS) is, at its heart, a Unix system, one can, in principle compile and install libctl and all its prerequisites just as on any other Unix system. However, this process is much easier using the [Homebrew](https://en.wikipedia.org/wiki/Homebrew_(package_management_software)) package to install most of the prerequisites, since it will handle dependencies and other details for you. You will need [administrator privileges](http://support.apple.com/kb/PH3920) on your Mac. The first steps are: - Install [Xcode](https://en.wikipedia.org/wiki/Xcode), the development/compiler package from Apple, free from the [Apple Xcode web page](https://developer.apple.com/xcode/). - Install Homebrew: download from the [Homebrew site](http://brew.sh/) and follow the instructions there. - Run the following commands in the terminal to compile and install the prerequisites. This may take a while to complete because it will install lots of other stuff first ```sh brew doctor brew install guile ``` Now, install libctl from source. ```sh ./configure && make && make install ``` Unix Installation Basics ------------------------ ### Installation Paths First, let's review some important information about installing software on Unix systems, especially in regards to installing software in non-standard locations. None of these issues are specific to libctl, but they've caused a lot of confusion among users. Most of the software below, including libctl, installs under `/usr/local` by default. That is, libraries go in `/usr/local/lib`, programs in `/usr/local/bin`, etc. If you don't have `root` privileges on your machine, you may need to install somewhere else, e.g. under `$HOME/install` (the `install/` subdirectory of your home directory). Most of the programs below use a GNU-style `configure` script, which means that all you would do to install there would be: ```sh ./configure --prefix=$HOME/install ``` when configuring the program. The directories `$HOME/install/lib` etc. are created automatically as needed. #### Paths for Running (Shared Libraries) Second, some packages are installed as shared libraries. You need to make sure that your runtime linker knows where to find these shared libraries. The bad news is that every operating system does this in a slightly different way. If you installed all of your libraries in a standard location on your operating system (e.g. `/usr/lib`), then the runtime linker will look there already and you don't need to do anything. Otherwise, if you compile things like `libctl` and install them into a "nonstandard" location (e.g. in your home directory), you will need to tell the runtime linker where to find them. There are several ways to do this. Suppose that you installed libraries into the directory `$HOME/install/lib`. The most robust option is probably to include this path in the linker flags: ```bash ./configure LDFLAGS="-L$HOME/install/lib -Wl,-rpath,$HOME/install/lib" ...other flags... ``` There are also some other ways. If you use Linux, have superuser privileges, and are installing in a system-wide location (not your home directory), you can add the library directory to `/etc/ld.so.conf` and run `/sbin/ldconfig`. On many systems, you can also specify directories to the runtime linker via the `LD_LIBRARY_PATH` environment variable. In particular, by `export LD_LIBRARY_PATH="$HOME/install/lib:$LD_LIBRARY_PATH"`; you can add this to your `.profile` file (depending on your shell) to make it run every time you run your shell. On MacOS, a security feature called [System Integrity Protection](https://en.wikipedia.org/wiki/System_Integrity_Protection) causes the value of `LD_LIBRARY_PATH` to be ignored, so using environment variables won't work there. ### Linux and BSD Binary Packages If you are installing on your personal Linux or BSD machine, then precompiled binary packages are likely to be available for many of these packages, and may even have been included with your system. On Debian systems, the packages are in `.deb` format and the built-in `apt-get` program can fetch them from a central repository. On Red Hat, SuSE, and most other Linux-based systems, binary packages are in RPM format. OpenBSD has its "ports" system, and so on. **Do not compile something from source if an official binary package is available.** For one thing, you're just creating pain for yourself. Worse, the binary package may already be installed, in which case installing a different version from source will just cause trouble. Guile ----- Guile is an extension/scripting language implementation based on Scheme, and we use it to provide a rich, fully-programmable user interface with minimal effort. It's free, of course, and you can download it from the [Guile homepage](http://www.gnu.org/software/guile/). Guile is typically included with Linux systems. - **Important:** Most Linux distributions come with Guile already installed. You can check by seeing whether you can run `guile --version` from the command line. In that case, do **not** install your own version of Guile from source — having two versions of Guile on the same system will cause problems. However, by default most distributions install only the Guile libraries and not the programming headers — to compile libctl, you should install the **guile-devel** or **guile-dev** package. ### Building From Source Here we provide instructions for building libctl from source on Ubuntu 16.04. Gzipped tarballs of stable versions are available on the [releases page](https://github.com/NanoComp/libctl/releases). ```bash #!/bin/bash set -e sudo apt-get update sudo apt-get -y install git guile-2.0-dev mkdir -p ~/install cd ~/install wget https://github.com/NanoComp/libctl/releases/download/v4.2.0/libctl-4.2.0.tar.gz tar xvzf libctl-4.2.0.tar.gz cd libctl-4.2.0/ ./configure --enable-shared LDFLAGS="-L/usr/local/lib -Wl,-rpath,/usr/local/lib" make && sudo make install ``` Libctl for Developers ------------------- If you want to modify the libctl source code, you will want to have a number of additional packages, most importantly: - The [Git](https://git-scm.com/) version-control system. Once you have Git, you can grab the latest development version of libctl with: ```sh git clone https://github.com/NanoComp/libctl.git ``` This gives you a fresh, up-to-date libctl repository in a directory `libctl`. See [git-scm.com](https://git-scm.com/) for more information on using Git; perhaps the most useful command is `git pull`, which you can execute periodically to get any new updates to the development version. Git will give you an absolutely minimal set of sources; to create a usable libctl directory, you should run: ```sh sh autogen.sh make ``` in the `libctl` directory. And subsequently, if you are editing the sources you should include `--enable-maintainer-mode` whenever you reconfigure. To do this, however, you will need a number of additional packages beyond those listed above: - GNU [autoconf](https://www.gnu.org/software/autoconf/autoconf.html), [automake](https://www.gnu.org/software/automake/), and [libtool](https://www.gnu.org/software/libtool/libtool.html) — these are used to create the Makefiles and configure scripts, and to build shared libraries.libctl-4.4.0/doc/docs/Introduction.md000066400000000000000000000055101356267410600175030ustar00rootroot00000000000000Scientific software for performing large computations is typically managed using textual control files that specify the parameters of the computation. Historically, these control files have typically consisted of long, inflexible collections of numbers whose meaning and format is hard-coded into the program. With **libctl**, we make it easy for programmers to support a greatly superior control file structure, and with less effort than was required for traditional input formats. The "ctl" in "libctl" stands for *Control Language*. By convention, libctl control files end with ".ctl" and are referred to as ctl files. Thus, libctl is the *Control Language Library* where the "lib" prefix follows the Unix idiom. Design Principles ----------------- The libctl design has the following goals: - **Input readability** The control file should be self-annotating and human-readable (as opposed to an inscrutable sequence of numbers). Of course, it should allow comments. - **Input flexibility**: The control file should not be sensitive to the ordering or spacing of the inputs. - **Input intelligence** The user should never have to enter any information that the program could reasonably infer. For example, reasonable defaults should be available wherever possible for unspecified parameters. - **Program flexibility**: It should be easy to add new parameters and features to the control file without breaking older control files or increasing complexity. - **Scriptability** Simple things should be simple, but complex things should be possible. The control file should be more than just a file format. It must be a programming language, able to script the computation and add new functionality without modifying the simulation source code. - **Programmer convenience**: All of this power should not come at the expense of the programmer. Rather, it should be easier to program than ever before — the programmer need only specify the interaction with the control file in an abstract form, and everything else should be taken care of automatically. All of these goals are achieved by libctl with the help of [Guile](https://en.wikipedia.org/wiki/GNU_Guile), the [GNU](https://en.wikipedia.org/wiki/GNU) scripting and extensibility language. Guile does all of the hard work for us, and allows us to embed a complete interpreter in a program with minimal effort. Despite its power, libctl is designed to be easy to use. A basic user only sees a convenient file format with a programming language to back it up if needs become more complex. For the programmer, all headaches associated with reading input files are lifted — once an abstract specification is supplied, all interaction with the user is handled automatically. In the subsequent sections of this manual, we will discuss in more detail the interaction of the user and the programmer with libctl. libctl-4.4.0/doc/docs/License_and_Copyright.md000066400000000000000000000033621356267410600212610ustar00rootroot00000000000000--- # License and Copyright --- libctl is copyright © 1998—2019, Steven G. Johnson. libctl is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. You can also find it on the GNU web site: [http://www.gnu.org/copyleft/gpl.html](http://www.gnu.org/copyleft/gpl.html) Many of the files in libctl are individually licensed under the terms of the GNU Lesser General Public License; either version 2 of the License, or (at your option) any later version. This is indicated by the licensing comments at the top of each file. There are a few files in libctl that we place in the public domain, which are not restricted by the terms of the GPL or LGPL; these files explicitly indicate this fact at the top of the file. *All files fall under the GPL unless they expressly say otherwise.* The files `src/integrator.c` and `src/cintegrator.c` contain multi-dimensional numeric integration code that was adapted in part from [HIntLib](http://mint.sbg.ac.at/HIntLib/) by Rudolf Schuerer and from the [GNU Scientific Library](https://en.wikipedia.org/wiki/GNU_Scientific_Library) by Brian Gough. Both of these libraries are licensed under the GNU GPL, version 2 or later. libctl-4.4.0/doc/docs/User_Reference.md000066400000000000000000000327421356267410600177250ustar00rootroot00000000000000In this section, we list all of the functions provided for users by libctl. We do *not* attempt to document standard Scheme functions, with a couple of exceptions below, since there are plenty of good Scheme references. Of course, the most important function is: ``` (help) ``` Outputs a listing of all the available classes, their properties, default values, and types. Also lists the input and output variables. Remember, Guile lets you enter expressions and see their values interactively. This is the best way to learn how to use anything that confuses you — just try it and see how it works. [TOC] Basic Scheme Functions ---------------------- ``` (set! variable value) ``` Change the value of `variable` to `value`. ``` (define variable value) ``` Define new `variable` with initial `value`. ``` (list [element1 element2 ...]) ``` Returns a list consisting of zero or more elements. ``` (append [list1 list2 ...]) ``` Concatenates zero or more lists into a single list. ``` (function [arg1 arg2 ...]) ``` This is how you call a Scheme `function` in general. ``` (define (function [arg1 arg2 ...]) body) ``` Define a new `function` with zero or more arguments that returns the result of given `body` when it is invoked. Command-Line Parameters ----------------------- ``` (define-param name default-value) ``` Define a variable `name` whose value can be set from the command line, and which assumes a value `default-value` if it is not set. To set the value on the command-line, include `name=value` on the command-line when the program is executed. In all other respects, `name` is an ordinary Scheme variable. ``` (set-param! name new-default-value) ``` Like `set!`, but does nothing if `name` was set on the command line. All libctl arguments accept the command-line parameter `--verbose` to turn on a verbose mode. This sets the variable `verbose?` to `true` (and, depending on the program, may enable other outputs). Complex Numbers --------------- Scheme includes full support for complex numbers and arithmetic; all of the ordinary operations (`+`, `*`, `sqrt`, etcetera) just work. For the same reason, you can freely use complex numbers in libctl's vector and matrix functions, below. To specify a complex number *a*+*b*i, you simply use the syntax `a+bi` if *a* and *b* are constants, and `(make-rectangular a b)` otherwise. You can also specify numbers in polar format a\*eib by the syntax `a@b` or `(make-polar a b)`. There are a few special functions provided by Scheme to manipulate complex numbers. `(real-part z)` and `(imag-part z)` return the real and imaginary parts of `z`, respectively. `(magnitude z)` returns the absolute value and `(angle z)` returns the phase angle. libctl also provides a `(conj z)` function, below, to return the complex conjugate. 3-Vector Functions ------------------ ``` (vector3 x [y z]) ``` Create a new 3-vector with the given components. If the `y` or `z` value is omitted, it is set to zero. ``` (vector3-x v) (vector3-y v) (vector3-z v) ``` Return the corresponding component of the vector `v`. ``` (vector3+ v1 v2) (vector3- v1 v2) (vector3-cross v1 v2) ``` Return the sum, difference, or cross product of the two vectors. ``` (vector3* a b) ``` If `a` and `b` are both vectors, returns their dot product. If one of them is a number and the other is a vector, then scales the vector by the number. ``` (vector3-dot v1 v2) ``` Returns the dot product of `v1` and `v2`. ``` (vector3-cross v1 v2) ``` Returns the cross product of `v1` and `v2`. ``` (vector3-cdot v1 v2) ``` Returns the conjugated dot product: *v1*\* dot *v2*. ``` (vector3-norm v) ``` Returns the length `(sqrt (vector3-cdot v v))` of the given vector. ``` (unit-vector3 x [y z]) ``` ``` (unit-vector3 v) ``` Given a vector or, alternatively, one or more components, returns a unit vector in that direction. ``` (vector3-close? v1 v2 tolerance) ``` Returns whether or not the corresponding components of the two vectors are within `tolerance` of each other. ``` (vector3= v1 v2) ``` Returns whether or not the two vectors are numerically equal. Beware of using this function after operations that may have some error due to the finite precision of floating-point numbers; use `vector3-close?` instead. ``` (rotate-vector3 axis theta v) ``` Returns the vector `v` rotated by an angle `theta` (in radians) in the right-hand direction around the `axis` vector (whose length is ignored). You may find the functions `(deg->rad theta-deg)` and `(rad->deg theta-rad)` useful to convert angles between degrees and radians. ``` (vector3->exact v) ``` Round a vector3 *v* to the nearest "exact" representation in Scheme: an integer or a rational number. This is mainly useful if you have an all-integer vector and you want to force Guile to treat it as integers rather than floating-point numbers. 3x3 Matrix Functions -------------------- ``` (matrix3x3 c1 c2 c3) ``` Creates a 3x3 matrix with the given 3-vectors as its columns. ``` (matrix3x3-transpose m) (matrix3x3-adjoint m) (matrix3x3-determinant m) (matrix3x3-inverse m) ``` Return the transpose, adjoint (conjugate transpose), determinant, or inverse of the given matrix. ``` (matrix3x3+ m1 m2) (matrix3x3- m1 m2) (matrix3x3* m1 m2) ``` Return the sum, difference, or product of the given matrices. ``` (matrix3x3* v m) (matrix3x3* m v) ``` Returns the (3-vector) product of the matrix `m` by the vector `v`, with the vector multiplied on the left or the right respectively. ``` (matrix3x3* s m) (matrix3x3* m s) ``` Scales the matrix `m` by the number `s`. ``` (rotation-matrix3x3 axis theta) ``` Like `rotate-vector3`, except returns the (unitary) rotation matrix that performs the given rotation. i.e., `(matrix3x3* (rotation-matrix3x3 axis theta) v)` produces the same result as `(rotate-vector3 axis theta v)`. Objects (Members of Classes) ---------------------------- ``` (make class [ properties ... ]) ``` Make an object of the given `class`. Each property is of the form `(property-name property-value)`. A property need not be specified if it has a default value, and properties may be given in any order. ``` (object-property-value object property-name) ``` Return the value of the property whose name (symbol) is `property-name` in `object`. For example, `(object-property-value a-circle-object 'radius)`. Returns `false` if `property-name` is not a property of `object`. Miscellaneous Utilities ----------------------- ``` (conj x) ``` Return the complex conjugate of a number `x` (for some reason, Scheme doesn't provide such a function). ``` (interpolate n list) ``` Given a `list` of numbers or 3-vectors, linearly interpolates between them to add `n` new evenly-spaced values between each pair of consecutive values in the original list. ``` (interpolate-uniform n list) ``` Similar to `interpolate`, but attempts to maintain a (roughly) uniform average spacing of the points in the interpolated list. In this case `n` is only the number of points interpolated *on average* between each pair of values in the original list. ``` (print expressions...) ``` Calls the Scheme `display` function on each of its arguments from left to right (printing them to standard output). Note that, like `display`, it does *not* append a newline to the end of the outputs; you have to do this yourself by including the `"\n"` string at the end of the expression list. In addition, there is a global variable `print-ok?`, defaulting to `true`, that controls whether `print` does anything; by setting `print-ok?` to false, you can disable all output. ``` (begin-time message-string statements...) ``` Like the Scheme `(begin ...)` construct, this executes the given sequence of statements one by one. In addition, however, it measures the elapsed time for the statements and outputs it as `message-string`, followed by the time, followed by a newline. The return value of `begin-time` is the elapsed time in seconds. ``` (minimize function tolerance) ``` Given a `function` of one (number) argument, finds its minimum within the specified fractional `tolerance`. If the return value of `minimize` is assigned to a variable `result`, then `(min-arg result)` and `(min-val result)` give the argument and value of the function at its minimum. If you can, you should use one of the variant forms of `minimize`, described below. ``` (minimize function tolerance guess) ``` The same as above, but you supply an initial `guess` for where the minimum is located. ``` (minimize function tolerance arg-min arg-max) ``` The same as above, but you supply the minimum and maximum function argument values within which to search for the minimum. This is the most preferred form of `minimize`, and is faster and more robust than the other two variants. ``` (minimize-multiple function tolerance arg1 ... argN) ``` Minimize a `function` of N numeric arguments within the specified fractional `tolerance`. `arg1` ... `argN` are an initial guess for the function arguments. Returns both the arguments and value of the function at its minimum. A list of the arguments at the minimum are retrieved via `min-arg`, and the value via `min-val`. ``` maximize, maximize-multiple ``` These are the same as the `minimize` functions except that they maximize the function instead of minimizing it. The functions `max-arg` and `max-val` are provided instead of `min-arg` and `min-val`. ``` (find-root function tolerance arg-min arg-max) ``` Find a root of the given `function` to within the specified fractional `tolerance`. `arg-min` and `arg-max` **bracket** the desired root; the function must have opposite signs at these two points. ``` (find-root-deriv function tolerance arg-min arg-max [arg-guess]) ``` As `find-root`, but `function` should return a `cons` pair of (*function-value . function-derivative*); the derivative information is exploited to achieve faster convergence via Newton's method, compared to `find-root`. The optional argument `arg-guess` should be an initial guess for the root location. ``` (derivative function x [dx tolerance]) (deriv function x [dx tolerance]) (derivative2 function x [dx tolerance]) (deriv2 function x [dx tolerance]) ``` Compute the numerical derivative of the given `function` at `x` to within *at best* the specified fractional `tolerance` (defaulting to the best achievable tolerance), using Ridder's method of polynomial extrapolation. `dx` should be a *maximum* displacement in `x` for derivative evaluation; the `function` should change by a significant amount (much larger than the numerical precision) over `dx`. `dx` defaults to 1% of `x` or 0.01, whichever is larger. If the return value of `derivative` is assigned to a variable `result`, then `(derivative-df result)` and `(derivative-df-err result)` give the derivative of the function and an estimate of the numerical error in the derivative, respectively. The `derivative2` function computes both the first and second derivatives, using minimal extra function evaluations; the second derivative and its error are then obtained by `(derivative-d2f result)` and `(derivative-d2f-err result)`. `deriv` and `deriv2` are identical to `derivative` and `derivative2`, except that they directly return the value of the first and second derivatives, respectively (no need to call `derivative-df` or `derivative-d2f`). They don't provide the error estimate, however, or the ability to compute first and second derivatives simulataneously. There are also modified versions of these functions that compute *one-sided* derivatives: they only evaluate the function at arguments *x* that are ≥0 (or only ≤0). These functions are named `derivative+`, `deriv+` etc. (or `derivative-` etc. for negative arguments) and otherwise behave identically. They are generally less accurate than the two-sided derivative, above, but are useful for functions with discontinuous derivatives. ``` (integrate f a b relerr [ abserr maxeval ]) ``` Return the definite integral of the function `f` from `a` to `b`, to within the specified relative error `relerr`, using an adaptive Gaussian quadrature (in 1d) or adaptive cubature (in multiple dimensions). The optional arguments `abserr` and `maxeval` specify an absolute error tolerance (default is zero) and a maximum number of function evaluations (default is no limit). Integration stops when *either* the relative error *or* the absolute error *or* the maximum number of evaluations is met (note that error estimates are only approximate, though). This function can compute multi-dimensional integrals, in which case `f` is a function of *N* variables and `a` and `b` are either lists or vectors of length *N*, giving the (constant) integration bounds in each dimension. Non-constant integration bounds, i.e. non-rectilinear integration domains, can be handled by an appropriate mapping of the function `f`. ``` (fold-left op init list) ``` Combine the elements of `list` using the binary "operator" function `(op x y)`, with initial value `init`, associating from the left of the list. That is, if `list` consist of the elements `(a b c d)`, then `(fold-left op init list)` computes `(op (op (op (op init a) b) c) d)`. For example, if `list` contains numbers, then `(fold-left + 0 list)` returns the sum of the elements of `list`. ``` (fold-right op init list) ``` As `fold-left`, but associate from the right. For example, `(op a (op b (op c (op d init))))`. ``` (memoize func) ``` Return a function wrapping around the function `func` that "memoizes" its arguments and return values. That is, it returns the same thing as `func`, but if passed the same arguments as a previous call it returns a cached return value from the previous call instead of recomputing it. libctl-4.4.0/doc/docs/images/000077500000000000000000000000001356267410600157445ustar00rootroot00000000000000libctl-4.4.0/doc/docs/images/libctl-logo.png000066400000000000000000000303741356267410600206700ustar00rootroot00000000000000‰PNG  IHDR݃‹„Ü pHYsbb††0®IDATxÚíý{t\å}îqˆ4MzÚ&4…kÏý>³ç¢ÑŒFÝ5º[w[¶e[–ƶlmlËXL,°Hñ…¤B€€»‡mÂ9iÀ\Ü”‡&´N9P.'¡$nÖ‚T±³Ú•Ì_ûlE®ìHb´gæ÷î™yçùî'ÿí%Ïzµòa<ÖÒ.ò¬ãwsˆ6oÀK>·ßíñˆM+;ZÚ»h×ÜÖáö‰Þ€—Å.[¸¼¢¥½‹|ÕµuNÑî xÉ'‰‡å•þ¡$áB–_.é/¾¨-»õ;S^:A»›ŸübQUeß=ߎ>ü&íx¥8Ò²þØ-^:A¾ÎýC•½[£¿I¾îƒù«Ê÷={ß—NÐnß³_õ–ù· J.Ägyä2PæeO|ø¡% â³|q(sƒ²Pº!R —Çå…Ë@™'”¯ïëˈïøw(s†2\FÜǹË@™?”á2â>ž]Ê\¢ —÷që2Pæe¸Œ¸O—2Ç(ÃeÄ}º ”ùF.#îãÍe Ì=ÊpqW.å|@.#îãÇå{î™Êù€2\FÜljËÇ Ô–å|@.#îãÁe œW(ÃeÄ}9ï2PÎ7”á2â¾Üv(ç!Êpq_» ”óe¸Œ¸/W]Êy‹2\FÜ—“.ÊyŒ2\FÜ—{.eNP.-*,/¹¾¯'…ÁeÄw9æ2PÊpq_.¹ ”2\FùPθ ”2\FyRn¸ ”2\FùS¸ ”2\FyU¶» ”2\FùVV» ”2\FyXöº ”2\FùY–º ”2\Fy[6º ”2\Fù\Ö¹ ”2\Fy^v¹ ”2\F(‹\Ê@.#$eË@(Ãe„æÊ —2P†ËÍ—y—2P†Ë]]†]Ê@.#´ Lº ”2\FhqsùðáC@Y-”ÿ'#”÷~kR}”á2â¾Ì¸|èÏ?_Tý»¯xéíd”½á²5ÇNE~“v³(×5õÞ±óÀK'È'£\Ö¾>:õFôá7i'£ì- î}jòÀK'h'£ìò‹…©<8.#”  ¸ ”2\F(Aj» ”rúƒËˆïTu(e’ÁeÄwê¹ ”2Õà2â;•\Ê@™ppñ.e L;¸ŒøŽ¹Ë@(“.#¾cë2PÊ,—ß1t(eFƒËˆïX¹ ”2»ÁeÄwL\Ê@™éà2â;z—2Pf=¸ŒøŽØe  ”U\F|Gé2PÊê .#¾#s(eÕ—ßѸ ”²šƒËˆï\Ê@YåÁeÄwéº ”²úƒËˆïÒrùÏ2PÎÄà2â»Ô]ÊÜ ¼¢<—P†ËˆûRt(å .#¾KÅe  ”3;¸Œø.i—2PÎøà2â»ä\Ê@9—ß%á2PÊY2¸ŒøN©ËÆe.Pvå:ÊpqŸ"—2PΪÁeÄwË» ”r¶ .#¾[Æe  ”³ppñ]"—2PÎÎÁeÄwé2PÊY;¸Œøni—2PÎæÁeÄwK¸ ”r–.«Ü¥‹% —z-t(eÂÝP_­Ó ‚ÇG<·Wëpè5+Êk#‘¶nÚÕ­ì4Ù¬ZOë-"Ÿüš]nw¤­›|ášz½^«õÑÏn—_öíc$ —JýŽË@(NFYcwüÞwŒLÐîc;™JÂÑûOž¹H»}ßþÀS×úéî‚‘ ò]×±¡tUtôÅ_Žž¹H»ûž3Ë>¶ó΂‘ ÚÉß>ù›hÐJ.õºâ2PÊ„ËE”oya(ÿÎQßôyù›hÕ”™ôfIÂ¥^—]Ê@™p9‰òwfü­½Ÿî,™ C”ï^>&(ï8$8]2ʢЗUnÖe  ” —»(_Ëå?é ­dò–GΘ½SžEYœC.«_AC}^³¢¤©"ÜYG¼Ž:«Ã¬m+k^C¼¦Õf«Ñb3†;ëÈç«(‹ýeÍkÈç-©”º¸6î¬#^G|@9+QŽ2D9PÊ託hÕ†çP†ËêWÐÑÕ~m¯ç±ròýᶠ¾¸ÄÑ£_ã-Z‡é±r»¡Ìa¯ÙîhŠ‘ÏìüL§û±ròýÁÞ2­]}_Of”¹D.«_Á¦Í´=Xðåzòýþ핆P«g’Å4GÁ—ëYì³ >GËAWÏ$ùlÕÛ?5è/ør=ù®™¨Ó: ×÷õdp@™W”á²úÁe¸L°?k¬œ.FR0Byÿ‹»ú¯eóÓ2Ê%]ý,PÞúÈ÷¡|Í®» ]îÅ(ÃeõƒËp9ÝÍ¢,zýë;”Kz>Ó¾¾`d‚|2ÊÅ+×ìÿÎ…Ñ3i'£l–±BYôXµ¥¢Ð'ÂåL—á2P¦(ÃeõƒËp(“K”á²úÁe¸ ”iöéÞ!F(o쬙ÝgÊnob”á²úÁe¸œÊ Õ9‡²¼ÒÞ­ŒPþÔšm~–(|ûí#´»f÷ÑB·Ï¢/…>.gSp.§†²;çP.ß°ãºÎ#äcŠ²%XÆå¾b%(ÃeõƒËp(e¸œ]Áe¸œ ÊÍuzƒÎR²UFˆW^£3-¡J[e„xƒ^k²Xl•ò™ýAÕ*ÿé©…_Ùë7˜ ÀV!^ED+µb”á²úÁe¸¬tŸíl±ùŠ†ÿ×GÏ\¤ÝîSÿæW²wÁÈùV4t6=s‘|«ï:¡­j(Ø{¼`d‚v¿¿%&¿SÞñ7FÏ\¤Ý-ß™ µ¬Ò-¢Ð§|pYåà2\Êù…ògVi¬¢(ô)\V9¸ —r~¡\02 —³<¸ ——GÙîåœG¹uÕgWË(Ãåì.ÃåePvB,¤Ê*£|}KßÊp9ûƒËp(çÊp9ûƒËp(çÊp9ûƒËpYU”÷>ÞYYŸs(÷ÞuR[aòÇ·Ýf))gqÔ…2\Îþà2\Ve±¦ù6í)™ S”õáškv-™ Œ²µ´’ÅQ'@.gp.åüB.gp.åüB.gp.åüB.gp.åüB.gp.åüB.gp9ß]Ê ¼çÙWŽ2\Îþàr^»üg Õ:£Þ®±UFhg-)7 fÑc«ŒOow‹übâʈÑn7赶²*[e„vÖÒ FGm ”êôšÏÖuŒL*\Îòàrþº<û䧋ÑÓ¶ãüMÔkVŒL*\Îòàržº ”¹AÙª)Ó™œ#“Ê—³<¸œ.延{Ða…2£§YÏ£,» —9 .çË@y1ʾ†(o}ä{æâk”á2Áåür(/FÙßÚËâiÖ2ʦ¢€ (Ãeþ‚Ëyä2Pæe¸Ì_p9_\ʼ¢ —ù .ç…Ë7D*¡,Ka U°@yÿ‹–­Ùr]ûú‚‘ ò}¦c#”·Ó¾¾˜ÊRFG=‹²¶lI7á2gÁeÎ]ÊÜ£ —ù .óì2PΔá2Áen]Ê‹Q´­còÀýÏ›ŠCŒŽzY”á2Áe>]Ê ö§JzF_üå虋´¸ï9£?È訕  —ù .sè2P^°ë:6”®Š²B¹(À訢 —ù .óæ2PÎ7”á2Áe®\¾¡©Ö`2XƒeŽªâUÔéLFS¨ÂZ^G;K¸F¯Ya¶ÛU ä3yý:›ÍZ^G>£Ýa4êí¡ GUñ*ëµ&£r”á2Áe~\þ³öF»¿˜Åã0vŸú7G¸ú“ý» F&ˆ·÷îšæÈðØ虋äkÞ{Dþâé¾Â¥öý{%á]û¯£g.Ònß·?(®mÖ™¢Ð§|p™³à2/.Ûõ@Y%”7íeŠòu«W±(ô)\æ,¸ÌƒËŸÜvx|@Y”?1x‹½´’)ʲ›p9σË9ïò'”Û‚~ <¿öYXÝT02A>uP†Ë.ç¶Ë³(—å+ë¸í+šŠHÁÞã#´S e¸Œàr» ”¹D.#¸œ«.e^Q†Ë.ç¤Ë9‰òÈÄŠúöú›Žž¹H>v(ÿþ–˜-T¡&ÊpÁåÜs9WQnèl9:zæ"ùØ¢\fqÔ P†Ë.ç˜Ë@™{”á2‚˹ä2PΔá2‚Ë9ãò'TÚCARä(Ê«î|XS^›s(êZ£ —\Î —e”åe,þõ)GQ^}× mYõ5»ŒLÐîãCcV–(ÿik_ÁÈd\F\Η²z(o»ÍZZ™Y”á2‚ËÙî2Pæå=Ïü»r”á2‚ËYíòm+Ñ™Möò:GUíl¡ ƒÉhr8¬åuäÓÙl&ÐQÕ@>³Û«×¬°0ø5ÐÖP¥Îd´—×:ªhg/«Òt××µŒL*\Îóàröº,£,¸=ÛygÁÈíØ=yD^ù†×un,™ ߧÖlóÕ·ïûûŸž¹H»›¾þºüNùãÛo/™ ü¾~…¯X¯×ŒL*\Îóàr–º ”¹AÙ¢/×™½#“Ê—ó<¸œ.ÿñ–€ åGy×]…n¯Œò¬›p%\Î:—2'(‹—Q†Ë(Ùàrv¹ ”yAÙcÕ†ç]ƒË(©àr¹ ”¹D.£dƒËÙâ2Pæe¸Œ’ .g…ËŸ(D7#”A&(ïñò5[¯k__02A¾?îò²Ayûcg­¡ (ËG]èr/F.£dƒË™wYFYãpüÞwŒLÐî·(— Ü÷ü虋´“Q.]5x}Ëê‚‘ òÉ({"mŒP¶ËX¡ì­ºð’®Áe”Tp9Ã.eîQVÇåkvÜý‡½7ý5;•Lc¶9„Å«7éo½õ&‹=óÌÓO?õ-ûæ7ÿ÷?üÃKo½õ&ùþé_~ú©o±Ø·¾ù¾2ùå_~ø!\ΤË@9PVÇeÍ8\ÜÕR´†’] !%»1ÔkVtux??ÞI¾uÝ¡juwS)ùZ‹^‡á@låçÇ;iwàÖ•~§qGCÉî¦RÚÝܲê =NËo~ýk¸œ1—2( NWb”Ù»Üt˜žÚÚ9=¥ÝÏ>78Xïò‰µñxŒ|“÷´ 7ÏE§©÷íí=Ý ž>ØÇh÷þû{Ûkŧõ{¢•.³]'¹ëN|Ž‘1—2(Ëß¾Y”µe¢Ð'fÌåÞ‡…Ê ü»(×1D¹Ûiîr™î>v.gÆe Ì Êv»”YºÌåÚ¢“õÄã1ò1E¹µÚuþüîxQ†Ëp.ç¨Ë«ü6&?'K1Ü|ð+ñxŒ|ìPþÞŽÞæ '#”Wµ0AY^½×¶e¸ —ár.ºÌåÉ/´Åã1ò±FùwvÆã1Ú1E¹ÁkëZ e¸ —árι ”9G.Ãe¸œ[.eþQ†Ëp.çË9‰ò7žX»¡¶ˆÊåLP¾ti_‡ÿ‰Á¶é±(ù—C.Ãe¸œ+.÷0D¹>øå»WÆã1òÉ(¯­öž‹ LEi'£ÜXæ`„òúNÿ‰-ÓcQò)A.Ãe¸œ.Ë(Ù¡|ä`C<#S”ëJìo¾1Çh7‹r—ÿĦL¢ —á2\Îv—]BÏj||SëÛ£ý´ûÑþ[j‹?‹\¸°|'^ÕQæz}dÃÛ£ý´{v[wMÐþOÿ¸õÂ…}´{÷Ý›W·ù¾²¶áíÑ~ò-û™2\†Ëp™f*¸ì4›ZkÄÍk‚ä«(²T{­ƒMÅäs[u^‡~ÓªÀæ5AÚ­m+²ê…‘¢Á¦bÚ­«óé5+«œ›×ÉW´6ÚŒãAQáà2\†ËYêò5»¿äõZŸx|M<£Ý¯}뮡ò;º*§Ç¢ä{tcK_§ÿW¿ÚÇh÷ÆëÃu%ö—vôNEiw.6°¶ÊËèw™þõãkÊ‹ôEëxPT8¸ —ár6º,£ì¬,{âñÞxòM¬ª[Õêýño:wníþæ¯×Tø,/ ¯zeOíþn¸§5ìzö™çÎí¢ÝO~²ëŽƒõ QNÖå s¹¨9õôSp.Ãeu\ö¸,ú­ m!òé5+j¶=[+È·®Í_dÕïl ‘¯ÚguÛtÛ7–îÙZA»›Â~»a{spg[ˆv7­,±ê =vB”“rYF¹£T8<`<ýüsp.Ãe\îñÛ ,%oßÊ2VN}|ÍÚ*&ƒzjKg{­øÁ{ãñíÞowƒçÛÃ=ÓcQÚýìsÑ°ÃäÐ S»„™)¥SèòÊçŽFá2\†Ëj¸ÌðÁ©{[K¡üø_­ÊWu¹Ã´Òn\ã²Üv2B¹#,>ó-úÿþÉûâVvÖ%B9e—¢œ‚Ë·¬6ÜwïWà2\†ËK üâwãñíd”wm Oô2AyjcóºNÿ¯~µ?ÑŽÊçb=î'ÿ†Éï2•Qî¨1%F95—Gº”¢œ¬Ë/ôšGïº.Ãe¸¬Êã•ÓcQò=Úß²¾‹Êu%ö—vôNEi7û ¦«½™E9—kmúR«R”“rYF¹Ü©‰Ø w; —á2\žßΠÇ÷ì3/\ØG»ÿø‘í¥#Í¥oö“ï«ëÖ¶MOï¹paí~ðý-~ËsCÝoöÓîÕ½ëWWz;¹úÂ…}´“z÷®J…('ëò ÏRé®~¾5•Ës(ø].\†Ëpy~ÃN“n}­o°©˜v›üò_NCE¦Ík‚ä댸E³n°±x°‰x5~›Q[¸ªÅ·yMvƒ«~»¡·Ò3ØTL>«®Ðe¢œ”Ë2Ê]eÂÄ ½Ëó(Ë÷Ãe¸ —¯ °›žfð8¨÷D‡‚GîhŒÇcäûÆãkÖVyÏŦǢ´ûÞŽÞºû›o Çã1Ú]º´¿¯Ãb#ýï2•ºF´”›u{Ú53S‚Â)tyåó\y¾5•ËW£ —á2\žßv ÌÊÝNó°×¾—Úå->kçoQž™"vyÊp.Ãå¹mʪ¡¼±«øñ•ÓcQÚÍ£,»FîòÏÚþý«—ï'ty1Êp.Ãe ¬Ê¿¸°ou‹ïëÑöé±(í䣮t™çP&wyÊ„./‰2\†Ëp(«‡rO“W”i]^Œ2•Ë2Ê.a1Êp.ç¹Ë@™C” ]^e—  —ár>» ”såócK LåòG¡œ¾Ë‰Q†Ëp9o]Þæ·1AYÞÈʲ‰ÃÍñxŒ|ßxbíÚj&(ÿÓÍkÛªDF(¯iõ=Éeyµnk×"”I\N€rš./‹2\†Ëùéò,ÊO±AyßʲÉ/´Åã1ò1E¹£Z|çñxŒvs(Ÿêš‹’ï£PNßåÄ(§ã²”á2\ÎC—2ç(§éòvŸ­9å”]Vˆ2\†Ëùæ2Pæåt\öÙê‹„w&…™)ÖåãƒJQ†Ëp9¯\Ê*¡üþû{;#n(¿w Zå2'F9e—¢œ‚Ë-vSЦe¸ —óÇe ¬Êunÿ¦:÷#qË¢œšËA‹F!Êɺ¼»Èá·ëDËxPT8¸ —óÁePV åîÏ·‡{¦Ç¢´»Œ²ky”Spùø à0*D9)—e”+\Âç×+½.Ãå¼pù·>í³êßÔúöh?í~¼¿oké=GZ.\ØG¾ïëj+u½>²áíÑ~Ú}oGo[•øÚkÛ/\ØG»7ß¼±¥ÊõÍÍoöÓîGû7*G9Y—Ÿ¹M°ê ‡›•Þ¯Üå9”_ý‚Òûá2\ΗÍF}Ðj;Lä+±ývCuØ–Ü*ìË®¼Ôf3hʦ0ƒyÌ:ùë_þ³¾ær[}µkÙ¹,Ú ÍPî0‘¯Øj(1éƃ¢Â)wYF¹Â¡ôØÞ¯Üåy”Sø<úŠË6mø“UîOŽ†É÷Ç[ŠõÅ!GÃ(‹iíÆOŽ†YlEÈf¯r4Œ’ÏZ²úº:;\VÇeO t(ä9Y ß xx¨øÒéN« '«,Öä3]:ÝÉbòiÈg’þ+\¼[bµE?N¡ËßÂM,àRx¿r—¯F9-—§¦lloníi§_wÛæ­[î<|„ÅVv¬líig±•Ýícc·ßyøùFFöUGªM\†Ëp9c.ý!lŸE9ÙÏ=–uvÊi¹,ÿ©ÖÏž5kâµûX .Ãe¸œØYå*‡ö@@éýÊ]^Œ2\Ιà2\†Ë™ryÊ„./‰2\Ιà2\†Ëqy1ÊT.Ë(Wº—@.çLp.Ãeõ]>¹{ ”I\N€2\Ιà2\†Ë*»|âæÙ‰[Œrú.'F.çLp.Ãe5]N€rš./‹2\Ιà2\†Ëª¹œåt\V‚2\Ιà2\†Ëê¸üÈ.¡r©Ï”ÓwY!Êp9g‚Ëp.«àò×njœÚÛ‚âxPÑýÊ]^i7)D9Y—\ÅfÍ÷U‚Ë*—á2\fíò½Û„j(§àòþÁ¬/TˆrR.Ë(W84[[ô§ŸN‚Ë*—á2\fêrW™R”“uù壂^³âè&afJéº<‡òÉÝÂѨ.g ¸ —á2;—[Æ"“F!ÊI¹,£\îÔ´ØóÏ·¦ryeù~¸œ™à2\†ËŒ\Þà1GüÂÕÏ·¦rùÕ ¡Â¥ñ;çŸoMåòÕ(Ã北á2\f᲌rG©ðô½Ë2Ê5nÍÜ3úh]^€2\ÎXp.Ãer—çP>ÿÀ•ç[S¹üÛwÊžÿ~p*¡Ë‹Q†Ë .Ãe¸Lëò<Ê3SÄ.Ï¡¼»È1?•ËK¢ —3\†Ëp™Ðå«Q¦uy1ÊT.ß#¢ö±½ÂÌ”—³"¸ —á2•Ë P&tù/.2‰Ës(?¹_˜™àr¶—á2\&qy1ÊT.¿õ%¡Î»Ê黜e¸œ±à2\†Ëé»<èµt‡¢Lâr”ÓtyY”árÆ‚Ëp.§éò Ï²®JxÿAafJ u91Ê鸬e¸œ±à2\†Ë鸜å4]^å”]Vˆ2\ÎXp.Ãå”]NŒr:.Ë(W»… QNÍåu¢E!Êp9cÁe¸ —SsyY”SvùI¡¾HØás,{².LºB…(Ã北á2\NÁe%(§æòŽVM£2”“uù½û¿­po—03¥tp93Áe¸ —“uY!Ê)¸<è±[•¢œ”Ë2Ê]eBجSx?\Îdp.Ãå¤\¶ê…('ër,à*uhVº”Þ¯Üå9”‡|V…÷Ãå —UsÙQ\Zêз›É´ë‹¬Ú¶…Ål:¡µØÌbNƒÐ²°˜×¢-¶ëZ‹Íä+uêí¥('岌r¨yà&¥÷+wyå>†Ë™ .«æ²mÕÐ “u—Nw’ï›Ç«·úí'«,V[d¼tº“ÅÚË,'«,&Ÿ†|&é¿ÂÅûî½õ-æ™)AẼ¿ØU-j^<¤ô~å._2\Ιà2\†ËÊwvª±•Úeå ×,ÊÉ~³ P†Ë9\†Ëp9ƒ.ϽSþÁ¥÷+wy1Êp9g‚Ëp.gÊå9”ÿñ¨Òû•»¼$Êp9g‚Ëp.gÄåÅ(S¹üo_šŠ…->«ÂûárÖ—á2\Vßå}~g{!Ê$.Ï¡<赌Åq÷Ãål .Ãe¸¬²Ë#~g…KXŒrú.'F.çLp.Ãe5]N€rš./‹2\Ιà2\†Ëª¹œåt\V‚2\Ιà2\†Ë긼,Ê)»¬åÔ\~ö™S\V9¸ —á² .ïýí?ô½:!ÌL JîWîòý7)E9—×ÕêŽ;"Áe•ƒËp.³vyw‘£Ò-¼úafJPr¿r—{\–rQ)Êɺ<9$è5+Ž¹K‚Ë*—á2\fêr¥M§åd]>pùLB—Ó4N¹Ë2ÊUm»Óx÷±£\V9¸ —á2;—ï¿I0hV(D9)—e”+š[¯<ßšÐeå‡î¶ Øå2Áå —á2\fäòËG«¾pKƒffJP8….ËbV:4'w_y¾5¡Ë_".ÝÁßÞ—3\†Ëp™…Ë2ÊåNÍÑ:ÿ|k*—e”ë\Zå™)z—n"ÎË(Ã北á2\&wyå¿sþùÖT.Ë(×8/£Lîò”árÆ‚Ëp.Óº<òø?ßšÊå9”½ VB—£ —3\†Ëp™Ðå«Q¦uy1Ê„.Ùxå3e¸œùà2\†ËT./@™Ðå%Q¦rYF¹Ù¥Šãp9K‚Ëp.“¸¼e*—oŠ ¢î¡ÂÌ”@îr”árÆ‚Ëp.§ïò’(“¸<‡ò½Û…™)ÜåÄ(Ã北á2\NÓeå —°åô]NŒrš.\» Êp9cÁe¸ —Óq9Êiº¼,Êé¸<Ö»<Êp9cÁe¸ —Sv91Êé¸,£qéîÝ&ÌL ä.Ë(·» ãAqÙÁåÌ—á2\NÍåeQNÙåƒA±IÔeH˜™È]ÞP#t(C.g,¸ —ár .+A95—;݆·"”Sp¹Ì¢8–ÿø.g8¸ —ár².+D9—Ÿ¹möW+D9Y—»ÝƶP÷Ã北á2\NÊåHȤåd]þùCBs@XY"ÌL)r—e”w­Lâ~¸œÉà²z.×µïZå9÷€Ë™ .«æ²Ûö9…<äÛì±ÝØå–ߌ³˜Ç¬9ò°X‰M÷Âd‹É§!ŸIú¯pñ½¶jKŸÏ*tyå~¯EáýI¹<2\Ιà²j.{!ùÿØéÿ%}ñgߦÿ—ô%W%NVX¬Égºtº“ÅäÓÏ$ýW¸x·Dr—çQNös%Î^2\Ιà2\†Ëtùj”É]^€2\Ιà2\†Ë™ryÊ´./F.çLp.Ã匸¼eB—{k« û2Íäëw[‡»Ü/LÖ±˜Ç¬=ò°XÀ¦{a²ŽÅ¶uºå3Iÿ.ޠǦ׬Pˆr².oð˜[ƒIܯÜå4Q–à2âµ-ý½;zÜò[9òmiw•ÛôÛK,æ³h³X‰C·½ÄÁbeVýæ6×á¡bòmm¢nfJP8å.Ë(¯­ž¹]éýÊ]Ne .#^ûó±½ò[¹ôÿ’¾xß<^½Õo?Y`±Ú"ã¥Ó,Ö^f9Y`1ù4ä3Iÿ.ÞÙ©ÆÖ óÌ” p ]žCùý•Þ¯ÜåY”ëJÒDY‚ˈ×à2\NŒr ŸG'v™ e .#^ƒËp91Ê´.¢,ÁeÄkp.'F™ÐeZ”%¸Œx .ÃåÄ(S¹LŽ²—¯Áe¸<¿Þ%P&q™Ê\F¼—áò<Ê몖@9}—¡,ÁeÄkp.'F9M—Ù¡,ÁeÄkp.'F9—™¢,ÁeÄkp9Ï]^å”]f²—¯Áå|vY Ê©¹|¸Ÿ9Ê\F¼—óÖe…(§àr‡ÃTY£,ÁeÄkp9?]v…('ëò¯U4ëÞþÑ$‰ù—ŸÁå먫8òœ¬ï@P< #include #include "ctl-io.h" #include /**************************************************************************/ /* function to display a little information about a geometric object to prove that we've read it in correctly. */ static void display_object_info(geometric_object obj) { printf(" center = (%g,%g,%g), epsilon = %g\n", obj.center.x, obj.center.y, obj.center.z, obj.material.epsilon); switch (obj.which_subclass) { case CYLINDER: printf(" cylinder with height %g, axis (%g, %g, %g)\n", obj.subclass.cylinder_data->height, obj.subclass.cylinder_data->axis.x, obj.subclass.cylinder_data->axis.y, obj.subclass.cylinder_data->axis.z); break; case SPHERE: printf(" sphere with radius %g\n", obj.subclass.sphere_data->radius); break; case BLOCK: printf(" block with size (%g,%g,%g)\n", obj.subclass.block_data->size.x, obj.subclass.block_data->size.y, obj.subclass.block_data->size.z); printf(" projection matrix: %10.6f%10.6f%10.6f\n" " %10.6f%10.6f%10.6f\n" " %10.6f%10.6f%10.6f\n", obj.subclass.block_data->projection_matrix.c0.x, obj.subclass.block_data->projection_matrix.c1.x, obj.subclass.block_data->projection_matrix.c2.x, obj.subclass.block_data->projection_matrix.c0.y, obj.subclass.block_data->projection_matrix.c1.y, obj.subclass.block_data->projection_matrix.c2.y, obj.subclass.block_data->projection_matrix.c0.z, obj.subclass.block_data->projection_matrix.c1.z, obj.subclass.block_data->projection_matrix.c2.z); break; case GEOMETRIC_OBJECT_SELF: printf(" generic geometric object\n"); break; default: printf(" UNKNOWN OBJECT TYPE!\n"); } } /* run function. This function is callable from Scheme. When it is called, the input variables are already assigned. After it is called, the values assigned to the output variables are automatically exported to scheme. */ void run_program(void) { int i, depth, nobjects; vector3 p; geom_box_tree t; /* Just print out some data to prove that we have read the input variables: */ printf("Working in %d dimensions.\n", dimensions); printf("\nk-points are:\n"); for (i = 0; i < k_points.num_items; ++i) printf(" (%g,%g,%g)\n", k_points.items[i].x, k_points.items[i].y, k_points.items[i].z); printf("\nsome geometry info:\n"); for (i = 0; i < geometry.num_items; ++i) display_object_info(geometry.items[i]); t = create_geom_box_tree(); printf("\ngeometry box tree:\n"); display_geom_box_tree(2, t); geom_box_tree_stats(t, &depth, &nobjects); printf("\ntree has depth %d and %d object nodes (vs. %d objects)\n", depth, nobjects, geometry.num_items); p.x = 1; p.y = 0; p.z = 0; printf("Epsilon of (%g, %g) is %g (tree) or %g (non-tree)\n", p.x, p.y, material_of_point_in_tree(p, t).epsilon, material_of_point(p).epsilon); destroy_geom_box_tree(t); printf("\nDone writing input. Sending data to output vars.\n"); /* Write out some data to the output variables. Note that we MUST do this. If we leave any output variables uninitialized, the result is undefined. */ if (num_write_output_vars > 1) destroy_output_vars(); /* we are responsible for calling this */ printf("dummy = (%g+%gi, %g+%gi, %g+%gi)\n", dummy.x.re, dummy.x.im, dummy.y.re, dummy.y.im, dummy.z.re, dummy.z.im); dummy = make_cvector3(vector3_scale(2, cvector3_re(dummy)), vector3_scale(3, cvector3_im(dummy))); mean_dielectric = 1.23456789; gaps.num_items = 2; gaps.items = (number *) malloc(gaps.num_items * sizeof(number)); gaps.items[0] = 3.14159; gaps.items[1] = 1.41421; } /* Another function callable from Scheme. This function does not use the input/output variables, but passes information in explicitely through its parameter and out through its return value. In a real program, this might return the fraction of the field energy in the given object. */ number energy_in_object(geometric_object obj) { printf("Computing power in object.\n"); display_object_info(obj); printf("Returning 0.123456.\n"); return 0.123456; } /* A function to test passing and returning list parameters to/from Scheme: */ vector3_list list_func_test(number x, integer_list s, vector3 v) { vector3_list vout; int i; vout.num_items = s.num_items; vout.items = (vector3*) malloc(sizeof(vector3) * vout.num_items); for (i = 0; i < vout.num_items; ++i) vout.items[i] = vector3_scale(s.items[i] * x, v); return vout; } /* return func(arg), where func is a Scheme function returning a number. */ number function_func(function func, number arg) { return ctl_convert_number_to_c( gh_call1(func, ctl_convert_number_to_scm(arg))); } libctl-4.4.0/examples/example.scm.in000066400000000000000000000041551356267410600173710ustar00rootroot00000000000000; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This file may be used without restriction. It is in the public ; domain, and is NOT restricted by the terms of any GNU license. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. (define-class material-type no-parent (define-property epsilon no-default 'number positive?) (define-property conductivity 0.0 'number)) ; use the solid geometry classes, variables, etcetera in libgeom: ; (one specifications file can include another specifications file) (include "@LIBCTL_DIR@/utils/geom.scm") ; **************************************************************** ; Add some predefined variables, for convenience: (define vacuum (make material-type (epsilon 1.0))) (define air vacuum) (define infinity 1.0e20) ; big number for infinite dimensions of objects (set! default-material air) ; **************************************************************** (define-input-var k-points '() (make-list-type 'vector3)) (define-input-output-var dummy (vector3 3.7+1.1i 2.3-0.1i 19) 'cvector3) (define-output-var mean-dielectric 'number) (define-output-var gaps (make-list-type 'number)) (export-type (make-list-type 'number)) (export-type (make-list-type (make-list-type 'number))) ; **************************************************************** (define-external-function run-program true true no-return-value) (define (run) (set! interactive? #f) ; don't be interactive if we call (run) (run-program)) (define-external-function energy-in-object false false 'number 'geometric-object) (define-external-function list-func-test false false (make-list-type 'vector3) 'number (make-list-type 'integer) 'vector3) (define-external-function function-func false false 'number 'function 'number) ; **************************************************************** ; Use "example>" instead of the default "guile>" prompt. (ctl-set-prompt! "example> ") libctl-4.4.0/examples/run.ctl000066400000000000000000000045371356267410600161410ustar00rootroot00000000000000; Copyright (C) 1998-2019 Steven G. Johnson ; ; This file may be used without restriction. It is in the public ; domain, and is NOT restricted by the terms of any GNU license. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; Sample control file (for example.scm specification). ; You should edit this file in Scheme mode if you are using emacs: ; type M-x scheme-mode or modify your .emacs file to automatically ; put .ctl files in Scheme mode. ; Define some dielectric materials: (define GaAs (make material-type (epsilon 11.56))) (define AlOx (make material-type (epsilon 2.25))) ; Set the dimensions. Use set! rather than define to change the value ; of an existing variable. (set! dimensions 2) ; Set the k-point list: (set! k-points (list (vector3 0 0) (vector3 0.5 0) (vector3 0.5 0.5) (vector3 0 0))) ; Reset the k-point list for fun, in a fancier way: ; Here, we will use the built-in interpolate function to interpolate ; points between the corners of the Brillouin zone. (define Gamma-point (vector3 0 0)) (define X-point (vector3 0.5 0)) (define M-point (vector3 0.5 0.5)) (set! k-points (interpolate 4 (list Gamma-point X-point M-point Gamma-point))) ; Define a parameter, R, that can be set from the command-line (e.g. ; by "R=0.3", and which assumes a default value of 0.1 if not set: (define-param R 0.1) ; (used as the radius of the sphere, below) ; Set the geometry: (set! geometry (list (make cylinder (material air) (center 1.5 0) (radius 0.2) (height 0.5) (axis 3 4)) (make sphere (material GaAs) (center 1.1 -1.1) (radius R)) (make block (material AlOx) (center -1 0.5) (size 0.2 1.3)) (make block (material air) (center -1.5 -1) (size 1.2 0.3) (e2 1 1)))) ; Append a 2d 3x3 lattice of cylinders to the geometry: (set! geometry-lattice (make lattice (size 5 5 1))) (set! geometry (append geometry (geometric-objects-lattice-duplicates (list (make cylinder (material GaAs) (center 0 0) (radius 0.1) (height 1.0)))))) (run) ; The (run) command normally turns interactive mode off; turn it back ; on so that we are dropped into a Guile command line: (set-param! interactive? true) libctl-4.4.0/mkdocs.yml000066400000000000000000000015661356267410600150150ustar00rootroot00000000000000site_name: libctl Documentation site_author: libctl Developers repo_url: https://github.com/NanoComp/libctl/ edit_uri: edit/master/doc/docs docs_dir: 'doc/docs' site_dir: 'doc/site' theme: name: readthedocs markdown_extensions: - wikilinks - toc: title: Table of Contents - attr_list - fenced_code - mdx_math: enable_dollar_delimiter: True extra_javascript: - 'https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.1/MathJax.js?config=TeX-AMS_HTML' pages: - Overview: index.md - Introduction: Introduction.md - Installation: Installation.md - Basic User Experience: Basic_User_Experience.md - Advanced User Experience: Advanced_User_Experience.md - User Reference: User_Reference.md - Developer Experience: Developer_Experience.md - Guile and Scheme Information: Guile_and_Scheme_Information.md - License and Copyright: License_and_Copyright.md libctl-4.4.0/src/000077500000000000000000000000001356267410600135715ustar00rootroot00000000000000libctl-4.4.0/src/Makefile.am000066400000000000000000000005331356267410600156260ustar00rootroot00000000000000 EXTRA_DIST = ctl.h.in if WITH_GUILE lib_LTLIBRARIES = libctl.la endif include_HEADERS = ctl-math.h nodist_include_HEADERS = ctl.h BUILT_SOURCES = ctl.h libctl_la_SOURCES = ctl.c ctl-math.c subplex.c ctl-f77-glue.c integrator.c cintegrator.c libctl_la_LDFLAGS = -no-undefined -version-info @SHARED_VERSION_INFO@ libctl_la_LIBADD = $(LIBGUILE) libctl-4.4.0/src/cintegrator.c000066400000000000000000000731021356267410600162610ustar00rootroot00000000000000#include "ctl.h" #ifdef CTL_HAS_COMPLEX_INTEGRATION /* * Copyright (c) 2005 Steven G. Johnson * * Portions (see comments) based on HIntLib (also distributed under * the GNU GPL, v2 or later), copyright (c) 2002-2005 Rudolf Schuerer. * (http://www.cosy.sbg.ac.at/~rschuer/hintlib/) * * Portions (see comments) based on GNU GSL (also distributed under * the GNU GPL, v2 or later), copyright (c) 1996-2000 Brian Gough. * (http://www.gnu.org/software/gsl/) * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * */ /* As integrator.c, but integrates complex-valued integrands */ #include #include #include #include #include /* Adaptive multidimensional integration on hypercubes (or, really, hyper-rectangles) using cubature rules. A cubature rule takes a function and a hypercube and evaluates the function at a small number of points, returning an estimate of the integral as well as an estimate of the error, and also a suggested dimension of the hypercube to subdivide. Given such a rule, the adaptive integration is simple: 1) Evaluate the cubature rule on the hypercube(s). Stop if converged. 2) Pick the hypercube with the largest estimated error, and divide it in two along the suggested dimension. 3) Goto (1). */ /* numeric type for integrand */ #include typedef complex double num; #define num_abs cabs typedef num (*integrand) (unsigned ndim, const double *x, void *); /* Integrate the function f from xmin[dim] to xmax[dim], with at most maxEval function evaluations (0 for no limit), until the given absolute or relative error is achieved. val returns the integral, and err returns the estimate for the absolute error in val. The return value of the function is 0 on success and non-zero if there was an error. */ static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, const double *xmax, unsigned maxEval, double reqAbsError, double reqRelError, num *val, double *err); /***************************************************************************/ /* Basic datatypes */ typedef struct { num val; double err; } esterr; static double relError(esterr ee) { return (ee.val == 0.0 ? HUGE_VAL : num_abs(ee.err / ee.val)); } typedef struct { unsigned dim; double *data; /* length 2*dim = center followed by half-widths */ double vol; /* cache volume = product of widths */ } hypercube; static double compute_vol(const hypercube *h) { unsigned i; double vol = 1; for (i = 0; i < h->dim; ++i) vol *= 2 * h->data[i + h->dim]; return vol; } static hypercube make_hypercube(unsigned dim, const double *center, const double *halfwidth) { unsigned i; hypercube h; h.dim = dim; h.data = (double *) malloc(sizeof(double) * dim * 2); for (i = 0; i < dim; ++i) { h.data[i] = center[i]; h.data[i + dim] = halfwidth[i]; } h.vol = compute_vol(&h); return h; } static hypercube make_hypercube_range(unsigned dim, const double *xmin, const double *xmax) { hypercube h = make_hypercube(dim, xmin, xmax); unsigned i; for (i = 0; i < dim; ++i) { h.data[i] = 0.5 * (xmin[i] + xmax[i]); h.data[i + dim] = 0.5 * (xmax[i] - xmin[i]); } h.vol = compute_vol(&h); return h; } static void destroy_hypercube(hypercube *h) { free(h->data); h->dim = 0; } typedef struct { hypercube h; esterr ee; unsigned splitDim; } region; static region make_region(const hypercube *h) { region R; R.h = make_hypercube(h->dim, h->data, h->data + h->dim); R.splitDim = 0; return R; } static void destroy_region(region *R) { destroy_hypercube(&R->h); } static void cut_region(region *R, region *R2) { unsigned d = R->splitDim, dim = R->h.dim; *R2 = *R; R->h.data[d + dim] *= 0.5; R->h.vol *= 0.5; R2->h = make_hypercube(dim, R->h.data, R->h.data + dim); R->h.data[d] -= R->h.data[d + dim]; R2->h.data[d] += R->h.data[d + dim]; } typedef struct rule_s { unsigned dim; /* the dimensionality */ unsigned num_points; /* number of evaluation points */ unsigned (*evalError)(struct rule_s *r, integrand f, void *fdata, const hypercube *h, esterr *ee); void (*destroy)(struct rule_s *r); } rule; static void destroy_rule(rule *r) { if (r->destroy) r->destroy(r); free(r); } static region eval_region(region R, integrand f, void *fdata, rule *r) { R.splitDim = r->evalError(r, f, fdata, &R.h, &R.ee); return R; } /***************************************************************************/ /* Functions to loop over points in a hypercube. */ /* Based on orbitrule.cpp in HIntLib-0.0.10 */ /* ls0 returns the least-significant 0 bit of n (e.g. it returns 0 if the LSB is 0, it returns 1 if the 2 LSBs are 01, etcetera). */ #if (defined(__GNUC__) || defined(__ICC)) && (defined(__i386__) || defined (__x86_64__)) /* use x86 bit-scan instruction, based on count_trailing_zeros() macro in GNU GMP's longlong.h. */ static unsigned ls0(unsigned n) { unsigned count; n = ~n; __asm__("bsfl %1,%0": "=r"(count):"rm"(n)); return count; } #else static unsigned ls0(unsigned n) { const unsigned bits[256] = { 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8, }; unsigned bit = 0; while ((n & 0xff) == 0xff) { n >>= 8; bit += 8; } return bit + bits[n & 0xff]; } #endif /** * Evaluate the integral on all 2^n points (+/-r,...+/-r) * * A Gray-code ordering is used to minimize the number of coordinate updates * in p. */ static num evalR_Rfs(integrand f, void *fdata, unsigned dim, double *p, const double *c, const double *r) { num sum = 0; unsigned i; unsigned signs = 0; /* 0/1 bit = +/- for corresponding element of r[] */ /* We start with the point where r is ADDed in every coordinate (this implies signs=0). */ for (i = 0; i < dim; ++i) p[i] = c[i] + r[i]; /* Loop through the points in Gray-code ordering */ for (i = 0;; ++i) { unsigned mask, d; sum += f(dim, p, fdata); d = ls0(i); /* which coordinate to flip */ if (d >= dim) break; /* flip the d-th bit and add/subtract r[d] */ mask = 1U << d; signs ^= mask; p[d] = (signs & mask) ? c[d] - r[d] : c[d] + r[d]; } return sum; } static num evalRR0_0fs(integrand f, void *fdata, unsigned dim, double *p, const double *c, const double *r) { unsigned i, j; num sum = 0; for (i = 0; i < dim - 1; ++i) { p[i] = c[i] - r[i]; for (j = i + 1; j < dim; ++j) { p[j] = c[j] - r[j]; sum += f(dim, p, fdata); p[i] = c[i] + r[i]; sum += f(dim, p, fdata); p[j] = c[j] + r[j]; sum += f(dim, p, fdata); p[i] = c[i] - r[i]; sum += f(dim, p, fdata); p[j] = c[j]; /* Done with j -> Restore p[j] */ } p[i] = c[i]; /* Done with i -> Restore p[i] */ } return sum; } static unsigned evalR0_0fs4d(integrand f, void *fdata, unsigned dim, double *p, const double *c, num *sum0_, const double *r1, num *sum1_, const double *r2, num *sum2_) { double maxdiff = 0; unsigned i, dimDiffMax = 0; num sum0, sum1 = 0, sum2 = 0; /* copies for aliasing, performance */ double ratio = r1[0] / r2[0]; ratio *= ratio; sum0 = f(dim, p, fdata); for (i = 0; i < dim; i++) { num f1a, f1b, f2a, f2b; double diff; p[i] = c[i] - r1[i]; sum1 += (f1a = f(dim, p, fdata)); p[i] = c[i] + r1[i]; sum1 += (f1b = f(dim, p, fdata)); p[i] = c[i] - r2[i]; sum2 += (f2a = f(dim, p, fdata)); p[i] = c[i] + r2[i]; sum2 += (f2b = f(dim, p, fdata)); p[i] = c[i]; diff = num_abs(f1a + f1b - 2 * sum0 - ratio * (f2a + f2b - 2 * sum0)); if (diff > maxdiff) { maxdiff = diff; dimDiffMax = i; } } *sum0_ += sum0; *sum1_ += sum1; *sum2_ += sum2; return dimDiffMax; } #define num0_0(dim) (1U) #define numR0_0fs(dim) (2 * (dim)) #define numRR0_0fs(dim) (2 * (dim) * (dim-1)) #define numR_Rfs(dim) (1U << (dim)) /***************************************************************************/ /* Based on rule75genzmalik.cpp in HIntLib-0.0.10: An embedded cubature rule of degree 7 (embedded rule degree 5) due to A. C. Genz and A. A. Malik. See: A. C. Genz and A. A. Malik, "An imbedded [sic] family of fully symmetric numerical integration rules," SIAM J. Numer. Anal. 20 (3), 580-588 (1983). */ typedef struct { rule parent; /* temporary arrays of length dim */ double *widthLambda, *widthLambda2, *p; /* dimension-dependent constants */ double weight1, weight3, weight5; double weightE1, weightE3; } rule75genzmalik; #define real(x) ((double)(x)) #define to_int(n) ((int)(n)) static int isqr(int x) { return x * x; } static void destroy_rule75genzmalik(rule *r_) { rule75genzmalik *r = (rule75genzmalik *) r_; free(r->p); } static unsigned rule75genzmalik_evalError(rule *r_, integrand f, void *fdata, const hypercube *h, esterr *ee) { /* lambda2 = sqrt(9/70), lambda4 = sqrt(9/10), lambda5 = sqrt(9/19) */ const double lambda2 = 0.3585685828003180919906451539079374954541; const double lambda4 = 0.9486832980505137995996680633298155601160; const double lambda5 = 0.6882472016116852977216287342936235251269; const double weight2 = 980. / 6561.; const double weight4 = 200. / 19683.; const double weightE2 = 245. / 486.; const double weightE4 = 25. / 729.; rule75genzmalik *r = (rule75genzmalik *) r_; unsigned i, dimDiffMax, dim = r_->dim; num sum1 = 0.0, sum2 = 0.0, sum3 = 0.0, sum4, sum5, result, res5th; const double *center = h->data; const double *halfwidth = h->data + dim; for (i = 0; i < dim; ++i) r->p[i] = center[i]; for (i = 0; i < dim; ++i) r->widthLambda2[i] = halfwidth[i] * lambda2; for (i = 0; i < dim; ++i) r->widthLambda[i] = halfwidth[i] * lambda4; /* Evaluate function in the center, in f(lambda2,0,...,0) and f(lambda3=lambda4, 0,...,0). Estimate dimension with largest error */ dimDiffMax = evalR0_0fs4d(f, fdata, dim, r->p, center, &sum1, r->widthLambda2, &sum2, r->widthLambda, &sum3); /* Calculate sum4 for f(lambda4, lambda4, 0, ...,0) */ sum4 = evalRR0_0fs(f, fdata, dim, r->p, center, r->widthLambda); /* Calculate sum5 for f(lambda5, lambda5, ..., lambda5) */ for (i = 0; i < dim; ++i) r->widthLambda[i] = halfwidth[i] * lambda5; sum5 = evalR_Rfs(f, fdata, dim, r->p, center, r->widthLambda); /* Calculate fifth and seventh order results */ result = h->vol * (r->weight1 * sum1 + weight2 * sum2 + r->weight3 * sum3 + weight4 * sum4 + r->weight5 * sum5); res5th = h->vol * (r->weightE1 * sum1 + weightE2 * sum2 + r->weightE3 * sum3 + weightE4 * sum4); ee->val = result; ee->err = num_abs(res5th - result); return dimDiffMax; } static rule *make_rule75genzmalik(unsigned dim) { rule75genzmalik *r; if (dim < 2) return 0; /* this rule does not support 1d integrals */ /* Because of the use of a bit-field in evalR_Rfs, we are limited to be < 32 dimensions (or however many bits are in unsigned). This is not a practical limitation...long before you reach 32 dimensions, the Genz-Malik cubature becomes excruciatingly slow and is superseded by other methods (e.g. Monte-Carlo). */ if (dim >= sizeof(unsigned) * 8) return 0; r = (rule75genzmalik *) malloc(sizeof(rule75genzmalik)); r->parent.dim = dim; r->weight1 = (real(12824 - 9120 * to_int(dim) + 400 * isqr(to_int(dim))) / real(19683)); r->weight3 = real(1820 - 400 * to_int(dim)) / real(19683); r->weight5 = real(6859) / real(19683) / real(1U << dim); r->weightE1 = (real(729 - 950 * to_int(dim) + 50 * isqr(to_int(dim))) / real(729)); r->weightE3 = real(265 - 100 * to_int(dim)) / real(1458); r->p = (double *) malloc(sizeof(double) * dim * 3); r->widthLambda = r->p + dim; r->widthLambda2 = r->p + 2 * dim; r->parent.num_points = num0_0(dim) + 2 * numR0_0fs(dim) + numRR0_0fs(dim) + numR_Rfs(dim); r->parent.evalError = rule75genzmalik_evalError; r->parent.destroy = destroy_rule75genzmalik; return (rule *) r; } /***************************************************************************/ /* 1d 15-point Gaussian quadrature rule, based on qk15.c and qk.c in GNU GSL (which in turn is based on QUADPACK). */ static unsigned rule15gauss_evalError(rule *r, integrand f, void *fdata, const hypercube *h, esterr *ee) { /* Gauss quadrature weights and kronrod quadrature abscissae and weights as evaluated with 80 decimal digit arithmetic by L. W. Fullerton, Bell Labs, Nov. 1981. */ const unsigned n = 8; const double xgk[8] = { /* abscissae of the 15-point kronrod rule */ 0.991455371120812639206854697526329, 0.949107912342758524526189684047851, 0.864864423359769072789712788640926, 0.741531185599394439863864773280788, 0.586087235467691130294144838258730, 0.405845151377397166906606412076961, 0.207784955007898467600689403773245, 0.000000000000000000000000000000000 /* xgk[1], xgk[3], ... abscissae of the 7-point gauss rule. xgk[0], xgk[2], ... to optimally extend the 7-point gauss rule */ }; static const double wg[4] = { /* weights of the 7-point gauss rule */ 0.129484966168869693270611432679082, 0.279705391489276667901467771423780, 0.381830050505118944950369775488975, 0.417959183673469387755102040816327 }; static const double wgk[8] = { /* weights of the 15-point kronrod rule */ 0.022935322010529224963732008058970, 0.063092092629978553290700663189204, 0.104790010322250183839876322541518, 0.140653259715525918745189590510238, 0.169004726639267902826583426598550, 0.190350578064785409913256402421014, 0.204432940075298892414161999234649, 0.209482141084727828012999174891714 }; const double center = h->data[0]; const double halfwidth = h->data[1]; double fv1[7], fv2[7]; const num f_center = f(1, ¢er, fdata); num result_gauss = f_center * wg[n/2 - 1]; num result_kronrod = f_center * wgk[n - 1]; double result_abs = num_abs(result_kronrod); num mean; double result_asc, err; unsigned j; for (j = 0; j < (n - 1) / 2; ++j) { int j2 = 2*j + 1; double x, w = halfwidth * xgk[j2]; num f1, f2, fsum; x = center - w; fv1[j2] = f1 = f(1, &x, fdata); x = center + w; fv2[j2] = f2 = f(1, &x, fdata); fsum = f1 + f2; result_gauss += wg[j] * fsum; result_kronrod += wgk[j2] * fsum; result_abs += wgk[j2] * (num_abs(f1) + num_abs(f2)); } for (j = 0; j < n/2; ++j) { int j2 = 2*j; double x, w = halfwidth * xgk[j2]; num f1, f2; x = center - w; fv1[j2] = f1 = f(1, &x, fdata); x = center + w; fv2[j2] = f2 = f(1, &x, fdata); result_kronrod += wgk[j2] * (f1 + f2); result_abs += wgk[j2] * (num_abs(f1) + num_abs(f2)); } ee->val = result_kronrod * halfwidth; /* compute error estimate: */ mean = result_kronrod * 0.5; result_asc = wgk[n - 1] * num_abs(f_center - mean); for (j = 0; j < n - 1; ++j) result_asc += wgk[j] * (num_abs(fv1[j]-mean) + num_abs(fv2[j]-mean)); err = num_abs(result_kronrod - result_gauss) * halfwidth; result_abs *= halfwidth; result_asc *= halfwidth; if (result_asc != 0 && err != 0) { double scale = pow((200 * err / result_asc), 1.5); if (scale < 1) err = result_asc * scale; else err = result_asc; } if (result_abs > DBL_MIN / (50 * DBL_EPSILON)) { double min_err = 50 * DBL_EPSILON * result_abs; if (min_err > err) err = min_err; } ee->err = err; return 0; /* no choice but to divide 0th dimension */ } static rule *make_rule15gauss(unsigned dim) { rule *r; if (dim != 1) return 0; /* this rule is only for 1d integrals */ r = (rule *) malloc(sizeof(rule)); r->dim = dim; r->num_points = 15; r->evalError = rule15gauss_evalError; r->destroy = 0; return r; } /***************************************************************************/ /* binary heap implementation (ala _Introduction to Algorithms_ by Cormen, Leiserson, and Rivest), for use as a priority queue of regions to integrate. */ typedef region heap_item; #define KEY(hi) ((hi).ee.err) typedef struct { unsigned n, nalloc; heap_item *items; esterr ee; } heap; static void heap_resize(heap *h, unsigned nalloc) { h->nalloc = nalloc; h->items = (heap_item *) realloc(h->items, sizeof(heap_item) * nalloc); } static heap heap_alloc(unsigned nalloc) { heap h; h.n = 0; h.nalloc = 0; h.items = 0; h.ee.val = h.ee.err = 0; heap_resize(&h, nalloc); return h; } /* note that heap_free does not deallocate anything referenced by the items */ static void heap_free(heap *h) { h->n = 0; heap_resize(h, 0); } static void heap_push(heap *h, heap_item hi) { int insert; h->ee.val += hi.ee.val; h->ee.err += hi.ee.err; insert = h->n; if (++(h->n) > h->nalloc) heap_resize(h, h->n * 2); while (insert) { int parent = (insert - 1) / 2; if (KEY(hi) <= KEY(h->items[parent])) break; h->items[insert] = h->items[parent]; insert = parent; } h->items[insert] = hi; } static heap_item heap_pop(heap *h) { heap_item ret; int i, n, child; if (!(h->n)) { fprintf(stderr, "attempted to pop an empty heap\n"); exit(EXIT_FAILURE); } ret = h->items[0]; h->items[i = 0] = h->items[n = --(h->n)]; while ((child = i * 2 + 1) < n) { int largest; heap_item swap; if (KEY(h->items[child]) <= KEY(h->items[i])) largest = i; else largest = child; if (++child < n && KEY(h->items[largest]) < KEY(h->items[child])) largest = child; if (largest == i) break; swap = h->items[i]; h->items[i] = h->items[largest]; h->items[i = largest] = swap; } h->ee.val -= ret.ee.val; h->ee.err -= ret.ee.err; return ret; } /***************************************************************************/ /* adaptive integration, analogous to adaptintegrator.cpp in HIntLib */ static int ruleadapt_integrate(rule *r, integrand f, void *fdata, const hypercube *h, unsigned maxEval, double reqAbsError, double reqRelError, esterr *ee) { unsigned maxIter; /* maximum number of adaptive subdivisions */ heap regions; unsigned i; int status = -1; /* = ERROR */ if (maxEval) { if (r->num_points > maxEval) return status; /* ERROR */ maxIter = (maxEval - r->num_points) / (2 * r->num_points); } else maxIter = UINT_MAX; regions = heap_alloc(1); heap_push(®ions, eval_region(make_region(h), f, fdata, r)); /* another possibility is to specify some non-adaptive subdivisions: if (initialRegions != 1) partition(h, initialRegions, EQUIDISTANT, ®ions, f,fdata, r); */ for (i = 0; i < maxIter; ++i) { region R, R2; if (regions.ee.err <= reqAbsError || relError(regions.ee) <= reqRelError) { status = 0; /* converged! */ break; } R = heap_pop(®ions); /* get worst region */ cut_region(&R, &R2); heap_push(®ions, eval_region(R, f, fdata, r)); heap_push(®ions, eval_region(R2, f, fdata, r)); } ee->val = ee->err = 0; /* re-sum integral and errors */ for (i = 0; i < regions.n; ++i) { ee->val += regions.items[i].ee.val; ee->err += regions.items[i].ee.err; destroy_region(®ions.items[i]); } /* printf("regions.nalloc = %d\n", regions.nalloc); */ heap_free(®ions); return status; } static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, const double *xmax, unsigned maxEval, double reqAbsError, double reqRelError, num *val, double *err) { rule *r; hypercube h; esterr ee; int status; if (dim == 0) { /* trivial integration */ *val = f(0, xmin, fdata); *err = 0; return 0; } r = dim == 1 ? make_rule15gauss(dim) : make_rule75genzmalik(dim); if (!r) { *val = 0; *err = HUGE_VAL; return -2; /* ERROR */ } h = make_hypercube_range(dim, xmin, xmax); status = ruleadapt_integrate(r, f, fdata, &h, maxEval, reqAbsError, reqRelError, &ee); *val = ee.val; *err = ee.err; destroy_hypercube(&h); destroy_rule(r); return status; } /***************************************************************************/ /* Compile with -DTEST_INTEGRATOR for a self-contained test program. Usage: ./integrator where = # dimensions, = relative tolerance, is either 0/1/2 for the three test integrands (see below), and is the maximum # function evaluations (0 for none). */ #ifdef TEST_INTEGRATOR int count = 0; int which_integrand = 0; const double radius = 0.50124145262344534123412; /* random */ /* Simple constant function */ num fconst (double x[], size_t dim, void *params) { return 1; } /*** f0, f1, f2, and f3 are test functions from the Monte-Carlo integration routines in GSL 1.6 (monte/test.c). Copyright (c) 1996-2000 Michael Booth, GNU GPL. ****/ /* Simple product function */ num f0 (unsigned dim, const double *x, void *params) { double prod = 1.0; unsigned int i; for (i = 0; i < dim; ++i) prod *= 2.0 * x[i]; return prod; } /* Gaussian centered at 1/2. */ num f1 (unsigned dim, const double *x, void *params) { double a = *(double *)params; double sum = 0.; unsigned int i; for (i = 0; i < dim; i++) { double dx = x[i] - 0.5; sum += dx * dx; } return (pow (M_2_SQRTPI / (2. * a), (double) dim) * exp (-sum / (a * a))); } /* double gaussian */ num f2 (unsigned dim, const double *x, void *params) { double a = *(double *)params; double sum1 = 0.; double sum2 = 0.; unsigned int i; for (i = 0; i < dim; i++) { double dx1 = x[i] - 1. / 3.; double dx2 = x[i] - 2. / 3.; sum1 += dx1 * dx1; sum2 += dx2 * dx2; } return 0.5 * pow (M_2_SQRTPI / (2. * a), dim) * (exp (-sum1 / (a * a)) + exp (-sum2 / (a * a))); } /* Tsuda's example */ num f3 (unsigned dim, const double *x, void *params) { double c = *(double *)params; double prod = 1.; unsigned int i; for (i = 0; i < dim; i++) prod *= c / (c + 1) * pow((c + 1) / (c + x[i]), 2.0); return prod; } /*** end of GSL test functions ***/ num f_test(unsigned dim, const double *x, void *data) { double val; unsigned i; ++count; switch (which_integrand) { case 0: /* simple smooth (separable) objective: prod. cos(x[i]). */ val = 1; for (i = 0; i < dim; ++i) val *= cos(x[i]); break; case 1: { /* integral of exp(-x^2), rescaled to (0,infinity) limits */ double scale = 1.0; val = 0; for (i = 0; i < dim; ++i) { double z = (1 - x[i]) / x[i]; val += z * z; scale *= M_2_SQRTPI / (x[i] * x[i]); } val = exp(-val) * scale; break; } case 2: /* discontinuous objective: volume of hypersphere */ val = 0; for (i = 0; i < dim; ++i) val += x[i] * x[i]; val = val < radius * radius; break; case 3: val = f0(dim, x, data); break; case 4: val = f1(dim, x, data); break; case 5: val = f2(dim, x, data); break; case 6: val = f3(dim, x, data); break; default: fprintf(stderr, "unknown integrand %d\n", which_integrand); exit(EXIT_FAILURE); } /* if (count < 100) printf("%d: f(%g, ...) = %g\n", count, x[0], val); */ return val; } /* surface area of n-dimensional unit hypersphere */ static double S(unsigned n) { double val; int fact = 1; if (n % 2 == 0) { /* n even */ val = 2 * pow(M_PI, n * 0.5); n = n / 2; while (n > 1) fact *= (n -= 1); val /= fact; } else { /* n odd */ val = (1 << (n/2 + 1)) * pow(M_PI, n/2); while (n > 2) fact *= (n -= 2); val /= fact; } return val; } static num exact_integral(unsigned dim, const double *xmax) { unsigned i; double val; switch(which_integrand) { case 0: val = 1; for (i = 0; i < dim; ++i) val *= sin(xmax[i]); break; case 2: val = dim == 0 ? 1 : S(dim) * pow(radius * 0.5, dim) / dim; break; default: val = 1.0; } return val; } int main(int argc, char **argv) { double *xmin, *xmax; double tol, err; num val; unsigned i, dim, maxEval; double fdata; dim = argc > 1 ? atoi(argv[1]) : 2; tol = argc > 2 ? atof(argv[2]) : 1e-2; which_integrand = argc > 3 ? atoi(argv[3]) : 0; maxEval = argc > 4 ? atoi(argv[4]) : 0; fdata = which_integrand == 6 ? (1.0 + sqrt (10.0)) / 9.0 : 0.1; xmin = (double *) malloc(dim * sizeof(double)); xmax = (double *) malloc(dim * sizeof(double)); for (i = 0; i < dim; ++i) { xmin[i] = 0; xmax[i] = 1 + (which_integrand >= 1 ? 0 : 0.4 * sin(i)); } printf("%u-dim integral, tolerance = %g, integrand = %d\n", dim, tol, which_integrand); adapt_integrate(f_test, &fdata, dim, xmin, xmax, maxEval, 0, tol, &val, &err); printf("integration val = %g, est. err = %g, true err = %g\n", val, err, num_abs(val - exact_integral(dim, xmax))); printf("#evals = %d\n", count); free(xmax); free(xmin); return 0; } #else /*************************************************************************/ /* libctl interface */ static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, const double *xmax, unsigned maxEval, double reqAbsError, double reqRelError, num *val, double *err); typedef struct { cmultivar_func f; void *fdata; } cnum_wrap_data; static num cnum_wrap(unsigned ndim, const double *x, void *fdata_) { cnum_wrap_data *fdata = (cnum_wrap_data *) fdata_; cnumber val = fdata->f(ndim, (double *) x, fdata->fdata); return (cnumber_re(val) + I*cnumber_im(val)); } cnumber cadaptive_integration(cmultivar_func f, number *xmin, number *xmax, integer n, void *fdata, number abstol, number reltol, integer maxnfe, number *esterr, integer *errflag) { num val; cnum_wrap_data wdata; wdata.f = f; wdata.fdata = fdata; *errflag = adapt_integrate(cnum_wrap, &wdata, n, xmin, xmax, maxnfe, abstol, reltol, &val, esterr); return make_cnumber(creal(val), cimag(val)); } static cnumber cf_scm_wrapper(integer n, number *x, void *f_scm_p) { SCM *f_scm = (SCM *) f_scm_p; return scm2cnumber(gh_call1(*f_scm, make_number_list(n, x))); } SCM cadaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, SCM abstol_scm, SCM reltol_scm, SCM maxnfe_scm) { integer n, maxnfe, errflag, i; number *xmin, *xmax, abstol, reltol; cnumber integral; n = list_length(xmin_scm); abstol = fabs(ctl_convert_number_to_c(abstol_scm)); reltol = fabs(ctl_convert_number_to_c(reltol_scm)); maxnfe = ctl_convert_integer_to_c(maxnfe_scm); if (list_length(xmax_scm) != n) { fprintf(stderr, "adaptive_integration: xmin/xmax dimension mismatch\n"); return SCM_UNDEFINED; } xmin = (number*) malloc(sizeof(number) * n); xmax = (number*) malloc(sizeof(number) * n); if (!xmin || !xmax) { fprintf(stderr, "adaptive_integration: error, out of memory!\n"); exit(EXIT_FAILURE); } for (i = 0; i < n; ++i) { xmin[i] = number_list_ref(xmin_scm, i); xmax[i] = number_list_ref(xmax_scm, i); } integral = cadaptive_integration(cf_scm_wrapper, xmin, xmax, n, &f_scm, abstol, reltol, maxnfe, &abstol, &errflag); free(xmax); free(xmin); switch (errflag) { case 3: fprintf(stderr, "adaptive_integration: invalid inputs\n"); return SCM_UNDEFINED; case 1: fprintf(stderr, "adaptive_integration: maxnfe too small\n"); break; case 2: fprintf(stderr, "adaptive_integration: lenwork too small\n"); break; } return gh_cons(cnumber2scm(integral), ctl_convert_number_to_scm(abstol)); } #endif #endif /* CTL_HAS_COMPLEX_INTEGRATION */ libctl-4.4.0/src/ctl-f77-glue.c000066400000000000000000000272711356267410600160630ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ #include #include #include #include "ctl.h" #include "config.h" /* This file contains glue code that enables us to call libctl from Fortran. We have to take into account several things: 1) All Fortran parameters are passed by reference. 2) Fortran compilers are case-insensitive, so they munge identifiers in a weird way for the linker. If we want a Fortran program to be able to call us, we have to munge our identifiers in the same way. (We do this with the F77_FUNC macro--every Fortran compiler is different. F77_FUNC is determined by the configure script.) 3) Fortran represents strings in a different way than C. To handle this, we require that Fortran callers pass us the length of a string as an explicit parameter. We also have to include ugly hacks to accomodate the fact that Cray Fortran compilers pass a data structure instead of a char* for string parameters. 4) On some machines, C functions return their results in a way that the Fortran compiler can't handle. To get around this, all return results of functions are converted into an extra parameter. The name of our Fortran routines is the same as the corresponding C routine with the underscores removed. So, we to construct the Fortran call, you do something like: C: foo = bar_baz(x,y,z); Fortran: call barbaz(x,y,z,foo) C: foo = bar_baz(x,string,y); Fortran: call barbaz(x,string,length(string),y,foo) (Note that string parameters get converted into two parameters: the string and its length.) */ #ifdef F77_FUNC /* if we know how to mangle identifiers for Fortran */ /**************************************************************************/ /* Convert Fortran string parameters to C char*. This is required in order to accomodate the ugly things that the Cray compilers do. */ #if defined(CRAY) || defined(_UNICOS) || defined(_CRAYMPP) #include typedef _fcd fortran_string; #define fcp2ccp(fs) _fcdtocp(fs) #else typedef char *fortran_string; #define fcp2ccp(fs) (fs) #endif /**************************************************************************/ /* Vector functions: (vector3 can be declared as an array of 3 reals in Fortran) */ void F77_FUNC(vector3scale,VECTOR3SCALE) (number *s, vector3 *v, vector3 *vscaled) { *vscaled = vector3_scale(*s,*v); } void F77_FUNC(vector3plus,VECTOR3PLUS) (vector3 *v1, vector3 *v2, vector3 *vresult) { *vresult = vector3_plus(*v1,*v2); } void F77_FUNC(vector3minus,VECTOR3MINUS) (vector3 *v1, vector3 *v2, vector3 *vresult) { *vresult = vector3_minus(*v1,*v2); } void F77_FUNC(vector3cross,VECTOR3CROSS) (vector3 *v1, vector3 *v2, vector3 *vresult) { *vresult = vector3_cross(*v1,*v2); } void F77_FUNC(vector3dot,VECTOR3DOT) (vector3 *v1, vector3 *v2, number *result) { *result = vector3_dot(*v1,*v2); } void F77_FUNC(vector3norm,VECTOR3DOT) (vector3 *v, number *result) { *result = vector3_norm(*v); } /**************************************************************************/ /* variable get/set functions */ /* Note that list and object variables in Fortran should be declared as something the same size as the corresponding type in C. (This turns out to be the same size as a long int.) */ /* Getters: */ void F77_FUNC(ctlgetnumber,CTLGETNUMBER) (fortran_string identifier, int *length, number *result) { char *s = fcp2ccp(identifier); s[*length] = 0; *result = ctl_get_number(s); } void F77_FUNC(ctlgetinteger,CTLGETINTEGER) (fortran_string identifier, int *length, integer *result) { char *s = fcp2ccp(identifier); s[*length] = 0; *result = ctl_get_integer(s); } void F77_FUNC(ctlgetboolean,CTLGETBOOLEAN) (fortran_string identifier, int *length, boolean *result) { char *s = fcp2ccp(identifier); s[*length] = 0; *result = ctl_get_boolean(s); } void F77_FUNC(ctlgetlist,CTLGETLIST) (fortran_string identifier, int *length, list *result) { char *s = fcp2ccp(identifier); s[*length] = 0; *result = ctl_get_list(s); } void F77_FUNC(ctlgetobject,CTLGETOBJECT) (fortran_string identifier, int *length, object *result) { char *s = fcp2ccp(identifier); s[*length] = 0; *result = ctl_get_object(s); } void F77_FUNC(ctlgetvector3,CTLGETVECTOR3) (fortran_string identifier, int *length, vector3 *result) { char *s = fcp2ccp(identifier); s[*length] = 0; *result = ctl_get_vector3(s); } /* ctl_get_string doesn't work perfectly--there is no portable way to set the length of the Fortran string. The length is returned in result_length. */ void F77_FUNC(ctlgetstring,CTLGETSTRING) (fortran_string identifier, int *length, fortran_string result, int *result_length) { char *r; char *s = fcp2ccp(identifier); s[*length] = 0; int len; r = ctl_get_string(s); strncpy(fcp2ccp(result), r, *result_length); len = (int) strlen(r); if (*result_length < len) *result_length = len; free(r); } /* Setters: */ void F77_FUNC(ctlsetnumber,CTLSETNUMBER) (fortran_string identifier, int *length, number *value) { char *s = fcp2ccp(identifier); s[*length] = 0; ctl_set_number(s, *value); } void F77_FUNC(ctlsetinteger,CTLSETINTEGER) (fortran_string identifier, int *length, integer *value) { char *s = fcp2ccp(identifier); s[*length] = 0; ctl_set_integer(s, *value); } void F77_FUNC(ctlsetboolean,CTLSETBOOLEAN) (fortran_string identifier, int *length, boolean *value) { char *s = fcp2ccp(identifier); s[*length] = 0; ctl_set_boolean(s, *value); } void F77_FUNC(ctlsetlist,CTLSETLIST) (fortran_string identifier, int *length, list *value) { char *s = fcp2ccp(identifier); s[*length] = 0; ctl_set_list(s, *value); } void F77_FUNC(ctlsetobject,CTLSETOBJECT) (fortran_string identifier, int *length, object *value) { char *s = fcp2ccp(identifier); s[*length] = 0; ctl_set_object(s, *value); } void F77_FUNC(ctlsetvector3,CTLSETVECTOR3) (fortran_string identifier, int *length, vector3 *value) { char *s = fcp2ccp(identifier); s[*length] = 0; ctl_set_vector3(s, *value); } void F77_FUNC(ctlsetstring,CTLSETSTRING) (fortran_string identifier, int *length, fortran_string value, int *value_length) { char *s = fcp2ccp(identifier); char *v = fcp2ccp(value); s[*length] = 0; v[*value_length] = 0; ctl_set_string(s, v); } /**************************************************************************/ /* list traversal */ void F77_FUNC(listlength,LISTLENGTH)(list *l, int *len) { *len = list_length(*l); } void F77_FUNC(numberlistref,NUMBERLISTREF) (list *l, int *index, number *value) { *value = number_list_ref(*l, *index); } void F77_FUNC(integerlistref,INTEGERLISTREF) (list *l, int *index, integer *value) { *value = integer_list_ref(*l, *index); } void F77_FUNC(booleanlistref,BOOLEANLISTREF) (list *l, int *index, boolean *value) { *value = boolean_list_ref(*l, *index); } void F77_FUNC(vector3listref,VECTOR3LISTREF) (list *l, int *index, vector3 *value) { *value = vector3_list_ref(*l, *index); } void F77_FUNC(listlistref,LISTLISTREF) (list *l, int *index, list *value) { *value = list_list_ref(*l, *index); } void F77_FUNC(objectlistref,OBJECTLISTREF) (list *l, int *index, object *value) { *value = object_list_ref(*l, *index); } void F77_FUNC(stringlistref,STRINGLISTREF) (list *l, int *index, fortran_string value, int *value_length) { char *v; int len; v = string_list_ref(*l, *index); strncpy(fcp2ccp(value), v, *value_length); len = (int) strlen(v); if (*value_length < len) *value_length = len; free(v); } /**************************************************************************/ /* list creation */ void F77_FUNC(makenumberlist,MAKENUMBERLIST) (int *num_items, number *items, list *result) { *result = make_number_list(*num_items, items); } void F77_FUNC(makeintegerlist,MAKEINTEGERLIST) (int *num_items, integer *items, list *result) { *result = make_integer_list(*num_items, items); } void F77_FUNC(makebooleanlist,MAKEBOOLEANLIST) (int *num_items, boolean *items, list *result) { *result = make_boolean_list(*num_items, items); } void F77_FUNC(makevector3list,MAKEVECTOR3LIST) (int *num_items, vector3 *items, list *result) { *result = make_vector3_list(*num_items, items); } void F77_FUNC(makelistlist,MAKELISTLIST) (int *num_items, list *items, list *result) { *result = make_list_list(*num_items, items); } void F77_FUNC(makeobjectlist,MAKEOBJECTLIST) (int *num_items, object *items, list *result) { *result = make_object_list(*num_items, items); } /* make_string_list is not supported. Strings in Fortran suck. */ /**************************************************************************/ /* object properties */ void F77_FUNC(objectismember,OBJECTISMEMBER) (fortran_string type_name, int *length, object *o, boolean *result) { char *s = fcp2ccp(type_name); s[*length] = 0; *result = object_is_member(s,*o); } void F77_FUNC(numberobjectproperty,NUMBEROBJECTPROPERTY) (object *o, fortran_string property_name, int *length, number *result) { char *s = fcp2ccp(property_name); s[*length] = 0; *result = number_object_property(*o,s); } void F77_FUNC(integerobjectproperty,INTEGEROBJECTPROPERTY) (object *o, fortran_string property_name, int *length, integer *result) { char *s = fcp2ccp(property_name); s[*length] = 0; *result = integer_object_property(*o,s); } void F77_FUNC(booleanobjectproperty,BOOLEANOBJECTPROPERTY) (object *o, fortran_string property_name, int *length, boolean *result) { char *s = fcp2ccp(property_name); s[*length] = 0; *result = boolean_object_property(*o,s); } void F77_FUNC(vector3objectproperty,VECTOR3OBJECTPROPERTY) (object *o, fortran_string property_name, int *length, vector3 *result) { char *s = fcp2ccp(property_name); s[*length] = 0; *result = vector3_object_property(*o,s); } void F77_FUNC(listobjectproperty,LISTOBJECTPROPERTY) (object *o, fortran_string property_name, int *length, list *result) { char *s = fcp2ccp(property_name); s[*length] = 0; *result = list_object_property(*o,s); } void F77_FUNC(objectobjectproperty,OBJECTOBJECTPROPERTY) (object *o, fortran_string property_name, int *length, object *result) { char *s = fcp2ccp(property_name); s[*length] = 0; *result = object_object_property(*o,s); } void F77_FUNC(stringobjectproperty,STRINGOBJECTPROPERTY) (object *o, fortran_string property_name, int *length, fortran_string result, int *result_length) { char *r; char *s = fcp2ccp(property_name); s[*length] = 0; int len; r = string_object_property(*o,s); strncpy(fcp2ccp(result), r, *result_length); len = (int) strlen(r); if (*result_length < len) *result_length = len; free(r); } /**************************************************************************/ #endif /* F77_FUNC */ libctl-4.4.0/src/ctl-math.c000066400000000000000000000166361356267410600154620ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ #include #include #include #include #include "ctl-math.h" /**************************************************************************/ /* vector3 and matrix3x3 utilities: */ number vector3_dot(vector3 v1,vector3 v2) { return (v1.x * v2.x + v1.y * v2.y + v1.z * v2.z); } number vector3_norm(vector3 v) { return (sqrt(vector3_dot(v,v))); } vector3 vector3_scale(number s, vector3 v) { vector3 vnew; vnew.x = s * v.x; vnew.y = s * v.y; vnew.z = s * v.z; return vnew; } vector3 unit_vector3(vector3 v) { number norm = vector3_norm(v); if (norm == 0.0) return v; else return vector3_scale(1.0/norm, v); } vector3 vector3_plus(vector3 v1,vector3 v2) { vector3 vnew; vnew.x = v1.x + v2.x; vnew.y = v1.y + v2.y; vnew.z = v1.z + v2.z; return vnew; } vector3 vector3_minus(vector3 v1,vector3 v2) { vector3 vnew; vnew.x = v1.x - v2.x; vnew.y = v1.y - v2.y; vnew.z = v1.z - v2.z; return vnew; } vector3 vector3_cross(vector3 v1,vector3 v2) { vector3 vnew; vnew.x = v1.y * v2.z - v2.y * v1.z; vnew.y = v1.z * v2.x - v2.z * v1.x; vnew.z = v1.x * v2.y - v2.x * v1.y; return vnew; } int vector3_equal(vector3 v1, vector3 v2) { return (v1.x == v2.x && v1.y == v2.y && v1.z == v2.z); } vector3 matrix3x3_vector3_mult(matrix3x3 m, vector3 v) { vector3 vnew; vnew.x = m.c0.x * v.x + m.c1.x * v.y + m.c2.x * v.z; vnew.y = m.c0.y * v.x + m.c1.y * v.y + m.c2.y * v.z; vnew.z = m.c0.z * v.x + m.c1.z * v.y + m.c2.z * v.z; return vnew; } vector3 matrix3x3_transpose_vector3_mult(matrix3x3 m, vector3 v) { vector3 vnew; vnew.x = m.c0.x * v.x + m.c0.y * v.y + m.c0.z * v.z; vnew.y = m.c1.x * v.x + m.c1.y * v.y + m.c1.z * v.z; vnew.z = m.c2.x * v.x + m.c2.y * v.y + m.c2.z * v.z; return vnew; } matrix3x3 matrix3x3_mult(matrix3x3 m1, matrix3x3 m2) { matrix3x3 m; m.c0.x = m1.c0.x * m2.c0.x + m1.c1.x * m2.c0.y + m1.c2.x * m2.c0.z; m.c0.y = m1.c0.y * m2.c0.x + m1.c1.y * m2.c0.y + m1.c2.y * m2.c0.z; m.c0.z = m1.c0.z * m2.c0.x + m1.c1.z * m2.c0.y + m1.c2.z * m2.c0.z; m.c1.x = m1.c0.x * m2.c1.x + m1.c1.x * m2.c1.y + m1.c2.x * m2.c1.z; m.c1.y = m1.c0.y * m2.c1.x + m1.c1.y * m2.c1.y + m1.c2.y * m2.c1.z; m.c1.z = m1.c0.z * m2.c1.x + m1.c1.z * m2.c1.y + m1.c2.z * m2.c1.z; m.c2.x = m1.c0.x * m2.c2.x + m1.c1.x * m2.c2.y + m1.c2.x * m2.c2.z; m.c2.y = m1.c0.y * m2.c2.x + m1.c1.y * m2.c2.y + m1.c2.y * m2.c2.z; m.c2.z = m1.c0.z * m2.c2.x + m1.c1.z * m2.c2.y + m1.c2.z * m2.c2.z; return m; } matrix3x3 matrix3x3_transpose(matrix3x3 m) { matrix3x3 mt; mt.c0.x = m.c0.x; mt.c1.x = m.c0.y; mt.c2.x = m.c0.z; mt.c0.y = m.c1.x; mt.c1.y = m.c1.y; mt.c2.y = m.c1.z; mt.c0.z = m.c2.x; mt.c1.z = m.c2.y; mt.c2.z = m.c2.z; return mt; } number matrix3x3_determinant(matrix3x3 m) { return(m.c0.x*m.c1.y*m.c2.z - m.c2.x*m.c1.y*m.c0.z + m.c1.x*m.c2.y*m.c0.z + m.c0.y*m.c1.z*m.c2.x - m.c1.x*m.c0.y*m.c2.z - m.c2.y*m.c1.z*m.c0.x); } matrix3x3 matrix3x3_inverse(matrix3x3 m) { matrix3x3 minv; number detinv = matrix3x3_determinant(m); if (detinv == 0.0) { fprintf(stderr, "error: singular matrix in matrix3x3_inverse!\n"); exit(EXIT_FAILURE); } detinv = 1.0/detinv; minv.c0.x = detinv * (m.c1.y * m.c2.z - m.c2.y * m.c1.z); minv.c1.y = detinv * (m.c0.x * m.c2.z - m.c2.x * m.c0.z); minv.c2.z = detinv * (m.c1.y * m.c0.x - m.c0.y * m.c1.x); minv.c0.z = detinv * (m.c0.y * m.c1.z - m.c1.y * m.c0.z); minv.c0.y = -detinv * (m.c0.y * m.c2.z - m.c2.y * m.c0.z); minv.c1.z = -detinv * (m.c0.x * m.c1.z - m.c1.x * m.c0.z); minv.c2.x = detinv * (m.c1.x * m.c2.y - m.c1.y * m.c2.x); minv.c1.x = -detinv * (m.c1.x * m.c2.z - m.c1.z * m.c2.x); minv.c2.y = -detinv * (m.c0.x * m.c2.y - m.c0.y * m.c2.x); return minv; } int matrix3x3_equal(matrix3x3 m1, matrix3x3 m2) { return (vector3_equal(m1.c0, m2.c0) && vector3_equal(m1.c1, m2.c1) && vector3_equal(m1.c2, m2.c2)); } vector3 matrix3x3_row1(matrix3x3 m) { vector3 v; v.x = m.c0.x; v.y = m.c1.x; v.z = m.c2.x; return v; } vector3 matrix3x3_row2(matrix3x3 m) { vector3 v; v.x = m.c0.y; v.y = m.c1.y; v.z = m.c2.y; return v; } vector3 matrix3x3_row3(matrix3x3 m) { vector3 v; v.x = m.c0.z; v.y = m.c1.z; v.z = m.c2.z; return v; } /**************************************************************************/ /* complex number utilities */ cnumber make_cnumber(number r, number i) { cnumber c; c.re = r; c.im = i; return c; } cnumber cnumber_conj(cnumber c) { return make_cnumber(c.re, -c.im); } int cnumber_equal(cnumber c1, cnumber c2) { return (c1.re == c2.re && c1.im == c2.im); } vector3 cvector3_re(cvector3 cv) { vector3 v; v.x = cv.x.re; v.y = cv.y.re; v.z = cv.z.re; return v; } vector3 cvector3_im(cvector3 cv) { vector3 v; v.x = cv.x.im; v.y = cv.y.im; v.z = cv.z.im; return v; } cvector3 make_cvector3(vector3 vr, vector3 vi) { cvector3 cv; cv.x = make_cnumber(vr.x, vi.x); cv.y = make_cnumber(vr.y, vi.y); cv.z = make_cnumber(vr.z, vi.z); return cv; } int cvector3_equal(cvector3 v1, cvector3 v2) { return (vector3_equal(cvector3_re(v1), cvector3_re(v2)) && vector3_equal(cvector3_im(v1), cvector3_im(v2))); } matrix3x3 cmatrix3x3_re(cmatrix3x3 cm) { matrix3x3 m; m.c0 = cvector3_re(cm.c0); m.c1 = cvector3_re(cm.c1); m.c2 = cvector3_re(cm.c2); return m; } matrix3x3 cmatrix3x3_im(cmatrix3x3 cm) { matrix3x3 m; m.c0 = cvector3_im(cm.c0); m.c1 = cvector3_im(cm.c1); m.c2 = cvector3_im(cm.c2); return m; } cmatrix3x3 make_cmatrix3x3(matrix3x3 mr, matrix3x3 mi) { cmatrix3x3 cm; cm.c0 = make_cvector3(mr.c0, mi.c0); cm.c1 = make_cvector3(mr.c1, mi.c1); cm.c2 = make_cvector3(mr.c2, mi.c2); return cm; } cmatrix3x3 make_hermitian_cmatrix3x3(number m00, number m11, number m22, cnumber m01, cnumber m02, cnumber m12) { cmatrix3x3 cm; cm.c0.x = make_cnumber(m00, 0); cm.c1.y = make_cnumber(m11, 0); cm.c2.z = make_cnumber(m22, 0); cm.c1.x = m01; cm.c0.y = cnumber_conj(m01); cm.c2.x = m02; cm.c0.z = cnumber_conj(m02); cm.c2.y = m12; cm.c1.z = cnumber_conj(m12); return cm; } int cmatrix3x3_equal(cmatrix3x3 m1, cmatrix3x3 m2) { return (matrix3x3_equal(cmatrix3x3_re(m1), cmatrix3x3_re(m2)) && matrix3x3_equal(cmatrix3x3_im(m1), cmatrix3x3_im(m2))); } libctl-4.4.0/src/ctl-math.h000066400000000000000000000105051356267410600154540ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ /* just the non-Guile-based vector/matrix math routines in libctl, for use in libctlgeom */ #ifndef CTL_MATH_H #define CTL_MATH_H #ifdef __cplusplus extern "C" { #endif /* __cplusplus */ /**************************************************************************/ /* Basic types: */ typedef int integer; typedef double number; typedef struct { number re, im; } cnumber; /* complex numbers! */ typedef short boolean; typedef char *string; /* define vector3 as a structure, not an array, so that it can be a function return value and so that simple assignment works. */ typedef struct { number x,y,z; } vector3; /* similarly for matrix3x3 */ typedef struct { vector3 c0, c1, c2; /* the columns */ } matrix3x3; /* define complex equivalents: */ typedef struct { cnumber x,y,z; } cvector3; typedef struct { cvector3 c0, c1, c2; /* the columns */ } cmatrix3x3; /**************************************************************************/ /* vector3 and matrix3x3 utilities: */ extern number vector3_dot(vector3 v1,vector3 v2); extern number vector3_norm(vector3 v); extern vector3 vector3_scale(number s, vector3 v); extern vector3 unit_vector3(vector3 v); extern vector3 vector3_cross(vector3 v1,vector3 v2); extern vector3 vector3_plus(vector3 v1,vector3 v2); extern vector3 vector3_minus(vector3 v1,vector3 v2); extern int vector3_equal(vector3 v1, vector3 v2); extern vector3 matrix3x3_vector3_mult(matrix3x3 m, vector3 v); extern vector3 matrix3x3_transpose_vector3_mult(matrix3x3 m, vector3 v); extern matrix3x3 matrix3x3_mult(matrix3x3 m1, matrix3x3 m2); extern matrix3x3 matrix3x3_transpose(matrix3x3 m); extern number matrix3x3_determinant(matrix3x3 m); extern matrix3x3 matrix3x3_inverse(matrix3x3 m); extern int matrix3x3_equal(matrix3x3 m1, matrix3x3 m2); extern vector3 matrix3x3_row1(matrix3x3 m); extern vector3 matrix3x3_row2(matrix3x3 m); extern vector3 matrix3x3_row3(matrix3x3 m); /**************************************************************************/ /* complex number utilities */ extern cnumber make_cnumber(number r, number i); extern cnumber cnumber_conj(cnumber c); extern int cnumber_equal(cnumber c1, cnumber c2); #define cnumber_re(c) ((c).re) #define cnumber_im(c) ((c).im) extern vector3 cvector3_re(cvector3 cv); extern vector3 cvector3_im(cvector3 cv); extern cvector3 make_cvector3(vector3 vr, vector3 vi); extern int cvector3_equal(cvector3 v1, cvector3 v2); extern matrix3x3 cmatrix3x3_re(cmatrix3x3 cm); extern matrix3x3 cmatrix3x3_im(cmatrix3x3 cm); extern cmatrix3x3 make_cmatrix3x3(matrix3x3 mr, matrix3x3 mi); cmatrix3x3 make_hermitian_cmatrix3x3(number m00, number m11, number m22, cnumber m01, cnumber m02, cnumber m12); extern int cmatrix3x3_equal(cmatrix3x3 m1, cmatrix3x3 m2); /**************************************************************************/ /* multi-dimensional integration routines */ typedef number (*multivar_func) (integer, number *, void *); extern number adaptive_integration(multivar_func f, number *xmin, number *xmax, integer n, void *fdata, number abstol, number reltol, integer maxnfe, number *esterr, integer *errflag); /**************************************************************************/ #ifdef __cplusplus } /* extern "C" */ #endif /* __cplusplus */ #endif /* CTL_MATH_H */ libctl-4.4.0/src/ctl.c000066400000000000000000000404321356267410600145220ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ #include #include #include #include #include "ctl.h" /**************************************************************************/ /* Functions missing from Guile 1.2: */ #if !defined(HAVE_GH_BOOL2SCM) && !defined(HAVE_NO_GH) /* Guile 1.2 is missing gh_bool2scm for some reason; redefine: */ SCM ctl_gh_bool2scm(boolean b) { return (b ? SCM_BOOL_T : SCM_BOOL_F); } #endif #if defined(HAVE_NO_GH) # define gh_length(x) scm_to_long(scm_length(x)) #elif !defined(HAVE_GH_LENGTH) # define gh_length gh_list_length #endif #if defined(HAVE_NO_GH) # define list_ref(l,index) scm_list_ref(l,scm_from_int(index)) #elif !defined(HAVE_GH_LIST_REF) /* Guile 1.2 doesn't have the gh_list_ref function. Sigh. */ /* Note: index must be in [0,list_length(l) - 1]. We don't check! */ static SCM list_ref(list l, int index) { SCM cur = SCM_UNSPECIFIED, rest = l; while (index >= 0) { cur = gh_car(rest); rest = gh_cdr(rest); --index; } return cur; } #else /* HAVE_GH_LIST_REF */ #define list_ref(l,index) gh_list_ref(l,gh_int2scm(index)) #endif #if defined(HAVE_NO_GH) # define vector_ref(v,i) scm_c_vector_ref(v,i) #elif !defined(HAVE_GH_VECTOR_REF) # define vector_ref(v,i) gh_vref(v,gh_int2scm(i)) #else # define vector_ref(v,i) gh_vector_ref(v,gh_int2scm(i)) #endif /**************************************************************************/ /* Scheme file loading (don't use gh_load directly because subsequent loads won't use the correct path name). Uses our "include" function from include.scm, or defaults to gh_load if this function isn't defined. */ void ctl_include(const char *filename) { SCM include_proc = gh_lookup("include"); if (include_proc == SCM_UNDEFINED) gh_load(filename); else #ifdef HAVE_NO_GH scm_call_1(include_proc, ctl_convert_string_to_scm(filename)); #else gh_call1(include_proc, gh_str02scm(filename)); #endif } /* convert a pathname into one relative to the current include dir */ char *ctl_fix_path(const char *path) { char *newpath; if (path[0] != '/') { SCM include_dir = gh_lookup("include-dir"); if (include_dir != SCM_UNDEFINED) { char *dir = ctl_convert_string_to_c(include_dir); newpath = (char *) malloc(sizeof(char) * (strlen(dir) + strlen(path) + 2)); strcpy(newpath, dir); free(dir); if (newpath[0] && newpath[strlen(newpath)-1] != '/') strcat(newpath, "/"); strcat(newpath, path); return newpath; } } newpath = (char *) malloc(sizeof(char) * (strlen(path) + 1)); strcpy(newpath, path); return newpath; } /**************************************************************************/ /* type conversion */ vector3 scm2vector3(SCM sv) { vector3 v; v.x = ctl_convert_number_to_c(vector_ref(sv,0)); v.y = ctl_convert_number_to_c(vector_ref(sv,1)); v.z = ctl_convert_number_to_c(vector_ref(sv,2)); return v; } matrix3x3 scm2matrix3x3(SCM sm) { matrix3x3 m; m.c0 = scm2vector3(vector_ref(sm,0)); m.c1 = scm2vector3(vector_ref(sm,1)); m.c2 = scm2vector3(vector_ref(sm,2)); return m; } static SCM make_vector3(SCM x, SCM y, SCM z) { SCM vscm; vscm = scm_c_make_vector(3, SCM_UNSPECIFIED); #ifdef SCM_SIMPLE_VECTOR_SET SCM_SIMPLE_VECTOR_SET(vscm, 0, x); SCM_SIMPLE_VECTOR_SET(vscm, 1, y); SCM_SIMPLE_VECTOR_SET(vscm, 2, z); #else { SCM *data; data = SCM_VELTS(vscm); data[0] = x; data[1] = y; data[2] = z; } #endif return vscm; } SCM vector32scm(vector3 v) { return make_vector3(ctl_convert_number_to_scm(v.x), ctl_convert_number_to_scm(v.y), ctl_convert_number_to_scm(v.z)); } SCM matrix3x32scm(matrix3x3 m) { return make_vector3(vector32scm(m.c0), vector32scm(m.c1), vector32scm(m.c2)); } cnumber scm2cnumber(SCM sx) { #ifdef HAVE_SCM_COMPLEXP if (scm_real_p(sx) && !(SCM_COMPLEXP(sx))) return make_cnumber(ctl_convert_number_to_c(sx), 0.0); else return make_cnumber(SCM_COMPLEX_REAL(sx), SCM_COMPLEX_IMAG(sx)); #else if (scm_real_p(sx) && !(SCM_NIMP(sx) && SCM_INEXP(sx) && SCM_CPLXP(sx))) return make_cnumber(ctl_convert_number_to_c(sx), 0.0); else return make_cnumber(SCM_REALPART(sx), SCM_IMAG(sx)); #endif } SCM cnumber2scm(cnumber x) { #if defined(HAVE_SCM_C_MAKE_RECTANGULAR) /* Guile 1.6.5 */ return scm_c_make_rectangular(x.re, x.im); /* Guile 1.5 */ #elif defined(HAVE_SCM_MAKE_COMPLEX) return scm_make_complex(x.re, x.im); /* Guile 1.5 */ #else if (x.im == 0.0) return ctl_convert_number_to_scm(x.re); else return scm_makdbl(x.re, x.im); #endif } cvector3 scm2cvector3(SCM sv) { cvector3 v; v.x = scm2cnumber(vector_ref(sv,0)); v.y = scm2cnumber(vector_ref(sv,1)); v.z = scm2cnumber(vector_ref(sv,2)); return v; } cmatrix3x3 scm2cmatrix3x3(SCM sm) { cmatrix3x3 m; m.c0 = scm2cvector3(vector_ref(sm,0)); m.c1 = scm2cvector3(vector_ref(sm,1)); m.c2 = scm2cvector3(vector_ref(sm,2)); return m; } SCM cvector32scm(cvector3 v) { return make_vector3(cnumber2scm(v.x), cnumber2scm(v.y), cnumber2scm(v.z)); } SCM cmatrix3x32scm(cmatrix3x3 m) { return make_vector3(cvector32scm(m.c0), cvector32scm(m.c1), cvector32scm(m.c2)); } /**************************************************************************/ /* variable get/set functions */ /**** Getters ****/ integer ctl_get_integer(const char *identifier) { return(ctl_convert_integer_to_c(gh_lookup(identifier))); } number ctl_get_number(const char *identifier) { return(ctl_convert_number_to_c(gh_lookup(identifier))); } cnumber ctl_get_cnumber(const char *identifier) { return(scm2cnumber(gh_lookup(identifier))); } boolean ctl_get_boolean(const char *identifier) { return(ctl_convert_boolean_to_c(gh_lookup(identifier))); } char* ctl_get_string(const char *identifier) { return(ctl_convert_string_to_c(gh_lookup(identifier))); } vector3 ctl_get_vector3(const char *identifier) { return(scm2vector3(gh_lookup(identifier))); } matrix3x3 ctl_get_matrix3x3(const char *identifier) { return(scm2matrix3x3(gh_lookup(identifier))); } cvector3 ctl_get_cvector3(const char *identifier) { return(scm2cvector3(gh_lookup(identifier))); } cmatrix3x3 ctl_get_cmatrix3x3(const char *identifier) { return(scm2cmatrix3x3(gh_lookup(identifier))); } list ctl_get_list(const char *identifier) { return(gh_lookup(identifier)); } object ctl_get_object(const char *identifier) { return(gh_lookup(identifier)); } function ctl_get_function(const char *identifier) { return(gh_lookup(identifier)); } SCM ctl_get_SCM(const char *identifier) { return(gh_lookup(identifier)); } /**** Setters ****/ /* UGLY hack alert! There doesn't seem to be any clean way of setting Scheme variables from C in Guile (e.g. no gh_* interface). One option is to use scm_symbol_set_x (symbol-set! in Scheme), but I'm not sure how to get this to work in Guile 1.3 because of the %&*@^-ing module system (I need to pass some module for the first parameter, but I don't know what to pass). Instead, I hacked together the following my_symbol_set_x routine, using the functions scm_symbol_value0 and scm_symbol_set_x from the Guile 1.3 sources. (scm_symbol_value0 has the virtue of looking in the correct module somehow; I also used this function to replace gh_lookup, which broke in Guile 1.3 as well...sigh.) Note that I can't call "set!" because it is really a macro. All the ugliness is confined to the set_value() routine, though. Update: in Guile 1.5, we can call scm_variable_set_x (equivalent to variable-set!) to set values of variables, which are looked up via scm_c_lookup (which doesn't exist in Guile 1.3.x). */ #if !(defined(HAVE_SCM_VARIABLE_SET_X) && defined(HAVE_SCM_C_LOOKUP)) # define USE_MY_SYMBOL_SET_X 1 /* use the hack */ #endif #ifdef USE_MY_SYMBOL_SET_X static SCM my_symbol_set_x(const char *name, SCM v) { /* code swiped from scm_symbol_value0 and scm_symbol_set_x */ SCM symbol = scm_intern_obarray_soft(name, strlen (name), scm_symhash, 0); SCM vcell = scm_sym2vcell (SCM_CAR (symbol), SCM_CDR (scm_top_level_lookup_closure_var), SCM_BOOL_F); if (SCM_FALSEP (vcell)) return SCM_UNDEFINED; SCM_SETCDR (vcell, v); return SCM_UNSPECIFIED; } #endif static void set_value(const char *identifier, SCM value) { #if defined(USE_SCM_SYMBOL_SET_X) /* worked in Guile 1.1, 1.2 */ scm_symbol_set_x(SCM_BOOL_F, gh_symbol2scm(identifier), value); #elif defined(HAVE_SCM_VARIABLE_SET_X) && defined(HAVE_SCM_C_LOOKUP) scm_variable_set_x(scm_c_lookup(identifier), value); #elif defined(USE_MY_SYMBOL_SET_X) my_symbol_set_x(identifier, value); #endif } void ctl_set_integer(const char *identifier, integer value) { set_value(identifier, ctl_convert_integer_to_scm(value)); } void ctl_set_number(const char *identifier, number value) { set_value(identifier, ctl_convert_number_to_scm(value)); } void ctl_set_cnumber(const char *identifier, cnumber value) { set_value(identifier, cnumber2scm(value)); } void ctl_set_boolean(const char *identifier, boolean value) { set_value(identifier, ctl_convert_boolean_to_scm(value)); } void ctl_set_string(const char *identifier, const char *value) { set_value(identifier, ctl_convert_string_to_scm(value)); } void ctl_set_vector3(const char *identifier, vector3 value) { set_value(identifier, vector32scm(value)); } void ctl_set_matrix3x3(const char *identifier, matrix3x3 value) { set_value(identifier, matrix3x32scm(value)); } void ctl_set_cvector3(const char *identifier, cvector3 value) { set_value(identifier, cvector32scm(value)); } void ctl_set_cmatrix3x3(const char *identifier, cmatrix3x3 value) { set_value(identifier, cmatrix3x32scm(value)); } void ctl_set_list(const char *identifier, list value) { set_value(identifier, value); } void ctl_set_object(const char *identifier, object value) { set_value(identifier, value); } void ctl_set_function(const char *identifier, function value) { set_value(identifier, value); } void ctl_set_SCM(const char *identifier, SCM value) { set_value(identifier, value); } /**************************************************************************/ /* list traversal */ int list_length(list l) { return(gh_length(l)); } integer integer_list_ref(list l, int index) { return(ctl_convert_integer_to_c(list_ref(l,index))); } number number_list_ref(list l, int index) { return(ctl_convert_number_to_c(list_ref(l,index))); } cnumber cnumber_list_ref(list l, int index) { return(scm2cnumber(list_ref(l,index))); } boolean boolean_list_ref(list l, int index) { return(SCM_BOOL_F != list_ref(l,index)); } char* string_list_ref(list l, int index) { return(ctl_convert_string_to_c(list_ref(l,index))); } vector3 vector3_list_ref(list l, int index) { return(scm2vector3(list_ref(l,index))); } matrix3x3 matrix3x3_list_ref(list l, int index) { return(scm2matrix3x3(list_ref(l,index))); } cvector3 cvector3_list_ref(list l, int index) { return(scm2cvector3(list_ref(l,index))); } cmatrix3x3 cmatrix3x3_list_ref(list l, int index) { return(scm2cmatrix3x3(list_ref(l,index))); } list list_list_ref(list l, int index) { return(list_ref(l,index)); } object object_list_ref(list l, int index) { return(list_ref(l,index)); } function function_list_ref(list l, int index) { return(list_ref(l,index)); } SCM SCM_list_ref(list l, int index) { return(list_ref(l,index)); } /**************************************************************************/ /* list creation */ #define MAKE_LIST(conv) \ { \ int i; \ list cur_list = SCM_EOL; \ for (i = num_items - 1; i >= 0; --i) \ cur_list = gh_cons(conv (items[i]), cur_list); \ return(cur_list); \ } \ #ifdef HAVE_NO_GH list make_integer_list(int num_items, const integer *items) MAKE_LIST(scm_from_int) list make_boolean_list(int num_items, const boolean *items) MAKE_LIST(scm_from_bool) list make_string_list(int num_items, const char **items) MAKE_LIST(scm_from_locale_string) list make_number_list(int num_items, const number *items) MAKE_LIST(scm_from_double) #else /* ! HAVE_NO_GH */ list make_integer_list(int num_items, const integer *items) MAKE_LIST(gh_int2scm) list make_boolean_list(int num_items, const boolean *items) MAKE_LIST(gh_bool2scm) list make_string_list(int num_items, const char **items) MAKE_LIST(gh_str02scm) list make_number_list(int num_items, const number *items) MAKE_LIST(gh_double2scm) #endif /* ! HAVE_NO_GH */ list make_cnumber_list(int num_items, const cnumber *items) MAKE_LIST(cnumber2scm) list make_vector3_list(int num_items, const vector3 *items) MAKE_LIST(vector32scm) list make_matrix3x3_list(int num_items, const matrix3x3 *items) MAKE_LIST(matrix3x32scm) list make_cvector3_list(int num_items, const cvector3 *items) MAKE_LIST(cvector32scm) list make_cmatrix3x3_list(int num_items, const cmatrix3x3 *items) MAKE_LIST(cmatrix3x32scm) #define NO_CONVERSION list make_list_list(int num_items, const list *items) MAKE_LIST(NO_CONVERSION) list make_object_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION) list make_function_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION) list make_SCM_list(int num_items, const object *items) MAKE_LIST(NO_CONVERSION) /**************************************************************************/ /* object properties */ boolean object_is_member(const char *type_name, object o) { return(SCM_BOOL_F != gh_call2(gh_lookup("object-member?"), gh_symbol2scm(type_name), o)); } static SCM object_property_value(object o, const char *property_name) { return(gh_call2(gh_lookup("object-property-value"), o, gh_symbol2scm(property_name))); } integer integer_object_property(object o, const char *property_name) { return(ctl_convert_integer_to_c(object_property_value(o,property_name))); } number number_object_property(object o, const char *property_name) { return(ctl_convert_number_to_c(object_property_value(o,property_name))); } cnumber cnumber_object_property(object o, const char *property_name) { return(scm2cnumber(object_property_value(o,property_name))); } boolean boolean_object_property(object o, const char *property_name) { return(SCM_BOOL_F != object_property_value(o,property_name)); } char* string_object_property(object o, const char *property_name) { return(ctl_convert_string_to_c(object_property_value(o,property_name))); } vector3 vector3_object_property(object o, const char *property_name) { return(scm2vector3(object_property_value(o,property_name))); } matrix3x3 matrix3x3_object_property(object o, const char *property_name) { return(scm2matrix3x3(object_property_value(o,property_name))); } cvector3 cvector3_object_property(object o, const char *property_name) { return(scm2cvector3(object_property_value(o,property_name))); } cmatrix3x3 cmatrix3x3_object_property(object o, const char *property_name) { return(scm2cmatrix3x3(object_property_value(o,property_name))); } list list_object_property(object o, const char *property_name) { return(object_property_value(o,property_name)); } object object_object_property(object o, const char *property_name) { return(object_property_value(o,property_name)); } function function_object_property(object o, const char *property_name) { return(object_property_value(o,property_name)); } SCM SCM_object_property(object o, const char *property_name) { return(object_property_value(o,property_name)); } libctl-4.4.0/src/ctl.h.in000066400000000000000000000316511356267410600151370ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ #ifndef CTL_H #define CTL_H #undef HAVE_NO_GH #ifdef HAVE_NO_GH # include #else # include #endif #include "ctl-math.h" #ifdef __cplusplus extern "C" { #endif /* __cplusplus */ /**************************************************************************/ /* Configuration options (guessed by configure). We have to put them here, rather than in a private config.h file, because they need to be known by user ctl-io.c and main.c files. */ /* set to version string */ #undef LIBCTL_VERSION #undef LIBCTL_MAJOR_VERSION #undef LIBCTL_MINOR_VERSION #undef LIBCTL_BUGFIX_VERSION /* Define if you have the following functions */ #undef HAVE_GH_ENTER #undef HAVE_GH_EVAL_STR #undef HAVE_GH_LOAD #undef HAVE_GH_BOOL2SCM #undef HAVE_GH_VECTOR_REF #undef HAVE_GH_LIST_REF #undef HAVE_GH_LENGTH #undef HAVE_SCM_FLUSH_ALL_PORTS #undef HAVE_SCM_MAKE_COMPLEX #undef HAVE_SCM_C_MAKE_RECTANGULAR #undef HAVE_SCM_VARIABLE_SET_X #undef HAVE_SCM_C_LOOKUP #undef HAVE_SCM_C_MAKE_VECTOR #undef HAVE_SCM_VARIABLE_REF /* Define if you have the HAVE_SCM_COMPLEXP macro. */ #undef HAVE_SCM_COMPLEXP /* Define if gh_lookup is not broken */ #undef GH_LOOKUP_OK /* Define if we have C99 complex numbers and hence complex integration */ #undef CTL_HAS_COMPLEX_INTEGRATION /**************************************************************************/ /* Basic types: */ typedef SCM list; typedef SCM function; typedef SCM object; /**************************************************************************/ #ifdef HAVE_NO_GH /* use replacements for gh functions */ # define gh_call0 scm_call_0 # define gh_call1 scm_call_1 # define gh_call2 scm_call_2 # define gh_call3 scm_call_3 # define gh_apply scm_apply_0 # define gh_eval_str scm_c_eval_string # define gh_symbol2scm scm_from_locale_symbol # define ctl_symbol2newstr(x) scm_to_locale_string(scm_symbol_to_string(x)) # define gh_cons scm_cons # define gh_car scm_car # define gh_cdr scm_cdr # if SCM_MAJOR_VERSION >= 2 /* get types right for C++, since fc argument is void* (grrr) in Guile 2.x */ # define gh_new_procedure(name, fcn, req, opt, rst) scm_c_define_gsubr(name, req, opt, rst, (scm_t_subr) (fcn)) # else # define gh_new_procedure(name, fcn, req, opt, rst) scm_c_define_gsubr(name, req, opt, rst, fcn) # endif # define gh_repl scm_shell #else # define ctl_symbol2newstr(x) gh_symbol2newstr(x, 0) #endif #if !defined(GH_LOOKUP_OK) || defined(HAVE_NO_GH) # if defined(HAVE_SCM_VARIABLE_REF) && defined(HAVE_SCM_C_LOOKUP) # define gh_lookup(name) scm_variable_ref(scm_c_lookup(name)) # else # define gh_lookup scm_symbol_value0 # endif #endif #if !defined(HAVE_GH_LOAD) || defined(HAVE_NO_GH) # ifdef HAVE_NO_GH # define gh_load scm_c_primitive_load # else # define gh_load gh_eval_file # endif #endif extern void ctl_include(const char *filename); extern char *ctl_fix_path(const char *path); /**************************************************************************/ #ifndef HAVE_SCM_C_MAKE_VECTOR # define scm_c_make_vector(n,fill) scm_make_vector(SCM_MAKINUM(n), fill) #endif /**************************************************************************/ /* type conversion */ #if !defined(HAVE_GH_BOOL2SCM) && !defined(HAVE_NO_GH) /* Guile 1.2 is missing gh_bool2scm for some reason; redefine: */ extern SCM ctl_gh_bool2scm(boolean); # define gh_bool2scm ctl_gh_bool2scm #endif extern vector3 scm2vector3(SCM sv); extern SCM vector32scm(vector3 v); extern matrix3x3 scm2matrix3x3(SCM sm); extern SCM matrix3x32scm(matrix3x3 m); extern cnumber scm2cnumber(SCM sx); extern SCM cnumber2scm(cnumber x); extern cvector3 scm2cvector3(SCM sv); extern SCM cvector32scm(cvector3 v); extern cmatrix3x3 scm2cmatrix3x3(SCM sm); extern SCM cmatrix3x32scm(cmatrix3x3 m); #ifdef HAVE_NO_GH # define ctl_convert_number_to_scm(x) scm_from_double(x) # define ctl_convert_number_to_c(x) scm_to_double(x) # define ctl_convert_integer_to_scm(x) scm_from_int(x) # define ctl_convert_integer_to_c(x) scm_to_int(x) # define ctl_convert_string_to_scm(x) scm_from_locale_string(x) # define ctl_convert_string_to_c(x) scm_to_locale_string(x) # define ctl_convert_boolean_to_scm(x) scm_from_bool(x) # define ctl_convert_boolean_to_c(x) scm_to_bool(x) #else # define ctl_convert_number_to_scm(x) gh_double2scm(x) # define ctl_convert_number_to_c(x) gh_scm2double(x) # define ctl_convert_integer_to_scm(x) gh_int2scm(x) # define ctl_convert_integer_to_c(x) gh_scm2int(x) # define ctl_convert_string_to_scm(x) gh_str02scm(x) # define ctl_convert_string_to_c(x) gh_scm2newstr(x, 0) # define ctl_convert_boolean_to_scm(x) gh_bool2scm(x) # define ctl_convert_boolean_to_c(x) gh_scm2bool(x) #endif #define ctl_convert_cnumber_to_scm(x) cnumber2scm(x) #define ctl_convert_vector3_to_scm(x) vector32scm(x) #define ctl_convert_matrix3x3_to_scm(x) matrix3x32scm(x) #define ctl_convert_cvector3_to_scm(x) cvector32scm(x) #define ctl_convert_cmatrix3x3_to_scm(x) cmatrix3x32scm(x) #define ctl_convert_SCM_to_scm(x) (x) #define ctl_convert_function_to_scm(x) (x) #define ctl_convert_object_to_scm(x) (x) #define ctl_convert_list_to_scm(x) (x) #define ctl_convert_cnumber_to_c(x) scm2cnumber(x) #define ctl_convert_vector3_to_c(x) scm2vector3(x) #define ctl_convert_matrix3x3_to_c(x) scm2matrix3x3(x) #define ctl_convert_cvector3_to_c(x) scm2cvector3(x) #define ctl_convert_cmatrix3x3_to_c(x) scm2cmatrix3x3(x) #define ctl_convert_SCM_to_c(x) (x) #define ctl_convert_function_to_c(x) (x) #define ctl_convert_object_to_c(x) (x) #define ctl_convert_list_to_c(x) (x) /**************************************************************************/ /* variable get/set functions */ extern integer ctl_get_integer(const char *identifier); extern number ctl_get_number(const char *identifier); extern cnumber ctl_get_cnumber(const char *identifier); extern boolean ctl_get_boolean(const char *identifier); extern char* ctl_get_string(const char *identifier); extern vector3 ctl_get_vector3(const char *identifier); extern matrix3x3 ctl_get_matrix3x3(const char *identifier); extern cvector3 ctl_get_cvector3(const char *identifier); extern cmatrix3x3 ctl_get_cmatrix3x3(const char *identifier); extern list ctl_get_list(const char *identifier); extern object ctl_get_object(const char *identifier); extern function ctl_get_function(const char *identifier); extern SCM ctl_get_SCM(const char *identifier); extern void ctl_set_integer(const char *identifier, integer value); extern void ctl_set_number(const char *identifier, number value); extern void ctl_set_cnumber(const char *identifier, cnumber value); extern void ctl_set_boolean(const char *identifier, boolean value); extern void ctl_set_string(const char *identifier, const char *value); extern void ctl_set_vector3(const char *identifier, vector3 value); extern void ctl_set_matrix3x3(const char *identifier, matrix3x3 value); extern void ctl_set_cvector3(const char *identifier, cvector3 value); extern void ctl_set_cmatrix3x3(const char *identifier, cmatrix3x3 value); extern void ctl_set_list(const char *identifier, list value); extern void ctl_set_object(const char *identifier, object value); extern void ctl_set_function(const char *identifier, function value); extern void ctl_set_SCM(const char *identifier, SCM value); /**************************************************************************/ /* list traversal */ extern int list_length(list l); extern integer integer_list_ref(list l, int index); extern number number_list_ref(list l, int index); extern cnumber cnumber_list_ref(list l, int index); extern boolean boolean_list_ref(list l, int index); extern char* string_list_ref(list l, int index); extern vector3 vector3_list_ref(list l, int index); extern matrix3x3 matrix3x3_list_ref(list l, int index); extern cvector3 cvector3_list_ref(list l, int index); extern cmatrix3x3 cmatrix3x3_list_ref(list l, int index); extern list list_list_ref(list l, int index); extern object object_list_ref(list l, int index); extern function function_list_ref(list l, int index); extern SCM SCM_list_ref(list l, int index); /**************************************************************************/ /* list creation */ extern list make_integer_list(int num_items, const integer *items); extern list make_number_list(int num_items, const number *items); extern list make_cnumber_list(int num_items, const cnumber *items); extern list make_boolean_list(int num_items, const boolean *items); extern list make_string_list(int num_items, const char **items); extern list make_vector3_list(int num_items, const vector3 *items); extern list make_matrix3x3_list(int num_items, const matrix3x3 *items); extern list make_cvector3_list(int num_items, const cvector3 *items); extern list make_cmatrix3x3_list(int num_items, const cmatrix3x3 *items); extern list make_list_list(int num_items, const list *items); extern list make_object_list(int num_items, const object *items); extern list make_function_list(int num_items, const function *items); extern list make_SCM_list(int num_items, const function *items); /**************************************************************************/ /* object properties */ boolean object_is_member(const char *type_name, object o); extern integer integer_object_property(object o, const char *property_name); extern number number_object_property(object o, const char *property_name); extern cnumber cnumber_object_property(object o, const char *property_name); extern boolean boolean_object_property(object o, const char *property_name); extern char* string_object_property(object o, const char *property_name); extern vector3 vector3_object_property(object o, const char *property_name); extern matrix3x3 matrix3x3_object_property(object o, const char *property_name); extern cvector3 cvector3_object_property(object o, const char *property_name); extern cmatrix3x3 cmatrix3x3_object_property(object o, const char *property_name); extern list list_object_property(object o, const char *property_name); extern object object_object_property(object o, const char *property_name); extern function function_object_property(object o, const char *property_name); extern SCM SCM_object_property(object o, const char *property_name); /**************************************************************************/ /* main() hook functions. These are prototypes of functions defined by the USER and called just before the program starts and just before it ends, respectively. If you want to define them, you should also define HAVE_CTL_HOOKS when compiling main.c. Note that due to the behavior of the Guile interactive mode, ctl_stop_hook will only get called in non-interactive mode. Sigh. */ extern void ctl_start_hook(int *argc, char ***argv); extern void ctl_stop_hook(void); /**************************************************************************/ /* subplex multi-dimensional minimization routines: */ extern number subplex(multivar_func f, number *x, integer n, void *fdata, number tol, integer maxnfe, number fmin, boolean use_fmin, number *scale, integer *nfe, integer *errflag); extern SCM subplex_scm(SCM f_scm, SCM x_scm, SCM tol_scm, SCM maxnfe_scm, SCM fmin_scm, SCM use_fmin_scm, SCM scale_scm); /* multi-dimensional integration routines */ extern SCM adaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, SCM abstol_scm, SCM reltol_scm, SCM maxnfe_scm); #ifdef CTL_HAS_COMPLEX_INTEGRATION typedef cnumber (*cmultivar_func) (integer, number *, void *); extern cnumber cadaptive_integration(cmultivar_func f, number *xmin, number *xmax, integer n, void *fdata, number abstol, number reltol, integer maxnfe, number *esterr, integer *errflag); extern SCM cadaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, SCM abstol_scm, SCM reltol_scm, SCM maxnfe_scm); #endif /* CTL_HAS_COMPLEX_INTEGRATION */ /**************************************************************************/ #ifdef __cplusplus } /* extern "C" */ #endif /* __cplusplus */ #endif /* CTL_H */ libctl-4.4.0/src/integrator.c000066400000000000000000000716421356267410600161250ustar00rootroot00000000000000/* * Copyright (c) 2005 Steven G. Johnson * * Portions (see comments) based on HIntLib (also distributed under * the GNU GPL, v2 or later), copyright (c) 2002-2005 Rudolf Schuerer. * (http://www.cosy.sbg.ac.at/~rschuer/hintlib/) * * Portions (see comments) based on GNU GSL (also distributed under * the GNU GPL, v2 or later), copyright (c) 1996-2000 Brian Gough. * (http://www.gnu.org/software/gsl/) * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * */ #include #include #include #include #include /* Adaptive multidimensional integration on hypercubes (or, really, hyper-rectangles) using cubature rules. A cubature rule takes a function and a hypercube and evaluates the function at a small number of points, returning an estimate of the integral as well as an estimate of the error, and also a suggested dimension of the hypercube to subdivide. Given such a rule, the adaptive integration is simple: 1) Evaluate the cubature rule on the hypercube(s). Stop if converged. 2) Pick the hypercube with the largest estimated error, and divide it in two along the suggested dimension. 3) Goto (1). */ typedef double (*integrand) (unsigned ndim, const double *x, void *); /* Integrate the function f from xmin[dim] to xmax[dim], with at most maxEval function evaluations (0 for no limit), until the given absolute or relative error is achieved. val returns the integral, and err returns the estimate for the absolute error in val. The return value of the function is 0 on success and non-zero if there was an error. */ static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, const double *xmax, unsigned maxEval, double reqAbsError, double reqRelError, double *val, double *err); /***************************************************************************/ /* Basic datatypes */ typedef struct { double val, err; } esterr; static double relError(esterr ee) { return (ee.val == 0.0 ? HUGE_VAL : fabs(ee.err / ee.val)); } typedef struct { unsigned dim; double *data; /* length 2*dim = center followed by half-widths */ double vol; /* cache volume = product of widths */ } hypercube; static double compute_vol(const hypercube *h) { unsigned i; double vol = 1; for (i = 0; i < h->dim; ++i) vol *= 2 * h->data[i + h->dim]; return vol; } static hypercube make_hypercube(unsigned dim, const double *center, const double *halfwidth) { unsigned i; hypercube h; h.dim = dim; h.data = (double *) malloc(sizeof(double) * dim * 2); for (i = 0; i < dim; ++i) { h.data[i] = center[i]; h.data[i + dim] = halfwidth[i]; } h.vol = compute_vol(&h); return h; } static hypercube make_hypercube_range(unsigned dim, const double *xmin, const double *xmax) { hypercube h = make_hypercube(dim, xmin, xmax); unsigned i; for (i = 0; i < dim; ++i) { h.data[i] = 0.5 * (xmin[i] + xmax[i]); h.data[i + dim] = 0.5 * (xmax[i] - xmin[i]); } h.vol = compute_vol(&h); return h; } static void destroy_hypercube(hypercube *h) { free(h->data); h->dim = 0; } typedef struct { hypercube h; esterr ee; unsigned splitDim; } region; static region make_region(const hypercube *h) { region R; R.h = make_hypercube(h->dim, h->data, h->data + h->dim); R.splitDim = 0; return R; } static void destroy_region(region *R) { destroy_hypercube(&R->h); } static void cut_region(region *R, region *R2) { unsigned d = R->splitDim, dim = R->h.dim; *R2 = *R; R->h.data[d + dim] *= 0.5; R->h.vol *= 0.5; R2->h = make_hypercube(dim, R->h.data, R->h.data + dim); R->h.data[d] -= R->h.data[d + dim]; R2->h.data[d] += R->h.data[d + dim]; } typedef struct rule_s { unsigned dim; /* the dimensionality */ unsigned num_points; /* number of evaluation points */ unsigned (*evalError)(struct rule_s *r, integrand f, void *fdata, const hypercube *h, esterr *ee); void (*destroy)(struct rule_s *r); } rule; static void destroy_rule(rule *r) { if (r->destroy) r->destroy(r); free(r); } static region eval_region(region R, integrand f, void *fdata, rule *r) { R.splitDim = r->evalError(r, f, fdata, &R.h, &R.ee); return R; } /***************************************************************************/ /* Functions to loop over points in a hypercube. */ /* Based on orbitrule.cpp in HIntLib-0.0.10 */ /* ls0 returns the least-significant 0 bit of n (e.g. it returns 0 if the LSB is 0, it returns 1 if the 2 LSBs are 01, etcetera). */ #if (defined(__GNUC__) || defined(__ICC)) && (defined(__i386__) || defined (__x86_64__)) /* use x86 bit-scan instruction, based on count_trailing_zeros() macro in GNU GMP's longlong.h. */ static unsigned ls0(unsigned n) { unsigned count; n = ~n; __asm__("bsfl %1,%0": "=r"(count):"rm"(n)); return count; } #else static unsigned ls0(unsigned n) { const unsigned bits[256] = { 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 7, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 6, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 5, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 4, 0, 1, 0, 2, 0, 1, 0, 3, 0, 1, 0, 2, 0, 1, 0, 8, }; unsigned bit = 0; while ((n & 0xff) == 0xff) { n >>= 8; bit += 8; } return bit + bits[n & 0xff]; } #endif /** * Evaluate the integral on all 2^n points (+/-r,...+/-r) * * A Gray-code ordering is used to minimize the number of coordinate updates * in p. */ static double evalR_Rfs(integrand f, void *fdata, unsigned dim, double *p, const double *c, const double *r) { double sum = 0; unsigned i; unsigned signs = 0; /* 0/1 bit = +/- for corresponding element of r[] */ /* We start with the point where r is ADDed in every coordinate (this implies signs=0). */ for (i = 0; i < dim; ++i) p[i] = c[i] + r[i]; /* Loop through the points in Gray-code ordering */ for (i = 0;; ++i) { unsigned mask, d; sum += f(dim, p, fdata); d = ls0(i); /* which coordinate to flip */ if (d >= dim) break; /* flip the d-th bit and add/subtract r[d] */ mask = 1U << d; signs ^= mask; p[d] = (signs & mask) ? c[d] - r[d] : c[d] + r[d]; } return sum; } static double evalRR0_0fs(integrand f, void *fdata, unsigned dim, double *p, const double *c, const double *r) { unsigned i, j; double sum = 0; for (i = 0; i < dim - 1; ++i) { p[i] = c[i] - r[i]; for (j = i + 1; j < dim; ++j) { p[j] = c[j] - r[j]; sum += f(dim, p, fdata); p[i] = c[i] + r[i]; sum += f(dim, p, fdata); p[j] = c[j] + r[j]; sum += f(dim, p, fdata); p[i] = c[i] - r[i]; sum += f(dim, p, fdata); p[j] = c[j]; /* Done with j -> Restore p[j] */ } p[i] = c[i]; /* Done with i -> Restore p[i] */ } return sum; } static unsigned evalR0_0fs4d(integrand f, void *fdata, unsigned dim, double *p, const double *c, double *sum0_, const double *r1, double *sum1_, const double *r2, double *sum2_) { double maxdiff = 0; unsigned i, dimDiffMax = 0; double sum0, sum1 = 0, sum2 = 0; /* copies for aliasing, performance */ double ratio = r1[0] / r2[0]; ratio *= ratio; sum0 = f(dim, p, fdata); for (i = 0; i < dim; i++) { double f1a, f1b, f2a, f2b, diff; p[i] = c[i] - r1[i]; sum1 += (f1a = f(dim, p, fdata)); p[i] = c[i] + r1[i]; sum1 += (f1b = f(dim, p, fdata)); p[i] = c[i] - r2[i]; sum2 += (f2a = f(dim, p, fdata)); p[i] = c[i] + r2[i]; sum2 += (f2b = f(dim, p, fdata)); p[i] = c[i]; diff = fabs(f1a + f1b - 2 * sum0 - ratio * (f2a + f2b - 2 * sum0)); if (diff > maxdiff) { maxdiff = diff; dimDiffMax = i; } } *sum0_ += sum0; *sum1_ += sum1; *sum2_ += sum2; return dimDiffMax; } #define num0_0(dim) (1U) #define numR0_0fs(dim) (2 * (dim)) #define numRR0_0fs(dim) (2 * (dim) * (dim-1)) #define numR_Rfs(dim) (1U << (dim)) /***************************************************************************/ /* Based on rule75genzmalik.cpp in HIntLib-0.0.10: An embedded cubature rule of degree 7 (embedded rule degree 5) due to A. C. Genz and A. A. Malik. See: A. C. Genz and A. A. Malik, "An imbedded [sic] family of fully symmetric numerical integration rules," SIAM J. Numer. Anal. 20 (3), 580-588 (1983). */ typedef struct { rule parent; /* temporary arrays of length dim */ double *widthLambda, *widthLambda2, *p; /* dimension-dependent constants */ double weight1, weight3, weight5; double weightE1, weightE3; } rule75genzmalik; #define real(x) ((double)(x)) #define to_int(n) ((int)(n)) static int isqr(int x) { return x * x; } static void destroy_rule75genzmalik(rule *r_) { rule75genzmalik *r = (rule75genzmalik *) r_; free(r->p); } static unsigned rule75genzmalik_evalError(rule *r_, integrand f, void *fdata, const hypercube *h, esterr *ee) { /* lambda2 = sqrt(9/70), lambda4 = sqrt(9/10), lambda5 = sqrt(9/19) */ const double lambda2 = 0.3585685828003180919906451539079374954541; const double lambda4 = 0.9486832980505137995996680633298155601160; const double lambda5 = 0.6882472016116852977216287342936235251269; const double weight2 = 980. / 6561.; const double weight4 = 200. / 19683.; const double weightE2 = 245. / 486.; const double weightE4 = 25. / 729.; rule75genzmalik *r = (rule75genzmalik *) r_; unsigned i, dimDiffMax, dim = r_->dim; double sum1 = 0.0, sum2 = 0.0, sum3 = 0.0, sum4, sum5, result, res5th; const double *center = h->data; const double *halfwidth = h->data + dim; for (i = 0; i < dim; ++i) r->p[i] = center[i]; for (i = 0; i < dim; ++i) r->widthLambda2[i] = halfwidth[i] * lambda2; for (i = 0; i < dim; ++i) r->widthLambda[i] = halfwidth[i] * lambda4; /* Evaluate function in the center, in f(lambda2,0,...,0) and f(lambda3=lambda4, 0,...,0). Estimate dimension with largest error */ dimDiffMax = evalR0_0fs4d(f, fdata, dim, r->p, center, &sum1, r->widthLambda2, &sum2, r->widthLambda, &sum3); /* Calculate sum4 for f(lambda4, lambda4, 0, ...,0) */ sum4 = evalRR0_0fs(f, fdata, dim, r->p, center, r->widthLambda); /* Calculate sum5 for f(lambda5, lambda5, ..., lambda5) */ for (i = 0; i < dim; ++i) r->widthLambda[i] = halfwidth[i] * lambda5; sum5 = evalR_Rfs(f, fdata, dim, r->p, center, r->widthLambda); /* Calculate fifth and seventh order results */ result = h->vol * (r->weight1 * sum1 + weight2 * sum2 + r->weight3 * sum3 + weight4 * sum4 + r->weight5 * sum5); res5th = h->vol * (r->weightE1 * sum1 + weightE2 * sum2 + r->weightE3 * sum3 + weightE4 * sum4); ee->val = result; ee->err = fabs(res5th - result); return dimDiffMax; } static rule *make_rule75genzmalik(unsigned dim) { rule75genzmalik *r; if (dim < 2) return 0; /* this rule does not support 1d integrals */ /* Because of the use of a bit-field in evalR_Rfs, we are limited to be < 32 dimensions (or however many bits are in unsigned). This is not a practical limitation...long before you reach 32 dimensions, the Genz-Malik cubature becomes excruciatingly slow and is superseded by other methods (e.g. Monte-Carlo). */ if (dim >= sizeof(unsigned) * 8) return 0; r = (rule75genzmalik *) malloc(sizeof(rule75genzmalik)); r->parent.dim = dim; r->weight1 = (real(12824 - 9120 * to_int(dim) + 400 * isqr(to_int(dim))) / real(19683)); r->weight3 = real(1820 - 400 * to_int(dim)) / real(19683); r->weight5 = real(6859) / real(19683) / real(1U << dim); r->weightE1 = (real(729 - 950 * to_int(dim) + 50 * isqr(to_int(dim))) / real(729)); r->weightE3 = real(265 - 100 * to_int(dim)) / real(1458); r->p = (double *) malloc(sizeof(double) * dim * 3); r->widthLambda = r->p + dim; r->widthLambda2 = r->p + 2 * dim; r->parent.num_points = num0_0(dim) + 2 * numR0_0fs(dim) + numRR0_0fs(dim) + numR_Rfs(dim); r->parent.evalError = rule75genzmalik_evalError; r->parent.destroy = destroy_rule75genzmalik; return (rule *) r; } /***************************************************************************/ /* 1d 15-point Gaussian quadrature rule, based on qk15.c and qk.c in GNU GSL (which in turn is based on QUADPACK). */ static unsigned rule15gauss_evalError(rule *r, integrand f, void *fdata, const hypercube *h, esterr *ee) { /* Gauss quadrature weights and kronrod quadrature abscissae and weights as evaluated with 80 decimal digit arithmetic by L. W. Fullerton, Bell Labs, Nov. 1981. */ const unsigned n = 8; const double xgk[8] = { /* abscissae of the 15-point kronrod rule */ 0.991455371120812639206854697526329, 0.949107912342758524526189684047851, 0.864864423359769072789712788640926, 0.741531185599394439863864773280788, 0.586087235467691130294144838258730, 0.405845151377397166906606412076961, 0.207784955007898467600689403773245, 0.000000000000000000000000000000000 /* xgk[1], xgk[3], ... abscissae of the 7-point gauss rule. xgk[0], xgk[2], ... to optimally extend the 7-point gauss rule */ }; static const double wg[4] = { /* weights of the 7-point gauss rule */ 0.129484966168869693270611432679082, 0.279705391489276667901467771423780, 0.381830050505118944950369775488975, 0.417959183673469387755102040816327 }; static const double wgk[8] = { /* weights of the 15-point kronrod rule */ 0.022935322010529224963732008058970, 0.063092092629978553290700663189204, 0.104790010322250183839876322541518, 0.140653259715525918745189590510238, 0.169004726639267902826583426598550, 0.190350578064785409913256402421014, 0.204432940075298892414161999234649, 0.209482141084727828012999174891714 }; const double center = h->data[0]; const double halfwidth = h->data[1]; double fv1[7], fv2[7]; const double f_center = f(1, ¢er, fdata); double result_gauss = f_center * wg[n/2 - 1]; double result_kronrod = f_center * wgk[n - 1]; double result_abs = fabs(result_kronrod); double result_asc, mean, err; unsigned j; (void) r; /* unused */ for (j = 0; j < (n - 1) / 2; ++j) { int j2 = 2*j + 1; double x, f1, f2, fsum, w = halfwidth * xgk[j2]; x = center - w; fv1[j2] = f1 = f(1, &x, fdata); x = center + w; fv2[j2] = f2 = f(1, &x, fdata); fsum = f1 + f2; result_gauss += wg[j] * fsum; result_kronrod += wgk[j2] * fsum; result_abs += wgk[j2] * (fabs(f1) + fabs(f2)); } for (j = 0; j < n/2; ++j) { int j2 = 2*j; double x, f1, f2, w = halfwidth * xgk[j2]; x = center - w; fv1[j2] = f1 = f(1, &x, fdata); x = center + w; fv2[j2] = f2 = f(1, &x, fdata); result_kronrod += wgk[j2] * (f1 + f2); result_abs += wgk[j2] * (fabs(f1) + fabs(f2)); } ee->val = result_kronrod * halfwidth; /* compute error estimate: */ mean = result_kronrod * 0.5; result_asc = wgk[n - 1] * fabs(f_center - mean); for (j = 0; j < n - 1; ++j) result_asc += wgk[j] * (fabs(fv1[j]-mean) + fabs(fv2[j]-mean)); err = fabs(result_kronrod - result_gauss) * halfwidth; result_abs *= halfwidth; result_asc *= halfwidth; if (result_asc != 0 && err != 0) { double scale = pow((200 * err / result_asc), 1.5); if (scale < 1) err = result_asc * scale; else err = result_asc; } if (result_abs > DBL_MIN / (50 * DBL_EPSILON)) { double min_err = 50 * DBL_EPSILON * result_abs; if (min_err > err) err = min_err; } ee->err = err; return 0; /* no choice but to divide 0th dimension */ } static rule *make_rule15gauss(unsigned dim) { rule *r; if (dim != 1) return 0; /* this rule is only for 1d integrals */ r = (rule *) malloc(sizeof(rule)); r->dim = dim; r->num_points = 15; r->evalError = rule15gauss_evalError; r->destroy = 0; return r; } /***************************************************************************/ /* binary heap implementation (ala _Introduction to Algorithms_ by Cormen, Leiserson, and Rivest), for use as a priority queue of regions to integrate. */ typedef region heap_item; #define KEY(hi) ((hi).ee.err) typedef struct { unsigned n, nalloc; heap_item *items; esterr ee; } heap; static void heap_resize(heap *h, unsigned nalloc) { h->nalloc = nalloc; h->items = (heap_item *) realloc(h->items, sizeof(heap_item) * nalloc); } static heap heap_alloc(unsigned nalloc) { heap h; h.n = 0; h.nalloc = 0; h.items = 0; h.ee.val = h.ee.err = 0; heap_resize(&h, nalloc); return h; } /* note that heap_free does not deallocate anything referenced by the items */ static void heap_free(heap *h) { h->n = 0; heap_resize(h, 0); } static void heap_push(heap *h, heap_item hi) { int insert; h->ee.val += hi.ee.val; h->ee.err += hi.ee.err; insert = h->n; if (++(h->n) > h->nalloc) heap_resize(h, h->n * 2); while (insert) { int parent = (insert - 1) / 2; if (KEY(hi) <= KEY(h->items[parent])) break; h->items[insert] = h->items[parent]; insert = parent; } h->items[insert] = hi; } static heap_item heap_pop(heap *h) { heap_item ret; int i, n, child; if (!(h->n)) { fprintf(stderr, "attempted to pop an empty heap\n"); exit(EXIT_FAILURE); } ret = h->items[0]; h->items[i = 0] = h->items[n = --(h->n)]; while ((child = i * 2 + 1) < n) { int largest; heap_item swap; if (KEY(h->items[child]) <= KEY(h->items[i])) largest = i; else largest = child; if (++child < n && KEY(h->items[largest]) < KEY(h->items[child])) largest = child; if (largest == i) break; swap = h->items[i]; h->items[i] = h->items[largest]; h->items[i = largest] = swap; } h->ee.val -= ret.ee.val; h->ee.err -= ret.ee.err; return ret; } /***************************************************************************/ /* adaptive integration, analogous to adaptintegrator.cpp in HIntLib */ static int ruleadapt_integrate(rule *r, integrand f, void *fdata, const hypercube *h, unsigned maxEval, double reqAbsError, double reqRelError, esterr *ee) { unsigned maxIter; /* maximum number of adaptive subdivisions */ heap regions; unsigned i; int status = -1; /* = ERROR */ if (maxEval) { if (r->num_points > maxEval) return status; /* ERROR */ maxIter = (maxEval - r->num_points) / (2 * r->num_points); } else maxIter = UINT_MAX; regions = heap_alloc(1); heap_push(®ions, eval_region(make_region(h), f, fdata, r)); /* another possibility is to specify some non-adaptive subdivisions: if (initialRegions != 1) partition(h, initialRegions, EQUIDISTANT, ®ions, f,fdata, r); */ for (i = 0; i < maxIter; ++i) { region R, R2; if (regions.ee.err <= reqAbsError || relError(regions.ee) <= reqRelError) { status = 0; /* converged! */ break; } R = heap_pop(®ions); /* get worst region */ cut_region(&R, &R2); heap_push(®ions, eval_region(R, f, fdata, r)); heap_push(®ions, eval_region(R2, f, fdata, r)); } ee->val = ee->err = 0; /* re-sum integral and errors */ for (i = 0; i < regions.n; ++i) { ee->val += regions.items[i].ee.val; ee->err += regions.items[i].ee.err; destroy_region(®ions.items[i]); } /* printf("regions.nalloc = %d\n", regions.nalloc); */ heap_free(®ions); return status; } static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, const double *xmax, unsigned maxEval, double reqAbsError, double reqRelError, double *val, double *err) { rule *r; hypercube h; esterr ee; int status; if (dim == 0) { /* trivial integration */ *val = f(0, xmin, fdata); *err = 0; return 0; } r = dim == 1 ? make_rule15gauss(dim) : make_rule75genzmalik(dim); if (!r) { *val = 0; *err = HUGE_VAL; return -2; /* ERROR */ } h = make_hypercube_range(dim, xmin, xmax); status = ruleadapt_integrate(r, f, fdata, &h, maxEval, reqAbsError, reqRelError, &ee); *val = ee.val; *err = ee.err; destroy_hypercube(&h); destroy_rule(r); return status; } /***************************************************************************/ /* Compile with -DTEST_INTEGRATOR for a self-contained test program. Usage: ./integrator where = # dimensions, = relative tolerance, is either 0/1/2 for the three test integrands (see below), and is the maximum # function evaluations (0 for none). */ #ifdef TEST_INTEGRATOR int count = 0; int which_integrand = 0; const double radius = 0.50124145262344534123412; /* random */ /* Simple constant function */ double fconst (double x[], size_t dim, void *params) { return 1; } /*** f0, f1, f2, and f3 are test functions from the Monte-Carlo integration routines in GSL 1.6 (monte/test.c). Copyright (c) 1996-2000 Michael Booth, GNU GPL. ****/ /* Simple product function */ double f0 (unsigned dim, const double *x, void *params) { double prod = 1.0; unsigned int i; for (i = 0; i < dim; ++i) prod *= 2.0 * x[i]; return prod; } /* Gaussian centered at 1/2. */ double f1 (unsigned dim, const double *x, void *params) { double a = *(double *)params; double sum = 0.; unsigned int i; for (i = 0; i < dim; i++) { double dx = x[i] - 0.5; sum += dx * dx; } return (pow (M_2_SQRTPI / (2. * a), (double) dim) * exp (-sum / (a * a))); } /* double gaussian */ double f2 (unsigned dim, const double *x, void *params) { double a = *(double *)params; double sum1 = 0.; double sum2 = 0.; unsigned int i; for (i = 0; i < dim; i++) { double dx1 = x[i] - 1. / 3.; double dx2 = x[i] - 2. / 3.; sum1 += dx1 * dx1; sum2 += dx2 * dx2; } return 0.5 * pow (M_2_SQRTPI / (2. * a), dim) * (exp (-sum1 / (a * a)) + exp (-sum2 / (a * a))); } /* Tsuda's example */ double f3 (unsigned dim, const double *x, void *params) { double c = *(double *)params; double prod = 1.; unsigned int i; for (i = 0; i < dim; i++) prod *= c / (c + 1) * pow((c + 1) / (c + x[i]), 2.0); return prod; } /*** end of GSL test functions ***/ double f_test(unsigned dim, const double *x, void *data) { double val; unsigned i; ++count; switch (which_integrand) { case 0: /* simple smooth (separable) objective: prod. cos(x[i]). */ val = 1; for (i = 0; i < dim; ++i) val *= cos(x[i]); break; case 1: { /* integral of exp(-x^2), rescaled to (0,infinity) limits */ double scale = 1.0; val = 0; for (i = 0; i < dim; ++i) { double z = (1 - x[i]) / x[i]; val += z * z; scale *= M_2_SQRTPI / (x[i] * x[i]); } val = exp(-val) * scale; break; } case 2: /* discontinuous objective: volume of hypersphere */ val = 0; for (i = 0; i < dim; ++i) val += x[i] * x[i]; val = val < radius * radius; break; case 3: val = f0(dim, x, data); break; case 4: val = f1(dim, x, data); break; case 5: val = f2(dim, x, data); break; case 6: val = f3(dim, x, data); break; default: fprintf(stderr, "unknown integrand %d\n", which_integrand); exit(EXIT_FAILURE); } /* if (count < 100) printf("%d: f(%g, ...) = %g\n", count, x[0], val); */ return val; } /* surface area of n-dimensional unit hypersphere */ static double S(unsigned n) { double val; int fact = 1; if (n % 2 == 0) { /* n even */ val = 2 * pow(M_PI, n * 0.5); n = n / 2; while (n > 1) fact *= (n -= 1); val /= fact; } else { /* n odd */ val = (1 << (n/2 + 1)) * pow(M_PI, n/2); while (n > 2) fact *= (n -= 2); val /= fact; } return val; } static double exact_integral(unsigned dim, const double *xmax) { unsigned i; double val; switch(which_integrand) { case 0: val = 1; for (i = 0; i < dim; ++i) val *= sin(xmax[i]); break; case 2: val = dim == 0 ? 1 : S(dim) * pow(radius * 0.5, dim) / dim; break; default: val = 1.0; } return val; } int main(int argc, char **argv) { double *xmin, *xmax; double tol, val, err; unsigned i, dim, maxEval; double fdata; dim = argc > 1 ? atoi(argv[1]) : 2; tol = argc > 2 ? atof(argv[2]) : 1e-2; which_integrand = argc > 3 ? atoi(argv[3]) : 0; maxEval = argc > 4 ? atoi(argv[4]) : 0; fdata = which_integrand == 6 ? (1.0 + sqrt (10.0)) / 9.0 : 0.1; xmin = (double *) malloc(dim * sizeof(double)); xmax = (double *) malloc(dim * sizeof(double)); for (i = 0; i < dim; ++i) { xmin[i] = 0; xmax[i] = 1 + (which_integrand >= 1 ? 0 : 0.4 * sin(i)); } printf("%u-dim integral, tolerance = %g, integrand = %d\n", dim, tol, which_integrand); adapt_integrate(f_test, &fdata, dim, xmin, xmax, maxEval, 0, tol, &val, &err); printf("integration val = %g, est. err = %g, true err = %g\n", val, err, fabs(val - exact_integral(dim, xmax))); printf("#evals = %d\n", count); free(xmax); free(xmin); return 0; } #else /*************************************************************************/ /* libctl interface */ #include "ctl-math.h" static int adapt_integrate(integrand f, void *fdata, unsigned dim, const double *xmin, const double *xmax, unsigned maxEval, double reqAbsError, double reqRelError, double *val, double *err); number adaptive_integration(multivar_func f, number *xmin, number *xmax, integer n, void *fdata, number abstol, number reltol, integer maxnfe, number *esterr, integer *errflag) { double val; *errflag = adapt_integrate((integrand) f, fdata, n, xmin, xmax, maxnfe, abstol, reltol, &val, esterr); return val; } #ifndef LIBCTLGEOM #include "ctl.h" /* from subplex.c */ extern number f_scm_wrapper(integer n, number *x, void *f_scm_p); SCM adaptive_integration_scm(SCM f_scm, SCM xmin_scm, SCM xmax_scm, SCM abstol_scm, SCM reltol_scm, SCM maxnfe_scm) { integer n, maxnfe, errflag, i; number *xmin, *xmax, abstol, reltol, integral; n = list_length(xmin_scm); abstol = fabs(ctl_convert_number_to_c(abstol_scm)); reltol = fabs(ctl_convert_number_to_c(reltol_scm)); maxnfe = ctl_convert_integer_to_c(maxnfe_scm); if (list_length(xmax_scm) != n) { fprintf(stderr, "adaptive_integration: xmin/xmax dimension mismatch\n"); return SCM_UNDEFINED; } xmin = (number*) malloc(sizeof(number) * n); xmax = (number*) malloc(sizeof(number) * n); if (!xmin || !xmax) { fprintf(stderr, "adaptive_integration: error, out of memory!\n"); exit(EXIT_FAILURE); } for (i = 0; i < n; ++i) { xmin[i] = number_list_ref(xmin_scm, i); xmax[i] = number_list_ref(xmax_scm, i); } integral = adaptive_integration(f_scm_wrapper, xmin, xmax, n, &f_scm, abstol, reltol, maxnfe, &abstol, &errflag); free(xmax); free(xmin); switch (errflag) { case 3: fprintf(stderr, "adaptive_integration: invalid inputs\n"); return SCM_UNDEFINED; case 1: fprintf(stderr, "adaptive_integration: maxnfe too small\n"); break; case 2: fprintf(stderr, "adaptive_integration: lenwork too small\n"); break; } return gh_cons(ctl_convert_number_to_scm(integral), ctl_convert_number_to_scm(abstol)); } #endif /* !LIBCTLGEOM */ #endif libctl-4.4.0/src/subplex.c000066400000000000000000001521061356267410600154240ustar00rootroot00000000000000/* Downloaded from http://www.netlib.org/opt/subplex.tgz README file for SUBPLEX NAME subplex - subspace-searching simplex method for unconstrained optimization DESCRIPTION Subplex is a subspace-searching simplex method for the unconstrained optimization of general multivariate functions. Like the Nelder-Mead simplex method it generalizes, the subplex method is well suited for optimizing noisy objective functions. The number of function evaluations required for convergence typically increases only linearly with the problem size, so for most applications the subplex method is much more efficient than the simplex method. INSTALLATION To build subplex on UNIX systems, edit the Makefile as necessary and type: make This will create a linkable library named subplex.a and a demonstration executable named demo. EXAMPLE To run subplex on a simple objective function type: demo < demo.in To run subplex on other problems, edit a copy of the sample driver demo.f as necessary. AUTHOR Tom Rowan Oak Ridge National Laboratory Mathematical Sciences Section P.O. Box 2008, Bldg. 6012 Oak Ridge, TN 37831-6367 Phone: (423) 574-3131 Fax : (423) 574-0680 Email: na.rowan@na-net.ornl.gov REFERENCE T. Rowan, "Functional Stability Analysis of Numerical Algorithms", Ph.D. thesis, Department of Computer Sciences, University of Texas at Austin, 1990. COMMENTS Please send comments, suggestions, or bug reports to na.rowan@na-net.ornl.gov. */ #include #include #include #include "ctl.h" typedef number doublereal; typedef boolean logical; #define TRUE_ 1 #define FALSE_ 0 typedef multivar_func D_fp; #define max(a,b) ((a) > (b) ? (a) : (b)) #define min(a,b) ((a) < (b) ? (a) : (b)) #define abs(x) fabs(x) /****************************************************************************/ /****************************************************************************/ /* dasum.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static doublereal dasum_(integer *n, doublereal *dx, integer *incx) { /* System generated locals */ integer i__1; doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6; /* Local variables */ integer i__, m; doublereal dtemp; integer ix, mp1; /* takes the sum of the absolute values. */ /* uses unrolled loops for increment equal to one. */ /* jack dongarra, linpack, 3/11/78. */ /* modified to correct problem with negative increment, 8/21/90. */ /* Parameter adjustments */ --dx; /* Function Body */ ret_val = 0.; dtemp = 0.; if (*n <= 0) { return ret_val; } if (*incx == 1) { goto L20; } /* code for increment not equal to 1 */ ix = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dtemp += (d__1 = dx[ix], abs(d__1)); ix += *incx; /* L10: */ } ret_val = dtemp; return ret_val; /* code for increment equal to 1 */ /* clean-up loop */ L20: m = *n % 6; if (m == 0) { goto L40; } i__1 = m; for (i__ = 1; i__ <= i__1; ++i__) { dtemp += (d__1 = dx[i__], abs(d__1)); /* L30: */ } if (*n < 6) { goto L60; } L40: mp1 = m + 1; i__1 = *n; for (i__ = mp1; i__ <= i__1; i__ += 6) { dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ + 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = dx[i__ + 5], abs(d__6)); /* L50: */ } L60: ret_val = dtemp; return ret_val; } /* dasum_ */ /* daxpy.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int daxpy_(integer *n, doublereal *da, doublereal *dx, integer *incx, doublereal *dy, integer *incy) { /* System generated locals */ integer i__1; /* Local variables */ integer i__, m, ix, iy, mp1; /* constant times a vector plus a vector. */ /* uses unrolled loops for increments equal to one. */ /* jack dongarra, linpack, 3/11/78. */ /* Parameter adjustments */ --dy; --dx; /* Function Body */ if (*n <= 0) { return 0; } if (*da == 0.) { return 0; } if (*incx == 1 && *incy == 1) { goto L20; } /* code for unequal increments or equal increments */ /* not equal to 1 */ ix = 1; iy = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dy[iy] += *da * dx[ix]; ix += *incx; iy += *incy; /* L10: */ } return 0; /* code for both increments equal to 1 */ /* clean-up loop */ L20: m = *n % 4; if (m == 0) { goto L40; } i__1 = m; for (i__ = 1; i__ <= i__1; ++i__) { dy[i__] += *da * dx[i__]; /* L30: */ } if (*n < 4) { return 0; } L40: mp1 = m + 1; i__1 = *n; for (i__ = mp1; i__ <= i__1; i__ += 4) { dy[i__] += *da * dx[i__]; dy[i__ + 1] += *da * dx[i__ + 1]; dy[i__ + 2] += *da * dx[i__ + 2]; dy[i__ + 3] += *da * dx[i__ + 3]; /* L50: */ } return 0; } /* daxpy_ */ /* dcopy.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int dcopy_(integer *n, doublereal *dx, integer *incx, doublereal *dy, integer *incy) { /* System generated locals */ integer i__1; /* Local variables */ integer i__, m, ix, iy, mp1; /* copies a vector, x, to a vector, y. */ /* uses unrolled loops for increments equal to one. */ /* jack dongarra, linpack, 3/11/78. */ /* Parameter adjustments */ --dy; --dx; /* Function Body */ if (*n <= 0) { return 0; } if (*incx == 1 && *incy == 1) { goto L20; } /* code for unequal increments or equal increments */ /* not equal to 1 */ ix = 1; iy = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } if (*incy < 0) { iy = (-(*n) + 1) * *incy + 1; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dy[iy] = dx[ix]; ix += *incx; iy += *incy; /* L10: */ } return 0; /* code for both increments equal to 1 */ /* clean-up loop */ L20: m = *n % 7; if (m == 0) { goto L40; } i__1 = m; for (i__ = 1; i__ <= i__1; ++i__) { dy[i__] = dx[i__]; /* L30: */ } if (*n < 7) { return 0; } L40: mp1 = m + 1; i__1 = *n; for (i__ = mp1; i__ <= i__1; i__ += 7) { dy[i__] = dx[i__]; dy[i__ + 1] = dx[i__ + 1]; dy[i__ + 2] = dx[i__ + 2]; dy[i__ + 3] = dx[i__ + 3]; dy[i__ + 4] = dx[i__ + 4]; dy[i__ + 5] = dx[i__ + 5]; dy[i__ + 6] = dx[i__ + 6]; /* L50: */ } return 0; } /* dcopy_ */ /* dscal.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int dscal_(integer *n, doublereal *da, doublereal *dx, integer *incx) { /* System generated locals */ integer i__1; /* Local variables */ integer i__, m, ix, mp1; /* scales a vector by a constant. */ /* uses unrolled loops for increment equal to one. */ /* jack dongarra, linpack, 3/11/78. */ /* modified to correct problem with negative increment, 8/21/90. */ /* Parameter adjustments */ --dx; /* Function Body */ if (*n <= 0) { return 0; } if (*incx == 1) { goto L20; } /* code for increment not equal to 1 */ ix = 1; if (*incx < 0) { ix = (-(*n) + 1) * *incx + 1; } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { dx[ix] = *da * dx[ix]; ix += *incx; /* L10: */ } return 0; /* code for increment equal to 1 */ /* clean-up loop */ L20: m = *n % 5; if (m == 0) { goto L40; } i__1 = m; for (i__ = 1; i__ <= i__1; ++i__) { dx[i__] = *da * dx[i__]; /* L30: */ } if (*n < 5) { return 0; } L40: mp1 = m + 1; i__1 = *n; for (i__ = mp1; i__ <= i__1; i__ += 5) { dx[i__] = *da * dx[i__]; dx[i__ + 1] = *da * dx[i__ + 1]; dx[i__ + 2] = *da * dx[i__ + 2]; dx[i__ + 3] = *da * dx[i__ + 3]; dx[i__ + 4] = *da * dx[i__ + 4]; /* L50: */ } return 0; } /* dscal_ */ /* dist.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static doublereal dist_(integer *n, doublereal *x, doublereal *y) { /* System generated locals */ integer i__1; doublereal ret_val, d__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ integer i__; doublereal scale, absxmy, sum; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* dist calculates the distance between the points x,y. */ /* input */ /* n - number of components */ /* x - point in n-space */ /* y - point in n-space */ /* local variables */ /* subroutines and functions */ /* fortran */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --y; --x; /* Function Body */ absxmy = (d__1 = x[1] - y[1], abs(d__1)); if (absxmy <= 1.) { sum = absxmy * absxmy; scale = 1.; } else { sum = 1.; scale = absxmy; } i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { absxmy = (d__1 = x[i__] - y[i__], abs(d__1)); if (absxmy <= scale) { /* Computing 2nd power */ d__1 = absxmy / scale; sum += d__1 * d__1; } else { /* Computing 2nd power */ d__1 = scale / absxmy; sum = sum * (d__1 * d__1) + 1.; scale = absxmy; } /* L10: */ } ret_val = scale * sqrt(sum); return ret_val; } /* dist_ */ /* calcc.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Table of constant values */ static doublereal c_b3 = 0.; static integer c__0 = 0; static integer c__1 = 1; static doublereal c_b7 = 1.; static int calcc_(integer *ns, doublereal *s, integer *ih, integer * inew, logical *updatc, doublereal *c__) { /* System generated locals */ integer s_dim1, s_offset, i__1; doublereal d__1; /* Local variables */ integer i__, j; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* calcc calculates the centroid of the simplex without the */ /* vertex with highest function value. */ /* input */ /* ns - subspace dimension */ /* s - double precision work space of dimension .ge. */ /* ns*(ns+3) used to store simplex */ /* ih - index to vertex with highest function value */ /* inew - index to new point */ /* updatc - logical switch */ /* = .true. : update centroid */ /* = .false. : calculate centroid from scratch */ /* c - centroid of the simplex without vertex with */ /* highest function value */ /* output */ /* c - new centroid */ /* local variables */ /* subroutines and functions */ /* blas */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --c__; s_dim1 = *ns; s_offset = 1 + s_dim1 * 1; s -= s_offset; /* Function Body */ if (*updatc) { if (*ih == *inew) { return 0; } i__1 = *ns; for (i__ = 1; i__ <= i__1; ++i__) { c__[i__] += (s[i__ + *inew * s_dim1] - s[i__ + *ih * s_dim1]) / * ns; /* L10: */ } } else { dcopy_(ns, &c_b3, &c__0, &c__[1], &c__1); i__1 = *ns + 1; for (j = 1; j <= i__1; ++j) { if (j != *ih) { daxpy_(ns, &c_b7, &s[j * s_dim1 + 1], &c__1, &c__[1], &c__1); } /* L20: */ } d__1 = 1. / *ns; dscal_(ns, &d__1, &c__[1], &c__1); } return 0; } /* calcc_ */ /* order.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int order_(integer *npts, doublereal *fs, integer *il, integer *is, integer *ih) { /* System generated locals */ integer i__1; /* Local variables */ integer i__, j, il0; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* order determines the indices of the vertices with the */ /* lowest, second highest, and highest function values. */ /* input */ /* npts - number of points in simplex */ /* fs - double precision vector of function values of */ /* simplex */ /* il - index to vertex with lowest function value */ /* output */ /* il - new index to vertex with lowest function value */ /* is - new index to vertex with second highest */ /* function value */ /* ih - new index to vertex with highest function value */ /* local variables */ /* subroutines and functions */ /* fortran */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --fs; /* Function Body */ il0 = *il; j = il0 % *npts + 1; if (fs[j] >= fs[*il]) { *ih = j; *is = il0; } else { *ih = il0; *is = j; *il = j; } i__1 = il0 + *npts - 2; for (i__ = il0 + 1; i__ <= i__1; ++i__) { j = i__ % *npts + 1; if (fs[j] >= fs[*ih]) { *is = *ih; *ih = j; } else if (fs[j] > fs[*is]) { *is = j; } else if (fs[j] < fs[*il]) { *il = j; } /* L10: */ } return 0; } /* order_ */ /* partx.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Common Block Declarations */ static struct { doublereal alpha, beta, gamma, delta, psi, omega; integer nsmin, nsmax, irepl, ifxsw; doublereal bonus, fstop; integer nfstop, nfxe; doublereal fxstat[4], ftest; logical minf, initx, newx; } usubc_; #define usubc_1 usubc_ static int partx_(integer *n, integer *ip, doublereal *absdx, integer *nsubs, integer *nsvals) { /* System generated locals */ integer i__1; /* Local variables */ static integer i__, nleft, nused; static doublereal as1max, gapmax, asleft, as1, as2; static integer ns1, ns2; static doublereal gap; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* partx partitions the vector x by grouping components of */ /* similar magnitude of change. */ /* input */ /* n - number of components (problem dimension) */ /* ip - permutation vector */ /* absdx - vector of magnitude of change in x */ /* nsvals - integer array dimensioned .ge. int(n/nsmin) */ /* output */ /* nsubs - number of subspaces */ /* nsvals - integer array of subspace dimensions */ /* common */ /* local variables */ /* subroutines and functions */ /* fortran */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --absdx; --ip; --nsvals; /* Function Body */ *nsubs = 0; nused = 0; nleft = *n; asleft = absdx[1]; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { asleft += absdx[i__]; /* L10: */ } L20: if (nused < *n) { ++(*nsubs); as1 = 0.; i__1 = usubc_1.nsmin - 1; for (i__ = 1; i__ <= i__1; ++i__) { as1 += absdx[ip[nused + i__]]; /* L30: */ } gapmax = -1.; i__1 = min(usubc_1.nsmax,nleft); for (ns1 = usubc_1.nsmin; ns1 <= i__1; ++ns1) { as1 += absdx[ip[nused + ns1]]; ns2 = nleft - ns1; if (ns2 > 0) { if (ns2 >= ((ns2 - 1) / usubc_1.nsmax + 1) * usubc_1.nsmin) { as2 = asleft - as1; gap = as1 / ns1 - as2 / ns2; if (gap > gapmax) { gapmax = gap; nsvals[*nsubs] = ns1; as1max = as1; } } } else { if (as1 / ns1 > gapmax) { nsvals[*nsubs] = ns1; return 0; } } /* L40: */ } nused += nsvals[*nsubs]; nleft = *n - nused; asleft -= as1max; goto L20; } return 0; } /* partx_ */ /* sortd.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int sortd_(integer *n, doublereal *xkey, integer *ix) { /* System generated locals */ integer i__1; /* Local variables */ integer ixip1, i__, ilast, iswap, ifirst, ixi; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* sortd uses the shakersort method to sort an array of keys */ /* in decreasing order. The sort is performed implicitly by */ /* modifying a vector of indices. */ /* For nearly sorted arrays, sortd requires O(n) comparisons. */ /* for completely unsorted arrays, sortd requires O(n**2) */ /* comparisons and will be inefficient unless n is small. */ /* input */ /* n - number of components */ /* xkey - double precision vector of keys */ /* ix - integer vector of indices */ /* output */ /* ix - indices satisfy xkey(ix(i)) .ge. xkey(ix(i+1)) */ /* for i = 1,...,n-1 */ /* local variables */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --ix; --xkey; /* Function Body */ ifirst = 1; iswap = 1; ilast = *n - 1; L10: if (ifirst <= ilast) { i__1 = ilast; for (i__ = ifirst; i__ <= i__1; ++i__) { ixi = ix[i__]; ixip1 = ix[i__ + 1]; if (xkey[ixi] < xkey[ixip1]) { ix[i__] = ixip1; ix[i__ + 1] = ixi; iswap = i__; } /* L20: */ } ilast = iswap - 1; i__1 = ifirst; for (i__ = ilast; i__ >= i__1; --i__) { ixi = ix[i__]; ixip1 = ix[i__ + 1]; if (xkey[ixi] < xkey[ixip1]) { ix[i__] = ixip1; ix[i__ + 1] = ixi; iswap = i__; } /* L30: */ } ifirst = iswap + 1; goto L10; } return 0; } /* sortd_ */ /* newpt.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int newpt_(integer *ns, doublereal *coef, doublereal *xbase, doublereal *xold, logical *new__, doublereal *xnew, logical *small) { /* System generated locals */ integer i__1; /* Local variables */ integer i__; logical eqold; doublereal xoldi; logical eqbase; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* newpt performs reflections, expansions, contractions, and */ /* shrinkages (massive contractions) by computing: */ /* xbase + coef * (xbase - xold) */ /* The result is stored in xnew if new .eq. .true., */ /* in xold otherwise. */ /* use : coef .gt. 0 to reflect */ /* coef .lt. 0 to expand, contract, or shrink */ /* input */ /* ns - number of components (subspace dimension) */ /* coef - one of four simplex method coefficients */ /* xbase - double precision ns-vector representing base */ /* point */ /* xold - double precision ns-vector representing old */ /* point */ /* new - logical switch */ /* = .true. : store result in xnew */ /* = .false. : store result in xold, xnew is not */ /* referenced */ /* output */ /* xold - unchanged if new .eq. .true., contains new */ /* point otherwise */ /* xnew - double precision ns-vector representing new */ /* point if new .eq. .true., not referenced */ /* otherwise */ /* small - logical flag */ /* = .true. : coincident points */ /* = .false. : otherwise */ /* local variables */ /* subroutines and functions */ /* fortran */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --xold; --xbase; --xnew; /* Function Body */ eqbase = TRUE_; eqold = TRUE_; if (*new__) { i__1 = *ns; for (i__ = 1; i__ <= i__1; ++i__) { xnew[i__] = xbase[i__] + *coef * (xbase[i__] - xold[i__]); eqbase = eqbase && xnew[i__] == xbase[i__]; eqold = eqold && xnew[i__] == xold[i__]; /* L10: */ } } else { i__1 = *ns; for (i__ = 1; i__ <= i__1; ++i__) { xoldi = xold[i__]; xold[i__] = xbase[i__] + *coef * (xbase[i__] - xold[i__]); eqbase = eqbase && xold[i__] == xbase[i__]; eqold = eqold && xold[i__] == xoldi; /* L20: */ } } *small = eqbase || eqold; return 0; } /* newpt_ */ /* start.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int start_(integer *n, doublereal *x, doublereal *step, integer *ns, integer *ips, doublereal *s, logical *small) { /* System generated locals */ integer s_dim1, s_offset, i__1; /* Local variables */ integer i__, j; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* start creates the initial simplex for simplx minimization. */ /* input */ /* n - problem dimension */ /* x - current best point */ /* step - stepsizes for corresponding components of x */ /* ns - subspace dimension */ /* ips - permutation vector */ /* output */ /* s - first ns+1 columns contain initial simplex */ /* small - logical flag */ /* = .true. : coincident points */ /* = .false. : otherwise */ /* local variables */ /* subroutines and functions */ /* blas */ /* fortran */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --ips; --step; --x; s_dim1 = *ns; s_offset = 1 + s_dim1 * 1; s -= s_offset; (void)n; /* unused */ /* Function Body */ i__1 = *ns; for (i__ = 1; i__ <= i__1; ++i__) { s[i__ + s_dim1] = x[ips[i__]]; /* L10: */ } i__1 = *ns + 1; for (j = 2; j <= i__1; ++j) { dcopy_(ns, &s[s_dim1 + 1], &c__1, &s[j * s_dim1 + 1], &c__1); s[j - 1 + j * s_dim1] = s[j - 1 + s_dim1] + step[ips[j - 1]]; /* L20: */ } /* check for coincident points */ i__1 = *ns + 1; for (j = 2; j <= i__1; ++j) { if (s[j - 1 + j * s_dim1] == s[j - 1 + s_dim1]) { goto L40; } /* L30: */ } *small = FALSE_; return 0; /* coincident points */ L40: *small = TRUE_; return 0; } /* start_ */ /* fstats.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int fstats_(doublereal *fx, integer *ifxwt, logical *reset) { /* System generated locals */ doublereal d__1, d__2, d__3; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ static doublereal fscale; static integer nsv; static doublereal f1sv; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* fstats modifies the common /usubc/ variables nfxe,fxstat. */ /* input */ /* fx - most recent evaluation of f at best x */ /* ifxwt - integer weight for fx */ /* reset - logical switch */ /* = .true. : initialize nfxe,fxstat */ /* = .false. : update nfxe,fxstat */ /* common */ /* local variables */ /* subroutines and functions */ /* fortran */ /* ----------------------------------------------------------- */ if (*reset) { usubc_1.nfxe = *ifxwt; usubc_1.fxstat[0] = *fx; usubc_1.fxstat[1] = *fx; usubc_1.fxstat[2] = *fx; usubc_1.fxstat[3] = 0.; } else { nsv = usubc_1.nfxe; f1sv = usubc_1.fxstat[0]; usubc_1.nfxe += *ifxwt; usubc_1.fxstat[0] += *ifxwt * (*fx - usubc_1.fxstat[0]) / usubc_1.nfxe; usubc_1.fxstat[1] = max(usubc_1.fxstat[1],*fx); usubc_1.fxstat[2] = min(usubc_1.fxstat[2],*fx); /* Computing MAX */ d__1 = abs(usubc_1.fxstat[1]), d__2 = abs(usubc_1.fxstat[2]), d__1 = max(d__1,d__2); fscale = max(d__1,1.); /* Computing 2nd power */ d__1 = usubc_1.fxstat[3] / fscale; /* Computing 2nd power */ d__2 = (usubc_1.fxstat[0] - f1sv) / fscale; /* Computing 2nd power */ d__3 = (*fx - usubc_1.fxstat[0]) / fscale; usubc_1.fxstat[3] = fscale * sqrt(((nsv - 1) * (d__1 * d__1) + nsv * ( d__2 * d__2) + *ifxwt * (d__3 * d__3)) / (usubc_1.nfxe - 1)); } return 0; } /* fstats_ */ /* evalf.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ /* Common Block Declarations */ static struct { doublereal fbonus, sfstop, sfbest; logical new__; } isubc_; #define isubc_1 isubc_ static logical c_true = TRUE_; static logical c_false = FALSE_; static int evalf_(D_fp f,void*fdata, integer *ns, integer *ips, doublereal *xs, integer *n, doublereal *x, doublereal *sfx, integer *nfe) { /* System generated locals */ integer i__1; /* Local variables */ static integer i__; static doublereal fx; static logical newbst; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* evalf evaluates the function f at a point defined by x */ /* with ns of its components replaced by those in xs. */ /* input */ /* f - user supplied function f(n,x) to be optimized */ /* ns - subspace dimension */ /* ips - permutation vector */ /* xs - double precision ns-vector to be mapped to x */ /* n - problem dimension */ /* x - double precision n-vector */ /* nfe - number of function evaluations */ /* output */ /* sfx - signed value of f evaluated at x */ /* nfe - incremented number of function evaluations */ /* common */ /* local variables */ /* subroutines and functions */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --ips; --xs; --x; /* Function Body */ i__1 = *ns; for (i__ = 1; i__ <= i__1; ++i__) { x[ips[i__]] = xs[i__]; /* L10: */ } usubc_1.newx = isubc_1.new__ || usubc_1.irepl != 2; fx = (*f)(*n, &x[1], fdata); if (usubc_1.irepl == 0) { if (usubc_1.minf) { *sfx = fx; } else { *sfx = -fx; } } else if (isubc_1.new__) { if (usubc_1.minf) { *sfx = fx; newbst = fx < usubc_1.ftest; } else { *sfx = -fx; newbst = fx > usubc_1.ftest; } if (usubc_1.initx || newbst) { if (usubc_1.irepl == 1) { fstats_(&fx, &c__1, &c_true); } usubc_1.ftest = fx; isubc_1.sfbest = *sfx; } } else { if (usubc_1.irepl == 1) { fstats_(&fx, &c__1, &c_false); fx = usubc_1.fxstat[usubc_1.ifxsw - 1]; } usubc_1.ftest = fx + isubc_1.fbonus * usubc_1.fxstat[3]; if (usubc_1.minf) { *sfx = usubc_1.ftest; isubc_1.sfbest = fx; } else { *sfx = -usubc_1.ftest; isubc_1.sfbest = -fx; } } ++(*nfe); return 0; } /* evalf_ */ /* simplx.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int simplx_(D_fp f, void *fdata, integer *n, doublereal *step, integer * ns, integer *ips, integer *maxnfe, logical *cmode, doublereal *x, doublereal *fx, integer *nfe, doublereal *s, doublereal *fs, integer * iflag) { /* System generated locals */ integer s_dim1, s_offset, i__1; doublereal d__1, d__2; /* Local variables */ static integer inew; static integer npts; static integer i__, j; static integer icent; static logical small; static integer itemp; static doublereal fc, fe; static integer ih, il; static doublereal fr; static integer is; static logical updatc; static doublereal dum, tol; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* simplx uses the Nelder-Mead simplex method to minimize the */ /* function f on a subspace. */ /* input */ /* f - function to be minimized, declared external in */ /* calling routine */ /* n - problem dimension */ /* step - stepsizes for corresponding components of x */ /* ns - subspace dimension */ /* ips - permutation vector */ /* maxnfe - maximum number of function evaluations */ /* cmode - logical switch */ /* = .true. : continuation of previous call */ /* = .false. : first call */ /* x - starting guess for minimum */ /* fx - value of f at x */ /* nfe - number of function evaluations */ /* s - double precision work array of dimension .ge. */ /* ns*(ns+3) used to store simplex */ /* fs - double precision work array of dimension .ge. */ /* ns+1 used to store function values of simplex */ /* vertices */ /* output */ /* x - computed minimum */ /* fx - value of f at x */ /* nfe - incremented number of function evaluations */ /* iflag - error flag */ /* = -1 : maxnfe exceeded */ /* = 0 : simplex reduced by factor of psi */ /* = 1 : limit of machine precision */ /* = 2 : reached fstop */ /* common */ /* local variables */ /* subroutines and functions */ /* blas */ /* fortran */ /* ----------------------------------------------------------- */ /* Parameter adjustments */ --x; --step; --fs; s_dim1 = *ns; s_offset = 1 + s_dim1 * 1; s -= s_offset; --ips; /* Function Body */ if (*cmode) { goto L50; } npts = *ns + 1; icent = *ns + 2; itemp = *ns + 3; updatc = FALSE_; start_(n, &x[1], &step[1], ns, &ips[1], &s[s_offset], &small); if (small) { *iflag = 1; return 0; } if (usubc_1.irepl > 0) { isubc_1.new__ = FALSE_; evalf_((D_fp)f,fdata, ns, &ips[1], &s[s_dim1 + 1], n, &x[1], &fs[1], nfe); } else { fs[1] = *fx; } isubc_1.new__ = TRUE_; i__1 = npts; for (j = 2; j <= i__1; ++j) { evalf_((D_fp)f, fdata,ns, &ips[1], &s[j * s_dim1 + 1], n, &x[1], &fs[j], nfe); /* L10: */ } il = 1; order_(&npts, &fs[1], &il, &is, &ih); tol = usubc_1.psi * dist_(ns, &s[ih * s_dim1 + 1], &s[il * s_dim1 + 1]); /* main loop */ L20: calcc_(ns, &s[s_offset], &ih, &inew, &updatc, &s[icent * s_dim1 + 1]); updatc = TRUE_; inew = ih; /* reflect */ newpt_(ns, &usubc_1.alpha, &s[icent * s_dim1 + 1], &s[ih * s_dim1 + 1], & c_true, &s[itemp * s_dim1 + 1], &small); if (small) { goto L40; } evalf_((D_fp)f,fdata, ns, &ips[1], &s[itemp * s_dim1 + 1], n, &x[1], &fr, nfe); if (fr < fs[il]) { /* expand */ d__1 = -usubc_1.gamma; newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[itemp * s_dim1 + 1], & c_true, &s[ih * s_dim1 + 1], &small); if (small) { goto L40; } evalf_((D_fp)f,fdata, ns, &ips[1], &s[ih * s_dim1 + 1], n, &x[1], &fe, nfe); if (fe < fr) { fs[ih] = fe; } else { dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], & c__1); fs[ih] = fr; } } else if (fr < fs[is]) { /* accept reflected point */ dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], &c__1); fs[ih] = fr; } else { /* contract */ if (fr > fs[ih]) { d__1 = -usubc_1.beta; newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[ih * s_dim1 + 1], & c_true, &s[itemp * s_dim1 + 1], &small); } else { d__1 = -usubc_1.beta; newpt_(ns, &d__1, &s[icent * s_dim1 + 1], &s[itemp * s_dim1 + 1], &c_false, &dum, &small); } if (small) { goto L40; } evalf_((D_fp)f,fdata, ns, &ips[1], &s[itemp * s_dim1 + 1], n, &x[1], &fc, nfe); /* Computing MIN */ d__1 = fr, d__2 = fs[ih]; if (fc < min(d__1,d__2)) { dcopy_(ns, &s[itemp * s_dim1 + 1], &c__1, &s[ih * s_dim1 + 1], & c__1); fs[ih] = fc; } else { /* shrink simplex */ i__1 = npts; for (j = 1; j <= i__1; ++j) { if (j != il) { d__1 = -usubc_1.delta; newpt_(ns, &d__1, &s[il * s_dim1 + 1], &s[j * s_dim1 + 1], &c_false, &dum, &small); if (small) { goto L40; } evalf_((D_fp)f,fdata, ns, &ips[1], &s[j * s_dim1 + 1], n, &x[1], &fs[j], nfe); } /* L30: */ } } updatc = FALSE_; } order_(&npts, &fs[1], &il, &is, &ih); /* check termination */ L40: if (usubc_1.irepl == 0) { *fx = fs[il]; } else { *fx = isubc_1.sfbest; } L50: if (usubc_1.nfstop > 0 && *fx <= isubc_1.sfstop && usubc_1.nfxe >= usubc_1.nfstop) { *iflag = 2; } else if (*nfe >= *maxnfe) { *iflag = -1; } else if (dist_(ns, &s[ih * s_dim1 + 1], &s[il * s_dim1 + 1]) <= tol || small) { *iflag = 0; } else { goto L20; } /* end main loop, return best point */ i__1 = *ns; for (i__ = 1; i__ <= i__1; ++i__) { x[ips[i__]] = s[i__ + il * s_dim1]; /* L60: */ } return 0; } /* simplx_ */ /* subopt.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int subopt_(integer *n) { /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* subopt sets options for subplx. */ /* input */ /* n - problem dimension */ /* common */ /* subroutines and functions */ /* fortran */ /* ----------------------------------------------------------- */ /* *********************************************************** */ /* simplex method strategy parameters */ /* *********************************************************** */ /* alpha - reflection coefficient */ /* alpha .gt. 0 */ usubc_1.alpha = 1.; /* beta - contraction coefficient */ /* 0 .lt. beta .lt. 1 */ usubc_1.beta = .5; /* gamma - expansion coefficient */ /* gamma .gt. 1 */ usubc_1.gamma = 2.; /* delta - shrinkage (massive contraction) coefficient */ /* 0 .lt. delta .lt. 1 */ usubc_1.delta = .5; /* *********************************************************** */ /* subplex method strategy parameters */ /* *********************************************************** */ /* psi - simplex reduction coefficient */ /* 0 .lt. psi .lt. 1 */ usubc_1.psi = .25; /* omega - step reduction coefficient */ /* 0 .lt. omega .lt. 1 */ usubc_1.omega = .1; /* nsmin and nsmax specify a range of subspace dimensions. */ /* In addition to satisfying 1 .le. nsmin .le. nsmax .le. n, */ /* nsmin and nsmax must be chosen so that n can be expressed */ /* as a sum of positive integers where each of these integers */ /* ns(i) satisfies nsmin .le. ns(i) .ge. nsmax. */ /* Specifically, */ /* nsmin*ceil(n/nsmax) .le. n must be true. */ /* nsmin - subspace dimension minimum */ usubc_1.nsmin = min(2,*n); /* nsmax - subspace dimension maximum */ usubc_1.nsmax = min(5,*n); /* *********************************************************** */ /* subplex method special cases */ /* *********************************************************** */ /* nelder-mead simplex method with periodic restarts */ /* nsmin = nsmax = n */ /* *********************************************************** */ /* nelder-mead simplex method */ /* nsmin = nsmax = n, psi = small positive */ /* *********************************************************** */ /* irepl, ifxsw, and bonus deal with measurement replication. */ /* Objective functions subject to large amounts of noise can */ /* cause an optimization method to halt at a false optimum. */ /* An expensive solution to this problem is to evaluate f */ /* several times at each point and return the average (or max */ /* or min) of these trials as the function value. subplx */ /* performs measurement replication only at the current best */ /* point. The longer a point is retained as best, the more */ /* accurate its function value becomes. */ /* The common variable nfxe contains the number of function */ /* evaluations at the current best point. fxstat contains the */ /* mean, max, min, and standard deviation of these trials. */ /* irepl - measurement replication switch */ /* irepl = 0, 1, or 2 */ /* = 0 : no measurement replication */ /* = 1 : subplx performs measurement replication */ /* = 2 : user performs measurement replication */ /* (This is useful when optimizing on the mean, */ /* max, or min of trials is insufficient. Common */ /* variable initx is true for first function */ /* evaluation. newx is true for first trial at */ /* this point. The user uses subroutine fstats */ /* within his objective function to maintain */ /* fxstat. By monitoring newx, the user can tell */ /* whether to return the function evaluation */ /* (newx = .true.) or to use the new function */ /* evaluation to refine the function evaluation */ /* of the current best point (newx = .false.). */ /* The common variable ftest gives the function */ /* value that a new point must beat to be */ /* considered the new best point.) */ usubc_1.irepl = 0; /* ifxsw - measurement replication optimization switch */ /* ifxsw = 1, 2, or 3 */ /* = 1 : retain mean of trials as best function value */ /* = 2 : retain max */ /* = 3 : retain min */ usubc_1.ifxsw = 1; /* Since the current best point will also be the most */ /* accurately evaluated point whenever irepl .gt. 0, a bonus */ /* should be added to the function value of the best point */ /* so that the best point is not replaced by a new point */ /* that only appears better because of noise. */ /* subplx uses bonus to determine how many multiples of */ /* fxstat(4) should be added as a bonus to the function */ /* evaluation. (The bonus is adjusted automatically by */ /* subplx when ifxsw or minf is changed.) */ /* bonus - measurement replication bonus coefficient */ /* bonus .ge. 0 (normally, bonus = 0 or 1) */ /* = 0 : bonus not used */ /* = 1 : bonus used */ usubc_1.bonus = 1.; /* nfstop = 0 : f(x) is not tested against fstop */ /* = 1 : if f(x) has reached fstop, subplx returns */ /* iflag = 2 */ /* = 2 : (only valid when irepl .gt. 0) */ /* if f(x) has reached fstop and */ /* nfxe .gt. nfstop, subplx returns iflag = 2 */ usubc_1.nfstop = 0; /* fstop - f target value */ /* Its usage is determined by the value of nfstop. */ /* minf - logical switch */ /* = .true. : subplx performs minimization */ /* = .false. : subplx performs maximization */ usubc_1.minf = TRUE_; return 0; } /* subopt_ */ /* setstp.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static double d_sign(doublereal *x, doublereal *y) { return copysign(*x, *y); } static int setstp_(integer *nsubs, integer *n, doublereal *deltax, doublereal *step) { /* System generated locals */ integer i__1; doublereal d__1, d__2, d__3; /* Builtin functions */ /* double d_sign(doublereal *, doublereal *); */ /* Local variables */ static integer i__; static doublereal stpfac; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* setstp sets the stepsizes for the corresponding components */ /* of the solution vector. */ /* input */ /* nsubs - number of subspaces */ /* n - number of components (problem dimension) */ /* deltax - vector of change in solution vector */ /* step - stepsizes for corresponding components of */ /* solution vector */ /* output */ /* step - new stepsizes */ /* common */ /* local variables */ /* subroutines and functions */ /* blas */ /* fortran */ /* ----------------------------------------------------------- */ /* set new step */ /* Parameter adjustments */ --step; --deltax; /* Function Body */ if (*nsubs > 1) { /* Computing MIN */ /* Computing MAX */ d__3 = dasum_(n, &deltax[1], &c__1) / dasum_(n, &step[1], &c__1); d__1 = max(d__3,usubc_1.omega), d__2 = 1. / usubc_1.omega; stpfac = min(d__1,d__2); } else { stpfac = usubc_1.psi; } dscal_(n, &stpfac, &step[1], &c__1); /* reorient simplex */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { if (deltax[i__] != 0.) { step[i__] = d_sign(&step[i__], &deltax[i__]); } else { step[i__] = -step[i__]; } /* L10: */ } return 0; } /* setstp_ */ /* subplx.f -- translated by f2c (version 19991025). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ static int subplx_(D_fp f, void *fdata, integer *n, doublereal *tol, integer * maxnfe, integer *mode, doublereal *scale, doublereal *x, doublereal * fx, integer *nfe, doublereal *work, integer *iwork, integer *iflag) { /* Initialized data */ static doublereal bnsfac[6] /* was [3][2] */ = { -1.,-2.,0.,1.,0.,2. }; /* System generated locals */ integer i__1; doublereal d__1, d__2, d__3, d__4, d__5, d__6; /* Local variables */ static integer i__; static logical cmode; static integer istep; static doublereal xpscl; static integer nsubs, ipptr; static integer isptr; static integer ns, insfnl, ifsptr; static integer insptr; static integer istptr; static doublereal scl, dum; static integer ins; static doublereal sfx; /* Coded by Tom Rowan */ /* Department of Computer Sciences */ /* University of Texas at Austin */ /* subplx uses the subplex method to solve unconstrained */ /* optimization problems. The method is well suited for */ /* optimizing objective functions that are noisy or are */ /* discontinuous at the solution. */ /* subplx sets default optimization options by calling the */ /* subroutine subopt. The user can override these defaults */ /* by calling subopt prior to calling subplx, changing the */ /* appropriate common variables, and setting the value of */ /* mode as indicated below. */ /* By default, subplx performs minimization. */ /* input */ /* f - user supplied function f(n,x) to be optimized, */ /* declared external in calling routine */ /* n - problem dimension */ /* tol - relative error tolerance for x (tol .ge. 0.) */ /* maxnfe - maximum number of function evaluations */ /* mode - integer mode switch with binary expansion */ /* (bit 1) (bit 0) : */ /* bit 0 = 0 : first call to subplx */ /* = 1 : continuation of previous call */ /* bit 1 = 0 : use default options */ /* = 1 : user set options */ /* scale - scale and initial stepsizes for corresponding */ /* components of x */ /* (If scale(1) .lt. 0., */ /* abs(scale(1)) is used for all components of x, */ /* and scale(2),...,scale(n) are not referenced.) */ /* x - starting guess for optimum */ /* work - double precision work array of dimension .ge. */ /* 2*n + nsmax*(nsmax+4) + 1 */ /* (nsmax is set in subroutine subopt. */ /* default: nsmax = min(5,n)) */ /* iwork - integer work array of dimension .ge. */ /* n + int(n/nsmin) */ /* (nsmin is set in subroutine subopt. */ /* default: nsmin = min(2,n)) */ /* output */ /* x - computed optimum */ /* fx - value of f at x */ /* nfe - number of function evaluations */ /* iflag - error flag */ /* = -2 : invalid input */ /* = -1 : maxnfe exceeded */ /* = 0 : tol satisfied */ /* = 1 : limit of machine precision */ /* = 2 : fstop reached (fstop usage is determined */ /* by values of options minf, nfstop, and */ /* irepl. default: f(x) not tested against */ /* fstop) */ /* iflag should not be reset between calls to */ /* subplx. */ /* common */ /* local variables */ /* subroutines and functions */ /* blas */ /* fortran */ /* data */ /* Parameter adjustments */ --x; --scale; --work; --iwork; /* Function Body */ /* ----------------------------------------------------------- */ if (*mode % 2 == 0) { /* first call, check input */ if (*n < 1) { goto L120; } if (*tol < 0.) { goto L120; } if (*maxnfe < 1) { goto L120; } if (scale[1] >= 0.) { i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xpscl = x[i__] + scale[i__]; if (xpscl == x[i__]) { goto L120; } /* L10: */ } } else { scl = abs(scale[1]); i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { xpscl = x[i__] + scl; if (xpscl == x[i__]) { goto L120; } /* L20: */ } } if (*mode / 2 % 2 == 0) { subopt_(n); } else { if (usubc_1.alpha <= 0.) { goto L120; } if (usubc_1.beta <= 0. || usubc_1.beta >= 1.) { goto L120; } if (usubc_1.gamma <= 1.) { goto L120; } if (usubc_1.delta <= 0. || usubc_1.delta >= 1.) { goto L120; } if (usubc_1.psi <= 0. || usubc_1.psi >= 1.) { goto L120; } if (usubc_1.omega <= 0. || usubc_1.omega >= 1.) { goto L120; } if (usubc_1.nsmin < 1 || usubc_1.nsmax < usubc_1.nsmin || *n < usubc_1.nsmax) { goto L120; } if (*n < ((*n - 1) / usubc_1.nsmax + 1) * usubc_1.nsmin) { goto L120; } if (usubc_1.irepl < 0 || usubc_1.irepl > 2) { goto L120; } if (usubc_1.ifxsw < 1 || usubc_1.ifxsw > 3) { goto L120; } if (usubc_1.bonus < 0.) { goto L120; } if (usubc_1.nfstop < 0) { goto L120; } } /* initialization */ istptr = *n + 1; isptr = istptr + *n; ifsptr = isptr + usubc_1.nsmax * (usubc_1.nsmax + 3); insptr = *n + 1; if (scale[1] > 0.) { dcopy_(n, &scale[1], &c__1, &work[1], &c__1); dcopy_(n, &scale[1], &c__1, &work[istptr], &c__1); } else { dcopy_(n, &scl, &c__0, &work[1], &c__1); dcopy_(n, &scl, &c__0, &work[istptr], &c__1); } i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { iwork[i__] = i__; /* L30: */ } *nfe = 0; usubc_1.nfxe = 1; if (usubc_1.irepl == 0) { isubc_1.fbonus = 0.; } else if (usubc_1.minf) { isubc_1.fbonus = bnsfac[usubc_1.ifxsw - 1] * usubc_1.bonus; } else { isubc_1.fbonus = bnsfac[usubc_1.ifxsw + 2] * usubc_1.bonus; } if (usubc_1.nfstop == 0) { isubc_1.sfstop = 0.; } else if (usubc_1.minf) { isubc_1.sfstop = usubc_1.fstop; } else { isubc_1.sfstop = -usubc_1.fstop; } usubc_1.ftest = 0.; cmode = FALSE_; isubc_1.new__ = TRUE_; usubc_1.initx = TRUE_; evalf_((D_fp)f, fdata, &c__0, &iwork[1], &dum, n, &x[1], &sfx, nfe); usubc_1.initx = FALSE_; } else { /* continuation of previous call */ if (*iflag == 2) { if (usubc_1.minf) { isubc_1.sfstop = usubc_1.fstop; } else { isubc_1.sfstop = -usubc_1.fstop; } cmode = TRUE_; goto L70; } else if (*iflag == -1) { cmode = TRUE_; goto L70; } else if (*iflag == 0) { cmode = FALSE_; goto L90; } else { return 0; } } /* subplex loop */ L40: i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = (d__1 = work[i__], abs(d__1)); /* L50: */ } sortd_(n, &work[1], &iwork[1]); partx_(n, &iwork[1], &work[1], &nsubs, &iwork[insptr]); dcopy_(n, &x[1], &c__1, &work[1], &c__1); ins = insptr; insfnl = insptr + nsubs - 1; ipptr = 1; /* simplex loop */ L60: ns = iwork[ins]; L70: simplx_((D_fp)f, fdata, n, &work[istptr], &ns, &iwork[ipptr], maxnfe, &cmode, &x[ 1], &sfx, nfe, &work[isptr], &work[ifsptr], iflag); cmode = FALSE_; if (*iflag != 0) { goto L110; } if (ins < insfnl) { ++ins; ipptr += ns; goto L60; } /* end simplex loop */ i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { work[i__] = x[i__] - work[i__]; /* L80: */ } /* check termination */ L90: istep = istptr; i__1 = *n; for (i__ = 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__4 = (d__2 = work[i__], abs(d__2)), d__5 = (d__1 = work[istep], abs( d__1)) * usubc_1.psi; /* Computing MAX */ d__6 = (d__3 = x[i__], abs(d__3)); if (max(d__4,d__5) / max(d__6,1.) > *tol) { setstp_(&nsubs, n, &work[1], &work[istptr]); goto L40; } ++istep; /* L100: */ } /* end subplex loop */ *iflag = 0; L110: if (usubc_1.minf) { *fx = sfx; } else { *fx = -sfx; } return 0; /* invalid input */ L120: *iflag = -2; return 0; } /* subplx_ */ /****************************************************************************/ /****************************************************************************/ /* front-end for subplex routines */ /* Wrapper around f2c'ed subplx_ routine, for multidimensinal unconstrained optimization: Parameters: f: function f(n,x,fdata) to be optimized n: problem dimension x[n]: (input) starting guess position, (output) computed minimum fdata: data pointer passed to f tol: relative error tolerance for x maxnfe: maximum number of function evaluations scale[n]: (input) scale & initial stepsizes for components of x (if *scale < 0, |*scale| is used for all components) nfe: (output) number of function evaluations errflag: (output) = -2 : invalid input = -1 : maxnfe exceeded = 0 : tol satisfied = 1 : limit of machine precision = 2 : fstop reached (fstop usage is determined by values of options minf, nfstop, and irepl. default: f(x) not tested against fstop) Return value: value of f at minimum. */ number subplex(multivar_func f, number *x, integer n, void *fdata, number tol, integer maxnfe, number fmin, boolean use_fmin, number *scale, integer *nfe, integer *errflag) { integer mode = 0, *iwork, nsmax, nsmin; number *work, fx; nsmax = min(5,n); nsmin = min(2,n); work = (number*) malloc(sizeof(number) * (2*n + nsmax*(nsmax+4) + 1)); iwork = (integer*) malloc(sizeof(integer) * (n + n/nsmin + 1)); if (!work || !iwork) { fprintf(stderr, "subplex: error, out of memory!\n"); exit(EXIT_FAILURE); } if (use_fmin) { /* stop when fmin is reached */ subopt_(&n); usubc_1.nfstop = 1; usubc_1.fstop = fmin; mode = 2; } subplx_(f,fdata, &n, &tol, &maxnfe, &mode, scale, x, &fx, nfe, work, iwork, errflag); free(iwork); free(work); return fx; } number f_scm_wrapper(integer n, number *x, void *f_scm_p) { SCM *f_scm = (SCM *) f_scm_p; return ctl_convert_number_to_c(gh_call1(*f_scm, make_number_list(n, x))); } /* Scheme-callable wrapper for subplex() function, above. */ SCM subplex_scm(SCM f_scm, SCM x_scm, SCM tol_scm, SCM maxnfe_scm, SCM fmin_scm, SCM use_fmin_scm, SCM scale_scm) { number *x, tol, *scale, fx, fmin; integer i, n, maxnfe, nfe, errflag, scale_len; boolean use_fmin; SCM retval; n = list_length(x_scm); tol = fabs(ctl_convert_number_to_c(tol_scm)); maxnfe = ctl_convert_integer_to_c(maxnfe_scm); fmin = ctl_convert_number_to_c(fmin_scm); use_fmin = ctl_convert_boolean_to_c(use_fmin_scm); scale_len = list_length(scale_scm); if (scale_len != 1 && scale_len != n) { fprintf(stderr, "subplex: invalid scale argument length %d\n", scale_len); return SCM_UNDEFINED; } x = (number*) malloc(sizeof(number) * n); scale = (number*) malloc(sizeof(number) * scale_len); if (!x || !scale) { fprintf(stderr, "subplex: error, out of memory!\n"); exit(EXIT_FAILURE); } for (i = 0; i < n; ++i) x[i] = number_list_ref(x_scm, i); for (i = 0; i < scale_len; ++i) scale[i] = fabs(number_list_ref(scale_scm, i)); if (scale_len == 1 && scale_len != n) *scale *= -1; fx = subplex(f_scm_wrapper, x, n, &f_scm, tol, maxnfe, fmin, use_fmin, scale, &nfe, &errflag); switch (errflag) { case -2: fprintf(stderr, "subplex error: invalid inputs\n"); return SCM_UNDEFINED; case -1: fprintf(stderr, "subplex warning: max # iterations exceeded\n"); break; case 1: fprintf(stderr, "subplex warning: machine precision reached\n"); break; case 2: fprintf(stderr, "subplex warning: fstop reached\n"); break; } retval = gh_cons(make_number_list(n, x), ctl_convert_number_to_scm(fx)); free(scale); free(x); return retval; } libctl-4.4.0/utils/000077500000000000000000000000001356267410600141425ustar00rootroot00000000000000libctl-4.4.0/utils/Makefile.am000066400000000000000000000033501356267410600161770ustar00rootroot00000000000000bin_SCRIPTS = gen-ctl-io include_HEADERS = ctlgeom.h nodist_include_HEADERS = ctlgeom-types.h lib_LTLIBRARIES = libctlgeom.la noinst_PROGRAMS = geomtst EXTRA_DIST = gen-ctl-io.in README geom.scm geom-ctl-io-defaults.c nlopt.c libctlgeom_la_SOURCES = geom.c $(top_srcdir)/src/ctl-math.c $(top_srcdir)/src/integrator.c geom-ctl-io.c ctlgeom-types.h libctlgeom_la_LDFLAGS = -version-info @SHARED_VERSION_INFO@ libctlgeom_la_CPPFLAGS = -DLIBCTLGEOM -I$(top_srcdir)/src geomtst_SOURCES = geomtst.c geomtst_LDADD = libctlgeom.la geomtst_CPPFLAGS = -I$(top_srcdir)/src check_PROGRAMS = test-prism test_prism_SOURCES = test-prism.c test_prism_LDADD = libctlgeom.la test_prism_CPPFLAGS = -I$(top_srcdir)/src TESTS = test-prism dist_man_MANS = gen-ctl-io.1 BUILT_SOURCES = gen-ctl-io geom-ctl-io.c ctlgeom-types.h nlopt-constants.scm nlopt-constants.scm: echo "#include " > nlopt-constants.h echo "; AUTOMATICALLY GENERATED - DO NOT EDIT" > $@ names=`$(CPP) nlopt-constants.h 2>/dev/null | $(EGREP) 'NLOPT_[LG][ND]' | sed 's/ //g;s/_/-/g' |tr = , |cut -d, -f1`; i=0; for n in $$names; do echo "(define $$n $$i)" >> $@; i=`expr $$i + 1`; done rm nlopt-constants.h if WITH_GUILE ctl-io.c: geom.scm $(GEN_CTL_IO) $(GEN_CTL_IO) --c-only --code -o $@ $(srcdir)/geom.scm $(top_srcdir) ctl-io.h: geom.scm $(GEN_CTL_IO) $(GEN_CTL_IO) --c-only --header -o $@ $(srcdir)/geom.scm $(top_srcdir) ctlgeom-types.h: ctl-io.h sed 's,SCM,void*,;s,ctl\.h,ctl-math.h,' ctl-io.h > $@ geom-ctl-io.c: ctl-io.c sed 's,ctl-io\.h,ctlgeom-types.h,;s,/.* Input variables .*/,@#include "geom-ctl-io-defaults.c"@#if 0@,;s,/.* Output variables .*/,#endif@,' ctl-io.c | tr '@' '\n' > $@ endif clean-local: rm -f ctl-io.[ch] nlopt-constants.scm ctlgeom-types.h geom-ctl-io.c libctl-4.4.0/utils/README000066400000000000000000000023131356267410600150210ustar00rootroot00000000000000This directory contains utilities for use with libctl. First, there are ctl-io.scm and gen-ctl-io.scm, which are used to generate C glue code (ctl-io.h and ctl-io.c) from a specifications file for translating input/output variables to/from C. Second, there is libctlgeom, a collection of utility code for manipulating geometric objects, for use with libctl. libctlgeom contains: * geom.scm: specifications file containing classes and utilities for dealing with three-dimensional geometric objects (spheres, cylinders, etcetera). This should be included in the specifications file for anything using libgeom, with: (include "/utils/geom.scm") Each geometric object derives from the class geometric-object, and has a material property whose type is the class material-type. Users should provide their own material-type class (if none is provided, a dummy class is used). * geom.c, geom.h: C routines (callable from Guile) for performing various operations on a geometry, such as finding out what object a given point is inside. Note that most of these routines use the global input variables defined in geom.scm--they must be called only when these variables have been imported to C. libctl-4.4.0/utils/ctl-io.scm000066400000000000000000000753671356267410600160570ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; *************************************************************************** ; "Standard" Scheme functions missing from Guile 1.2: (define (string-upcase s) (list->string (map (lambda (c) (if (and (char>=? c #\a) (char<=? c #\z)) (integer->char (+ (char->integer c) (char->integer #\A) (- (char->integer #\a)))) c)) (string->list s)))) ; *************************************************************************** (define cxx false) ; set to true for C++ output (c.f. gen-ctl-io --cxx) (define namespace "ctlio") (define (ns0) (ns namespace)) (define (ns namespace) (if cxx (string-append namespace "::") "")) (define (c-identifier s) (list->string (map (lambda (c) (if (or (eq? c #\-) (eq? c #\space)) #\_ (if (eq? c #\?) #\p (if (eq? c #\!) #\B c)))) (string->list s)))) (define symbol->c-identifier (compose c-identifier symbol->string)) (define (c-type-string t) (if (eq? t 'string) "char*" ; "string" name is reserved in C++ (c-identifier (type-string t)))) (define declared-type-names '()) (define (declare-type-name type-name) (if (and (list-type-name? type-name) (not (member (c-type-string type-name) declared-type-names))) (begin (if (list-type-name? (list-el-type-name type-name)) (declare-type-name (list-el-type-name type-name))) (print "typedef struct {\n") (print "int num_items;\n") (print (c-type-string (list-el-type-name type-name)) " *items;\n") (print "} " (c-type-string type-name) ";\n\n") (set! declared-type-names (cons (c-type-string type-name) declared-type-names))))) (define (only-list-types type-names) (list-transform-positive type-names list-type-name?)) (define (c-var-decl' var-name var-type-name ns) (print (c-type-string var-type-name) " " ns (symbol->c-identifier var-name) ";\n")) (define (c-var-decl var-name var-type-name) (c-var-decl' var-name var-type-name "")) ; *************************************************************************** ; use new/delete for C++, malloc/free for C (define (free . vars) (let ((var (apply string-append vars))) (if cxx (string-append "delete[] (" var ")") (string-append "free(" var ")")))) (define (free1 . vars) (let ((var (apply string-append vars))) (if cxx (string-append "delete (" var ")") (string-append "free(" var ")")))) (define (malloc tname . nums) (let ((num (apply string-append nums))) (if cxx (string-append "(new " tname "[" num "])") (string-append "((" tname " *) malloc(sizeof(" tname ") * (" num ")))")))) (define (malloc1 . tnames) (let ((tname (apply string-append tnames))) (if cxx (string-append "(new " tname ")") (string-append "((" tname " *) malloc(sizeof(" tname ")))")))) ; *************************************************************************** (define (find-direct-subclasses class) (list-transform-positive class-list (lambda (c) (eq? (class-parent c) class)))) (define (class-identifier class) (symbol->c-identifier (class-type-name class))) (define (class-enum-name0 class) (string-upcase (class-identifier class))) (define (class-enum-name class) (string-append (ns (class-identifier (class-parent class))) (class-enum-name0 class))) (define (class-self-enum-name class) (string-append (ns (class-identifier class)) (class-enum-name0 class) "_SELF")) (define (c-class-decl class) (for-each (compose declare-type-name property-type-name) (class-properties class)) (print "typedef struct " (class-identifier class) "_struct {\n") (for-each (lambda (property) (c-var-decl (property-name property) (property-type-name property))) (class-properties class)) (let ((subclasses (find-direct-subclasses class))) (if (not (null? subclasses)) (begin (print "enum { " (class-enum-name0 class) "_SELF") (for-each (lambda (sc) (print ", " (class-enum-name0 sc))) subclasses) (print " } which_subclass;\n") (print "union {\n") (for-each (lambda (sc) (print "struct " (class-identifier sc) "_struct *" (class-identifier sc) "_data;\n")) subclasses) (print "} subclass;\n")))) (print "} " (class-identifier class) ";\n") (if (and (not (null? (find-direct-subclasses class))) (null? (class-properties class))) (print "#define " (class-enum-name0 class) "_ABSTRACT 1\n")) (print "\n")) (define (display-c-class-decls) (print "/******* Type declarations *******/\n\n") (for-each c-class-decl (reverse class-list))) ; *************************************************************************** (define (declare-var var) (c-var-decl' (var-name var) (var-type-name var) (ns0))) (define (declare-extern-var var) (print "extern ") (c-var-decl (var-name var) (var-type-name var))) (define (declarer-if-not-input-var declarer) (lambda (var) (if (not (member var input-var-list)) (declarer var) (begin (print "/* " (var-name var) " is both input and output */\n"))))) (define (all-type-names) (append exported-type-list (map var-type-name (append (reverse input-var-list) (reverse output-var-list))) (map external-function-return-type-name external-function-list) (fold-left append '() (map external-function-arg-type-names external-function-list)))) (define (declare-var-types) (for-each declare-type-name (all-type-names))) (define (declare-vars declarer) (print "/******* Input variables *******/\n") (for-each declarer (reverse input-var-list)) (print "\n") (print "/******* Output variables *******/\n") (for-each (declarer-if-not-input-var declarer) (reverse output-var-list)) (print "\n")) (define (declare-vars-header) (declare-var-types) (declare-vars declare-extern-var)) (define (declare-vars-source) (declare-vars declare-var)) ; *************************************************************************** (define (input-value s-var-name-str c-var-name-str type-name getter) (let ((desc (get-type-descriptor type-name))) (cond ((eq? (type-descriptor-kind desc) 'simple) (print c-var-name-str " = " (getter type-name s-var-name-str) ";\n")) ((eq? (type-descriptor-kind desc) 'object) (print (class-input-function-name type-name) "(" (getter 'object s-var-name-str) ", &" c-var-name-str ");\n")) ((eq? (type-descriptor-kind desc) 'uniform-list) (input-list (getter 'list s-var-name-str) c-var-name-str (list-el-type-name type-name)))))) (define (get-global type-symbol name-str) (string-append "ctl_get_" (symbol->c-identifier type-symbol) "(\"" name-str "\")" )) (define (property-getter object-name-str) (lambda (type-symbol name-str) (string-append (symbol->c-identifier type-symbol) "_object_property(" object-name-str ", " "\"" name-str "\")" ))) (define (list-getter lo-name-str) (lambda (type-symbol name-str) (string-append (symbol->c-identifier type-symbol) "_list_ref(" lo-name-str ", " name-str ")" ))) (define list-temp-suffix "_t") (define (input-list list-object-get-str c-var-name-str type-name) (print "{\n") (let ((lo-name-str (string-append "lo" list-temp-suffix)) (index-name-str (string-append "i" list-temp-suffix)) (saved-list-temp-suffix list-temp-suffix)) (set! list-temp-suffix (string-append list-temp-suffix "_t")) (print "list " lo-name-str " = " list-object-get-str ";\n") (print "int " index-name-str ";\n") (print c-var-name-str ".num_items = list_length(" lo-name-str ");\n") (print c-var-name-str ".items = " (malloc (c-type-string type-name) c-var-name-str ".num_items") ";\n") (print "for (" index-name-str " = 0; " index-name-str " < " c-var-name-str ".num_items; " index-name-str "++) {\n") (input-value index-name-str (string-append c-var-name-str ".items[" index-name-str "]") type-name (list-getter lo-name-str)) (print "}\n") (set! list-temp-suffix saved-list-temp-suffix)) (print "}\n")) (define (class-input-function-name type-name) (string-append (symbol->c-identifier type-name) "_input")) (define (class-input-function-decl class ns) (print "void " ns (class-input-function-name (class-type-name class)) "(SCM so, " (c-type-string (class-type-name class)) " *o)")) (define (class-input-function class) (class-input-function-decl class (ns0)) (print "\n{\n") (for-each (lambda (property) (input-value (symbol->string (property-name property)) (string-append "o->" (symbol->c-identifier (property-name property))) (property-type-name property) (property-getter "so"))) (class-properties class)) (let ((subclasses (find-direct-subclasses class))) (for-each (lambda (sc) (print "if (object_is_member(\"" (class-type-name sc) "\", so)) {\n") (print "o->which_subclass = " (class-enum-name sc) ";\n") (print "o->subclass." (class-identifier sc) "_data = " (malloc1 (class-identifier sc)) ";\n") (print (class-input-function-name (class-type-name sc)) "(so, o->subclass." (class-identifier sc) "_data);\n" "}\nelse ")) subclasses) (if (not (null? subclasses)) (begin (print "\n") (print "o->which_subclass = " (class-self-enum-name class) ";\n")))) (print "}\n\n")) (define (output-class-input-functions-header) (print "/******* class input function prototypes *******/\n\n") (for-each (lambda (class) (print "extern ") (class-input-function-decl class "") (print ";\n")) class-list) (print "\n")) (define (output-class-input-functions-source) (print "/******* class input functions *******/\n\n") (for-each class-input-function class-list)) (define (input-vars-function) (print "/******* read input variables *******/\n\n") (print "SCM " (ns0) "read_input_vars(void)\n") (print "{\n") (print "if (num_read_input_vars++) destroy_input_vars();\n") (for-each (lambda (var) (input-value (symbol->string (var-name var)) (symbol->c-identifier (var-name var)) (var-type-name var) get-global)) (reverse input-var-list)) (print "return SCM_UNSPECIFIED;\n") (print "}\n\n")) ; *************************************************************************** (define (copy-value c0-var-name-str c-var-name-str type-name) (let ((desc (get-type-descriptor type-name))) (cond ((eq? (type-descriptor-kind desc) 'simple) (print c-var-name-str " = " c0-var-name-str ";\n")) ((eq? (type-descriptor-kind desc) 'object) (print (class-copy-function-name type-name) "(&" c0-var-name-str ", &" c-var-name-str ");\n")) ((eq? (type-descriptor-kind desc) 'uniform-list) (copy-list c0-var-name-str c-var-name-str (list-el-type-name type-name)))))) (define (copy-list c0-var-name-str c-var-name-str type-name) (print "{\n") (let ((index-name-str (string-append "i" list-temp-suffix)) (saved-list-temp-suffix list-temp-suffix)) (set! list-temp-suffix (string-append list-temp-suffix "_t")) (print "int " index-name-str ";\n") (print c-var-name-str ".num_items = " c0-var-name-str ".num_items;\n") (print c-var-name-str ".items = " (malloc (c-type-string type-name) c-var-name-str ".num_items") ";\n") (print "for (" index-name-str " = 0; " index-name-str " < " c-var-name-str ".num_items; " index-name-str "++) {\n") (copy-value (string-append c0-var-name-str ".items[" index-name-str "]") (string-append c-var-name-str ".items[" index-name-str "]") type-name) (print "}\n") (set! list-temp-suffix saved-list-temp-suffix)) (print "}\n")) (define (class-copy-function-name type-name) (string-append (symbol->c-identifier type-name) "_copy")) (define (class-copy-function-decl class ns) (print "void " ns (class-copy-function-name (class-type-name class)) "(const " (c-type-string (class-type-name class)) " *o0," (c-type-string (class-type-name class)) " *o)")) (define (class-copy-function class) (class-copy-function-decl class (ns0)) (print "\n{\n") (for-each (lambda (property) (copy-value (string-append "o0->" (symbol->c-identifier (property-name property))) (string-append "o->" (symbol->c-identifier (property-name property))) (property-type-name property))) (class-properties class)) (let ((subclasses (find-direct-subclasses class))) (for-each (lambda (sc) (print "if (o0->which_subclass == " (class-enum-name sc) ") {\n") (print "o->which_subclass = " (class-enum-name sc) ";\n") (print "o->subclass." (class-identifier sc) "_data = " (malloc1 (class-identifier sc)) ";\n") (print (class-copy-function-name (class-type-name sc)) "(o0->subclass." (class-identifier sc) "_data, o->subclass." (class-identifier sc) "_data);\n" "}\nelse ")) subclasses) (if (not (null? subclasses)) (begin (print "\n") (print "o->which_subclass = " (class-self-enum-name class) ";\n")))) (print "}\n\n")) (define (output-class-copy-functions-header) (print "/******* class copy function prototypes *******/\n\n") (for-each (lambda (class) (print "extern ") (class-copy-function-decl class "") (print ";\n")) class-list) (print "\n")) (define (output-class-copy-functions-source) (print "/******* class copy functions *******/\n\n") (for-each class-copy-function class-list)) ; *************************************************************************** (define (equal-value c0-var-name-str c-var-name-str type-name) (let ((desc (get-type-descriptor type-name))) (cond ((primitive-type? type-name) (print "if (" c-var-name-str " != " c0-var-name-str ") return 0;\n")) ((eq? type-name 'string) (print "if (strcmp(" c-var-name-str ", " c0-var-name-str ")) return 0;\n")) ((eq? (type-descriptor-kind desc) 'simple) (print "if (!" type-name "_equal(" c-var-name-str ", " c0-var-name-str ")) return 0;\n")) ((eq? (type-descriptor-kind desc) 'object) (print "if (!" (class-equal-function-name type-name) "(&" c0-var-name-str ", &" c-var-name-str ")) return 0;\n")) ((eq? (type-descriptor-kind desc) 'uniform-list) (equal-list c0-var-name-str c-var-name-str (list-el-type-name type-name)))))) (define (equal-list c0-var-name-str c-var-name-str type-name) (print "{\n") (let ((index-name-str (string-append "i" list-temp-suffix)) (saved-list-temp-suffix list-temp-suffix)) (set! list-temp-suffix (string-append list-temp-suffix "_t")) (print "int " index-name-str ";\n") (print "if (" c-var-name-str ".num_items != " c0-var-name-str ".num_items) return 0;\n") (print "for (" index-name-str " = 0; " index-name-str " < " c-var-name-str ".num_items; " index-name-str "++) {\n") (equal-value (string-append c0-var-name-str ".items[" index-name-str "]") (string-append c-var-name-str ".items[" index-name-str "]") type-name) (print "}\n") (set! list-temp-suffix saved-list-temp-suffix)) (print "}\n")) (define (class-equal-function-name type-name) (string-append (symbol->c-identifier type-name) "_equal")) (define (class-equal-function-decl class ns) (print "boolean " ns (class-equal-function-name (class-type-name class)) "(const " (c-type-string (class-type-name class)) " *o0, " "const " (c-type-string (class-type-name class)) " *o)")) (define (class-equal-function class) (class-equal-function-decl class (ns0)) (print "\n{\n") (for-each (lambda (property) (equal-value (string-append "o0->" (symbol->c-identifier (property-name property))) (string-append "o->" (symbol->c-identifier (property-name property))) (property-type-name property))) (class-properties class)) (let ((subclasses (find-direct-subclasses class))) (if (not (null? subclasses)) (print "if (o0->which_subclass != o->which_subclass) return 0;\n")) (for-each (lambda (sc) (print "if (o0->which_subclass == " (class-enum-name sc) ") {\n") (print "if (!" (class-equal-function-name (class-type-name sc)) "(o0->subclass." (class-identifier sc) "_data, o->subclass." (class-identifier sc) "_data)) return 0;\n" "}\nelse ")) subclasses) (print ";\n")) (print "return 1;\n") (print "}\n\n")) (define (output-class-equal-functions-header) (print "/******* class equal function prototypes *******/\n\n") (for-each (lambda (class) (print "extern ") (class-equal-function-decl class "") (print ";\n")) class-list) (print "\n")) (define (output-class-equal-functions-source) (print "/******* class equal functions *******/\n\n") (for-each class-equal-function class-list)) ; *************************************************************************** (define (export-object-value c-var-name-str type-name exporter) (error "object output variables are not yet supported. " type-name c-var-name-str)) (define (export-list-value c-var-name-str type-name exporter) (let ((el-type-name (list-el-type-name type-name))) (let ((el-desc (get-type-descriptor el-type-name))) (cond ((eq? (type-descriptor-kind el-desc) 'simple) (exporter (string-append "make_" (type-descriptor-name-str el-desc) "_list(" c-var-name-str ".num_items, " c-var-name-str ".items)"))) (else (error "only export of lists of simple types is currently supported, not " el-type-name)))))) (define (output-value s-var-name-str c-var-name-str type-name setter) (let ((desc (get-type-descriptor type-name))) (cond ((eq? (type-descriptor-kind desc) 'simple) (print (setter type-name s-var-name-str c-var-name-str) "\n")) ((eq? (type-descriptor-kind desc) 'object) (export-object-value c-var-name-str type-name (lambda (sobj-str) (print (setter 'object s-var-name-str sobj-str)) (print "\n")))) ((eq? (type-descriptor-kind desc) 'uniform-list) (export-list-value c-var-name-str type-name (lambda (slist-str) (print (setter 'list s-var-name-str slist-str)) (print "\n"))))))) (define (set-global type-symbol s-name-str c-name-str) (string-append "ctl_set_" (symbol->c-identifier type-symbol) "(\"" s-name-str "\", " c-name-str ");" )) (define (output-vars-function) (print "/******* write output variables *******/\n\n") (print "SCM " (ns0) "write_output_vars(void)\n") (print "{\n") (print "num_write_output_vars++;\n") (for-each (lambda (var) (output-value (symbol->string (var-name var)) (symbol->c-identifier (var-name var)) (var-type-name var) set-global)) (reverse output-var-list)) (print "return SCM_UNSPECIFIED;\n") (print "}\n\n")) ; *************************************************************************** (define (destroy-c-var var-str type-name) (let ((desc (get-type-descriptor type-name))) (cond ((eq? type-name 'string) (print (free var-str) ";\n")) ((eq? (type-descriptor-kind desc) 'uniform-list) (destroy-list var-str (list-el-type-name type-name))) ((eq? (type-descriptor-kind desc) 'object) (destroy-object var-str type-name))))) (define (class-destroy-function-name type-name) (string-append (symbol->c-identifier type-name) "_destroy")) (define (class-destroy-function-decl class ns) (print "void " ns (class-destroy-function-name (class-type-name class)) "(" (c-type-string (class-type-name class)) " o)")) (define (destroy-list var-str el-type-name) (let ((index-name (string-append "index" list-temp-suffix)) (saved-suffix list-temp-suffix)) (set! list-temp-suffix (string-append list-temp-suffix "_t")) (print "{\n") (print "int " index-name ";\n") (print "for (" index-name " = 0; " index-name " < " var-str ".num_items; " index-name "++) {\n") (destroy-c-var (string-append var-str ".items[" index-name "]") el-type-name) (print "}\n") (print "}\n") (print (free var-str ".items") ";\n") (set! list-temp-suffix saved-suffix))) (define (destroy-object var-str type-name) (print (class-destroy-function-name type-name) "(" var-str ");\n")) (define (destroy-property prefix-str property) (destroy-c-var (string-append prefix-str (symbol->c-identifier (property-name property))) (property-type-name property))) (define (class-destroy-function class) (class-destroy-function-decl class (ns0)) (print "\n{\n") (for-each (lambda (property) (destroy-property "o." property)) (class-properties class)) (let ((subclasses (find-direct-subclasses class))) (for-each (lambda (sc) (print "if (o.which_subclass == " (class-enum-name sc) ") {\n") (destroy-object (string-append "*o.subclass." (class-identifier sc) "_data") (class-type-name sc)) (print (free1 "o.subclass." (class-identifier sc) "_data") ";\n") (print "}\n") (print "else ")) subclasses) (if (not (null? subclasses)) (begin (print "{ }\n")))) (print "}\n\n")) (define (output-class-destruction-functions-header) (print "/******* class destruction function prototypes *******/\n\n") (for-each (lambda (class) (print "extern ") (class-destroy-function-decl class "") (print ";\n")) class-list) (print "\n")) (define (output-class-destruction-functions-source) (print "/******* class destruction functions *******/\n\n") (for-each class-destroy-function class-list)) (define (destroy-input-vars-function) (print "/******* destroy input variables *******/\n\n") (print "SCM " (ns0) "destroy_input_vars(void)\n") (print "{\n") (for-each (lambda (var) (destroy-c-var (symbol->c-identifier (var-name var)) (var-type-name var))) (reverse input-var-list)) (print "return SCM_UNSPECIFIED;\n") (print "}\n\n")) (define (destroy-output-vars-function) (print "/******* destroy output variables *******/\n\n") (print "SCM " (ns0) "destroy_output_vars(void)\n") (print "{\n") (for-each (lambda (var) (if (not (member var input-var-list)) (destroy-c-var (symbol->c-identifier (var-name var)) (var-type-name var)))) (reverse output-var-list)) (print "return SCM_UNSPECIFIED;\n") (print "}\n\n")) ; *************************************************************************** (define (list->indices lst start-index) (if (null? lst) '() (cons start-index (list->indices (cdr lst) (+ start-index 1))))) (define (declare-external-function external-function ns) (print "SCM " ns (symbol->c-identifier (external-function-aux-name (external-function-name external-function))) "(") (for-each (lambda (argnum) (if (> argnum 0) (print ", ")) (print "SCM arg_scm_" argnum)) (list->indices (external-function-arg-type-names external-function) 0)) (if (= (length (external-function-arg-type-names external-function)) 0) (print "void")) (print ")")) (define (declare-external-c-function external-function) (print "extern " (if (not (eq? (external-function-return-type-name external-function) no-return-value)) (c-type-string (external-function-return-type-name external-function)) "void") " " (symbol->c-identifier (external-function-name external-function)) "(") (for-each (lambda (arg-type-name argnum) (if (> argnum 0) (print ", ")) (print (c-type-string arg-type-name))) (external-function-arg-type-names external-function) (list->indices (external-function-arg-type-names external-function) 0)) (if (= (length (external-function-arg-type-names external-function)) 0) (print "void")) (print ");\n")) (define (output-external-functions-header) (print "/******* external-functions *******/\n\n") (for-each (lambda (ef) (declare-external-c-function ef) (print "extern ") (declare-external-function ef "") (print ";\n\n")) external-function-list) (print "\nextern void export_external_functions(void);\n") (print "\n")) (define (output-external-function-export external-function) (print "gh_new_procedure(\"" (external-function-aux-name (external-function-name external-function)) "\", " "(SCM (*)()) " (symbol->c-identifier (external-function-aux-name (external-function-name external-function))) ", " (length (external-function-arg-type-names external-function)) ", 0, 0);\n")) (define (output-export-external-functions) (print "void " (ns0) "export_external_functions(void)\n") (print "{\n") (for-each output-external-function-export external-function-list) (print "}\n\n")) (define (get-c-local type-symbol name-str) (string-append "ctl_convert_" (symbol->c-identifier type-symbol) "_to_c(" name-str ")")) (define (set-c-local type-symbol s-name-str c-name-str) (string-append s-name-str " = ctl_convert_" (symbol->c-identifier type-symbol) "_to_scm(" c-name-str ");")) (define (output-external-function external-function) (declare-external-function external-function (ns0)) (print "\n") (print "{\n") (if (not (eq? (external-function-return-type-name external-function) no-return-value)) (begin (print "SCM return_val_scm;\n") (c-var-decl 'return-val-c (external-function-return-type-name external-function)))) (for-each (lambda (arg-type-name argnum) (print (c-type-string arg-type-name) " arg_c_" argnum ";\n")) (external-function-arg-type-names external-function) (list->indices (external-function-arg-type-names external-function) 0)) (print "\n") (for-each (lambda (arg-type-name argnum) (input-value (string-append "arg_scm_" (number->string argnum)) (string-append "arg_c_" (number->string argnum)) arg-type-name get-c-local)) (external-function-arg-type-names external-function) (list->indices (external-function-arg-type-names external-function) 0)) (print "\n") (print "#ifdef HAVE_SCM_FLUSH_ALL_PORTS\nscm_flush_all_ports();\n#endif\n") (if (not (eq? (external-function-return-type-name external-function) no-return-value)) (print "return_val_c = ")) (print (symbol->c-identifier (external-function-name external-function)) "(") (for-each (lambda (argnum) (if (> argnum 0) (print ", ")) (print "arg_c_" argnum)) (list->indices (external-function-arg-type-names external-function) 0)) (print ");\n\n") (print "fflush(stdout); fflush(stderr);\n") (for-each (lambda (arg-type-name argnum) (destroy-c-var (string-append "arg_c_" (number->string argnum)) arg-type-name)) (external-function-arg-type-names external-function) (list->indices (external-function-arg-type-names external-function) 0)) (print "\n") (if (not (eq? (external-function-return-type-name external-function) no-return-value)) (begin (output-value "return_val_scm" "return_val_c" (external-function-return-type-name external-function) set-c-local) (destroy-c-var "return_val_c" (external-function-return-type-name external-function)) (print "return return_val_scm;\n")) (begin (print "return SCM_UNSPECIFIED;\n"))) (print "}\n\n")) (define (output-external-functions-source) (print "/******* external-functions *******/\n\n") (for-each output-external-function external-function-list) (output-export-external-functions)) ; *************************************************************************** (define (swig-type-header type-name) (print "%typemap(in) " (if cxx (string-append namespace "::") "") (c-type-string type-name) " {\n") (if cxx (print "using namespace " namespace ";\n")) (input-value "$input" "$1" type-name get-c-local) (print "}\n") (if (and (not (eq? 'object (type-descriptor-kind (get-type-descriptor type-name)))) (or (not (list-type-name? type-name)) (eq? 'simple (type-descriptor-kind (get-type-descriptor (list-el-type-name type-name)))))) (begin (print "%typemap(out) " (if cxx (string-append namespace "::") "") (c-type-string type-name) " {\n") (if cxx (print "using namespace " namespace ";\n")) (output-value "$result" "$1" type-name set-c-local) (destroy-c-var "$1" type-name) (print "}\n"))) (print "\n") ) (define (output-swig-header) (print "%{\n#include \"ctl-io.h\"\n%}\n\n") (print "/******* SWIG type-conversion mappings *******/\n\n") (for-each swig-type-header (append (only-list-types (all-type-names)) (map class-type-name class-list)))) ; *************************************************************************** (define ctl-io-c-only? false) (define (output-header) (if ctl-io-c-only? (begin (display-c-class-decls) (declare-vars-header) (output-class-copy-functions-header) (output-class-equal-functions-header) (output-class-destruction-functions-header)) (begin (display-c-class-decls) (declare-vars-header) (print "extern int num_read_input_vars;\n") (print "extern int num_write_output_vars;\n\n") (print "extern SCM read_input_vars(void);\n") (print "extern SCM write_output_vars(void);\n") (print "extern SCM destroy_input_vars(void);\n") (print "extern SCM destroy_output_vars(void);\n\n") (output-external-functions-header) (output-class-input-functions-header) (output-class-copy-functions-header) (output-class-equal-functions-header) (output-class-destruction-functions-header)))) (define (output-source) (if ctl-io-c-only? (begin (declare-vars-source) (output-class-copy-functions-source) (output-class-equal-functions-source) (output-class-destruction-functions-source)) (begin (declare-vars-source) (print "int " (ns0) "num_read_input_vars = 0; /* # calls to read_input_vars */\n" "int " (ns0) "num_write_output_vars = 0; /* # calls to read_input_vars */\n\n") (output-class-input-functions-source) (output-class-copy-functions-source) (output-class-equal-functions-source) (output-class-destruction-functions-source) (input-vars-function) (output-vars-function) (destroy-input-vars-function) (destroy-output-vars-function) (output-external-functions-source)))) libctl-4.4.0/utils/ctlgeom.h000066400000000000000000000174751356267410600157630ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ #ifndef GEOM_H #define GEOM_H #ifdef CXX_CTL_IO # define MATERIAL_TYPE ctlio::material_type # define GEOMETRIC_OBJECT ctlio::geometric_object # define GEOMETRIC_OBJECT_LIST ctlio::geometric_object_list # define LATTICE ctlio::lattice #else # define MATERIAL_TYPE material_type # define GEOMETRIC_OBJECT geometric_object # define GEOMETRIC_OBJECT_LIST geometric_object_list # define LATTICE lattice #endif #ifndef CTL_IO_H /* for libctlgeom */ # undef MATERIAL_TYPE # define MATERIAL_TYPE void* #endif /* Where possible (e.g. for gcc >= 3.1), enable a compiler warning for code that uses a deprecated function */ #if defined(__GNUC__) && (__GNUC__ > 3 || (__GNUC__==3 && __GNUC_MINOR__ > 0)) # define CTLGEOM_DEPRECATED __attribute__((deprecated)) #else # define CTLGEOM_DEPRECATED #endif #ifdef __cplusplus extern "C" { #endif /* __cplusplus */ /**************************************************************************/ #ifndef CTL_IO_H # include extern void display_geometric_object_info(int indentby, geometric_object o); #endif extern void geom_initialize(void); extern void geom_fix_object_ptr(GEOMETRIC_OBJECT *o); extern void geom_fix_object(GEOMETRIC_OBJECT o) CTLGEOM_DEPRECATED; extern void geom_fix_objects(void); extern void geom_fix_objects0(GEOMETRIC_OBJECT_LIST geometry) CTLGEOM_DEPRECATED; extern void geom_fix_object_list(GEOMETRIC_OBJECT_LIST geometry); extern void geom_fix_lattice(void); extern void geom_fix_lattice0(LATTICE *L); extern void geom_cartesian_lattice(void); extern void geom_cartesian_lattice0(LATTICE *L); extern double geom_object_volume(GEOMETRIC_OBJECT o); extern boolean point_in_objectp(vector3 p, GEOMETRIC_OBJECT o); extern boolean point_in_periodic_objectp(vector3 p, GEOMETRIC_OBJECT o); extern boolean point_in_fixed_objectp(vector3 p, GEOMETRIC_OBJECT o); extern boolean point_in_fixed_pobjectp(vector3 p, GEOMETRIC_OBJECT *o); extern boolean point_in_periodic_fixed_objectp(vector3 p, GEOMETRIC_OBJECT o); extern vector3 to_geom_object_coords(vector3 p, GEOMETRIC_OBJECT o); extern vector3 from_geom_object_coords(vector3 p, GEOMETRIC_OBJECT o); extern vector3 normal_to_object(vector3 p, GEOMETRIC_OBJECT o); extern vector3 normal_to_fixed_object(vector3 p, GEOMETRIC_OBJECT o); extern int intersect_line_with_object(vector3 p, vector3 d, GEOMETRIC_OBJECT o, double s[2]); extern double intersect_line_segment_with_object(vector3 p, vector3 d, GEOMETRIC_OBJECT o, double a, double b); extern MATERIAL_TYPE material_of_point_inobject(vector3 p, boolean *inobject); extern MATERIAL_TYPE material_of_point_inobject0( GEOMETRIC_OBJECT_LIST geometry, vector3 p, boolean *inobject); extern MATERIAL_TYPE material_of_point(vector3 p); extern MATERIAL_TYPE material_of_point0(GEOMETRIC_OBJECT_LIST geometry, vector3 p); GEOMETRIC_OBJECT object_of_point0(GEOMETRIC_OBJECT_LIST geometry, vector3 p, vector3 *shiftby); GEOMETRIC_OBJECT object_of_point(vector3 p, vector3 *shiftby); vector3 shift_to_unit_cell(vector3 p); extern matrix3x3 square_basis(matrix3x3 lattice_basis, vector3 size); extern void ctl_printf(const char *fmt, ...); extern void (*ctl_printf_callback)(const char *s); typedef struct { vector3 low, high; } geom_box; typedef struct { geom_box box; const GEOMETRIC_OBJECT *o; vector3 shiftby; int precedence; } geom_box_object; typedef struct geom_box_tree_struct { geom_box b, b1, b2; struct geom_box_tree_struct *t1, *t2; int nobjects; geom_box_object *objects; } *geom_box_tree; extern void destroy_geom_box_tree(geom_box_tree t); extern geom_box_tree create_geom_box_tree(void); extern geom_box_tree create_geom_box_tree0(GEOMETRIC_OBJECT_LIST geometry, geom_box b0); extern geom_box_tree restrict_geom_box_tree(geom_box_tree, const geom_box *); extern geom_box_tree geom_tree_search(vector3 p, geom_box_tree t, int *oindex); extern geom_box_tree geom_tree_search_next(vector3 p, geom_box_tree t, int *oindex); extern MATERIAL_TYPE material_of_point_in_tree_inobject(vector3 p, geom_box_tree t, boolean *inobject); extern MATERIAL_TYPE material_of_point_in_tree(vector3 p, geom_box_tree t); extern MATERIAL_TYPE material_of_unshifted_point_in_tree_inobject(vector3 p, geom_box_tree t, boolean *inobject); const GEOMETRIC_OBJECT *object_of_point_in_tree(vector3 p, geom_box_tree t, vector3 *shiftby, int *precedence); extern vector3 to_geom_box_coords(vector3 p, geom_box_object *gbo); extern void display_geom_box_tree(int indentby, geom_box_tree t); extern void geom_box_tree_stats(geom_box_tree t, int *depth, int *nobjects); extern void geom_get_bounding_box(GEOMETRIC_OBJECT o, geom_box *box); extern number box_overlap_with_object(geom_box b, GEOMETRIC_OBJECT o, number tol, integer maxeval); extern number ellipsoid_overlap_with_object(geom_box b, GEOMETRIC_OBJECT o, number tol, integer maxeval); extern number range_overlap_with_object(vector3 low, vector3 high, GEOMETRIC_OBJECT o, number tol, integer maxeval); extern vector3 get_grid_size(void); extern vector3 get_resolution(void); extern void get_grid_size_n(int *nx, int *ny, int *nz); GEOMETRIC_OBJECT make_geometric_object(MATERIAL_TYPE material, vector3 center); GEOMETRIC_OBJECT make_cylinder(MATERIAL_TYPE material, vector3 center, number radius, number height, vector3 axis); GEOMETRIC_OBJECT make_wedge(MATERIAL_TYPE material, vector3 center, number radius, number height, vector3 axis, number wedge_angle, vector3 wedge_start); GEOMETRIC_OBJECT make_cone(MATERIAL_TYPE material, vector3 center, number radius, number height, vector3 axis, number radius2); GEOMETRIC_OBJECT make_sphere(MATERIAL_TYPE material, vector3 center, number radius); GEOMETRIC_OBJECT make_block(MATERIAL_TYPE material, vector3 center, vector3 e1, vector3 e2, vector3 e3, vector3 size); GEOMETRIC_OBJECT make_ellipsoid(MATERIAL_TYPE material, vector3 center, vector3 e1, vector3 e2, vector3 e3, vector3 size); // prism with `center` field computed automatically from vertices, height, axis GEOMETRIC_OBJECT make_prism(MATERIAL_TYPE material, const vector3 *vertices, int num_vertices, double height, vector3 axis); // as make_prism, but with a rigid translation so that the prism is centered at center GEOMETRIC_OBJECT make_prism_with_center(MATERIAL_TYPE material, vector3 center, const vector3 *vertices, int num_vertices, double height, vector3 axis); int vector3_nearly_equal(vector3 v1, vector3 v2, double tolerance); /**************************************************************************/ #ifdef __cplusplus } /* extern "C" */ #endif /* __cplusplus */ #endif /* GEOM_H */ libctl-4.4.0/utils/gen-ctl-io.1000066400000000000000000000054201356267410600161630ustar00rootroot00000000000000.\" libctl: flexible Guile-based control files for scientific software .\" Copyright (C) 1998-2019 Steven G. Johnson .\" .\" This library is free software; you can redistribute it and/or .\" modify it under the terms of the GNU Lesser General Public .\" License as published by the Free Software Foundation; either .\" version 2 of the License, or (at your option) any later version. .\" .\" This library is distributed in the hope that it will be useful, .\" but WITHOUT ANY WARRANTY; without even the implied warranty of .\" MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU .\" Lesser General Public License for more details. .\" .\" You should have received a copy of the GNU Lesser General Public .\" License along with this library; if not, write to the .\" Free Software Foundation, Inc., 59 Temple Place - Suite 330, .\" Boston, MA 02111-1307, USA. .\" .\" Steven G. Johnson can be contacted at stevenj@alum.mit.edu. .\" .TH GEN-CTL-IO 1 "March 27, 2006" "libctl" "libctl" .SH NAME gen-ctl-io \- generate C interface code for libctl control files .SH SYNOPSIS .B gen-ctl-io [OPTION]... [\fIspec-file\fR] .SH DESCRIPTION .PP ." Add any additional description here .B gen-ctl-io generates C code to import/export the input/output variables used in a libctl control file. .B gen-ctl-io generates files like \fIctl-io.h\fP and \fIctl-io.c\fP. These files define global variables, data structures, and functions for the input/output variables, classes, and function interfaces defined in the .I spec-file argument, automating the interaction between C and Guile. The arguments such as .B --code and .B --header are used to control whether \fIctl-io.c\fP or \fIctl-io.h\fP, etcetera, are generated. If no argument is specified then both of these files are generated by default, for backwards compatibility. libctl is a free library to aid in interfacing scientific software with the GNU Guile scripting and extension language. Documentation for it may be found online at the libctl home page: .I http://ab-initio.mit.edu/libctl .SH OPTIONS .TP \fB\--code\fR Generate C (or C++) source code to implement the Guile interface functions. The default output file name is ctl-io.c (in C) or ctl-io.cpp (in C++). .TP \fB\--header\fR Generate the header file declaring the interface data types and functions. The default output file name is ctl-io.h (in C) or ctl-io.hpp (in C++). .TP \fB\--swig\fR Generate a SWIG interface definition file declaring automatic conversions for the various libctl data types. The default output file name is ctl-io.i. .TP \fB\--cxx\fR Generate C++ code instead of C code. .TP \fB\-o\fR \fIfile\fR Use .I file as the output file name instead of the defaults (above). .SH BUGS Send bug reports to S. G. Johnson, stevenj@alum.mit.edu. .SH AUTHORS Written by Steven G. Johnson. libctl-4.4.0/utils/gen-ctl-io.in000077500000000000000000000140711356267410600164360ustar00rootroot00000000000000#!/bin/sh # libctl: flexible Guile-based control files for scientific software # Copyright (C) 1998, 1999, 2000, 2001, 2002, Steven G. Johnson # # This library is free software; you can redistribute it and/or # modify it under the terms of the GNU Lesser General Public # License as published by the Free Software Foundation; either # version 2 of the License, or (at your option) any later version. # # This library is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU # Lesser General Public License for more details. # # You should have received a copy of the GNU Lesser General Public # License along with this library; if not, write to the # Free Software Foundation, Inc., 59 Temple Place - Suite 330, # Boston, MA 02111-1307, USA. # # Steven G. Johnson can be contacted at stevenj@alum.mit.edu. code=false header=false cxx=false swig=false c_only=false output_file="" while test $# -ge 1; do case $1 in -o) shift; output_file=$1 ;; --cxx) cxx=true ;; --code) code=true; header=false; swig=false ;; --header) header=true; code=false; swig=false ;; --swig) swig=true; header=false; code=false ;; --c-only) c_only=true ;; *) break;; esac shift done if test $code = true; then if test $cxx = true; then default_output_file=ctl-io.cpp else default_output_file=ctl-io.c fi elif test $header = true; then if test $cxx = true; then default_output_file=ctl-io.hpp else default_output_file=ctl-io.h fi elif test $swig = true; then default_output_file=ctl-io.i else # No output specified. Backwards compatibility mode (code + header output). $0 --header $* $0 --code $* exit 0 fi if test "x$output_file" = x; then output_file=$default_output_file fi spec_file=$1 if test ! -f "$spec_file"; then echo "cannot read specification file $spec_file" exit 1 fi if test "$#" = "2"; then libctl_dir="$2" else prefix="@prefix@" datarootdir="@datarootdir@" libctl_dir="@datadir@/libctl" fi case $libctl_dir in .*) libctl_dir=`pwd`/$libctl_dir ;; esac if test ! -r $libctl_dir/utils/ctl-io.scm; then echo "couldn't find $libctl_dir/utils/ctl-io.scm" exit 1 fi ok=yes ########################################################################### if test $header = true; then rm -f $output_file cat > $output_file < EOF if test $cxx = true; then cat >> $output_file <> $output_file <> $output_file (@GUILE@ -l $libctl_dir/base/include.scm \ -c "(include "'"'"$libctl_dir/base/ctl.scm"'"'") (include "'"'"$libctl_dir/utils/ctl-io.scm"'"'") (set"'!'" cxx $cxx) (include "'"'"$spec_file"'"'") (set! ctl-io-c-only? $c_only) (output-header)" >> $output_file) || ok=no if test $ok = no; then rm -f $output_file; exit 1; fi echo >> $output_file if test $cxx = true; then cat >> $output_file <> $output_file <> $output_file < /dev/null 2>&1 rm -f ${output_file}~ ${output_file}.BAK fi fi # header = true ########################################################################### if test $code = true; then rm -f $output_file cat > $output_file < #include #include #include "ctl-io.h" #ifdef CXX_CTL_IO using namespace ctlio; #endif EOF (@GUILE@ -l $libctl_dir/base/include.scm \ -c "(include "'"'"$libctl_dir/base/ctl.scm"'"'") (include "'"'"$libctl_dir/utils/ctl-io.scm"'"'") (set"'!'" cxx $cxx) (include "'"'"$spec_file"'"'") (set! ctl-io-c-only? $c_only) (output-source)" >> $output_file) || ok=no if test $ok = no; then rm -f $output_file; exit 1; fi if test $cxx = false; then @INDENT@ $output_file > /dev/null 2>&1 rm -f ${output_file}~ ${output_file}.BAK fi fi # code = true ########################################################################### if test $swig = true; then cat > $output_file <> $output_file) || ok=no if test $ok = no; then rm -f $output_file; exit 1; fi cat >> $output_file < #include #include #include #include #ifndef LIBCTLGEOM # include "ctl-io.h" #else # define material_type void* static void material_type_copy(void **src, void **dest) { *dest = *src; } #endif #include "ctlgeom.h" #ifdef CXX_CTL_IO using namespace ctlio; # define CTLIO ctlio:: # define GEOM geometric_object:: # define BLK block:: # define CYL cylinder:: # define MAT material_type:: #else # define CTLIO # define GEOM # define BLK # define CYL # define MAT #endif #ifdef __cplusplus # define MALLOC(type,num) (new type[num]) # define MALLOC1(type) (new type) # define FREE(p) delete[] (p) # define FREE1(p) delete (p) #else # define MALLOC(type,num) ((type *) malloc(sizeof(type) * (num))) # define MALLOC1(type) MALLOC(type,1) # define FREE(p) free(p) # define FREE1(p) free(p) #endif #define K_PI 3.14159265358979323846 #define CHECK(cond, s) if (!(cond)){fprintf(stderr,s "\n");exit(EXIT_FAILURE);} #define MAX(a,b) ((a) > (b) ? (a) : (b)) #define MIN(a,b) ((a) < (b) ? (a) : (b)) // forward declarations of prism-related routines, at the bottom of this file static boolean node_in_polygon(double qx, double qy, vector3 *nodes, int num_nodes); static boolean point_in_prism(prism *prsm, vector3 pc); static vector3 normal_to_prism(prism *prsm, vector3 pc); static double intersect_line_segment_with_prism(prism *prsm, vector3 pc, vector3 dc, double a, double b); static void get_prism_bounding_box(prism *prsm, geom_box *box); static void display_prism_info(int indentby, geometric_object *o); static void init_prism(geometric_object *o); /**************************************************************************/ /* Allows writing to Python's stdout when running from Meep's Python interface */ void (*ctl_printf_callback)(const char *s) = NULL; void ctl_printf(const char *fmt, ...) { va_list ap; va_start(ap, fmt); if (ctl_printf_callback) { char *s; CHECK(vasprintf(&s, fmt, ap) >= 0, "vasprintf failed"); ctl_printf_callback(s); free(s); } else { vprintf(fmt, ap); fflush(stdout); } va_end(ap); } /* If v is a vector in the lattice basis, normalize v so that its cartesian length is unity. */ static void lattice_normalize(vector3 *v) { *v = vector3_scale( 1.0 / sqrt(vector3_dot(*v, matrix3x3_vector3_mult(geometry_lattice.metric, *v))), *v); } static vector3 lattice_to_cartesian(vector3 v) { return matrix3x3_vector3_mult(geometry_lattice.basis, v); } static vector3 cartesian_to_lattice(vector3 v) { return matrix3x3_vector3_mult(matrix3x3_inverse(geometry_lattice.basis), v); } /* geom_fix_object_ptr is called after an object's externally-configurable parameters have been initialized, but before any actual geometry calculations are done; it is an opportunity to (re)compute internal data fields (such as cached rotation matrices) that depend on externally-configurable parameters. One example: "Fix" the parameters of the given object to account for the geometry_lattice basis, which may be non-orthogonal. In particular, this means that the normalization of several unit vectors, such as the cylinder or block axes, needs to be changed. Unfortunately, we can't do this stuff at object-creation time in Guile, because the geometry_lattice variable may not have been assigned to its final value at that point. */ void geom_fix_object_ptr(geometric_object *o) { switch(o->which_subclass) { case GEOM CYLINDER: lattice_normalize(&o->subclass.cylinder_data->axis); if (o->subclass.cylinder_data->which_subclass == CYL WEDGE) { vector3 a = o->subclass.cylinder_data->axis; vector3 s = o->subclass.cylinder_data->subclass.wedge_data->wedge_start; double p = vector3_dot(s, matrix3x3_vector3_mult(geometry_lattice.metric, a)); o->subclass.cylinder_data->subclass.wedge_data->e1 = vector3_minus(s, vector3_scale(p, a)); lattice_normalize(&o->subclass.cylinder_data->subclass.wedge_data->e1); o->subclass.cylinder_data->subclass.wedge_data->e2 = cartesian_to_lattice( vector3_cross(lattice_to_cartesian(o->subclass.cylinder_data->axis), lattice_to_cartesian(o->subclass.cylinder_data->subclass.wedge_data->e1))); } break; case GEOM BLOCK: { matrix3x3 m; lattice_normalize(&o->subclass.block_data->e1); lattice_normalize(&o->subclass.block_data->e2); lattice_normalize(&o->subclass.block_data->e3); m.c0 = o->subclass.block_data->e1; m.c1 = o->subclass.block_data->e2; m.c2 = o->subclass.block_data->e3; o->subclass.block_data->projection_matrix = matrix3x3_inverse(m); break; } case GEOM PRISM: { init_prism(o); break; } case GEOM COMPOUND_GEOMETRIC_OBJECT: { int i; int n = o->subclass.compound_geometric_object_data->component_objects.num_items; geometric_object *os = o->subclass.compound_geometric_object_data->component_objects.items; for (i = 0; i < n; ++i) { #if MATERIAL_TYPE_ABSTRACT if (os[i].material.which_subclass == MAT MATERIAL_TYPE_SELF) material_type_copy(&o->material, &os[i].material); #endif geom_fix_object_ptr(os + i); } break; } case GEOM GEOMETRIC_OBJECT_SELF: case GEOM SPHERE: break; /* these objects are fine */ } } // deprecated API — doesn't work for prisms void geom_fix_object(geometric_object o) { geom_fix_object_ptr(&o); } /* fix all objects in the geometry list as described in geom_fix_object, above */ void geom_fix_object_list(geometric_object_list geometry) { int index; for (index = 0; index < geometry.num_items; ++index) geom_fix_object_ptr(geometry.items + index); } void geom_fix_objects0(geometric_object_list geometry) { geom_fix_object_list(geometry); } void geom_fix_objects(void) { geom_fix_object_list(geometry); } void geom_fix_lattice0(lattice *L) { L->basis1 = unit_vector3(L->basis1); L->basis2 = unit_vector3(L->basis2); L->basis3 = unit_vector3(L->basis3); L->b1 = vector3_scale(L->basis_size.x, L->basis1); L->b2 = vector3_scale(L->basis_size.y, L->basis2); L->b3 = vector3_scale(L->basis_size.z, L->basis3); L->basis.c0 = L->b1; L->basis.c1 = L->b2; L->basis.c2 = L->b3; L->metric = matrix3x3_mult(matrix3x3_transpose(L->basis), L->basis); } void geom_fix_lattice(void) { geom_fix_lattice0(&geometry_lattice); } void geom_cartesian_lattice0(lattice *L) { L->basis1.x = 1; L->basis1.y = 0; L->basis1.z = 0; L->basis2.x = 0; L->basis2.y = 1; L->basis2.z = 0; L->basis3.x = 0; L->basis3.y = 0; L->basis3.z = 1; L->basis_size.x = L->basis_size.y = L->basis_size.z = 1; geom_fix_lattice0(L); } void geom_cartesian_lattice(void) { geom_cartesian_lattice0(&geometry_lattice); } void geom_initialize(void) { /* initialize many of the input variables that are normally initialized from Scheme, except for default_material and geometry_lattice.size. */ geom_cartesian_lattice(); geometry_center.x = geometry_center.y = geometry_center.z = 0; dimensions = 3; ensure_periodicity = 1; geometry.num_items = 0; geometry.items = 0; } /**************************************************************************/ /* Return whether or not the point p (in the lattice basis) is inside the object o. Requires that the global input var geometry_lattice already be initialized. point_in_fixed_objectp additionally requires that geom_fix_object has been called on o (if the lattice basis is non-orthogonal). */ boolean CTLIO point_in_objectp(vector3 p, geometric_object o) { geom_fix_object_ptr(&o); return point_in_fixed_objectp(p, o); } boolean point_in_fixed_objectp(vector3 p, geometric_object o) { return point_in_fixed_pobjectp(p, &o); } /* as point_in_fixed_objectp, but sets o to the object in question (if true) (which may be different from the input o if o is a compound object) */ boolean point_in_fixed_pobjectp(vector3 p, geometric_object *o) { vector3 r = vector3_minus(p,o->center); switch (o->which_subclass) { case GEOM GEOMETRIC_OBJECT_SELF: return 0; case GEOM SPHERE: { number radius = o->subclass.sphere_data->radius; return(radius > 0.0 && vector3_dot(r,matrix3x3_vector3_mult(geometry_lattice.metric, r)) <= radius*radius); } case GEOM CYLINDER: { vector3 rm = matrix3x3_vector3_mult(geometry_lattice.metric, r); number proj = vector3_dot(o->subclass.cylinder_data->axis, rm); number height = o->subclass.cylinder_data->height; if (fabs(proj) <= 0.5 * height) { number radius = o->subclass.cylinder_data->radius; if (o->subclass.cylinder_data->which_subclass == CYL CONE) radius += (proj/height + 0.5) * (o->subclass.cylinder_data->subclass.cone_data->radius2 - radius); else if (o->subclass.cylinder_data->which_subclass == CYL WEDGE) { number x = vector3_dot(rm, o->subclass.cylinder_data->subclass.wedge_data->e1); number y = vector3_dot(rm, o->subclass.cylinder_data->subclass.wedge_data->e2); number theta = atan2(y, x); number wedge_angle = o->subclass.cylinder_data->subclass.wedge_data->wedge_angle; if (wedge_angle > 0) { if (theta < 0) theta = theta + 2 * K_PI; if (theta > wedge_angle) return 0; } else { if (theta > 0) theta = theta - 2 * K_PI; if (theta < wedge_angle) return 0; } } return(radius != 0.0 && vector3_dot(r,rm) - proj*proj <= radius*radius); } else return 0; } case GEOM BLOCK: { vector3 proj = matrix3x3_vector3_mult(o->subclass.block_data->projection_matrix, r); switch (o->subclass.block_data->which_subclass) { case BLK BLOCK_SELF: { vector3 size = o->subclass.block_data->size; return(fabs(proj.x) <= 0.5 * size.x && fabs(proj.y) <= 0.5 * size.y && fabs(proj.z) <= 0.5 * size.z); } case BLK ELLIPSOID: { vector3 isa = o->subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; double a = proj.x * isa.x, b = proj.y * isa.y, c = proj.z * isa.z; return(a*a + b*b + c*c <= 1.0); } } break; // never get here but silence compiler warning } case GEOM PRISM: { return point_in_prism(o->subclass.prism_data, p); } case GEOM COMPOUND_GEOMETRIC_OBJECT: { int i; int n = o->subclass.compound_geometric_object_data ->component_objects.num_items; geometric_object *os = o->subclass.compound_geometric_object_data ->component_objects.items; vector3 shiftby = o->center; for (i = 0; i < n; ++i) { *o = os[i]; o->center = vector3_plus(o->center, shiftby); if (point_in_fixed_pobjectp(p, o)) return 1; } break; } } return 0; } /**************************************************************************/ /* convert a point p inside o to a coordinate in [0,1]^3 that is some "natural" coordinate for the object */ vector3 to_geom_object_coords(vector3 p, geometric_object o) { const vector3 half = {0.5, 0.5, 0.5}; vector3 r = vector3_minus(p,o.center); switch (o.which_subclass) { default: { vector3 po = {0,0,0}; return po; } case GEOM SPHERE: { number radius = o.subclass.sphere_data->radius; return vector3_plus(half, vector3_scale(0.5 / radius, r)); } /* case GEOM CYLINDER: NOT YET IMPLEMENTED */ case GEOM BLOCK: { vector3 proj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, r); vector3 size = o.subclass.block_data->size; if (size.x != 0.0) proj.x /= size.x; if (size.y != 0.0) proj.y /= size.y; if (size.z != 0.0) proj.z /= size.z; return vector3_plus(half, proj); } /* case GEOM PRISM: NOT YET IMPLEMENTED */ } } /* inverse of to_geom_object_coords */ vector3 from_geom_object_coords(vector3 p, geometric_object o) { const vector3 half = {0.5, 0.5, 0.5}; p = vector3_minus(p, half); switch (o.which_subclass) { default: return o.center; case GEOM SPHERE: { number radius = o.subclass.sphere_data->radius; return vector3_plus(o.center, vector3_scale(radius / 0.5, p)); } /* case GEOM CYLINDER: NOT YET IMPLEMENTED */ case GEOM BLOCK: { vector3 size = o.subclass.block_data->size; return vector3_plus( o.center, vector3_plus( vector3_scale(size.x * p.x, o.subclass.block_data->e1), vector3_plus( vector3_scale(size.y * p.y, o.subclass.block_data->e2), vector3_scale(size.z * p.z, o.subclass.block_data->e3)) )); } /* case GEOM PRISM: NOT YET IMPLEMENTED */ } } /**************************************************************************/ /* Return the normal vector from the given object to the given point, in lattice coordinates, using the surface of the object that the point is "closest" to for some definition of "closest" that is reasonable (at least for points near to the object). The length and sign of the normal vector are arbitrary. */ vector3 CTLIO normal_to_object(vector3 p, geometric_object o) { geom_fix_object_ptr(&o); return normal_to_fixed_object(p, o); } vector3 normal_to_fixed_object(vector3 p, geometric_object o) { vector3 r = vector3_minus(p,o.center); switch (o.which_subclass) { case GEOM CYLINDER: { vector3 rm = matrix3x3_vector3_mult(geometry_lattice.metric, r); double proj = vector3_dot(o.subclass.cylinder_data->axis, rm), height = o.subclass.cylinder_data->height, radius, prad; if (fabs(proj) > height * 0.5) return o.subclass.cylinder_data->axis; radius = o.subclass.cylinder_data->radius; prad = sqrt(fabs(vector3_dot(r,rm) - proj*proj)); if (o.subclass.cylinder_data->which_subclass == CYL CONE) radius += (proj/height + 0.5) * (o.subclass.cylinder_data->subclass.cone_data->radius2 - radius); if (fabs(fabs(proj) - height * 0.5) < fabs(prad - radius)) return o.subclass.cylinder_data->axis; if (o.subclass.cylinder_data->which_subclass == CYL CONE) return vector3_minus(r, vector3_scale(proj + prad * (o.subclass.cylinder_data->subclass.cone_data->radius2 - radius) / height, o.subclass.cylinder_data->axis)); else return vector3_minus(r, vector3_scale(proj, o.subclass.cylinder_data->axis)); } // case GEOM CYLINDER case GEOM BLOCK: { vector3 proj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, r); switch (o.subclass.block_data->which_subclass) { case BLK BLOCK_SELF: { vector3 size = o.subclass.block_data->size; double d1 = fabs(fabs(proj.x) - 0.5 * size.x); double d2 = fabs(fabs(proj.y) - 0.5 * size.y); double d3 = fabs(fabs(proj.z) - 0.5 * size.z); if (d1 < d2 && d1 < d3) return matrix3x3_row1(o.subclass.block_data->projection_matrix); else if (d2 < d3) return matrix3x3_row2(o.subclass.block_data->projection_matrix); else return matrix3x3_row3(o.subclass.block_data->projection_matrix); } // case BLK BLOCK_SELF case BLK ELLIPSOID: default: { vector3 isa = o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; proj.x *= isa.x * isa.x; proj.y *= isa.y * isa.y; proj.z *= isa.z * isa.z; return matrix3x3_transpose_vector3_mult( o.subclass.block_data->projection_matrix, proj); } // case BLK ELLIPSOID } // switch (o.subclass.block_data->which_subclass) } // case GEOM BLOCK case GEOM PRISM: return normal_to_prism(o.subclass.prism_data, p); default: return r; } // switch (o.which_subclass) return r; // never get here } /**************************************************************************/ /* Here is a useful macro to loop over different possible shifts of the lattice vectors. body is executed for each possible shift, where the shift is given by the value of shiftby (which should be a vector3 variable). I would much rather make this a function, but C's lack of lambda-like function construction or closures makes this easier to do as a macro. (One could at least wish for an easier way to make multi-line macros.) */ #define LOOP_PERIODIC(shiftby, body) { \ switch (dimensions) { \ case 1: \ { \ int iii; \ shiftby.y = shiftby.z = 0; \ for (iii = -1; iii <= 1; ++iii) { \ shiftby.x = iii * geometry_lattice.size.x; \ body; \ } \ break; \ } \ case 2: \ { \ int iii, jjj; \ shiftby.z = 0; \ for (iii = -1; iii <= 1; ++iii) { \ shiftby.x = iii * geometry_lattice.size.x; \ for (jjj = -1; jjj <= 1; ++jjj) { \ shiftby.y = jjj * geometry_lattice.size.y; \ body; \ } \ } \ break; \ } \ case 3: \ { \ int iii, jjj, kkk; \ for (iii = -1; iii <= 1; ++iii) { \ shiftby.x = iii * geometry_lattice.size.x; \ for (jjj = -1; jjj <= 1; ++jjj) { \ shiftby.y = jjj * geometry_lattice.size.y; \ for (kkk = -1; kkk <= 1; ++kkk) { \ shiftby.z = kkk * geometry_lattice.size.z; \ body; \ if (geometry_lattice.size.z == 0) break; \ } \ if (geometry_lattice.size.y == 0) break; \ } \ if (geometry_lattice.size.x == 0) break; \ } \ break; \ } \ } \ } /**************************************************************************/ /* Like point_in_objectp, but also checks the object shifted by the lattice vectors: */ boolean CTLIO point_in_periodic_objectp(vector3 p, geometric_object o) { geom_fix_object_ptr(&o); return point_in_periodic_fixed_objectp(p, o); } boolean point_in_periodic_fixed_objectp(vector3 p, geometric_object o) { vector3 shiftby; LOOP_PERIODIC(shiftby, if (point_in_fixed_objectp(vector3_minus(p, shiftby), o)) return 1); return 0; } boolean point_shift_in_periodic_fixed_pobjectp(vector3 p, geometric_object *o, vector3 *shiftby) { geometric_object o0 = *o; LOOP_PERIODIC((*shiftby), { *o = o0; if (point_in_fixed_pobjectp( vector3_minus(p, *shiftby), o)) return 1; }); return 0; } /**************************************************************************/ /* Functions to return the object or material type corresponding to the point p (in the lattice basis). Returns default_material if p is not in any object. Requires that the global input vars geometry_lattice, geometry, dimensions, default_material and ensure_periodicity already be initialized. Also requires that geom_fix_objects() has been called! material_of_point_inobject is a variant that also returns whether or not the point was in any object. */ geometric_object object_of_point0(geometric_object_list geometry, vector3 p, vector3 *shiftby) { geometric_object o; int index; shiftby->x = shiftby->y = shiftby->z = 0; /* loop in reverse order so that later items are given precedence: */ for (index = geometry.num_items - 1; index >= 0; --index) { o = geometry.items[index]; if ((ensure_periodicity && point_shift_in_periodic_fixed_pobjectp(p, &o, shiftby)) || point_in_fixed_pobjectp(p, &o)) return o; } o.which_subclass = GEOM GEOMETRIC_OBJECT_SELF; /* no object found */ return o; } geometric_object object_of_point(vector3 p, vector3 *shiftby) { return object_of_point0(geometry, p, shiftby); } material_type material_of_point_inobject0(geometric_object_list geometry, vector3 p, boolean *inobject) { vector3 shiftby; geometric_object o = object_of_point0(geometry, p, &shiftby); *inobject = o.which_subclass != GEOM GEOMETRIC_OBJECT_SELF;; return (*inobject ? o.material : default_material); } material_type material_of_point_inobject(vector3 p, boolean *inobject) { return material_of_point_inobject0(geometry, p, inobject); } material_type material_of_point0(geometric_object_list geometry, vector3 p) { boolean inobject; return material_of_point_inobject0(geometry, p, &inobject); } material_type material_of_point(vector3 p) { return material_of_point0(geometry, p); } /**************************************************************************/ /* Given a geometric object o, display some information about it, indented by indentby spaces. */ void CTLIO display_geometric_object_info(int indentby, geometric_object o) { geom_fix_object_ptr(&o); ctl_printf("%*s", indentby, ""); switch (o.which_subclass) { case GEOM CYLINDER: switch (o.subclass.cylinder_data->which_subclass) { case CYL WEDGE: ctl_printf("wedge"); break; case CYL CONE: ctl_printf("cone"); break; case CYL CYLINDER_SELF: ctl_printf("cylinder"); break; } break; case GEOM SPHERE: ctl_printf("sphere"); break; case GEOM BLOCK: switch (o.subclass.block_data->which_subclass) { case BLK ELLIPSOID: ctl_printf("ellipsoid"); break; case BLK BLOCK_SELF: ctl_printf("block"); break; } break; case GEOM PRISM: ctl_printf("prism"); break; case GEOM COMPOUND_GEOMETRIC_OBJECT: ctl_printf("compound object"); break; default: ctl_printf("geometric object"); break; } ctl_printf(", center = (%g,%g,%g)\n", o.center.x, o.center.y, o.center.z); switch (o.which_subclass) { case GEOM CYLINDER: ctl_printf("%*s radius %g, height %g, axis (%g, %g, %g)\n", indentby, "", o.subclass.cylinder_data->radius, o.subclass.cylinder_data->height, o.subclass.cylinder_data->axis.x, o.subclass.cylinder_data->axis.y, o.subclass.cylinder_data->axis.z); if (o.subclass.cylinder_data->which_subclass == CYL CONE) ctl_printf("%*s radius2 %g\n", indentby, "", o.subclass.cylinder_data->subclass.cone_data->radius2); else if (o.subclass.cylinder_data->which_subclass == CYL WEDGE) ctl_printf("%*s wedge-theta %g\n", indentby, "", o.subclass.cylinder_data->subclass.wedge_data->wedge_angle); break; case GEOM SPHERE: ctl_printf("%*s radius %g\n", indentby, "", o.subclass.sphere_data->radius); break; case GEOM BLOCK: ctl_printf("%*s size (%g,%g,%g)\n", indentby, "", o.subclass.block_data->size.x, o.subclass.block_data->size.y, o.subclass.block_data->size.z); ctl_printf("%*s axes (%g,%g,%g), (%g,%g,%g), (%g,%g,%g)\n", indentby, "", o.subclass.block_data->e1.x, o.subclass.block_data->e1.y, o.subclass.block_data->e1.z, o.subclass.block_data->e2.x, o.subclass.block_data->e2.y, o.subclass.block_data->e2.z, o.subclass.block_data->e3.x, o.subclass.block_data->e3.y, o.subclass.block_data->e3.z); break; case GEOM PRISM: display_prism_info(indentby, &o); break; case GEOM COMPOUND_GEOMETRIC_OBJECT: { int i; int n = o.subclass.compound_geometric_object_data ->component_objects.num_items; geometric_object *os = o.subclass.compound_geometric_object_data ->component_objects.items; ctl_printf("%*s %d components:\n", indentby, "", n); for (i = 0; i < n; ++i) display_geometric_object_info(indentby + 5, os[i]); break; } default: break; } } /**************************************************************************/ /* Compute the intersections with o of a line along p+s*d, returning the number of intersections (at most 2) and the two intersection "s" values in s[0] and s[1]. (Note: o must not be a compound object.) */ int intersect_line_with_object(vector3 p, vector3 d, geometric_object o, double s[2]) { p = vector3_minus(p, o.center); s[0] = s[1] = 0; switch (o.which_subclass) { case GEOM SPHERE: { number radius = o.subclass.sphere_data->radius; vector3 dm = matrix3x3_vector3_mult(geometry_lattice.metric, d); double a = vector3_dot(d, dm); double b2 = -vector3_dot(dm, p); double c = vector3_dot(p, matrix3x3_vector3_mult( geometry_lattice.metric, p)) - radius * radius; double discrim = b2*b2 - a*c; if (discrim < 0) return 0; else if (discrim == 0) { s[0] = b2 / a; return 1; } else { discrim = sqrt(discrim); s[0] = (b2 + discrim) / a; s[1] = (b2 - discrim) / a; return 2; } } // case GEOM SPHERE case GEOM CYLINDER: { vector3 dm = matrix3x3_vector3_mult(geometry_lattice.metric, d); vector3 pm = matrix3x3_vector3_mult(geometry_lattice.metric, p); number height = o.subclass.cylinder_data->height; number radius = o.subclass.cylinder_data->radius; number radius2 = o.subclass.cylinder_data->which_subclass == CYL CONE ? o.subclass.cylinder_data->subclass.cone_data->radius2 : radius; double dproj = vector3_dot(o.subclass.cylinder_data->axis, dm); double pproj = vector3_dot(o.subclass.cylinder_data->axis, pm); double D = (radius2 - radius) / height; double L = radius + (radius2 - radius) * 0.5 + pproj*D; double a = vector3_dot(d,dm) - dproj*dproj * (1 + D*D); double b2 = dproj * (pproj + D*L) - vector3_dot(p,dm); double c = vector3_dot(p,pm) - pproj*pproj - L*L; double discrim = b2*b2 - a*c; int ret; if (a == 0) { /* linear equation */ if (b2 == 0) { if (c == 0) { /* infinite intersections */ s[0] = ((height * 0.5) - pproj) / dproj; s[1] = -((height * 0.5) + pproj) / dproj; return 2; } else ret = 0; } else { s[0] = 0.5 * c / b2; ret = 1; } } else if (discrim < 0) ret = 0; else if (discrim == 0) { s[0] = b2 / a; ret = 1; } else { discrim = sqrt(discrim); s[0] = (b2 + discrim) / a; s[1] = (b2 - discrim) / a; ret = 2; } if (ret == 2 && fabs(pproj + s[1] * dproj) > height * 0.5) ret = 1; if (ret >= 1 && fabs(pproj + s[0] * dproj) > height * 0.5) { --ret; s[0] = s[1]; } if (ret == 2 || dproj == 0) return ret; /* find intersections with endcaps */ s[ret] = (height * 0.5 - pproj) / dproj; if (a * s[ret]*s[ret] - 2*b2 * s[ret] + c <= 0) ++ret; if (ret < 2) { s[ret] = -(height * 0.5 + pproj) / dproj; if (a * s[ret]*s[ret] - 2*b2 * s[ret] + c <= 0) ++ret; } if (ret == 2 && s[0] == s[1]) ret = 1; return ret; } // case GEOM CYLINDER case GEOM BLOCK: { vector3 dproj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, d); vector3 pproj = matrix3x3_vector3_mult(o.subclass.block_data->projection_matrix, p); switch (o.subclass.block_data->which_subclass) { case BLK BLOCK_SELF: { vector3 size = o.subclass.block_data->size; int ret = 0; size.x *= 0.5; size.y *= 0.5; size.z *= 0.5; if (dproj.x != 0) { s[ret] = (size.x - pproj.x) / dproj.x; if (fabs(pproj.y+s[ret]*dproj.y) <= size.y && fabs(pproj.z+s[ret]*dproj.z) <= size.z) ++ret; s[ret] = (-size.x - pproj.x) / dproj.x; if (fabs(pproj.y+s[ret]*dproj.y) <= size.y && fabs(pproj.z+s[ret]*dproj.z) <= size.z) ++ret; if (ret == 2) return 2; } if (dproj.y != 0) { s[ret] = (size.y - pproj.y) / dproj.y; if (fabs(pproj.x+s[ret]*dproj.x) <= size.x && fabs(pproj.z+s[ret]*dproj.z) <= size.z) ++ret; if (ret == 2) return 2; s[ret] = (-size.y - pproj.y) / dproj.y; if (fabs(pproj.x+s[ret]*dproj.x) <= size.x && fabs(pproj.z+s[ret]*dproj.z) <= size.z) ++ret; if (ret == 2) return 2; } if (dproj.z != 0) { s[ret] = (size.z - pproj.z) / dproj.z; if (fabs(pproj.x+s[ret]*dproj.x) <= size.x && fabs(pproj.y+s[ret]*dproj.y) <= size.y) ++ret; if (ret == 2) return 2; s[ret] = (-size.z - pproj.z) / dproj.z; if (fabs(pproj.x+s[ret]*dproj.x) <= size.x && fabs(pproj.y+s[ret]*dproj.y) <= size.y) ++ret; } return ret; } // case BLK BLOCK_SELF: case BLK ELLIPSOID: default: { vector3 isa = o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes; double a, b2, c, discrim; dproj.x *= isa.x; dproj.y *= isa.y; dproj.z *= isa.z; pproj.x *= isa.x; pproj.y *= isa.y; pproj.z *= isa.z; a = vector3_dot(dproj, dproj); b2 = -vector3_dot(dproj, pproj); c = vector3_dot(pproj, pproj) - 1; discrim = b2*b2 - a*c; if (discrim < 0) return 0; else if (discrim == 0) { s[0] = b2 / a; return 1; } else { discrim = sqrt(discrim); s[0] = (b2 + discrim) / a; s[1] = (b2 - discrim) / a; return 2; } } // case BLK BLOCK_SELF, default } // switch (o.subclass.block_data->which_subclass) } // case GEOM BLOCK default: return 0; } } /* Compute the intersections with o of a line along p+s*d in the interval s in [a,b], returning the length of the s intersection in this interval. (Note: o must not be a compound object.) */ double intersect_line_segment_with_object(vector3 p, vector3 d, geometric_object o, double a, double b) { if (o.which_subclass==GEOM PRISM) { return intersect_line_segment_with_prism(o.subclass.prism_data, p, d, a, b); } else { double s[2]; if (2 == intersect_line_with_object(p, d, o, s)) { double ds = (s[0] < s[1] ? MIN(s[1],b) - MAX(s[0],a) : MIN(s[0],b) - MAX(s[1],a) ); return (ds > 0 ? ds : 0.0); } else return 0.0; } } /**************************************************************************/ /* Given a basis (matrix columns are the basis unit vectors) and the size of the lattice (in basis vectors), returns a new "square" basis. This corresponds to a region of the same volume, but made rectangular, suitable for outputing to an HDF file. Given a vector in the range (0..1, 0..1, 0..1), multiplying by the square basis matrix will yield the coordinates of a point in the rectangular volume, given in the lattice basis. */ matrix3x3 CTLIO square_basis(matrix3x3 basis, vector3 size) { matrix3x3 square; square.c0 = basis.c0; square.c1 = vector3_minus(basis.c1, vector3_scale(vector3_dot(basis.c0, basis.c1), basis.c1)); square.c2 = vector3_minus(basis.c2, vector3_scale(vector3_dot(basis.c0, basis.c2), basis.c2)); square.c2 = vector3_minus(square.c2, vector3_scale(vector3_dot(basis.c0, square.c2), unit_vector3(square.c2))); square.c0 = vector3_scale(size.x, square.c0); square.c1 = vector3_scale(size.y, square.c1); square.c2 = vector3_scale(size.z, square.c2); return matrix3x3_mult(matrix3x3_inverse(basis), square); } /**************************************************************************/ /* compute the 3d volume enclosed by a geometric object o. */ double geom_object_volume(GEOMETRIC_OBJECT o) { switch (o.which_subclass) { case GEOM SPHERE: { number radius = o.subclass.sphere_data->radius; return (1.333333333333333333 * K_PI) * radius*radius*radius; } case GEOM CYLINDER: { number height = o.subclass.cylinder_data->height; number radius = o.subclass.cylinder_data->radius; number radius2 = o.subclass.cylinder_data->which_subclass == CYL CONE ? o.subclass.cylinder_data->subclass.cone_data->radius2 : radius; double vol = height * (K_PI/3) * (radius*radius + radius*radius2 + radius2*radius2); if (o.subclass.cylinder_data->which_subclass == CYL WEDGE) return vol * fabs(o.subclass.cylinder_data->subclass.wedge_data->wedge_angle) / (2*K_PI); else return vol; } case GEOM BLOCK: { vector3 size = o.subclass.block_data->size; double vol = size.x * size.y * size.z * fabs(matrix3x3_determinant(geometry_lattice.basis) / matrix3x3_determinant(o.subclass.block_data->projection_matrix)); return o.subclass.block_data->which_subclass == BLK BLOCK_SELF ? vol : vol * (K_PI/6); } case GEOM PRISM: { vector3_list vertices = o.subclass.prism_data->vertices_p; double area = 0; int i; for (i = 0; i < vertices.num_items; ++i) { int i1 = (i + 1) % vertices.num_items; area += 0.5 * (vertices.items[i1].x - vertices.items[i].x) * (vertices.items[i1].y + vertices.items[i].y); } return fabs(area) * o.subclass.prism_data->height; } default: return 0; /* unsupported object types? */ } } /**************************************************************************/ /**************************************************************************/ /* Fast geometry routines */ /* Using the above material_of_point routine is way too slow, especially when there are lots of objects to test. Thus, we develop the following replacement routines. The basic idea here is twofold. (1) Compute bounding boxes for each geometric object, for which inclusion tests can be computed quickly. (2) Build a tree that recursively breaks down the unit cell in half, allowing us to perform searches in logarithmic time. */ /**************************************************************************/ /* geom_box utilities: */ static void geom_box_union(geom_box *bu, const geom_box *b1, const geom_box *b2) { bu->low.x = MIN(b1->low.x, b2->low.x); bu->low.y = MIN(b1->low.y, b2->low.y); bu->low.z = MIN(b1->low.z, b2->low.z); bu->high.x = MAX(b1->high.x, b2->high.x); bu->high.y = MAX(b1->high.y, b2->high.y); bu->high.z = MAX(b1->high.z, b2->high.z); } static void geom_box_intersection(geom_box *bi, const geom_box *b1, const geom_box *b2) { bi->low.x = MAX(b1->low.x, b2->low.x); bi->low.y = MAX(b1->low.y, b2->low.y); bi->low.z = MAX(b1->low.z, b2->low.z); bi->high.x = MIN(b1->high.x, b2->high.x); bi->high.y = MIN(b1->high.y, b2->high.y); bi->high.z = MIN(b1->high.z, b2->high.z); } static void geom_box_add_pt(geom_box *b, vector3 p) { b->low.x = MIN(b->low.x, p.x); b->low.y = MIN(b->low.y, p.y); b->low.z = MIN(b->low.z, p.z); b->high.x = MAX(b->high.x, p.x); b->high.y = MAX(b->high.y, p.y); b->high.z = MAX(b->high.z, p.z); } #define BETWEEN(x, low, high) ((x) >= (low) && (x) <= (high)) static int geom_box_contains_point(const geom_box *b, vector3 p) { return (BETWEEN(p.x, b->low.x, b->high.x) && BETWEEN(p.y, b->low.y, b->high.y) && BETWEEN(p.z, b->low.z, b->high.z)); } /* return whether or not the given two boxes intersect */ static int geom_boxes_intersect(const geom_box *b1, const geom_box *b2) { /* true if the x, y, and z ranges all intersect. */ return ((BETWEEN(b1->low.x, b2->low.x, b2->high.x) || BETWEEN(b1->high.x, b2->low.x, b2->high.x) || BETWEEN(b2->low.x, b1->low.x, b1->high.x)) && (BETWEEN(b1->low.y, b2->low.y, b2->high.y) || BETWEEN(b1->high.y, b2->low.y, b2->high.y) || BETWEEN(b2->low.y, b1->low.y, b1->high.y)) && (BETWEEN(b1->low.z, b2->low.z, b2->high.z) || BETWEEN(b1->high.z, b2->low.z, b2->high.z) || BETWEEN(b2->low.z, b1->low.z, b1->high.z))); } static void geom_box_shift(geom_box *b, vector3 shiftby) { b->low = vector3_plus(b->low, shiftby); b->high = vector3_plus(b->high, shiftby); } /**************************************************************************/ /* Computing a bounding box for a geometric object: */ /* compute | (b x c) / (a * (b x c)) |, for use below */ static number compute_dot_cross(vector3 a, vector3 b, vector3 c) { vector3 bxc = vector3_cross(b, c); return fabs(vector3_norm(bxc) / vector3_dot(a, bxc)); } /* Compute a bounding box for the object o, preferably the smallest bounding box. The box is a parallelepiped with axes given by the geometry lattice vectors, and its corners are given in the lattice basis. Requires that geometry_lattice global has been initialized, etcetera. */ void geom_get_bounding_box(geometric_object o, geom_box *box) { geom_fix_object_ptr(&o); /* initialize to empty box at the center of the object: */ box->low = box->high = o.center; switch (o.which_subclass) { case GEOM GEOMETRIC_OBJECT_SELF: break; case GEOM SPHERE: { /* Find the parallelepiped that the sphere inscribes. The math comes out surpisingly simple--try it! */ number radius = o.subclass.sphere_data->radius; /* actually, we could achieve the same effect here by inverting the geometry_lattice.basis matrix... */ number r1 = compute_dot_cross(geometry_lattice.b1, geometry_lattice.b2, geometry_lattice.b3) * radius; number r2 = compute_dot_cross(geometry_lattice.b2, geometry_lattice.b3, geometry_lattice.b1) * radius; number r3 = compute_dot_cross(geometry_lattice.b3, geometry_lattice.b1, geometry_lattice.b2) * radius; box->low.x -= r1; box->low.y -= r2; box->low.z -= r3; box->high.x += r1; box->high.y += r2; box->high.z += r3; break; } case GEOM CYLINDER: { /* Find the bounding boxes of the two (circular) ends of the cylinder, then take the union. Again, the math for finding the bounding parallelepiped of a circle comes out suprisingly simple in the end. Proof left as an exercise for the reader. */ number radius = o.subclass.cylinder_data->radius; number h = o.subclass.cylinder_data->height * 0.5; vector3 axis = /* cylinder axis in cartesian coords */ matrix3x3_vector3_mult(geometry_lattice.basis, o.subclass.cylinder_data->axis); vector3 e12 = vector3_cross(geometry_lattice.basis1, geometry_lattice.basis2); vector3 e23 = vector3_cross(geometry_lattice.basis2, geometry_lattice.basis3); vector3 e31 = vector3_cross(geometry_lattice.basis3, geometry_lattice.basis1); number elen2, eproj; number r1, r2, r3; geom_box tmp_box; /* Find bounding box dimensions, in lattice coords, for the circular ends of the cylinder: */ elen2 = vector3_dot(e23, e23); eproj = vector3_dot(e23, axis); r1 = fabs(sqrt(fabs(elen2 - eproj*eproj)) / vector3_dot(e23, geometry_lattice.b1)); elen2 = vector3_dot(e31, e31); eproj = vector3_dot(e31, axis); r2 = fabs(sqrt(fabs(elen2 - eproj*eproj)) / vector3_dot(e31, geometry_lattice.b2)); elen2 = vector3_dot(e12, e12); eproj = vector3_dot(e12, axis); r3 = fabs(sqrt(fabs(elen2 - eproj*eproj)) / vector3_dot(e12, geometry_lattice.b3)); /* Get axis in lattice coords: */ axis = o.subclass.cylinder_data->axis; tmp_box = *box; /* set tmp_box to center of object */ /* bounding box for -h*axis cylinder end: */ box->low.x -= h * axis.x + r1*radius; box->low.y -= h * axis.y + r2*radius; box->low.z -= h * axis.z + r3*radius; box->high.x -= h * axis.x - r1*radius; box->high.y -= h * axis.y - r2*radius; box->high.z -= h * axis.z - r3*radius; if (o.subclass.cylinder_data->which_subclass == CYL CONE) radius = fabs(o.subclass.cylinder_data->subclass.cone_data->radius2); /* bounding box for +h*axis cylinder end: */ tmp_box.low.x += h * axis.x - r1*radius; tmp_box.low.y += h * axis.y - r2*radius; tmp_box.low.z += h * axis.z - r3*radius; tmp_box.high.x += h * axis.x + r1*radius; tmp_box.high.y += h * axis.y + r2*radius; tmp_box.high.z += h * axis.z + r3*radius; geom_box_union(box, box, &tmp_box); break; } case GEOM BLOCK: { /* blocks are easy: just enlarge the box to be big enough to contain all 8 corners of the block. */ vector3 s1 = vector3_scale(o.subclass.block_data->size.x, o.subclass.block_data->e1); vector3 s2 = vector3_scale(o.subclass.block_data->size.y, o.subclass.block_data->e2); vector3 s3 = vector3_scale(o.subclass.block_data->size.z, o.subclass.block_data->e3); vector3 corner = vector3_plus(o.center, vector3_scale(-0.5, vector3_plus(s1, vector3_plus(s2, s3)))); geom_box_add_pt(box, corner); geom_box_add_pt(box, vector3_plus(corner, s1)); geom_box_add_pt(box, vector3_plus(corner, s2)); geom_box_add_pt(box, vector3_plus(corner, s3)); geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s1, s2))); geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s1, s3))); geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s3, s2))); geom_box_add_pt(box, vector3_plus(corner, vector3_plus(s1, vector3_plus(s2, s3)))); break; } case GEOM PRISM: { get_prism_bounding_box(o.subclass.prism_data, box); break; } case GEOM COMPOUND_GEOMETRIC_OBJECT: { int i; int n = o.subclass.compound_geometric_object_data ->component_objects.num_items; geometric_object *os = o.subclass.compound_geometric_object_data ->component_objects.items; for (i = 0; i < n; ++i) { geom_box boxi; geom_get_bounding_box(os[i], &boxi); geom_box_shift(&boxi, o.center); geom_box_union(box, box, &boxi); } break; } } } /**************************************************************************/ /* Compute the fraction of a box's volume (or area/length in 2d/1d) that overlaps an object. Instead of a box, we also allow an ellipsoid inscribed inside the box (or a skewed ellipsoid if the box is not orthogonal). */ typedef struct { geometric_object o; vector3 p, dir; int pdim[2]; /* the (up to two) integration directions */ double scx[2]; /* scale factor (e.g. sign flip) for x coordinates */ unsigned dim; double a0, b0; /* box limits along analytic direction */ int is_ellipsoid; /* 0 for box, 1 for ellipsoid */ double winv[2], c[2]; /* ellipsoid width-inverses/centers in int. dirs */ double w0, c0; /* width/center along analytic direction */ } overlap_data; static double overlap_integrand(integer ndim, number *x, void *data_) { overlap_data *data = (overlap_data *) data_; double s[2]; const double *scx = data->scx; vector3 p = data->p; double a0 = data->a0, b0 = data->b0; double scale_result = 1.0; if (ndim > 0) { switch (data->pdim[0]) { case 0: p.x = scx[0] * x[0]; break; case 1: p.y = scx[0] * x[0]; break; case 2: p.z = scx[0] * x[0]; break; } if (ndim > 1) { switch (data->pdim[1]) { case 0: p.x = scx[1] * x[1]; break; case 1: p.y = scx[1] * x[1]; break; case 2: p.z = scx[1] * x[1]; break; } } } if (data->is_ellipsoid && ndim > 0) { /* compute width of ellipsoid at this point, along the analytic-intersection direction */ double dx = (x[0] - data->c[0]) * data->winv[0]; double w = 1.0 - dx * dx; if (ndim > 1) { /* rescale 2nd dimension to stay inside ellipsoid */ double x1; if (w < 0) return 0.0; /* outside the ellipsoid */ scale_result = sqrt(w); x1 = data->c[1] + (x[1] - data->c[1]) * scale_result; switch (data->pdim[1]) { case 0: p.x = scx[1] * x1; break; case 1: p.y = scx[1] * x1; break; case 2: p.z = scx[1] * x1; break; } dx = (x1 - data->c[1]) * data->winv[1]; w -= dx * dx; } if (w < 0) return 0.0; /* outside the ellipsoid */ w = data->w0 * sqrt(w); a0 = data->c0 - w; b0 = data->c0 + w; } return intersect_line_segment_with_object(p, data->dir, data->o, a0, b0) * scale_result; } number overlap_with_object(geom_box b, int is_ellipsoid, geometric_object o, number tol, integer maxeval) { overlap_data data; int empty_x = b.low.x == b.high.x; int empty_y = b.low.y == b.high.y; int empty_z = b.low.z == b.high.z; double V0 = ((empty_x ? 1 : b.high.x - b.low.x) * (empty_y ? 1 : b.high.y - b.low.y) * (empty_z ? 1 : b.high.z - b.low.z)); vector3 ex = {1,0,0}, ey = {0,1,0}, ez = {0,0,1}; geom_box bb; double xmin[2] = {0,0}, xmax[2] = {0,0}, esterr; int errflag; unsigned i; geom_get_bounding_box(o, &bb); if (!is_ellipsoid && !empty_x && !empty_y && !empty_z && /* todo: optimize 1d and 2d cases */ bb.low.x >= b.low.x && bb.high.x <= b.high.x && bb.low.y >= b.low.y && bb.high.y <= b.high.y && bb.low.z >= b.low.z && bb.high.z <= b.high.z) return geom_object_volume(o) / (V0 * fabs(matrix3x3_determinant(geometry_lattice.basis))); /* o is completely contained within b */ geom_box_intersection(&bb, &b, &bb); if (bb.low.x > bb.high.x || bb.low.y > bb.high.y || bb.low.z > bb.high.z || (!empty_x && bb.low.x == bb.high.x) || (!empty_y && bb.low.y == bb.high.y) || (!empty_z && bb.low.z == bb.high.z)) return 0.0; data.winv[0] = data.winv[1] = data.w0 = 1.0; data.c[0] = data.c[1] = data.c0 = 0; data.o = o; data.p.x = data.p.y = data.p.z = 0; data.dim = 0; if (!empty_x) { data.dir = ex; data.a0 = bb.low.x; data.b0 = bb.high.x; data.w0 = 0.5 * (b.high.x - b.low.x); data.c0 = 0.5 * (b.high.x + b.low.x); if (!empty_y) { xmin[data.dim] = bb.low.y; xmax[data.dim] = bb.high.y; data.winv[data.dim] = 2.0 / (b.high.y - b.low.y); data.c[data.dim] = 0.5 * (b.high.y + b.low.y); data.pdim[data.dim++] = 1; } if (!empty_z) { xmin[data.dim] = bb.low.z; xmax[data.dim] = bb.high.z; data.winv[data.dim] = 2.0 / (b.high.z - b.low.z); data.c[data.dim] = 0.5 * (b.high.z + b.low.z); data.pdim[data.dim++] = 2; } } else if (!empty_y) { data.dir = ey; data.a0 = bb.low.y; data.b0 = bb.high.y; data.w0 = 0.5 * (b.high.y - b.low.y); data.c0 = 0.5 * (b.high.y + b.low.y); if (!empty_x) { xmin[data.dim] = bb.low.x; xmax[data.dim] = bb.high.x; data.winv[data.dim] = 2.0 / (b.high.x - b.low.x); data.c[data.dim] = 0.5 * (b.high.x + b.low.x); data.pdim[data.dim++] = 0; } if (!empty_z) { xmin[data.dim] = bb.low.z; xmax[data.dim] = bb.high.z; data.winv[data.dim] = 2.0 / (b.high.z - b.low.z); data.c[data.dim] = 0.5 * (b.high.z + b.low.z); data.pdim[data.dim++] = 2; } } else if (!empty_z) { data.dir = ez; data.a0 = bb.low.z; data.b0 = bb.high.z; data.w0 = 0.5 * (b.high.z - b.low.z); data.c0 = 0.5 * (b.high.z + b.low.z); if (!empty_x) { xmin[data.dim] = bb.low.x; xmax[data.dim] = bb.high.x; data.winv[data.dim] = 2.0 / (b.high.x - b.low.x); data.c[data.dim] = 0.5 * (b.high.x + b.low.x); data.pdim[data.dim++] = 0; } if (!empty_y) { xmin[data.dim] = bb.low.y; xmax[data.dim] = bb.high.y; data.winv[data.dim] = 2.0 / (b.high.y - b.low.y); data.c[data.dim] = 0.5 * (b.high.y + b.low.y); data.pdim[data.dim++] = 1; } } else return 1.0; #if 1 /* To maintain mirror symmetries through the x/y/z axes, we flip the integration range whenever xmax < 0. (This is in case the integration routine is not fully symmetric, which may happen(?) due to the upper bound on the #evaluations.)*/ for (i = 0; i < data.dim; ++i) { if (xmax[i] < 0) { double xm = xmin[i]; data.scx[i] = -1; xmin[i] = -xmax[i]; xmax[i] = -xm; data.c[i] = -data.c[i]; } else data.scx[i] = 1; } #else for (i = 0; i < data.dim; ++i) data.scx[i] = 1; #endif if ((data.is_ellipsoid = is_ellipsoid)) { /* data for ellipsoid calc. */ if (data.dim == 1) V0 *= K_PI / 4; else if (data.dim == 2) V0 *= K_PI / 6; } return adaptive_integration(overlap_integrand, xmin, xmax, data.dim, &data, 0.0, tol, maxeval, &esterr, &errflag) / V0; } number box_overlap_with_object(geom_box b, geometric_object o, number tol, integer maxeval) { return overlap_with_object(b, 0, o, tol, maxeval); } number ellipsoid_overlap_with_object(geom_box b, geometric_object o, number tol, integer maxeval) { return overlap_with_object(b, 1, o, tol, maxeval); } number CTLIO range_overlap_with_object(vector3 low, vector3 high, geometric_object o, number tol, integer maxeval) { geom_box b; b.low = low; b.high = high; return box_overlap_with_object(b, o, tol, maxeval); } /**************************************************************************/ /* geom_box_tree: a tree of boxes and the objects contained within them. The tree recursively partitions the unit cell, allowing us to perform binary searches for the object containing a given point. */ void destroy_geom_box_tree(geom_box_tree t) { if (t) { destroy_geom_box_tree(t->t1); destroy_geom_box_tree(t->t2); if (t->nobjects && t->objects) FREE(t->objects); FREE1(t); } } /* return whether the object o, shifted by the vector shiftby, possibly intersects b. Upon return, obj_b is the bounding box for o. */ static int object_in_box(geometric_object o, vector3 shiftby, geom_box *obj_b, const geom_box *b) { geom_get_bounding_box(o, obj_b); geom_box_shift(obj_b, shiftby); return geom_boxes_intersect(obj_b, b); } static geom_box_tree new_geom_box_tree(void) { geom_box_tree t; t = MALLOC1(struct geom_box_tree_struct); CHECK(t, "out of memory"); t->t1 = t->t2 = NULL; t->nobjects = 0; t->objects = NULL; return t; } /* Divide b into b1 and b2, cutting b in two along the axis divide_axis (0 = x, 1 = y, 2 = z) at divide_point. */ static void divide_geom_box(const geom_box *b, int divide_axis, number divide_point, geom_box *b1, geom_box *b2) { *b1 = *b2 = *b; switch (divide_axis) { case 0: b1->high.x = b2->low.x = divide_point; break; case 1: b1->high.y = b2->low.y = divide_point; break; case 2: b1->high.z = b2->low.z = divide_point; break; } } #define VEC_I(v,i) ((i) == 0 ? (v).x : ((i) == 1 ? (v).y : (v).z)) #define SMALL 1.0e-7 /* Find the best place (best_partition) to "cut" along the axis divide_axis in order to maximally divide the objects between the partitions. Upon return, n1 and n2 are the number of objects below and above the partition, respectively. */ static void find_best_partition(int nobjects, const geom_box_object *objects, int divide_axis, number *best_partition, int *n1, int *n2) { number cur_partition; int i, j, cur_n1, cur_n2; *n1 = *n2 = nobjects + 1; *best_partition = 0; /* Search for the best partition, by checking all possible partitions either just above the high end of an object or just below the low end of an object. */ for (i = 0; i < nobjects; ++i) { cur_partition = VEC_I(objects[i].box.high, divide_axis) * (1 + SMALL); cur_n1 = cur_n2 = 0; for (j = 0; j < nobjects; ++j) { double low = VEC_I(objects[j].box.low, divide_axis); double high = VEC_I(objects[j].box.high, divide_axis); cur_n1 += low <= cur_partition; cur_n2 += high >= cur_partition; } CHECK(cur_n1 + cur_n2 >= nobjects, "assertion failure 1 in find_best_partition"); if (MAX(cur_n1, cur_n2) < MAX(*n1, *n2)) { *best_partition = cur_partition; *n1 = cur_n1; *n2 = cur_n2; } } for (i = 0; i < nobjects; ++i) { cur_partition = VEC_I(objects[i].box.low, divide_axis) * (1 - SMALL); cur_n1 = cur_n2 = 0; for (j = 0; j < nobjects; ++j) { double low = VEC_I(objects[j].box.low, divide_axis); double high = VEC_I(objects[j].box.high, divide_axis); cur_n1 += low <= cur_partition; cur_n2 += high >= cur_partition; } CHECK(cur_n1 + cur_n2 >= nobjects, "assertion failure 2 in find_best_partition"); if (MAX(cur_n1, cur_n2) < MAX(*n1, *n2)) { *best_partition = cur_partition; *n1 = cur_n1; *n2 = cur_n2; } } } /* divide_geom_box_tree: recursively divide t in two, each time dividing along the axis that maximally partitions the boxes, and only stop partitioning when partitioning doesn't help any more. Upon return, t points to the partitioned tree. */ static void divide_geom_box_tree(geom_box_tree t) { int division_nobjects[3][2] = {{0,0},{0,0},{0,0}}; number division_point[3]; int best = -1; int i, j, n1, n2; if (!t) return; if (t->t1 || t->t2) { /* this node has already been divided */ divide_geom_box_tree(t->t1); divide_geom_box_tree(t->t2); return; } if (t->nobjects <= 2) return; /* no point in partitioning */ /* Try partitioning along each dimension, counting the number of objects in the partitioned boxes and finding the best partition. */ for (i = 0; i < dimensions; ++i) { if (VEC_I(t->b.high, i) == VEC_I(t->b.low, i)) continue; /* skip empty dimensions */ find_best_partition(t->nobjects, t->objects, i, &division_point[i], &division_nobjects[i][0], &division_nobjects[i][1]); if (best < 0 || MAX(division_nobjects[i][0], division_nobjects[i][1]) < MAX(division_nobjects[best][0], division_nobjects[best][1])) best = i; } /* don't do anything if division makes the worst case worse or if it fails to improve the best case: */ if (best < 0 || MAX(division_nobjects[best][0], division_nobjects[best][1]) + 1 > t->nobjects || MIN(division_nobjects[best][0], division_nobjects[best][1]) + 1 >= t->nobjects) return; /* division didn't help us */ divide_geom_box(&t->b, best, division_point[best], &t->b1, &t->b2); t->t1 = new_geom_box_tree(); t->t2 = new_geom_box_tree(); t->t1->b = t->b1; t->t2->b = t->b2; t->t1->nobjects = division_nobjects[best][0]; t->t1->objects = MALLOC(geom_box_object, t->t1->nobjects); CHECK(t->t1->objects, "out of memory"); t->t2->nobjects = division_nobjects[best][1]; t->t2->objects = MALLOC(geom_box_object, t->t2->nobjects); CHECK(t->t2->objects, "out of memory"); for (j = n1 = n2 = 0; j < t->nobjects; ++j) { if (geom_boxes_intersect(&t->b1, &t->objects[j].box)) { CHECK(n1 < t->t1->nobjects, "BUG in divide_geom_box_tree"); t->t1->objects[n1++] = t->objects[j]; } if (geom_boxes_intersect(&t->b2, &t->objects[j].box)) { CHECK(n2 < t->t2->nobjects, "BUG in divide_geom_box_tree"); t->t2->objects[n2++] = t->objects[j]; } } CHECK(j == t->nobjects && n1 == t->t1->nobjects && n2 == t->t2->nobjects, "BUG in divide_geom_box_tree: wrong nobjects"); t->nobjects = 0; FREE(t->objects); t->objects = NULL; divide_geom_box_tree(t->t1); divide_geom_box_tree(t->t2); } geom_box_tree create_geom_box_tree(void) { geom_box b0; b0.low = vector3_plus(geometry_center, vector3_scale(-0.5, geometry_lattice.size)); b0.high = vector3_plus(geometry_center, vector3_scale(0.5, geometry_lattice.size)); return create_geom_box_tree0(geometry, b0); } static int num_objects_in_box(const geometric_object *o, vector3 shiftby, const geom_box *b) { if (o->which_subclass == GEOM COMPOUND_GEOMETRIC_OBJECT) { int n = o->subclass.compound_geometric_object_data ->component_objects.num_items; geometric_object *os = o->subclass.compound_geometric_object_data ->component_objects.items; int i, sum = 0; shiftby = vector3_plus(shiftby, o->center); for (i = 0; i < n; ++i) sum += num_objects_in_box(os + i, shiftby, b); return sum; } else { geom_box ob; return object_in_box(*o, shiftby, &ob, b); } } static int store_objects_in_box(const geometric_object *o, vector3 shiftby, const geom_box *b, geom_box_object *bo, int precedence) { if (o->which_subclass == GEOM COMPOUND_GEOMETRIC_OBJECT) { int n = o->subclass.compound_geometric_object_data ->component_objects.num_items; geometric_object *os = o->subclass.compound_geometric_object_data ->component_objects.items; int i, sum = 0; shiftby = vector3_plus(shiftby, o->center); for (i = 0; i < n; ++i) sum += store_objects_in_box(os + i, shiftby, b, bo + sum, precedence - sum); return sum; } else { geom_box ob; if (object_in_box(*o, shiftby, &ob, b)) { bo->box = ob; bo->o = o; bo->shiftby = shiftby; bo->precedence = precedence; return 1; } else return 0; } } geom_box_tree create_geom_box_tree0(geometric_object_list geometry, geom_box b0) { geom_box_tree t = new_geom_box_tree(); int i, index; t->b = b0; for (i = geometry.num_items - 1; i >= 0; --i) { vector3 shiftby = {0,0,0}; if (ensure_periodicity) { LOOP_PERIODIC(shiftby, t->nobjects += num_objects_in_box( geometry.items + i, shiftby, &t->b)); } else t->nobjects += num_objects_in_box( geometry.items + i, shiftby, &t->b); } t->objects = MALLOC(geom_box_object, t->nobjects); CHECK(t->objects || t->nobjects == 0, "out of memory"); for (i = geometry.num_items - 1, index = 0; i >= 0; --i) { vector3 shiftby = {0,0,0}; if (ensure_periodicity) { int precedence = t->nobjects - index; LOOP_PERIODIC(shiftby, index += store_objects_in_box( geometry.items + i, shiftby, &t->b, t->objects + index, precedence)); } else index += store_objects_in_box( geometry.items + i, shiftby, &t->b, t->objects + index, t->nobjects - index); } CHECK(index == t->nobjects, "bug in create_geom_box_tree0"); divide_geom_box_tree(t); return t; } /* create a new tree from t, pruning all nodes that don't intersect b */ geom_box_tree restrict_geom_box_tree(geom_box_tree t, const geom_box *b) { geom_box_tree tr; int i, j; if (!t || !geom_boxes_intersect(&t->b, b)) return NULL; tr = new_geom_box_tree(); for (i = 0, j = 0; i < t->nobjects; ++i) if (geom_boxes_intersect(&t->objects[i].box, b)) ++j; tr->nobjects = j; tr->objects = MALLOC(geom_box_object, tr->nobjects); CHECK(tr->objects || tr->nobjects == 0, "out of memory"); for (i = 0, j = 0; i < t->nobjects; ++i) if (geom_boxes_intersect(&t->objects[i].box, b)) tr->objects[j++] = t->objects[i]; tr->t1 = restrict_geom_box_tree(t->t1, b); tr->t2 = restrict_geom_box_tree(t->t2, b); if (tr->nobjects == 0) { if (tr->t1 && !tr->t2) { geom_box_tree tr0 = tr; tr = tr->t1; FREE1(tr0); } else if (tr->t2 && !tr->t1) { geom_box_tree tr0 = tr; tr = tr->t2; FREE1(tr0); } } return tr; } /**************************************************************************/ /* recursively search the tree for the given point, returning the subtree (if any) that contains it and the index oindex of the object in that tree. The input value of oindex indicates the starting object to search in t (0 to search all). */ static geom_box_tree tree_search(vector3 p, geom_box_tree t, int *oindex) { int i; geom_box_tree gbt; if (!t || !geom_box_contains_point(&t->b, p)) return NULL; for (i = *oindex; i < t->nobjects; ++i) if (geom_box_contains_point(&t->objects[i].box, p) && point_in_fixed_objectp(vector3_minus(p, t->objects[i].shiftby), *t->objects[i].o)) { *oindex = i; return t; } *oindex = 0; gbt = tree_search(p, t->t1, oindex); if (!gbt) gbt = tree_search(p, t->t2, oindex); return gbt; } /* shift p to be within the unit cell of the lattice (centered on the origin) */ vector3 shift_to_unit_cell(vector3 p) { while (p.x >= 0.5 * geometry_lattice.size.x) p.x -= geometry_lattice.size.x; while (p.x < -0.5 * geometry_lattice.size.x) p.x += geometry_lattice.size.x; while (p.y >= 0.5 * geometry_lattice.size.y) p.y -= geometry_lattice.size.y; while (p.y < -0.5 * geometry_lattice.size.y) p.y += geometry_lattice.size.y; while (p.z >= 0.5 * geometry_lattice.size.z) p.z -= geometry_lattice.size.z; while (p.z < -0.5 * geometry_lattice.size.z) p.z += geometry_lattice.size.z; return p; } const geometric_object *object_of_point_in_tree(vector3 p, geom_box_tree t, vector3 *shiftby, int *precedence) { int oindex = 0; t = tree_search(p, t, &oindex); if (t) { geom_box_object *gbo = t->objects + oindex; *shiftby = gbo->shiftby; *precedence = gbo->precedence; return gbo->o; } else { shiftby->x = shiftby->y = shiftby->z = 0; *precedence = 0; return 0; } } material_type material_of_unshifted_point_in_tree_inobject( vector3 p, geom_box_tree t, boolean *inobject) { int oindex = 0; t = tree_search(p, t, &oindex); if (t) { *inobject = 1; return (t->objects[oindex].o->material); } else { *inobject = 0; return default_material; } } material_type material_of_point_in_tree_inobject(vector3 p, geom_box_tree t, boolean *inobject) { /* backwards compatibility */ return material_of_unshifted_point_in_tree_inobject( shift_to_unit_cell(p), t, inobject); } material_type material_of_point_in_tree(vector3 p, geom_box_tree t) { boolean inobject; return material_of_point_in_tree_inobject(p, t, &inobject); } geom_box_tree geom_tree_search_next(vector3 p, geom_box_tree t, int *oindex) { *oindex += 1; /* search starting at next oindex */ return tree_search(p, t, oindex); } geom_box_tree geom_tree_search(vector3 p, geom_box_tree t, int *oindex) { *oindex = -1; /* search all indices > -1 */ return geom_tree_search_next(p, t, oindex); } /**************************************************************************/ /* convert a vector p in the given object to some coordinate in [0,1]^3 that is a more "natural" map of the object interior. */ vector3 to_geom_box_coords(vector3 p, geom_box_object *gbo) { return to_geom_object_coords(vector3_minus(p, gbo->shiftby), *gbo->o); } /**************************************************************************/ void display_geom_box_tree(int indentby, geom_box_tree t) { int i; if (!t) return; ctl_printf("%*sbox (%g..%g, %g..%g, %g..%g)\n", indentby, "", t->b.low.x, t->b.high.x, t->b.low.y, t->b.high.y, t->b.low.z, t->b.high.z); for (i = 0; i < t->nobjects; ++i) { ctl_printf("%*sbounding box (%g..%g, %g..%g, %g..%g)\n", indentby+5, "", t->objects[i].box.low.x, t->objects[i].box.high.x, t->objects[i].box.low.y, t->objects[i].box.high.y, t->objects[i].box.low.z, t->objects[i].box.high.z); ctl_printf("%*sshift object by (%g, %g, %g)\n", indentby+5, "", t->objects[i].shiftby.x, t->objects[i].shiftby.y, t->objects[i].shiftby.z); display_geometric_object_info(indentby + 5, *t->objects[i].o); } display_geom_box_tree(indentby + 5, t->t1); display_geom_box_tree(indentby + 5, t->t2); } /**************************************************************************/ /* Computing tree statistics (depth and number of nodes): */ /* helper function for geom_box_tree_stats */ static void get_tree_stats(geom_box_tree t, int *depth, int *nobjects) { if (t) { int d1, d2; *nobjects += t->nobjects; d1 = d2 = *depth + 1; get_tree_stats(t->t1, &d1, nobjects); get_tree_stats(t->t2, &d2, nobjects); *depth = MAX(d1, d2); } } void geom_box_tree_stats(geom_box_tree t, int *depth, int *nobjects) { *depth = *nobjects = 0; get_tree_stats(t, depth, nobjects); } /**************************************************************************/ #ifndef LIBCTLGEOM vector3 get_grid_size(void) { return ctl_convert_vector3_to_c(gh_call0(gh_lookup("get-grid-size"))); } vector3 get_resolution(void) { return ctl_convert_vector3_to_c(gh_call0(gh_lookup("get-resolution"))); } void get_grid_size_n(int *nx, int *ny, int *nz) { vector3 grid_size; grid_size = get_grid_size(); *nx = (int) grid_size.x; *ny = (int) grid_size.y; *nz = (int) grid_size.z; } #endif /**************************************************************************/ /* constructors for the geometry types (ugh, wish these could be automatically generated from geom.scm) */ geometric_object make_geometric_object(material_type material, vector3 center) { geometric_object o; material_type_copy(&material, &o.material); o.center = center; o.which_subclass = GEOM GEOMETRIC_OBJECT_SELF; return o; } geometric_object make_cylinder(material_type material, vector3 center, number radius, number height, vector3 axis) { geometric_object o = make_geometric_object(material, center); o.which_subclass = GEOM CYLINDER; o.subclass.cylinder_data = MALLOC1(cylinder); CHECK(o.subclass.cylinder_data, "out of memory"); o.subclass.cylinder_data->radius = radius; o.subclass.cylinder_data->height = height; o.subclass.cylinder_data->axis = axis; o.subclass.cylinder_data->which_subclass = CYL CYLINDER_SELF; geom_fix_object_ptr(&o); return o; } geometric_object make_cone(material_type material, vector3 center, number radius, number height, vector3 axis, number radius2) { geometric_object o = make_cylinder(material, center, radius,height, axis); o.subclass.cylinder_data->which_subclass = CYL CONE; o.subclass.cylinder_data->subclass.cone_data = MALLOC1(cone); CHECK(o.subclass.cylinder_data->subclass.cone_data, "out of memory"); o.subclass.cylinder_data->subclass.cone_data->radius2 = radius2; return o; } geometric_object make_wedge(material_type material, vector3 center, number radius, number height, vector3 axis, number wedge_angle, vector3 wedge_start) { geometric_object o = make_cylinder(material, center, radius,height, axis); o.subclass.cylinder_data->which_subclass = CYL WEDGE; o.subclass.cylinder_data->subclass.wedge_data = MALLOC1(wedge); CHECK(o.subclass.cylinder_data->subclass.wedge_data, "out of memory"); o.subclass.cylinder_data->subclass.wedge_data->wedge_angle = wedge_angle; o.subclass.cylinder_data->subclass.wedge_data->wedge_start = wedge_start; geom_fix_object_ptr(&o); return o; } geometric_object make_sphere(material_type material, vector3 center, number radius) { geometric_object o = make_geometric_object(material, center); o.which_subclass = GEOM SPHERE; o.subclass.sphere_data = MALLOC1(sphere); CHECK(o.subclass.sphere_data, "out of memory"); o.subclass.sphere_data->radius = radius; return o; } geometric_object make_block(material_type material, vector3 center, vector3 e1, vector3 e2, vector3 e3, vector3 size) { geometric_object o = make_geometric_object(material, center); o.which_subclass = GEOM BLOCK; o.subclass.block_data = MALLOC1(block); CHECK(o.subclass.block_data, "out of memory"); o.subclass.block_data->e1 = e1; o.subclass.block_data->e2 = e2; o.subclass.block_data->e3 = e3; o.subclass.block_data->size = size; o.subclass.block_data->which_subclass = BLK BLOCK_SELF; geom_fix_object_ptr(&o); return o; } geometric_object make_ellipsoid(material_type material, vector3 center, vector3 e1, vector3 e2, vector3 e3, vector3 size) { geometric_object o = make_block(material, center, e1,e2,e3, size); o.subclass.block_data->which_subclass = BLK ELLIPSOID; o.subclass.block_data->subclass.ellipsoid_data = MALLOC1(ellipsoid); CHECK(o.subclass.block_data->subclass.ellipsoid_data, "out of memory"); o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.x = 2.0 / size.x; o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.y = 2.0 / size.y; o.subclass.block_data->subclass.ellipsoid_data->inverse_semi_axes.z = 2.0 / size.z; return o; } /*************************************************************** * The remainder of this file implements geometric primitives for prisms. * A prism is a planar polygon, consisting of 3 or more user-specified * vertices, extruded through a given thickness (the "height") in the * direction of a given unit vector (the "axis.") * Most calculations are done in the "prism coordinate system", * in which the prism floor lies in the XY plane with centroid * at the origin and the prism axis is the positive Z-axis. * Some variable naming conventions: * -- Suffix 'p' or '_p' on variable names identifies variables * storing coordinates or vector components in the prism system. * Suffix 'c' or '_c' (or no suffix) corresponds to coodinates/components * in ordinary 3d space. ('c' stands for 'cartesian'). * -- We use the term 'vertex' for points in 3-space, stored as vector3 * quantities with variable names beginning with 'p' or 'v'. For 3D * direction vectors we use variable names beginning with 'd'. * -- We use the term 'node' for points in 2-space, stored as vector3 * quantities (with the z component unused) with variables beginning with 'q'. * For 2D direction vectors we use variable names beginning with 'u'. * homer reid 4/2018 ***************************************************************/ /***************************************************************/ /* given coordinates of a point in the prism coordinate system,*/ /* return cartesian coordinates of that point */ /***************************************************************/ vector3 prism_coordinate_p2c(prism *prsm, vector3 pp) { return vector3_plus(prsm->centroid, matrix3x3_vector3_mult(prsm->m_p2c,pp)); } vector3 prism_vector_p2c(prism *prsm, vector3 vp) { return matrix3x3_vector3_mult(prsm->m_p2c, vp); } vector3 prism_coordinate_c2p(prism *prsm, vector3 pc) { return matrix3x3_vector3_mult(prsm->m_c2p, vector3_minus(pc,prsm->centroid)); } vector3 prism_vector_c2p(prism *prsm, vector3 vc) { return matrix3x3_vector3_mult(prsm->m_c2p, vc); } /***************************************************************/ /* given 2D points q0,q1,q2 and a 2D vector u, determine */ /* whether or not the line q0 + s*u intersects the line */ /* segment q1--q2. */ /* algorithm: solve the 2x2 linear system q0+s*u = q1+t*(q2-q1)*/ /* for the scalar quantities s, t; intersection corresponds to */ /* 0 <= t < 1. */ /* return values: */ /* ** case 1: u is not parallel to q1--q2 ** */ /* NON_INTERSECTING: test negative */ /* INTERSECTING: test positive */ /* ** case 2: u is parallel to q1--q2 ** */ /* IN_SEGMENT: q0 lies on line segment q1--q2 */ /* ON_RAY: q0 does not lie on q1--q2, but there is a*/ /* *positive* value of s such that q0+s*u */ /* lies on q1--q2 */ /* NON_INTERSECTING neither of the above */ /***************************************************************/ #define THRESH 1.0e-5 #define NON_INTERSECTING 0 #define INTERSECTING 1 #define IN_SEGMENT 2 #define ON_RAY 3 int intersect_line_with_segment(vector3 q0, vector3 q1, vector3 q2, vector3 u, double *s) { /* ||ux q1x-q2x|| |s| = | q1x-q0x | */ /* ||uy q1y-q2y|| |t| = | q1y-q0y | */ double M00 = u.x, M01=q1.x-q2.x; double M10 = u.y, M11=q1.y-q2.y; double RHSx = q1.x-q0.x; double RHSy = q1.y-q0.y; double DetM = M00*M11 - M01*M10; double L2 = M01*M01 + M11*M11; // squared length of edge, used to set length scale if ( fabs(DetM) < 1.0e-10*L2 ) { // d zero or nearly parallel to edge double q01x = q0.x-q1.x, q01y = q0.y-q1.y, q01 = sqrt(q01x*q01x+q01y*q01y); double q02x = q0.x-q2.x, q02y = q0.y-q2.y, q02 = sqrt(q02x*q02x+q02y*q02y); double dot = q01x*q02x + q01y*q02y; if ( fabs(dot) < (1.0-THRESH)*q01*q02 ) return NON_INTERSECTING; else if (dot<0.0) { *s=0.0; return IN_SEGMENT; } else if ( (u.x*q01x + u.y*q01y) < 0.0 ) { *s = fmin(q01, q02) / sqrt(u.x*u.x + u.y*u.y); return ON_RAY; } return NON_INTERSECTING; } float t = (M00*RHSy-M10*RHSx)/DetM; if (s) *s = (M11*RHSx-M01*RHSy)/DetM; // the plumb line intersects the segment if 0<=t<=1, with t==0,1 // corresponding to the endpoints; for our purposes we count // the intersection if the plumb line runs through the t==0 vertex, but // NOT the t==1 vertex, to avoid double-counting for complete polygons. return ( t<-THRESH || t>=(1-THRESH) ) ? NON_INTERSECTING : INTERSECTING; } // like the previous routine, but only count intersections if s>=0 boolean intersect_ray_with_segment(vector3 q0, vector3 q1, vector3 q2, vector3 u, double *s) { double ss; int status=intersect_line_with_segment(q0,q1,q2,u,&ss); if (status==INTERSECTING && ss<0.0) return NON_INTERSECTING; if (s) *s=ss; return status; } /***************************************************************/ /* 2D point-in-polygon test: return 1 if q0 lies within the */ /* polygon with the given vertices, 0 otherwise. */ // method: cast a plumb line in the negative y direction from */ /* q0 to infinity and count the number of edges intersected; */ /* point lies in polygon iff this is number is odd. */ /***************************************************************/ boolean node_in_or_on_polygon(vector3 q0, vector3 *nodes, int num_nodes, boolean include_boundaries) { vector3 u = {0.0, -1.0, 0.0}; int nn, edges_crossed=0; for(nn=0; nnheight; vector3 pp = prism_coordinate_c2p(prsm, pc); if ( pp.z<0.0 || pp.z>prsm->height ) return 0; vector3 *nodes = prsm->vertices_p.items; int num_nodes = prsm->vertices_p.num_items; return node_in_or_on_polygon(pp, nodes, num_nodes, include_boundaries); } boolean point_in_prism(prism *prsm, vector3 pc) { // by default, points on polygon edges are considered to lie inside the // polygon; this can be reversed by setting the environment variable // LIBCTL_EXCLUDE_BOUNDARIES=1 static boolean include_boundaries=1, init=0; if (init==0) { init=1; char *s=getenv("LIBCTL_EXCLUDE_BOUNDARIES"); if (s && s[0]=='1') include_boundaries=0; } return point_in_or_on_prism(prsm, pc, include_boundaries); } // comparator for qsort static int dcmp(const void *pd1, const void *pd2) { double d1=*((double *)pd1), d2=*((double *)pd2); return (d1d2) ? 1.0 : 0.0; } /******************************************************************/ /* 3D line-prism intersection: compute all values of s at which */ /* the line p+s*d intersects a prism face. */ /* pc, dc = cartesian coordinates of p, cartesian components of d */ /* slist is a caller-allocated buffer with enough room for */ /* at least num_vertices+2 doubles. on return it contains */ /* the intersection s-values sorted in ascending order. */ /* the return value is the number of intersections. */ /******************************************************************/ int intersect_line_with_prism(prism *prsm, vector3 pc, vector3 dc, double *slist) { vector3 pp = prism_coordinate_c2p(prsm,pc); vector3 dp = prism_vector_c2p(prsm,dc); vector3 *vps = prsm->vertices_p.items; int num_vertices = prsm->vertices_p.num_items; double height = prsm->height; // use length of first polygon edge as a length scale for judging // lengths to be small or large double length_scale = vector3_norm(vector3_minus(vps[1], vps[0])); // identify intersections with prism side faces int num_intersections=0; int nv; for(nv=0; nvzp_max) ) continue; slist[num_intersections++]=s; } // identify intersections with prism ceiling and floor faces int LowerUpper; if ( fabs(dp.z) > 1.0e-7*vector3_norm(dp) ) for(LowerUpper=0; LowerUpper<2; LowerUpper++) { double z0p = LowerUpper ? height : 0.0; double s = (z0p - pp.z)/dp.z; if (!node_in_polygon(pp.x+s*dp.x, pp.y+s*dp.y, vps, num_vertices)) continue; slist[num_intersections++]=s; } qsort((void *)slist,num_intersections,sizeof(double),dcmp); return num_intersections; } /***************************************************************/ /***************************************************************/ /***************************************************************/ double intersect_line_segment_with_prism(prism *prsm, vector3 pc, vector3 dc, double a, double b) { double *slist=prsm->workspace.items; int num_intersections=intersect_line_with_prism(prsm, pc, dc, slist); // na=smallest index such that slist[na] > a int na=-1; int ns; for(ns=0; na==-1 && nsa) na=ns; if (na==-1) return 0.0; int inside = ( (na%2)==0 ? 0 : 1); double last_s=a; double ds=0.0; for(ns=na; ns 0.0 ? ds : 0.0; } /***************************************************************/ /* compute the minimum distance from a 3D point p to the */ /* line segment with endpoints v1,v2. */ /* algorithm: let pLine = v1 + d*(v2-v1) be the point on the */ /* line closest to p; d is defined by minimizing |p-pLine|^2. */ /* --> |p-v1|^2 + d^2 |v2-v1|^2 - 2*d*dot(p-v1,v2-v1) = min */ /* --> 2d |v2-v1|^2 - 2*dot(p-v1,v2-v1) = 0 */ /* --> d = dot(p-v1,v2-v1) / |v2-v1|^2 */ /***************************************************************/ double min_distance_to_line_segment(vector3 p, vector3 v1, vector3 v2) { vector3 v2mv1 = vector3_minus(v2,v1); vector3 pmv1 = vector3_minus(p,v1); double d = vector3_dot(v2mv1,pmv1) / vector3_dot(v2mv1,v2mv1); if (d<0.0) d=0.0; // if pProj lies outside the line segment, if (d>1.0) d=1.0; // displace it to whichever vertex is closer vector3 pLine = vector3_plus(v1, vector3_scale(d,v2mv1)); return vector3_norm(vector3_minus(p,pLine)); } /***************************************************************/ /* compute the projection of a 3D point p into the plane */ /* that contains the three points {o, o+v1, o+v2} and has */ /* normal vector v3. */ /* algorithm: solve a 3x3 system to compute the projection of */ /* p into the plane (call it pPlane) */ /* pPlane = p-s*v3 = o + t*v1 + u*v2 */ /* where v3 is the normal to the plane and s,t,u */ /* are unknowns. */ /* the return value is the value of s (where pPlane = p-s*v3), */ /* i.e. the minimum distance from p to the plane. */ /* if in_quadrilateral is non-null it is set to 0 */ /* or 1 according as pPlane does or does not lie in the */ /* quadrilateral with vertices (o, o+v1, o+v2, o+v1+v2). */ /***************************************************************/ double normal_distance_to_plane(vector3 p, vector3 o, vector3 v1, vector3 v2, vector3 v3, int *in_quadrilateral) { CHECK( (vector3_norm(v3)>1.0e-6), "degenerate plane in project_point_into_plane" ); matrix3x3 M; M.c0 = v1; M.c1 = v2; M.c2 = v3; vector3 RHS = vector3_minus(p,o); vector3 tus = matrix3x3_vector3_mult(matrix3x3_inverse(M),RHS); // "t, u, s" float t=tus.x, u=tus.y, s=tus.z; if (in_quadrilateral) *in_quadrilateral = ( ( 0.0<=t && t<=1.0 && 0.0<=u && u<=1.0 ) ? 1 : 0 ); return s; } // like normal_distance_to_plane, but if pPlane (projection of point into plane) // lies outside the quadrilateral {o,o+v1,o+v2,o+v1+v2} then take into account // the in-plane distance from pPlane to the quadrilateral double min_distance_to_quadrilateral(vector3 p, vector3 o, vector3 v1, vector3 v2, vector3 v3) { int inside; double s=normal_distance_to_plane(p, o, v1, v2, v3, &inside); if(inside==1) return s; vector3 pPlane = vector3_minus(p, vector3_scale(s,v3) ); vector3 p01 = vector3_plus(o,v1); vector3 p10 = vector3_plus(o,v2); vector3 p11 = vector3_plus(p01,v2); double d = min_distance_to_line_segment(pPlane, o, p01) ; d = fmin(d, min_distance_to_line_segment(pPlane, o, p10) ); d = fmin(d, min_distance_to_line_segment(pPlane, p01, p11) ); d = fmin(d, min_distance_to_line_segment(pPlane, p11, p10) ); return sqrt(s*s+d*d); } // fc==0/1 for floor/ceiling double min_distance_to_prism_roof_or_ceiling(vector3 pp, prism *prsm, int fc) { vector3 *vps = prsm->vertices_p.items; int num_vertices = prsm->vertices_p.num_items; vector3 op = {0.0,0.0,0.0}; if (fc==1) op.z = prsm->height; // origin of floor/ceiling vector3 zhatp = {0,0,1.0}; double s = normal_distance_to_plane(pp,op,vps[0],vps[1],zhatp,0); vector3 ppProj = vector3_minus(pp, vector3_scale(s,zhatp) ); // projection of p into plane of floor/ceiling if (node_in_polygon(ppProj.x,ppProj.y,vps,num_vertices)==1) return s; int nv; double d=min_distance_to_line_segment(ppProj,vps[0],vps[1] ); for(nv=1; nvheight==0.0) return prsm->axis; double height = prsm->height; vector3 *vps = prsm->vertices_p.items; int num_vertices = prsm->vertices_p.num_items; vector3 zhatp = {0.0, 0.0, 1.0}; vector3 axisp = vector3_scale(height, zhatp); vector3 pp = prism_coordinate_c2p(prsm, pc); vector3 retval; double min_distance=HUGE_VAL; int nv; // consider side walls for(nv=0; nvvertices.items; int num_vertices = prsm->vertices.num_items; box->low = box->high = vertices[0]; int nv, fc; for(nv=0; nvheight, prsm->axis) ); box->low.x = fmin(box->low.x, v.x); box->low.y = fmin(box->low.y, v.y); box->low.z = fmin(box->low.z, v.z); box->high.x = fmax(box->high.x, v.x); box->high.y = fmax(box->high.y, v.y); box->high.z = fmax(box->high.z, v.z); } } /***************************************************************/ /***************************************************************/ /***************************************************************/ void display_prism_info(int indentby, geometric_object *o) { prism *prsm = o->subclass.prism_data; vector3 *vs = prsm->vertices.items; int num_vertices = prsm->vertices.num_items; ctl_printf("%*s height %g, axis (%g,%g,%g), %i vertices:\n", indentby, "",prsm->height,prsm->axis.x,prsm->axis.y,prsm->axis.z,num_vertices); int nv; for(nv=0; nvprism that are assumed to */ /* be initialized are: vertices, height, and (optionally) axis.*/ /* If axis has not been initialized (i.e. it is set to its */ /* default value, which is the zero vector) then the prism axis*/ /* is automatically computed as the normal to the vertex plane.*/ /* If o->center is equal to auto_center on entry, then it is */ /* set to the prism center, as computed from the vertices, */ /* axis, and height. Otherwise, the prism is rigidly translated*/ /* to center it at the specified value of o->center. */ /***************************************************************/ // special vector3 that signifies 'no value specified' vector3 auto_center = { NAN, NAN, NAN }; void init_prism(geometric_object *o) { prism *prsm = o->subclass.prism_data; vector3 *vertices = prsm->vertices.items; int num_vertices = prsm->vertices.num_items; CHECK(num_vertices>=3, "fewer than 3 vertices in init_prism"); // compute centroid of vertices vector3 centroid = {0.0, 0.0, 0.0}; int nv; for(nv=0; nvcentroid = centroid = vector3_scale(1.0/((double)num_vertices), centroid); // make sure all vertices lie in a plane, i.e. that the normal // vectors to all triangles (v_n, v_{n+1}, centroid) agree. int plane_normal_set=0; vector3 plane_normal; double tol=1.0e-6; for(nv=0; nvaxis) == 0.0 ) prsm->axis = plane_normal; else { prsm->axis = unit_vector3(prsm->axis); boolean axis_normal_to_plane = ( vector3_nearly_equal(prsm->axis, plane_normal, tol) || vector3_nearly_equal(prsm->axis, vector3_scale(-1.0,plane_normal), tol) ); CHECK(axis_normal_to_plane, "axis not normal to vertex plane in init_prism"); } // set current_center=prism center as determined by vertices and height. // if the center of the geometric object was left unspecified, // set it to current_center; otherwise displace the entire prism // so that it is centered at the specified center. vector3 current_center = vector3_plus(centroid, vector3_scale(0.5*prsm->height,prsm->axis) ); if (isnan(o->center.x) && isnan(o->center.y) && isnan(o->center.z)) // center == auto-center o->center = current_center; else { vector3 shift = vector3_minus(o->center, current_center); for(nv=0; nvaxis; if (vector3_nearly_equal(zhat, x0hat, tol)) { xhat=y0hat; yhat=z0hat; } else if (vector3_nearly_equal(zhat, y0hat, tol)) { xhat=z0hat; yhat=x0hat; } else if (vector3_nearly_equal(zhat, z0hat, tol)) { xhat=x0hat; yhat=y0hat; } else { xhat = unit_vector3(vector3_minus(vertices[1],vertices[0])); yhat = unit_vector3(vector3_cross(zhat,xhat)); } matrix3x3 m_p2c = {xhat, yhat, zhat}; prsm->m_p2c = m_p2c; prsm->m_c2p = matrix3x3_inverse(m_p2c); // compute vertices in prism coordinate system prsm->vertices_p.num_items = num_vertices; prsm->vertices_p.items = (vector3 *)malloc(num_vertices*sizeof(vector3)); for(nv=0; nvvertices_p.items[nv] = prism_coordinate_c2p(prsm,vertices[nv]); // workspace is an internally-stored double-valued array of length num_vertices+2 // that is used by some geometry routines prsm->workspace.num_items = num_vertices+2; prsm->workspace.items = (double *)malloc( (num_vertices+2)*sizeof(double) ); } /***************************************************************/ /* routines called from C++ or python codes to create prisms */ /***************************************************************/ // prism with center determined automatically from vertices, height, and axis geometric_object make_prism(material_type material, const vector3 *vertices, int num_vertices, double height, vector3 axis) { return make_prism_with_center(material, auto_center, vertices, num_vertices, height, axis); } // prism in which all vertices are translated to ensure that the prism is centered at center geometric_object make_prism_with_center(material_type material, vector3 center, const vector3 *vertices, int num_vertices, double height, vector3 axis) { geometric_object o=make_geometric_object(material, center); o.which_subclass=GEOM PRISM; prism *prsm = o.subclass.prism_data = MALLOC1(prism); CHECK(prsm, "out of memory"); prsm->vertices.num_items = num_vertices; prsm->vertices.items = (vector3 *)malloc(num_vertices*sizeof(vector3)); CHECK(prsm->vertices.items, "out of memory"); memcpy(prsm->vertices.items, vertices, num_vertices*sizeof(vector3)); prsm->height = height; prsm->axis = axis; init_prism(&o); return o; } libctl-4.4.0/utils/geom.scm000066400000000000000000000333661356267410600156100ustar00rootroot00000000000000; libctl: flexible Guile-based control files for scientific software ; Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson ; ; This library is free software; you can redistribute it and/or ; modify it under the terms of the GNU Lesser General Public ; License as published by the Free Software Foundation; either ; version 2 of the License, or (at your option) any later version. ; ; This library is distributed in the hope that it will be useful, ; but WITHOUT ANY WARRANTY; without even the implied warranty of ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ; Lesser General Public License for more details. ; ; You should have received a copy of the GNU Lesser General Public ; License along with this library; if not, write to the ; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ; Boston, MA 02111-1307, USA. ; ; Steven G. Johnson can be contacted at stevenj@alum.mit.edu. ; **************************************************************** (if (defined? 'ctl-io-c-only?) (set! ctl-io-c-only? true)) (define MATERIAL-TYPE (if (defined? 'material-type) 'material-type 'SCM)) ; A default material so that we don't have to specify a material for ; an object when we just care about its geometry. If material-type is ; an "abstract superclass" (no properties of its own), programs could ; interpret this as equating to default-material (below). However, we ; only define this default if (make material-type) works, i.e. if ; defaults exist for all properties (if any) of material-type. (define nothing (if (eq? MATERIAL-TYPE 'SCM) '() (if (for-all? (class-properties-all material-type) property-has-default?) (make material-type) no-default))) (define-class geometric-object no-parent (define-property material nothing MATERIAL-TYPE) (define-property center no-default 'vector3)) (define-class compound-geometric-object geometric-object (define-property component-objects '() (make-list-type 'geometric-object))) (define (non-negative? x) (not (negative? x))) (define-class cylinder geometric-object (define-post-processed-property axis (vector3 0 0 1) 'vector3 unit-vector3) (define-property radius no-default 'number non-negative?) (define-property height no-default 'number non-negative?)) (define-class cone cylinder (define-property radius2 0 'number)) (define-class wedge cylinder (define-property wedge-angle (* 8 (atan 1)) 'number) (define-property wedge-start (vector3 1 0 0) 'vector3) (define-derived-property e1 'vector3 (lambda (object) (let ((a (object-property-value object 'axis)) (s (object-property-value object 'wedge-start))) (unit-vector3 (vector3- s (vector3-scale (vector3-dot a s) a)))))) (define-derived-property e2 'vector3 (lambda (object) (let ((a (object-property-value object 'axis)) (e1 (object-property-value object 'e1))) (vector3-cross a e1))))) (define-class sphere geometric-object (define-property radius no-default 'number non-negative?)) (define-class block geometric-object (define-post-processed-property e1 (vector3 1 0 0) 'vector3 unit-vector3) (define-post-processed-property e2 (vector3 0 1 0) 'vector3 unit-vector3) (define-post-processed-property e3 (vector3 0 0 1) 'vector3 unit-vector3) (define-property size no-default 'vector3) (define-derived-property projection-matrix 'matrix3x3 (lambda (object) (matrix3x3-inverse (matrix3x3 (object-property-value object 'e1) (object-property-value object 'e2) (object-property-value object 'e3)))))) (define identity_matrix (matrix3x3 (vector3 1 0 0) (vector3 0 1 0) (vector3 0 0 1))) ; some notes regarding prisms: ; (a) When instantiating a prism, typically only the ; fields `vertices`, `height,` and (optionally) `axis` ; will be initialized by the user; all remaining fields are ; derived properties that are computed internally. (So, morally ; they should be thought of as having been declared using ; `define-derived-property` or `define-post-processed-property,` ; except here the code that does the derivation or ; post-processing is implemented in C, not scheme.) ; (b) The suffix _p (for "prism") is used to identify variables ; that store coordinates of points or components of vectors ; in the prism coordinate system. (The prism coordinate system ; is defined by the condition that the prism axis is the z-axis ; and the prism floor lies in the xy plane at z==0.) Variables ; with no suffix refer to quantities in ordinary 3D space. ; (c) "centroid" refers to the centroid of the prism floor polygon; this is ; the origin of the prism coordinate system [i.e. by definition ; we have centroid_p=(0 0 0)]. ; (d) If 'axis' is left unspecified, it is inferred to be the ; normal to the plane of the prism floor, with sign defined ; by a right-hand-rule with respect to the first two vertices, i.e. ; axis = normal_vector( (v1-centroid) x (v2-centroid) ) ; (e) The specification of the prism vertices and height suffices to ; determine the center of the geometric object ; (center = centroid + 0.5*height*axis), so---in contrast to all other ; types of geometric-object---there is no need to specify the `center` ; field when instantiating a prism. (define-class prism geometric-object ; fields to be filled in by users (define-property vertices '() (make-list-type 'vector3)) (define-property height 0 'number) (define-property axis (vector3 0 0 0) 'vector3) ; derived fields computed internally (define-property vertices_p '() (make-list-type 'vector3)) (define-property centroid (vector3 0 0 0) 'vector3) (define-property workspace '() (make-list-type 'number)) (define-property m_c2p identity_matrix 'matrix3x3) (define-property m_p2c identity_matrix 'matrix3x3)) (define-class ellipsoid block (define-derived-property inverse-semi-axes 'vector3 (lambda (object) (vector-map (lambda (x) (/ 2.0 x)) (object-property-value object 'size))))) ; **************************************************************** (define-class lattice no-parent (define-post-processed-property basis1 (vector3 1 0 0) 'vector3 unit-vector3) (define-post-processed-property basis2 (vector3 0 1 0) 'vector3 unit-vector3) (define-post-processed-property basis3 (vector3 0 0 1) 'vector3 unit-vector3) (define-property size (vector3 1 1 1) 'vector3) (define-property basis-size (vector3 1 1 1) 'vector3) (define-derived-property b1 'vector3 (lambda (object) (vector3-scale (vector3-x (object-property-value object 'basis-size)) (object-property-value object 'basis1)))) (define-derived-property b2 'vector3 (lambda (object) (vector3-scale (vector3-y (object-property-value object 'basis-size)) (object-property-value object 'basis2)))) (define-derived-property b3 'vector3 (lambda (object) (vector3-scale (vector3-z (object-property-value object 'basis-size)) (object-property-value object 'basis3)))) (define-derived-property basis 'matrix3x3 (lambda (object) (let ((B (matrix3x3 (object-property-value object 'b1) (object-property-value object 'b2) (object-property-value object 'b3)))) (if (zero? (matrix3x3-determinant B)) (error "lattice basis vectors must be linearly independent!")) B))) (define-derived-property metric 'matrix3x3 (lambda (object) (let ((B (object-property-value object 'basis))) (matrix3x3* (matrix3x3-transpose B) B))))) ; **************************************************************** ; Define some utility functions: (define (shift-geometric-object go shift-vector) (let ((c (object-property-value go 'center))) (modify-object go (center (vector3+ c shift-vector))))) (define (geometric-object-duplicates shift-vector min-multiple max-multiple go) (define (g-o-d min-multiple L) (if (<= min-multiple max-multiple) (g-o-d (+ min-multiple 1) (cons (shift-geometric-object go (vector3-scale min-multiple shift-vector)) L)) L)) (g-o-d min-multiple '())) (define (geometric-objects-duplicates shift-vector min-multiple max-multiple go-list) (fold-left append '() (map (lambda (go) (geometric-object-duplicates shift-vector min-multiple max-multiple go)) go-list))) (define (lattice-duplicates lat go-list . usize) (define (lat->lattice v) (cartesian->lattice (matrix3x3* (object-property-value lat 'basis) v))) (let ((u1 (if (>= (length usize) 1) (list-ref usize 0) 1)) (u2 (if (>= (length usize) 2) (list-ref usize 1) 1)) (u3 (if (>= (length usize) 3) (list-ref usize 2) 1)) (s (object-property-value lat 'size))) (let ((b1 (lat->lattice (vector3 u1 0 0))) (b2 (lat->lattice (vector3 0 u2 0))) (b3 (lat->lattice (vector3 0 0 u3))) (n1 (ceiling (/ (vector3-x s) u1))) (n2 (ceiling (/ (vector3-y s) u2))) (n3 (ceiling (/ (vector3-z s) u3)))) (geometric-objects-duplicates b1 (- (floor (/ (- n1 1) 2))) (ceiling (/ (- n1 1) 2)) (geometric-objects-duplicates b2 (- (floor (/ (- n2 1) 2))) (ceiling (/ (- n2 1) 2)) (geometric-objects-duplicates b3 (- (floor (/ (- n3 1) 2))) (ceiling (/ (- n3 1) 2)) go-list)))))) (define (geometric-objects-lattice-duplicates go-list . usize) (apply lattice-duplicates (cons geometry-lattice (cons go-list usize)))) ; **************************************************************** (define-input-var dimensions 3 'integer) (define-input-var default-material nothing MATERIAL-TYPE) (define-input-var geometry-center (vector3 0) 'vector3) (define-input-var geometry-lattice (make lattice) 'lattice) (define-input-var geometry '() (make-list-type 'geometric-object)) (define-input-var ensure-periodicity true 'boolean) ; special vector3 that signifies 'no value specified' (define auto-center (vector3 (nan) (nan) (nan))) (define-external-function point-in-object? true false 'boolean 'vector3 'geometric-object) (define-external-function normal-to-object true false 'vector3 'vector3 'geometric-object) (define-external-function point-in-periodic-object? true false 'boolean 'vector3 'geometric-object) ; (define-external-function material-of-point true false ; MATERIAL-TYPE 'vector3) (define-external-function display-geometric-object-info false false no-return-value 'integer 'geometric-object) (define-external-function range-overlap-with-object true false 'number 'vector3 'vector3 'geometric-object 'number 'integer) (define-external-function square-basis false false 'matrix3x3 'matrix3x3 'vector3) ; **************************************************************** ; Functions and variables for determining the grid size (define no-size 1e-20) ; for when a particular lattice dimension has no size (define-param resolution 10) ; the resolution (may be a vector3) (define-param grid-size false) ; force grid size, if set (define (get-resolution) (if (vector? resolution) resolution (vector3 resolution resolution resolution))) (define (get-grid-size) (if grid-size grid-size (let ((res (get-resolution))) (vector-map (lambda (x) (inexact->exact (max (ceiling x) 1))) (vector-map * res (object-property-value geometry-lattice 'size)))))) (define (get-grid-size-prod) (let ((s (get-grid-size))) (* (vector3-x s) (vector3-y s) (vector3-z s)))) ; **************************************************************** ; Cartesian conversion and rotation for lattice and reciprocal coords: ; The following conversion routines work for vector3 and matrix3x3 arguments: (define (lattice->cartesian x) (if (vector3? x) (matrix3x3* (object-property-value geometry-lattice 'basis) x) (matrix3x3* (matrix3x3* (object-property-value geometry-lattice 'basis) x) (matrix3x3-inverse (object-property-value geometry-lattice 'basis))))) (define (cartesian->lattice x) (if (vector3? x) (matrix3x3* (matrix3x3-inverse (object-property-value geometry-lattice 'basis)) x) (matrix3x3* (matrix3x3* (matrix3x3-inverse (object-property-value geometry-lattice 'basis)) x) (object-property-value geometry-lattice 'basis)))) (define (reciprocal->cartesian x) (let ((s (vector-map (lambda (x) (if (= x no-size) 1 x)) (object-property-value geometry-lattice 'size)))) (let ((Rst (matrix3x3-transpose (matrix3x3* (object-property-value geometry-lattice 'basis) (matrix3x3 (vector3 (vector3-x s) 0 0) (vector3 0 (vector3-y s) 0) (vector3 0 0 (vector3-z s))))))) (if (vector3? x) (matrix3x3* (matrix3x3-inverse Rst) x) (matrix3x3* (matrix3x3* (matrix3x3-inverse Rst) x) Rst))))) (define (cartesian->reciprocal x) (let ((s (vector-map (lambda (x) (if (= x no-size) 1 x)) (object-property-value geometry-lattice 'size)))) (let ((Rst (matrix3x3-transpose (matrix3x3* (object-property-value geometry-lattice 'basis) (matrix3x3 (vector3 (vector3-x s) 0 0) (vector3 0 (vector3-y s) 0) (vector3 0 0 (vector3-z s))))))) (if (vector3? x) (matrix3x3* Rst x) (matrix3x3* (matrix3x3* Rst x) (matrix3x3-inverse Rst)))))) (define (lattice->reciprocal x) (cartesian->reciprocal (lattice->cartesian x))) (define (reciprocal->lattice x) (cartesian->lattice (reciprocal->cartesian x))) ; rotate vectors in lattice/reciprocal coords (note that the axis ; is also given in the corresponding basis): (define (rotate-lattice-vector3 axis theta v) (cartesian->lattice (rotate-vector3 (lattice->cartesian axis) theta (lattice->cartesian v)))) (define (rotate-reciprocal-vector3 axis theta v) (cartesian->reciprocal (rotate-vector3 (reciprocal->cartesian axis) theta (reciprocal->cartesian v)))) ; **************************************************************** libctl-4.4.0/utils/geomtst.c000066400000000000000000000211571356267410600157760ustar00rootroot00000000000000#include #include #include #include #include "ctlgeom.h" /************************************************************************/ /* return a random number in [0,1]: */ static double mydrand(void) { double d = rand(); return (d / (double) RAND_MAX); } /* return a uniform random number in [a,b] */ static double myurand(double a, double b) { return ((b - a) * mydrand() + a); } #define K_PI 3.141592653589793238462643383279502884197 /* return a random unit vector, uniformly distributed over a sphere */ vector3 random_unit_vector3(void) { double z, t, r; vector3 v; z = 2*mydrand() - 1; t = 2*K_PI*mydrand(); r = sqrt(1 - z*z); v.x = r * cos(t); v.y = r * sin(t); v.z = z; return v; } double find_edge(geometric_object o, vector3 dir, double max, double tol) { double min = 0; if (!(point_in_fixed_objectp(vector3_scale(min, dir), o) && !point_in_fixed_objectp(vector3_scale(max, dir), o))) { fprintf(stderr, "object out of bounds in find_edge"); exit(1); } do { double d = (min + max) / 2; if (point_in_fixed_objectp(vector3_scale(d, dir), o)) min = d; else max = d; } while (max - min > tol); return (min + max) / 2; } static vector3 make_vector3(double x, double y, double z) { vector3 v; v.x = x; v.y = y; v.z = z; return v; } /* return a random geometric object, centered at the origin, with diameter roughly 1 */ geometric_object random_object(void) { void* m = NULL; vector3 c = { 0, 0, 0 }; geometric_object o; switch (rand() % 5) { case 0: o = make_sphere(m, c, myurand(0.5,1.5)); break; case 1: o = make_cylinder(m, c, myurand(0.5,1.5), myurand(0.5,1.5), random_unit_vector3()); break; case 2: o = make_cone(m, c, myurand(0.5,1.5), myurand(0.5,1.5), random_unit_vector3(), myurand(0.5,1.5)); break; case 3: o = make_block(m, c, #if 1 random_unit_vector3(), random_unit_vector3(), random_unit_vector3(), #else make_vector3(1,0,0), make_vector3(0,1,0), make_vector3(0,0,1), #endif make_vector3(myurand(0.5,1.5), myurand(0.5,1.5), myurand(0.5,1.5))); break; case 4: o = make_ellipsoid(m, c, random_unit_vector3(), random_unit_vector3(), random_unit_vector3(), make_vector3(myurand(0.5,1.5), myurand(0.5,1.5), myurand(0.5,1.5))); break; } return o; } /************************************************************************/ static double z1(double x) { return (x == 0 ? 1.0 : x); } static double simple_overlap(geom_box b, geometric_object o, double tol) { double d1,d2,d3, x1,x2,x3, olap0 = 0; double itol = 1.0 / ((int) (1/tol + 0.5)); d1 = (b.high.x - b.low.x) * itol; d2 = (b.high.y - b.low.y) * itol; d3 = (b.high.z - b.low.z) * itol; for (x1 = b.low.x + d1*0.5; x1 <= b.high.x; x1 += d1+(b.high.x==b.low.x)) for (x2 = b.low.y + d2*0.5; x2 <= b.high.y; x2 += d2+(b.high.y==b.low.y)) for (x3 = b.low.z + d3*0.5; x3 <= b.high.z; x3 += d3+(b.high.z==b.low.z)){ vector3 v; v.x = x1; v.y = x2; v.z = x3; olap0 += z1(d1)*z1(d2)*z1(d3) * point_in_fixed_objectp(v, o); } olap0 /= z1(b.high.x-b.low.x) * z1(b.high.y-b.low.y) * z1(b.high.z-b.low.z); return olap0; } static double sqr(double x) { return x * x; } static double simple_ellip_overlap(geom_box b, geometric_object o, double tol) { double d1,d2,d3, x1,x2,x3, c1,c2,c3, w1,w2,w3, olap0 = 0; double itol = 1.0 / ((int) (1/tol + 0.5)); int dim; d1 = (b.high.x - b.low.x) * itol; d2 = (b.high.y - b.low.y) * itol; d3 = (b.high.z - b.low.z) * itol; c1 = (b.high.x + b.low.x) * 0.5; c2 = (b.high.y + b.low.y) * 0.5; c3 = (b.high.z + b.low.z) * 0.5; w1 = 2.0 / z1(b.high.x - b.low.x); w2 = 2.0 / z1(b.high.y - b.low.y); w3 = 2.0 / z1(b.high.z - b.low.z); for (x1 = b.low.x + d1*0.5; x1 <= b.high.x; x1 += d1+(b.high.x==b.low.x)) for (x2 = b.low.y + d2*0.5; x2 <= b.high.y; x2 += d2+(b.high.y==b.low.y)) for (x3 = b.low.z + d3*0.5; x3 <= b.high.z; x3 += d3+(b.high.z==b.low.z)) if (sqr((x1 - c1) * w1) + sqr((x2 - c2) * w2) + sqr((x3 - c3) * w3) < 1.0) { vector3 v; v.x = x1; v.y = x2; v.z = x3; olap0 += z1(d1)*z1(d2)*z1(d3) * point_in_fixed_objectp(v, o); } olap0 /= z1(b.high.x-b.low.x) * z1(b.high.y-b.low.y) * z1(b.high.z-b.low.z); dim = (b.high.x!=b.low.x) + (b.high.y!=b.low.y) + (b.high.z!=b.low.z); olap0 /= dim == 3 ? 3.14159265358979323846 / 6 : (dim == 2 ? 3.14159265358979323846 / 4 : 1); return olap0; } geometric_object random_object_and_lattice(void) { geometric_object o = random_object(); #if 1 geometry_lattice.basis1 = random_unit_vector3(); geometry_lattice.basis2 = random_unit_vector3(); geometry_lattice.basis3 = random_unit_vector3(); geom_fix_lattice(); geom_fix_object_ptr(&o); #endif return o; } static const char *object_name(geometric_object o) { switch (o.which_subclass) { case CYLINDER: switch (o.subclass.cylinder_data->which_subclass) { case WEDGE: return "wedge"; case CONE: return "cone"; case CYLINDER_SELF: return "cylinder"; } case SPHERE: return "sphere"; case BLOCK: switch (o.subclass.block_data->which_subclass) { case ELLIPSOID: return "ellipsoid"; case BLOCK_SELF: return "block"; } case PRISM: return "prism"; case COMPOUND_GEOMETRIC_OBJECT: return "compound object"; default: return "geometric object"; } } void check_overlap(double tol, double olap0, double olap, int dim, geometric_object o, geom_box b) { if (fabs(olap0 - olap) > 2 * tol * fabs(olap)) { fprintf(stderr, "Large error %e in overlap (%g vs. %g) for:\n" " lattice = (%g,%g,%g), (%g,%g,%g), (%g,%g,%g)\n" " box = (%g,%g,%g) - (%g,%g,%g)\n", fabs(olap0 - olap) / fabs(olap), olap, olap0, geometry_lattice.basis1.x, geometry_lattice.basis1.y, geometry_lattice.basis1.z, geometry_lattice.basis2.x, geometry_lattice.basis2.y, geometry_lattice.basis2.z, geometry_lattice.basis3.x, geometry_lattice.basis3.y, geometry_lattice.basis3.z, b.low.x, b.low.y, b.low.z, b.high.x, b.high.y, b.high.z); display_geometric_object_info(2, o); /* exit(1); */ } else printf("Got %s %dd overlap %g vs. %g with tol = %e\n", object_name(o), dim,olap,olap0,tol); } static void test_overlap(double tol, number (*box_overlap_with_object) (geom_box b, geometric_object o, number tol, integer maxeval), double (*simple_overlap) (geom_box b, geometric_object o, double tol)) { geometric_object o = random_object_and_lattice(); vector3 dir = random_unit_vector3(); geom_box b; double d, olap, olap0; int dim; b.low = make_vector3(myurand(-1,0), myurand(-1,0), myurand(-1,0)); b.high = make_vector3(myurand(0,1), myurand(0,1), myurand(0,1)); d = find_edge(o, dir, 10, tol); b.low = vector3_plus(b.low, vector3_scale(d, dir)); b.high = vector3_plus(b.high, vector3_scale(d, dir)); dim = rand() % 3 + 1; if (dim < 3) b.low.z = b.high.z = 0; if (dim < 2) b.low.y = b.high.y = 0; olap = box_overlap_with_object(b, o, tol/100, 10000/tol); olap0 = simple_overlap(b, o, tol/2); check_overlap(tol, olap0, olap, dim, o, b); geometric_object_destroy(o); } static void test_volume(double tol) { geometric_object o = random_object_and_lattice(); geom_box b; double olap1, olap2; geom_get_bounding_box(o, &b); olap1 = box_overlap_with_object(b, o, tol/100, 10000/tol); b.low.x += 1e-7 * (b.high.x - b.low.x); /* b no longer contains o */ olap2 = box_overlap_with_object(b, o, tol/100, 10000/tol); check_overlap(tol, olap1, olap2, 3, o, b); geometric_object_destroy(o); } /************************************************************************/ int main(void) { const int ntest = 100; const double tol = 1e-2; int i; srand(time(NULL)); geom_initialize(); printf("**** whole box overlap: ****\n"); for (i = 0; i < ntest; ++i) test_volume(tol); for (i = 0; i < ntest; ++i) { printf("**** box overlap: ****\n"); test_overlap(tol, box_overlap_with_object, simple_overlap); printf("**** ellipsoid overlap: ****\n"); test_overlap(tol, ellipsoid_overlap_with_object, simple_ellip_overlap); } return 0; } libctl-4.4.0/utils/nlopt.c000066400000000000000000000063741356267410600154540ustar00rootroot00000000000000/* wrapper around NLopt nonlinear optimization library (if installed) */ #ifdef HAVE_NLOPT #include #include #include #include #include static double f_scm_wrap(integer n, const double *x, double *grad, void *f_scm_p) { SCM *f_scm = (SCM *) f_scm_p; SCM ret = gh_call1(*f_scm, make_number_list(n, x)); if (scm_real_p(ret)) return scm_to_double(ret); else { /* otherwise must be a list of value, gradient components, i.e. (cons value gradient). */ SCM gscm = ret; int i; for (i = 0; i < n; ++i) { gscm = SCM_CDR(gscm); grad[i] = scm_to_double(SCM_CAR(gscm)); } return scm_to_double(SCM_CAR(ret)); } } /* Scheme-callable wrapper for nlopt_minimize() function. Note that Guile-callable C subroutines cannot take more than 10 arguments (grrr), so we past the last few arguments with a "rest" list parameter */ SCM nlopt_minimize_scm(SCM algorithm_scm, SCM f_scm, SCM lb_scm, SCM ub_scm, SCM x_scm, SCM minf_max_scm, SCM ftol_rel_scm, SCM ftol_abs_scm, SCM rest /* SCM xtol_rel_scm, SCM xtol_abs_scm, SCM maxeval_scm, SCM maxtime_scm */) { nlopt_algorithm algorithm = (nlopt_algorithm) scm_to_int(algorithm_scm); int i, n = list_length(x_scm); double *x, *lb, *ub, *xtol_abs = 0; double minf_max = scm_to_double(minf_max_scm); double ftol_rel = scm_to_double(ftol_rel_scm); double ftol_abs = scm_to_double(ftol_abs_scm); double xtol_rel = 0; double maxeval = 0; double maxtime = 0; int nrest = list_length(rest); /* double xtol_rel = scm_to_double(xtol_rel_scm); int maxeval = scm_to_int(maxeval_scm); double maxtime = scm_to_double(maxtime_scm); */ double minf; nlopt_result result; SCM v, ret; x = (double *) malloc(sizeof(double) * n * 4); lb = x + n; ub = lb + n; if (!x) { fprintf(stderr, "nlopt_minimize_scm: out of memory!\n"); exit(EXIT_FAILURE); } if (list_length(lb_scm) != n || list_length(ub_scm) != n) { fprintf(stderr, "nlopt_minimize_scm: invalid arguments\n"); exit(EXIT_FAILURE); } for (v=x_scm, i=0; i < n; ++i) { x[i] = scm_to_double(SCM_CAR(v)); v = SCM_CDR(v); } for (v=lb_scm, i=0; i < n; ++i) { lb[i] = scm_to_double(SCM_CAR(v)); v = SCM_CDR(v); } for (v=ub_scm, i=0; i < n; ++i) { ub[i] = scm_to_double(SCM_CAR(v)); v = SCM_CDR(v); } if (nrest >= 1) xtol_rel = scm_to_double(SCM_CAR(rest)); if (nrest >= 2) { SCM xtol_abs_scm = scm_cadr(rest); if (list_length(xtol_abs_scm)) { xtol_abs = ub + n; for (v=xtol_abs_scm, i=0; i < n; ++i) { xtol_abs[i] = scm_to_double(SCM_CAR(v)); v = SCM_CDR(v); } } } if (nrest >= 3) maxeval = scm_to_int(scm_caddr(rest)); if (nrest >= 4) maxtime = scm_to_double(scm_cadddr(rest)); result = nlopt_minimize(algorithm, n, f_scm_wrap, &f_scm, lb, ub, x, &minf, minf_max, ftol_rel, ftol_abs, xtol_rel, xtol_abs, maxeval, maxtime); ret = scm_cons(scm_from_int((int) result), scm_cons(scm_from_double(minf), make_number_list(n, x))); free(x); return ret; } #endif /* HAVE_NLOPT */ libctl-4.4.0/utils/test-prism.c000066400000000000000000000567531356267410600164350ustar00rootroot00000000000000/* libctl: flexible Guile-based control files for scientific software * Copyright (C) 1998-2019 Massachusetts Institute of Technology and Steven G. Johnson * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public * License as published by the Free Software Foundation; either * version 2 of the License, or (at your option) any later version. * * This library is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * Lesser General Public License for more details. * * You should have received a copy of the GNU Lesser General Public * License along with this library; if not, write to the * Free Software Foundation, Inc., 59 Temple Place - Suite 330, * Boston, MA 02111-1307, USA. * * Steven G. Johnson can be contacted at stevenj@alum.mit.edu. */ /************************************************************************/ /* test-prism.c: unit test for prisms in libctlgeom */ /* homer reid 5/2018 */ /************************************************************************/ #include #include #include #include #include #include "ctlgeom.h" vector3 normal_to_plane(vector3 o, vector3 v1, vector3 v2, vector3 p, double *min_distance); double min_distance_to_line_segment(vector3 p, vector3 v1, vector3 v2); boolean point_in_or_on_prism(prism *prsm, vector3 xc, boolean include_boundaries); #define K_PI 3.141592653589793238462643383279502884197 // routine from geom.c that rotates the coordinate of a point // from the prism coordinate system to the cartesian coordinate system vector3 prism_coordinate_p2c(prism *prsm, vector3 vp); vector3 prism_coordinate_c2p(prism *prsm, vector3 vc); vector3 prism_vector_p2c(prism *prsm, vector3 vp); vector3 prism_vector_c2p(prism *prsm, vector3 vc); /***************************************************************/ /* utility routines for writing points, lines, quadrilaterals */ /* to text files for viewing in e.g. gnuplot */ /***************************************************************/ void GPPoint(FILE *f, vector3 v, prism *prsm) { if (prsm) v = prism_coordinate_p2c(prsm, v); fprintf(f,"%e %e %e \n\n\n",v.x,v.y,v.z); } void GPLine(FILE *f, vector3 v, vector3 l, prism *prsm) { if (prsm) { v = prism_coordinate_p2c(prsm, v); l = prism_vector_p2c(prsm, l); } fprintf(f,"%e %e %e \n",v.x,v.y,v.z); fprintf(f,"%e %e %e \n\n\n",v.x+l.x,v.y+l.y,v.z+l.z); } void GPQuad(FILE *f, vector3 v, vector3 l1, vector3 l2, prism *prsm) { if (prsm) { v = prism_coordinate_p2c(prsm, v); l1 = prism_vector_p2c(prsm, l1); l2 = prism_vector_p2c(prsm, l2); } fprintf(f,"%e %e %e \n",v.x,v.y,v.z); fprintf(f,"%e %e %e \n",v.x+l1.x,v.y+l1.y,v.z+l1.z); fprintf(f,"%e %e %e \n",v.x+l1.x+l2.x,v.y+l1.y+l2.y,v.z+l1.z+l2.z); fprintf(f,"%e %e %e \n",v.x+l2.x,v.y+l2.y,v.z+l2.z); fprintf(f,"%e %e %e \n\n\n",v.x,v.y,v.z); } /***************************************************************/ /***************************************************************/ /***************************************************************/ void my_get_prism_bounding_box(prism *prsm, geom_box *box) { vector3 *vertices = prsm->vertices_p.items; int num_vertices = prsm->vertices_p.num_items; double height = prsm->height; box->low = box->high = prism_coordinate_p2c(prsm, vertices[0]); int nv, fc; for(nv=0; nvlow.x = fmin(box->low.x, vc.x); box->low.y = fmin(box->low.y, vc.y); box->low.z = fmin(box->low.z, vc.z); box->high.x = fmax(box->high.x, vc.x); box->high.y = fmax(box->high.y, vc.y); box->high.z = fmax(box->high.z, vc.z); } } static vector3 make_vector3(double x, double y, double z) { vector3 v; v.x = x; v.y = y; v.z = z; return v; } /************************************************************************/ /* return a uniform random number in [a,b] */ /************************************************************************/ static double urand(double a, double b) { return a + (b-a)*(rand()/((double)RAND_MAX)); } static double drand() { return urand(0.0,1.0); } /************************************************************************/ /* random point uniformly distributed over a parallelepiped */ /************************************************************************/ vector3 random_point_in_box(vector3 min_corner, vector3 max_corner) { return make_vector3( urand(min_corner.x, max_corner.x), urand(min_corner.y, max_corner.y), urand(min_corner.z, max_corner.z) ); } /************************************************************************/ /* random point uniformly distributed over a planar polygon */ /* (all z coordinates are 0) */ /************************************************************************/ vector3 random_point_in_polygon(vector3 *vertices, int num_vertices) { // randomly choose a vertex and generate random point within the triangle // formed by that vertex, the next vertex, and the centroid int which_vertex = rand() % num_vertices; vector3 v0 = {0,0,0}; vector3 v1 = vertices[which_vertex]; vector3 v2 = vertices[(which_vertex+1)%num_vertices]; double xi = urand(0.0,1.0), eta = urand(0.0,1.0-xi); return vector3_plus( vector3_scale(xi, vector3_minus(v1,v0)), vector3_scale(eta, vector3_minus(v2,v0)) ); } /************************************************************************/ /* random point uniformly distributed over the surface of a prism */ /************************************************************************/ vector3 random_point_on_prism(geometric_object o) { prism *prsm = o.subclass.prism_data; vector3 *vertices = prsm->vertices_p.items; int num_vertices = prsm->vertices_p.num_items; double height = prsm->height; // choose a face int num_faces = num_vertices + 2; int which_face = rand() % num_faces; if ( which_face < num_vertices ) // side face { vector3 min_corner = vertices[which_face]; vector3 max_corner = vertices[ (which_face+1)%num_vertices ]; max_corner.z = height; return random_point_in_box( prism_coordinate_p2c(prsm, min_corner), prism_coordinate_p2c(prsm, max_corner) ); } else // floor or ceiling { vector3 p = random_point_in_polygon(vertices, num_vertices); if (which_face==num_faces-1) p.z=height; return prism_coordinate_p2c(prsm, p); } } /************************************************************************/ /* random unit vector with direction uniformly distributed over unit sphere*/ /************************************************************************/ vector3 random_unit_vector3() { double cos_theta=urand(0.0,1.0), sin_theta=sqrt(1.0-cos_theta*cos_theta); double phi=urand(0.0,2.0*K_PI); return make_vector3(sin_theta*cos(phi), sin_theta*sin(phi), cos_theta); } /***************************************************************/ /* write prism vertices and edges to text file. */ /* after running this routine to produce a file named MyFile, */ /* the prism may be plotted in gnuplot like this: */ /* gnuplot> splot 'MyFile' u 1:2:3 w lp pt 7 ps 1 */ /***************************************************************/ void prism2gnuplot(prism *prsm, char *filename) { vector3 *vertices = prsm->vertices_p.items; int num_vertices = prsm->vertices_p.num_items; double height = prsm->height; FILE *f=fopen(filename,"w"); int nv; for(nv=0; nvvertices_p.items; int num_vertices = prsm->vertices_p.num_items; double height = prsm->height; vector3 zhat = prsm->m_p2c.c2; vector3 axis = vector3_scale(height, zhat); FILE *f=fopen(filename,"w"); int nv; for(nv=0; nv=0.0 ? 1.0 : -1.0; } vector3 standardize(vector3 v) { vector3 sv=unit_vector3(v); double sign = (sv.z!=0.0 ? sgn(sv.z) : sv.y!=0.0 ? sgn(sv.y) : sgn(sv.x)); return vector3_scale(sign,sv); } /************************************************************************/ /* first unit test: check inclusion of randomly-generated points */ /************************************************************************/ int test_point_inclusion(geometric_object the_block, geometric_object the_prism, int num_tests, int write_log) { vector3 size = the_block.subclass.block_data->size; vector3 min_corner = vector3_scale(-1.0, size); vector3 max_corner = vector3_scale(+1.0, size); FILE *f = write_log ? fopen("/tmp/test-prism.points","w") : 0; int num_failed=0, num_adjusted=0, n; for(n=0; nsize; vector3 min_corner = vector3_scale(-1.0, size); vector3 max_corner = vector3_scale(+1.0, size); FILE *f = write_log ? fopen("/tmp/test-prism.normals","w") : 0; int num_failed=0; double tolerance=1.0e-6; int n; for(n=0; nsize; vector3 min_corner = vector3_scale(-1.0, size); vector3 max_corner = vector3_scale(+1.0, size); FILE *f = write_log ? fopen("/tmp/test-prism.segments","w") : 0; int num_failed=0; int n; for(n=0; n 1.0e-6*fmax(fabs(sblock),fabs(sprism)) ) num_failed++; if (f) { int success = fabs(sblock-sprism) <= 1.0e-6*fmax(fabs(sblock),fabs(sprism)); fprintf(f," %e %e %s\n",sblock,sprism,success ? "success" : "fail"); if (success==0) { fprintf(f,"#%e %e %e %e %e %e %e %e\n",p.x,p.y,p.z,d.x,d.y,d.z,a,b); fprintf(f,"%e %e %e\n%e %e %e\n%e %e %e\n", p.x,p.y,p.z, p.x+a*d.x,p.y+a*d.y,p.z+a*d.z, p.x+b*d.x,p.y+b*d.y,p.z+b*d.z); } fprintf(f,"\n"); } } if (f) fclose(f); printf("%i/%i segments failed\n",num_failed,num_tests); return num_failed; } /***************************************************************/ /* unit tests: create the same parallelepiped two ways (as a */ /* block and as a prism) and verify that geometric primitives */ /* give identical results */ /***************************************************************/ #define NUMPTS 10000 #define NUMLINES 1000 #define LX 0.5 #define LY 1.0 #define LZ 1.5 int run_unit_tests() { void* m = NULL; vector3 c = { 0, 0, 0 }; vector3 xhat = make_vector3(1,0,0); vector3 yhat = make_vector3(0,1,0); vector3 zhat = make_vector3(0,0,1); vector3 size = make_vector3(LX,LY,LZ); vector3 v[4]; v[0].x=-0.5*LX; v[0].y=-0.5*LY; v[0].z=-0.5*LZ; v[1].x=+0.5*LX; v[1].y=-0.5*LY; v[1].z=-0.5*LZ; v[2].x=+0.5*LX; v[2].y=+0.5*LY; v[2].z=-0.5*LZ; v[3].x=-0.5*LX; v[3].y=+0.5*LY; v[3].z=-0.5*LZ; geometric_object the_block = make_block(m, c, xhat, yhat, zhat, size); geometric_object the_prism=make_prism(m, v, 4, LZ, zhat); /***************************************************************/ /* with probability P_SHIFT, shift the centers of both block */ /* and prism by a random displacement vector */ /***************************************************************/ #define P_SHIFT 0.75 if ( urand(0.0,1.0) < P_SHIFT ) { vector3 shift = vector3_scale( urand(0.0,1.0), random_unit_vector3() ); the_block.center = vector3_plus(the_block.center, shift); the_prism.center = vector3_plus(the_prism.center, shift); } char *s=getenv("LIBCTL_TEST_PRISM_LOG"); int write_log = (s && s[0]=='1') ? 1 : 0; if (write_log) prism2gnuplot(the_prism.subclass.prism_data, "/tmp/test-prism.prism"); int num_failed_1 = test_point_inclusion(the_block, the_prism, NUMPTS, write_log); // 20180712 disabling this test because the new implementation of normal_to_object // for prisms is actually more accurate than the implementation for blocks, // although the distinction is only significant in cases where it is irrelevant int num_failed_2 = 0; // test_normal_to_object(the_block, the_prism, NUMLINES, write_log); int num_failed_3 = test_line_segment_intersection(the_block, the_prism, NUMLINES, write_log); return num_failed_1 + num_failed_2 + num_failed_3; } /***************************************************************/ /***************************************************************/ /***************************************************************/ void print_usage(char *msg, int print_usage) { if (!msg) fprintf(stderr,"%s\n",msg); if (print_usage) { printf("usage: \n"); printf(" --vertexfile MyVertices\n"); printf(" --height height\n"); printf(" --axis x y z\n"); printf("\n"); printf(" --point x y z\n"); printf(" --dir x y z\n"); printf(" --a a\n"); printf(" --b b\n"); } exit(1); } void quit(char *msg) { print_usage(msg, 0); } void usage(char *msg) { print_usage(msg, 1); } /************************************************************************/ /************************************************************************/ /************************************************************************/ int main(int argc, char *argv[]) { srand(time(NULL)); geom_initialize(); if (argc<=1) // if no arguments, run unit tests return run_unit_tests(); /***************************************************************/ /* process arguments *******************************************/ /***************************************************************/ char *vertexfile=0; vector3 axis={0,0,1}; double height=1.5; vector3 test_point={0,0,0}; vector3 test_dir={0,0,1}; double a = 0.2, b=0.3; int narg; for(narg=1; narg=argc) usage("too few arguments to --axis"); sscanf(argv[narg+1],"%le",&(axis.x)); sscanf(argv[narg+2],"%le",&(axis.y)); sscanf(argv[narg+3],"%le",&(axis.z)); narg+=3; } else if (!strcmp(argv[narg],"--point")) { if (narg+3>=argc) usage("too few arguments to --point"); sscanf(argv[narg+1],"%le",&(test_point.x)); sscanf(argv[narg+2],"%le",&(test_point.y)); sscanf(argv[narg+3],"%le",&(test_point.z)); narg+=3; } else if (!strcmp(argv[narg],"--line")) { if (narg+6>=argc) usage("too few arguments to --line"); vector3 v1,v2; sscanf(argv[narg+1],"%le",&(v1.x)); sscanf(argv[narg+2],"%le",&(v1.y)); sscanf(argv[narg+3],"%le",&(v1.z)); sscanf(argv[narg+4],"%le",&(v2.x)); sscanf(argv[narg+5],"%le",&(v2.y)); sscanf(argv[narg+6],"%le",&(v2.z)); printf("Min distance=%e\n",min_distance_to_line_segment(test_point,v1,v2)); narg+=6; } else if (!strcmp(argv[narg],"--dir")) { if (narg+3>=argc) usage("too few arguments to --lineseg"); sscanf(argv[narg+1],"%le",&(test_dir.x)); sscanf(argv[narg+2],"%le",&(test_dir.y)); sscanf(argv[narg+3],"%le",&(test_dir.z)); narg+=3; } else if (!strcmp(argv[narg],"--height")) sscanf(argv[++narg],"%le",&height); else if (!strcmp(argv[narg],"--a")) sscanf(argv[++narg],"%le",&a); else if (!strcmp(argv[narg],"--b")) sscanf(argv[++narg],"%le",&b); else usage("unknown argument"); } if (!vertexfile) usage("no --vertexfile specified"); /***************************************************************/ /* read vertices from vertex file and create prism *************/ /***************************************************************/ vector3 *vertices=0; int num_vertices=0; FILE *f=fopen(vertexfile,"r"); if (!f) usage("could not open vertexfile"); char Line[100]; int LineNum=0; while( fgets(Line,100,f) ) { if (Line[0]=='\n' || Line[0]=='#') continue; num_vertices++; vector3 v; if ( 3!=sscanf(Line,"%le %le %le\n",&(v.x),&(v.y),&(v.z)) ) { fprintf(stderr,"bad vertex on line %i of %s",num_vertices,vertexfile); exit(1); } vertices = (vector3 *)realloc(vertices, num_vertices*sizeof(vector3)); vertices[num_vertices-1]=v; } fclose(f); geometric_object the_prism=make_prism(NULL, vertices, num_vertices, height, axis); prism *prsm=the_prism.subclass.prism_data; prism2gmsh(prsm, "test-prism.pp"); prism2gnuplot(prsm, "test-prism.gp"); f=fopen("test-point.gp","w"); fprintf(f,"%e %e %e\n",test_point.x,test_point.y,test_point.z); fclose(f); printf("Wrote prism description to GNUPLOT file test-prism.gp.\n"); printf("Wrote prism description to GMSH file test-prism.geo.\n"); geom_box prism_box; my_get_prism_bounding_box(prsm, &prism_box); f=fopen("test-prism-bb.gp","w"); fprintf(f,"%e %e %e\n",prism_box.low.x, prism_box.low.y, prism_box.low.z); fprintf(f,"%e %e %e\n",prism_box.high.x, prism_box.low.y, prism_box.low.z); fprintf(f,"%e %e %e\n",prism_box.high.x, prism_box.high.y, prism_box.low.z); fprintf(f,"%e %e %e\n",prism_box.low.x, prism_box.high.y, prism_box.low.z); fprintf(f,"%e %e %e\n\n\n",prism_box.low.x, prism_box.low.y, prism_box.low.z); fprintf(f,"%e %e %e\n",prism_box.low.x, prism_box.low.y, prism_box.high.z); fprintf(f,"%e %e %e\n",prism_box.high.x, prism_box.low.y, prism_box.high.z); fprintf(f,"%e %e %e\n",prism_box.high.x, prism_box.high.y, prism_box.high.z); fprintf(f,"%e %e %e\n",prism_box.low.x, prism_box.high.y, prism_box.high.z); fprintf(f,"%e %e %e\n\n\n",prism_box.low.x, prism_box.low.y, prism_box.high.z); printf("Wrote bounding box to GNUPLOT file test-prism-bb.gp.\n"); /***************************************************************/ /* test point inclusion, normal to object, and line-segment */ /* intersection with specified data */ /***************************************************************/ boolean in_prism=point_in_objectp(test_point,the_prism); vector3 nhat=normal_to_object(test_point, the_prism); double s= intersect_line_segment_with_object(test_point, test_dir, the_prism, a, b); printf("point {%e,%e,%e}: \n",test_point.x,test_point.y,test_point.z); printf(" %s prism\n", in_prism ? "in" : "not in"); printf(" normal to prism: {%e,%e,%e}\n",nhat.x,nhat.y,nhat.z); printf(" intersection with line segment {%e,%e,%e} + (%e,%e)*{%e,%e,%e}: %e\n", test_point.x, test_point.y, test_point.z, a,b,test_dir.x, test_dir.y, test_dir.z,s); }