pax_global_header00006660000000000000000000000064115265157220014520gustar00rootroot0000000000000052 comment=c173974e0e3896e036c63ed3c60e234cdfef370d frigaut-yorick-yutils-c173974/000077500000000000000000000000001152651572200162715ustar00rootroot00000000000000frigaut-yorick-yutils-c173974/LICENSE000066400000000000000000000431311152651572200173000ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 Library 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 Library General Public License instead of this License. frigaut-yorick-yutils-c173974/Makefile000066400000000000000000000103341152651572200177320ustar00rootroot00000000000000# these values filled in by yorick -batch make.i Y_MAKEDIR=/usr/lib/yorick Y_EXE=/usr/lib/yorick/bin/yorick Y_EXE_PKGS= Y_EXE_HOME=/usr/lib/yorick Y_EXE_SITE=/usr/lib/yorick # # !! THIS IS NOT A PLUGIN !! # This is a package made of several interpreted # include file. This makefile is just used to install, # uninstall it or build the distribution tar file. # ------------------------------------------------ macros for this package # used for distribution PKG_NAME = yutils # include files for this package PKG_I=astro_util1.i constants.i coords.i copy_plot.i detect.i doppler.i \ emulate_yeti.i fft_utils.i gauss.i graphk.i histo.i idl-colors.i img.i \ linalg.i lmfit.i moffat.i multiprofile.i plot_demo2.i plot_demo.i \ plot.i plvp.i poly.i pyk.i random_et.i rdcols.i rgb.i tws_button.i \ tws_field.i tws_grid.i tws.i tws_label.i tws_popup.i tws_radio.i \ tws_root.i util_fr.i utils.i # autoload file for this package, if any PKG_I_START = emulate_yeti_start.i yutils_start.i # override macros Makepkg sets for rules and other macros # Y_HOME and Y_SITE in Make.cfg may not be correct (e.g.- relocatable) Y_HOME=$(Y_EXE_HOME) Y_SITE=$(Y_EXE_SITE) # include $(Y_MAKEDIR)/Make.cfg DEST_Y_SITE=$(DESTDIR)$(Y_SITE) DEST_Y_HOME=$(DESTDIR)$(Y_HOME) # ------------------------------------- targets and rules for this package build: @echo "Nothing to build. This is not a plugin" @echo "other targets: install, uninstall, clean" @echo "for maintainers: package, distpkg" clean: -rm -rf pkg *~ install: mkdir -p $(DEST_Y_SITE)/i mkdir -p $(DEST_Y_SITE)/data mkdir -p $(DEST_Y_SITE)/python mkdir -p $(DEST_Y_SITE)/i-start cp -p $(PKG_I) $(DEST_Y_SITE)/i/ cp -p colors1.tbl $(DEST_Y_SITE)/data/ cp -p pyk.py $(DEST_Y_SITE)/python/ cp -p $(PKG_I_START) $(DEST_Y_SITE)/i-start/ uninstall: -cd $(DEST_Y_SITE)/i; rm $(PKG_I) -rm $(DEST_Y_SITE)/i-start/yutils_start.i -rm $(DEST_Y_SITE)/i-start/emulate_yeti_start.i -rm $(DEST_Y_SITE)/data/colors1.tbl -rm $(DEST_Y_SITE)/python/pyk.py # -------------------------------------------- package build rules PKG_VERSION = $(shell (awk '{if ($$1=="Version:") print $$2}' $(PKG_NAME).info)) # .info might not exist, in which case he line above will exit in error. package: mkdir -p pkg/$(PKG_NAME)/dist/y_site/i mkdir -p pkg/$(PKG_NAME)/dist/y_site/python mkdir -p pkg/$(PKG_NAME)/dist/y_site/data mkdir -p pkg/$(PKG_NAME)/dist/y_site/i-start cp -p $(PKG_I) pkg/$(PKG_NAME)/dist/y_site/i/ cd pkg/$(PKG_NAME)/dist/y_site/i/; if test -f "check.i"; then rm check.i; fi if test -f "check.i"; then cp -p check.i pkg/$(PKG_NAME)/.; fi cp -p *.py pkg/$(PKG_NAME)/dist/y_site/python/ cp -p *.tbl pkg/$(PKG_NAME)/dist/y_site/data/ if test -n "$(PKG_I_START)"; then cp -p $(PKG_I_START) \ pkg/$(PKG_NAME)/dist/y_site/i-start/; fi cp -p $(PKG_NAME).info pkg/$(PKG_NAME)/$(PKG_NAME).info cd pkg; tar zcvf $(PKG_NAME)-$(PKG_VERSION)-pkg.tgz $(PKG_NAME) distpkg: #tarball there if test -f "pkg/$(PKG_NAME)-$(PKG_VERSION)-pkg.tgz" ; then \ ncftpput -f $(HOME)/.ncftp/maumae www/yorick/packages/tarballs/ \ pkg/$(PKG_NAME)-$(PKG_VERSION)-pkg.tgz; fi #info files in each architecture directory if test -f "pkg/$(PKG_NAME)/$(PKG_NAME).info" ; then \ ncftpput -f $(HOME)/.ncftp/maumae www/yorick/packages/darwin-ppc/info/ \ pkg/$(PKG_NAME)/$(PKG_NAME).info; fi if test -f "pkg/$(PKG_NAME)/$(PKG_NAME).info" ; then \ ncftpput -f $(HOME)/.ncftp/maumae www/yorick/packages/darwin-i386/info/ \ pkg/$(PKG_NAME)/$(PKG_NAME).info; fi if test -f "pkg/$(PKG_NAME)/$(PKG_NAME).info" ; then \ ncftpput -f $(HOME)/.ncftp/maumae www/yorick/packages/linux-ppc/info/ \ pkg/$(PKG_NAME)/$(PKG_NAME).info; fi if test -f "pkg/$(PKG_NAME)/$(PKG_NAME).info" ; then \ ncftpput -f $(HOME)/.ncftp/maumae www/yorick/packages/linux-x86/info/ \ pkg/$(PKG_NAME)/$(PKG_NAME).info; fi distsrc: make clean -rm -rf pkg cd ..; tar --exclude pkg --exclude .svn --exclude CVS --exclude *.spec -zcvf \ $(PKG_NAME)-$(PKG_VERSION)-src.tgz yorick-$(PKG_NAME)-$(PKG_VERSION);\ ncftpput -f $(HOME)/.ncftp/maumae www/yorick/packages/src/ \ $(PKG_NAME)-$(PKG_VERSION)-src.tgz ncftpput -f $(HOME)/.ncftp/maumae www/yorick/contrib/ \ ../$(PKG_NAME)-$(PKG_VERSION)-src.tgz # -------------------------------------------------------- end of Makefile frigaut-yorick-yutils-c173974/README000066400000000000000000000055201152651572200171530ustar00rootroot00000000000000/* yutil Yorick package, version 1.5.0 * * Authors: E.Thiebaut, F.Rigaut, B.Aracil, T.Paumard * * Copyright 2007, E.Thiebaut, F.Rigaut, B.Aracil, T.Paumard * last revision/addition: 2008jan04 * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * */ 1. Content: ---------- README LICENSE astro_util1.i check.i constants.i copy_plot.i detect.i fft_utils.i histo.i idl-colors.i img.i linalg.i lmfit.i plot_demo2.i plot_demo.i plot.i plvp.i poly.i pyk.i random_et.i rdcols.i rgb.i util_fr.i utils.i coords.i doppler.i graphk.i gauss.i tws*.i Set of utility routines for yorick. 2. Authors: ---------- Mostly from E.Thiebaut, some from F.Rigaut, B.Aracil and T.Paumard 3. Installation: --------------- On a *nix system: yorick -batch make.i [sudo] make install On windows, or if you want to do it by hand, do the following: a. Copy all files in Y_SITE/contrib/ (create the directory if needed) b. Copy yutils_start.i in Y_SITE/i-start/ You may want to run "check.i", as in : yorick -i check.i at the shell prompt, or start yorick and type #include "check.i" 4. Documentation ---------------- All function manpages are accessible through the regular help,function See http://www.maumae.net/yorick for the html help pages. 5. History ---------- $Log: README,v $ Revision 1.7 2010-04-17 19:36:16 frigaut added yorick -batch make.i to instructions in README closes SF bug 2892060 Revision 1.6 2010/04/15 16:09:18 frigaut - split emulate_yeti_start.i to condition on - yeti in path (as per thibaut's changes) - new yorick builtin functions exist (yorick post apr2010) - bumped version number to 1.5.0 Revision 1.4 2008/01/04 15:08:28 frigaut - minor reformating Revision 1.3 2008/01/04 15:05:13 frigaut - updated Makefile README yorick-yutils.spec yutils.info to include new tws*.i files from thibaut 2007dec11: * various fixes (sky in astro_utils, round in util_fr) * Homogeneized/changed licences to GPLv2 * gotten rid of pdb_utils for license issues * added pyk.py * modified idl-colors.i and pyk.i to search the whole path for include files * fixed paths in rgb.i and added error checking. 2005nov07: * slight updates to plvp.i * moved to version 1.1 (from 0.5.3). frigaut-yorick-yutils-c173974/astro_util1.i000066400000000000000000000615671152651572200207300ustar00rootroot00000000000000/* A collection of routines for processing of astronomical data * * * Author: Francois Rigaut * Written 2003 * last revision/addition: 2010 * * Main functions: * --------------- * autocuts(image,&sigma,p=) * sky(image,&sigma,n=) * ct2lst(lng,tz,jd) * jdcnv(yr,mn,day,hr) * altaz(ha, dec, lat, &alt, &az) * airmass(sza) * sigmaFilter(image,nsigma,iter=,silent=) * deadpix(image,bpm,silent=) * makeflat(biasfile,flatfiles) * makebias(biasfiles) * check_fwhmfit(nil) * gaussianRound(x,a) * gaussian(x,a) * moffatRound(x,a) * moffat(x,a) * starsep(im,p,pixsize=,disp=,boxsize=,nwindow=) * fwhmfit(bim,boxsize=,saturation=,pixsize=,funtype=,... * * Copyright (c) 2003-2010, Francois Rigaut * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * */ //--------------------------------------------------------- func autocuts(image,&sigma,p=) /* DOCUMENT autocuts(image,&sigma,p=) * Often, the interesting information in astronomical images is burried * in intensity levels that will not appear if you do a simple "pli,image". * "autocuts" does a quick estimation of the cut levels needed to * display a fraction "p" of the pixel intensity distribution. * It then filters the image within these limits (using clip) and * returns it. * SEE ALSO: clip, sky */ { if (is_void(p)) {p = 0.99;} if ( (p < 0.) | (p > 1.) ) { error,"This value of p does not make sense. 0= 5 recommended. iter : Keyword, number of iterations. Recommended value : 3-5 silent: No verbose F.Rigaut 2001/10 SEE ALSO: deadpix */ { local im; radbox= 1; if (iter == []) {iter = 0;} s = dimsof(image); sx = s(2) ; sy = s(3) ; im = reform(image,sx*sy); dx = span(-radbox,radbox,2*radbox+1)(,-:1:2*radbox+1); dy = transpose(dx)*sx; d = dx+dy; d = reform(d,(2*radbox+1)^2); d = d(where(d != 0)); nd = numberof(d); restart: arim = array(float,sx*sy,nd); ind = indgen(sx*sy); for (i=1;i<=nd;i++) { vind = long(clip(ind+d(i),1,sx*sy)); arim(,i) = im(vind); } arim = arim(sort(arim,2)); arim = arim(,2:-1); av = arim(,avg); st = arim(,rms); ind = where( abs(im-av) > nsigma*st ); bpm = long(im)*0 ; im = reform(im,sx,sy); if (is_array(ind)) { bpm(ind) = 1; bpm = reform(bpm,sx,sy); im = deadpix(im,bpm,silent=silent); if (iter > 0) {iter = iter-1; im = reform(im,sx*sy); goto restart;} return im; } return im; } //++++++++++++++++++++++++++++++++++ func deadpix(image,bpm,silent=) /* DOCUMENT func deadpix(image,bad pixel map,silent=) Correction of bad pixels in an image by averaging the (good) neighbors. image = 2D array bpm = 2D array bad pixel map has the same dimension as image, and is 1 at the location of a bad pixel F.Rigaut 2001/10 SEE ALSO: sigma_filter */ { local image,im; im = image*(1-bpm); s = dimsof(image); sx = s(2); sy = s(3); while (sum(bpm) != 0) { bind = where(bpm); if (!is_set(silent)) {write,format="%i bad pixels to process\n",numberof(bind);} ind = array(long,numberof(bind),8); ind(,1) = bind-1; ind(,2) = bind+1; ind(,3) = bind+sx; ind(,4) = bind-sx; ind(,5) = bind+sx-1; ind(,6) = bind+sx+1; ind(,7) = bind-sx-1; ind(,8) = bind-sx+1; // "ind" contains the indices of the neighbor pixels from bad pixels ind = long(clip(ind,1,sx*sy)); // ind is clipped to avoid outbound errors. The edge should // be mostly ok. might be a few special cases where it is not perfect. gpm = 1-bpm; // gpm = good pixel map hmg = (gpm(ind))(,sum); // hmg = "how many good" = how many of the neighbors are good pixels ? // this is a vector with as many elements as bad pixels. avv = (im(ind))(,sum)/clip(float(hmg),0.5,); // avv is a vector that contains the average of the good neighbors wok = where(hmg >= 3); // wok = list of indices in bind for which there // is at least 3 good neighbors im(bind(wok)) = avv(wok); // replace bad pixels bpm(bind(wok)) = 0; // update bad pixel map } return im; } //+++++++++++++++++++++++++++ func makeflat(biasfile,flatfiles) /* DOCUMENT function makeflat(biasfile,flatfiles) Build flat field from a biasfile (single file name) and a serie of flat fields (string containing the file names). Does NOT save the resulting flat. F.Rigaut, 2001/11/10. SEE ALSO: makebias. */ { print,"Reading arrays, assuming Unsigned Integers"; bias = float(fits_read(biasfile)); dx = (dimsof(bias))(2); dy = (dimsof(bias))(3); cube = array(float,dx,dy,numberof(flatfiles)); for (i=1 ; i<=numberof(flatfiles) ; i++) { cube(,,i) = float(uint(fits_read(flatfiles(i))))-bias; mx = avg(median(cube(,,i))); cube(,,i) = cube(,,i)/mx; } print,"Computing Median of cube"; flat = median(cube,3); flat = float(flat)/median(median(flat)); // to reduce cpu time req return flat; } //+++++++++++++++++++++++++++ func makebias(biasfiles) /* DOCUMENT function makebias(biasfiles) Build bias image from a serie of biasfiles (string containing the file names). Does NOT save the resulting bias. F.Rigaut, 2001/11/10. SEE ALSO: makeflat. */ { print,"Reading arrays, assuming Unsigned Integers"; im = uint(fits_read(biasfiles(0))); dx = (dimsof(im))(2); dy = (dimsof(im))(3); cube = array(int,dx,dy,numberof(biasfiles)); cube(,,1) = im; for (i=2 ; i<=numberof(biasfiles) ; i++) { cube(,,i) = uint(fits_read(biasfiles(i)));} print,"Computing median from cube" bias = median(cube,3); return bias; } //----------------------------------------- struct fwhmfitres { double xpos, xposerr, ypos, yposerr, xfwhm, xfwhmerr, yfwhm, yfwhmerr, flux, fluxerr, sky, skyerr, ell, ellerr, angle, peak;}; fwhmfit_version = "1.4"; fwhmfit_modifDate = "September 12, 2005"; require, "random.i"; require, "string.i"; require, "random_et.i"; require, "lmfit.i"; func check_fwhmfit(nil) { im = poidev(makegaussian(256,5)*1000); im += gaussdev(dimsof(im))*10.; ima = im; for (i=1;i<=20;i++) { ima += roll(im,long((random(2)-0.5)*256))*random(); } fwhmfit,ima,funtype="gaussian"; return ima; } func gaussianRound(x,a) { // a = [sky,Total flux,Xcent,Ycent,~fwhm] xp = x(,,1)-a(3); yp = x(,,2)-a(4); z = exp(-((xp/a(5))^2.+(yp/a(5))^2.)); s = sum(z); if (s==0) return a(1); z = a(1)+a(2)*z/s; return z; } func gaussian(x,a) { // a = [sky,Total flux,Xcent,Ycent,~Xfwhm,~Yfwhm,angle] a(7) = a(7)%360.; alpha = a(7)/180.*pi; xp = (x(,,1)-a(3))*cos(alpha)-(x(,,2)-a(4))*sin(alpha); yp = (x(,,1)-a(3))*sin(alpha)+(x(,,2)-a(4))*cos(alpha); r = sqrt(xp^2.+yp^2.); z = exp(-((xp/a(5))^2.+(yp/a(6))^2.)); s = sum(z); if (s==0) return a(1); z = a(1)+a(2)*z/s; return z; } func moffatRound(x,a) { // a=[sky,total,xc,yc,a,coefpow] a1 = a(5); xp = x(,,1)-a(3); yp = x(,,2)-a(4); z = (1. + ((xp/a1)^2.+(yp/a1)^2.))^(-a(6)); s = sum(z); if (s==0) return a(1); z = a(1)+a(2)*z/s; return z; } func moffat(x,a) { // a=[sky,total,xc,yc,a,b,angle,coefpow] a(7) = a(7)%360.; alpha = a(7)/180.*pi; a1 = a(5); a2 = a(6); xp = (x(,,1)-a(3))*cos(alpha)-(x(,,2)-a(4))*sin(alpha); yp = (x(,,1)-a(3))*sin(alpha)+(x(,,2)-a(4))*cos(alpha); z = (1. + ((xp/a1)^2.+(yp/a2)^2.))^(-a(8)); s = sum(z); if (s==0) return a(1); z = a(1)+a(2)*z/s; return z; } func starsep(im,p,pixsize=,disp=,boxsize=,nwindow=) /* DOCUMENT starsep(image,type,pixsize=,disp=,boxsize=,nwindow=) Use this function to interactively determine the separation of 2 objects in a stellar image. Type: > starsep,image,0 and click on a star. This star will be the (x,y) zero point for further measurements Then type > starsep,image,1 and click on another star. This will print the (X,Y) separation between this new object and the reference. Calling this function as a function does not print anything but returns the triplet (xsep,ysep,separation) Use pixsize=some_value to get the separation in arcsec. Use disp=1 to get the default behavior of fwhmfit (set up the windows and display the image) Use disp=2 to just set up the small fit/residual window) boxsize,nwindow: see fwhmfit manpage SEE ALSO: fwhmfit */ { extern _starsepxref,_starsepyref; if (is_void(disp)) disp=0; if (p==0) { r = fwhmfit(im,oneshot=1,disp=disp,silent=1,boxsize=boxsize,nwindow=nwindow); _starsepxref=r.xpos(0); _starsepyref=r.ypos(0); } else { if (is_void(_starsepxref)) error,"The zero point was not defined"; r = fwhmfit(im,oneshot=1,disp=disp,silent=1,boxsize=boxsize,nwindow=nwindow); v = _(r.xpos(0)-_starsepxref,r.ypos(0)-_starsepyref); v = _(v,abs(v(1),v(2))); if (pixsize) v*=pixsize; if (am_subroutine()) { if (pixsize) { write,format="Separation (arcsec): x=%.2f; y=%.2f; Distance=%.2f\n", v(1),v(2),v(3); } else { write,format="Separation (pixels): x=%.2f; y=%.2f; Distance=%.2f\n", v(1),v(2),v(3); } } else return v; } } func fwhmfit(bim,boxsize=,saturation=,pixsize=,funtype=,\ magswitch=,nwindow=,silent=,airmass=,disp=,oneshot=,dpi=) /* DOCUMENT func fwhmfit(image,boxsize=,saturation=,pixsize=,funtype=,magswitch=, nwindow=,silent=,airmass=,disp=,oneshot=,dpi=) image = 2D image boxsize = Specify the size of the box of sub-images (usually 4-10 times the fwhm) saturation = Saturation value (prevents picking saturated stars) pixsize = Specify the image pixel size funtype = function to use for fit (gaussian,special,moffat) magswitch = Output flux in magnitude (zp=25 is used) nwindow = Number of window for UI (default 2) silent = don't display the numbers on screen airmass = airmass. Outputs airmass corrected FWHM values disp = 0: no display at all 1: normal behavior (set up window + displays) 2: display only the fit & residual oneshot = if set, exits after processing the first object dpi = dpi of the created window (disp has to be = 1) */ { if (!is_set(boxsize)) boxsize = 40; if (!is_set(saturation)) saturation = 0.; if (!is_set(pixsize)) {pixsize = 1.;} else {pixset=1;}; if (!is_set(funtype)) {funtype = "moffat";} else {funcset=1;}; if (!is_set(magswitch)) magswitch=0; if (!is_set(airmass)) airmass=1.; if (!is_set(nwindow)) nwindow=2; if (is_void(disp)) disp=1; if (is_void(dpi)) dpi=75; if ((funtype=="gaussian")&&(!silent)) {write,"Using Gaussian fit";} // if (funtype == "special") {write,"Using Special fit";} if ((funtype=="moffat")&&(!silent)) {write,"Using Moffat fit";} b = boxsize/2; pow = 0.85; zp = 25.; f = array(float,2,1); ferr = array(float,2,1); el = 0.; eler = 0.; an = 0.; airmass = double(airmass); allres = []; dims = (dimsof(bim))(2:3); sky1 = sky(bim); bim = bim-sky1; if (saturation != 0.) {saturation -= sky1;} if (disp) { if (nwindow==1) { if (disp==2) { get_style, landscape, systems, legends, clegends; if (numberof(systems)!=2) { write,"WARNING: disp=2 and nwindow=1 but set up not done, doing it."; disp=1; } } if (disp!=2) { winkill,0; window,0,width=long(500.*dpi/75),height=long(620.*dpi/75), style="yfwhm.gs",wait=1,dpi=dpi; } else { plsys,2; pli,array('\xff',[3,3,3*boxsize,boxsize]); limits,-1,3*boxsize,-1,boxsize,square=1; plsys,1; } } else { // then 2 windows if (disp!=2) window,0,style="boxed.gs",wait=1; window,1,style="nobox.gs",width=450,height=150,wait=1; window,0; } if (disp!=2) { fma; pli,cpc(bim); myxytitles,"pixels","pixels",[0.02,0.02]; limits,square=1; plt,swrite(format="fwhmfit.i, yorick FWHM fitting routine version %s, F.Rigaut, %s.", fwhmfit_version,fwhmfit_modifDate),0.1,0.25,tosys=0,orient=1,height=12; } } if (!silent) { write,"Left click on star for FWHM. Right click to exit."; write,"Middle click to remove last entry."; if (pixset) { if (!magswitch) { write,"X[pix] Y[pix] X FWHM[\"] Y FWHM[\"] FLUX[ADU] ELLIP ANGLE MAX"; } else { write,"X[pix] Y[pix] X FWHM[\"] Y FWHM[\"] MAGNITUDE ELLIP ANGLE MAX"; } } else { if (!magswitch) { write,"X[pix] Y[pix] X FWHM[pix] Y FWHM[pix] FLUX[ADU] ELLIP ANGLE MAX"; } else { write,"X[pix] Y[pix] X FWHM[pix] Y FWHM[pix] MAGNITUDE ELLIP ANGLE MAX"; } } } do { res = mouse(1,0,""); c = long(res(1:2)); but = res(10); if (but == 3) break; if (but == 2) { if (numberof(el) == 1) { write,"You can only unbuffer after having buffered at least one star!"; continue; } f = f(,:-1); ferr = ferr(,:-1); el = el(:-1); eler = eler(:-1); an = an(:-1); write,"Last measurement taken out of star list"; continue; } i1 = clip(c(1)-b,1,); i2 = clip(c(1)+b,,dims(1)); j1 = clip(c(2)-b,1,); j2 = clip(c(2)+b,,dims(1)); im = smooth(bim(i1:i2,j1:j2),2); wm = where2(im == max(im))(*)(1:2)-b-1; c = c + wm; im = bim(i1:i2,j1:j2); pos = c(1:2)-b; pos = [i1,j1]-1; im = sigmaFilter(im,5,iter=2,silent=1); if ((saturation > 0) && (max(im) > saturation)) { write,"Some pixels > specified saturation level. Aborting !"; continue; } sky2 = sky(im,dev2); im = im - sky2; d = dimsof(im); w = 1.+0.*clip(im,dev2,)^2; x = indices(d); if (funtype == "gaussian") { // a = [sky,Total flux,Xcent,Ycent,fwhm_parameter] ai = [0,sum(im-median(im(*))),d(2)/2.,d(3)/2.,5.]; r = lmfit(gaussianRound,x,ai,im,w,tol=1e-5,itmax=50,eps=0.01); // a = [sky,Total flux,Xcent,Ycent,a,b,angle] a = [ai(1),ai(2),ai(3),ai(4),ai(5),ai(5),10.]; r = lmfit(gaussian,x,a,im,w,stdev=1,tol=1e-8,itmax=50,eps=0.01); tmp = gaussian(x,a); err = *r.stdev; pos = pos + a(3:4); a(5:6) = abs(a(5:6)); if (a(5) fwhmX, swap a(5:6) = a(5:6)(::-1); err(5:6) = err(5:6)(::-1); a(7) +=90; } angle = ((a(7)+90) % 180.) ; //a(7) relative to Y if (angle < 0) { angle = angle+180.; } fwhm = a(5:6)*2*(-log(0.5))^(1./2.)*pixsize; //gaussian fwhmerr = err(5:6)*2*(-log(0.5))^(1./2.)*pixsize; fwhm = fwhm/airmass^0.6; fwhmerr = fwhmerr/airmass^0.6; ellip = abs(fwhm(2)-fwhm(1))/avg(fwhm); ellerr= 2*(fwhmerr(1)+fwhmerr(2))*(2*fwhm(2))/(fwhm(1)+fwhm(2))^2.; } else if (funtype == "moffat") { // a = [sky,total,xc,yc,fwhm_parameter,beta] ai = [0,sum(im-median(im(*))),d(2)/2.,d(3)/2.,5.,1.]; r = lmfit(moffatRound,x,ai,im,w,tol=1e-5,itmax=50,eps=0.01); // a = [sky,total,xc,yc,a,b,angle,beta] a = [ai(1),ai(2),ai(3),ai(4),ai(5),ai(5),0.,ai(6)]; r = lmfit(moffat,x,a,im,w,stdev=1,tol=2e-8,itmax=50,eps=0.01); tmp = moffat(x,a); err = *r.stdev; pos = pos + a(3:4); a(5:6) = abs(a(5:6)); if (a(5) fwhmX, swap a(5:6) = a(5:6)(::-1); err(5:6) = err(5:6)(::-1); a(7) +=90; } angle = ((a(7)+90) % 180.) ; //a(7) relative to Y if (angle < 0) { angle = angle+180.; } if (a(8)==0) { fhwm=fwhmerr=ellip=ellerr=0.; continue; } fwhm = 2*a(5:6)*sqrt(0.5^(-1./a(8))-1.)*pixsize; // moffat fwhmerr = fwhm*(err(5:6)/a(5:6)+ 0.5*abs(log(0.5))*err(8)/a(8)^2.*0.5^(1./a(8))/(0.5^(1./a(8))-1.)); fwhm = fwhm/airmass^0.6; fwhmerr = fwhmerr/airmass^0.6; ellip = (fwhm(1)-fwhm(2))/avg(fwhm); ellerr = 2*(fwhmerr(1)+fwhmerr(2))*(2*fwhm(2))/(fwhm(1)+fwhm(2))^2.; } maxim = max(tmp); if (disp) { if (nwindow==2) { window,1; tv,transpose(grow(transpose(im),transpose(tmp), transpose(im-tmp+a(1)))),square=1; window,0; } else { plsys,2; pli,transpose(grow(transpose(im),transpose(tmp), transpose(im-tmp+a(1)))); limits,0,3*boxsize,0,boxsize,square=1; plsys,1; plt,"Data",0.248,1.0,tosys=0,height=12,justify="CN"; plt,"Fit",0.407,1.0,tosys=0,height=12,justify="CN"; plt,"Residual",0.572,1.0,tosys=0,height=12,justify="CN"; } } grow,f,fwhm; grow,ferr,fwhmerr; grow,el,ellip; grow,eler,ellerr; grow,an,angle; if (magswitch) {flux = zp-2.5*log10(clip(a(2),1e-10,));} else {flux = a(2);} if (!silent) { write,format="%7.2f %7.2f %5.2f+/-%4.2f %5.2f+/-%4.2f %9.1f %4.2f %6.2f %6.1f\n", pos(1),pos(2),fwhm(1),fwhmerr(1),fwhm(2),fwhmerr(2),flux,ellip,angle,maxim; } res = fwhmfitres(xpos=pos(1),xposerr=err(3),ypos=pos(2),yposerr=err(4), xfwhm=fwhm(1),xfwhmerr=fwhmerr(1),yfwhm=fwhm(2),yfwhmerr=fwhmerr(2), flux=flux,fluxerr=err(2),sky=a(1),skyerr=err(1), ell=ellip,ellerr=ellerr,angle=angle,peak=maxim); grow,allres,res; if (oneshot) break; } while (but != 3); if (numberof(f) == 2) { if (!silent) write,"Bye bye"; return;} f = f(,2:); ferr = ferr(,2:); el = el(2:); eler = eler(2:); if (anyof(ferr==0)) { avgfwhm=0.; } else { avgfwhm = sum((f*1./ferr)(*))/sum(1./ferr(*)); } // stdfwhm = f(*)(rms); stdfwhm = avg([f(1,)(rms),f(2,)(rms)]); // avg X and Y rms avgel = avg(el); stdel = el(rms)+sqrt(sum(eler^2.))/numberof(eler); if (!silent) { if (pixset) { write,format="\nMedian FWHM : X = %5.3f / Y = %5.3f / = %6.3f [arcsec]\n", median(f(1,)),median(f(2,)),avg([median(f(1,)),median(f(2,))]); } else { write,format="\nMedian FWHM : X = %6.3f / Y = %6.3f / = %6.3f [pixel]\n", median(f(1,)),median(f(2,)),avg([median(f(1,)),median(f(2,))]); } } return allres; } frigaut-yorick-yutils-c173974/check.i000066400000000000000000000063451152651572200175300ustar00rootroot00000000000000/* Check routines for the yorick yutils package * * * Author: Francois Rigaut * Written 2003 * last revision/addition: 2007 * * Copyright (c) 2003-3007, Francois Rigaut * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * */ require,"linalg.i"; require,"util_fr.i"; require,"utils.i"; require,"random_et.i"; require,"random.i"; write,"\nCheck file in construction!!\n"; func clmfit(y,x,&a,function,&yfit) /* DOCUMENT clmfit(y,x,&a,function,&yfit) * Useful wrapper for the lmfit procedure. * y = the data to fit vs x * a = the output coefficients (may have initial value on input) * function = a string containing the function definition where * x and a must be used as variable and coefficients name * e.g. "a(1)+a(2)*cos(x)" * yfit = optional output. Best fit. * SEE ALSO: lmfit */ { if (open("./.foo.i","r",1)) system,"rm ./.foo.i"; f = open("./.foo.i","w"); write,f,"func foo(x,a) {return "+function+";}"; close,f; include,"./.foo.i",10; r= lmfit(foo,x,a,y); yfit = foo(x,a); return a; } if (batch()) error,"Run as yorick -i check-yutils.i"; pwd; ls; pm,makegaussian(5,2); write,"Various + random_et + plot tests"; n=64; g=makegaussian(n,12)*100; tic; g=random_poisson(g)+random_n([2,n,n]); write,format="Ellapsed time=%f\n",tac(); write,"pls,smooth(g)"; fma; pls,smooth(g); pause,1000; write,"pl3s,smooth(g)"; fma; pl3s,smooth(g),fill=1; pause,1000; write,"test of lmfit"; xy = indices(n); a = [0,1,1,n/2,n/2]; foo="a(1)+a(2)*exp(-(abs(x(,,1)-a(4),x(,,2)-a(5))/a(3))^2.)"; clmfit,g,xy,a,foo,yfit; tv,_(g,yfit),square=1; pltitle,"Noisy gaussian and fit"; write,format="Fit parameters: %.2f+%.1f*exp(-(sqrt((x-%.2f)^2"+\ "+(y-%.2f)^2)/%.2f)^2)\n",a(1),a(2),a(4),a(5),a(3); s=swrite(format="%.1f+%.1f*exp(-(sqrt((x-%.2f)^2^"+\ "+(y-%.2f)^2^)/%.2f)^2^)\n",a(1),a(2),a(4),a(5),a(3)); plt,s,-10,n,tosys=1,orient=1,height=10,justify="CC"; pause,1000; write,"Test of additional color tables"; for (i=1;i<=41;i++) {loadct,i; pause,100;} xy = indices([2,64,40]); g = exp(-((xy(,,1)-28)/10)^2 - ((xy(,,2)-19)/4)^2.); tv,g,square=1; tv,undersample(g,2); limits,square=0; pause,1000; write,"Ramdom_et and histo tests"; x = random_poisson(array(10,10000)); fma; histo_plot,x; pause,500; write,"Input/output to disk tests" n=100; x = random_n(n); iv = indgen(n); //create a random filename: fname=swrite(format="/tmp/junk-%d.dat",long(random()*10000)); f = open(fname,"w"); for (i=1;i<=n;i++) write,f,iv(i),x(i); close,f; d = rdcols(fname); plot,*d(2),*d(1); d = read_ascii(fname); d(2,) = clip(d(2,),-0.5,0.5); plg,d(2,),d(1,),color="red"; remove,fname; stat,d; write,"All tests successful for package yutils"; frigaut-yorick-yutils-c173974/colors1.tbl000066400000000000000000001000411152651572200203520ustar00rootroot00000000000000)  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ !%)-159=AEIMQUZ^bfjnrvz~ !"$%')*,-/124579:<=?ABDEGIJLMOQRTUWYZ\^_abdfgijlnoqrtvwyz|~  !#$%'(*+,./0234678:;=>?ABCEFGIJKMNPQRTUVXYZ\]^`acdeghiklmopqstvwxz{|~ $*06?ABDEFHIKLNOQRTUVXY[\^_abcefhiklnoqrsuvxy{|~  "#%')+-/13468:<>@BDEGIKMOQSUVXZ\^`bdfgikmoqsuwxz|~ #'+/36:>BFJNRVZ^bfimquy}%-4ADGKNQTWZ]`dgjmpsvy}}zxuspnkifd]WQKD>82+%   "$')+.02579;>@BEGILNPSUWY\^`cegjlnqsuwz|~ !#%')+-/2468:<>@BDFHKMOQSUWY[]_addddddddddddddddddddddddddddddddd`]ZWTQNKGDA>;852.+(%"  !&*/49=BGLQQQQQQQQPPPPPPPOTY^chmrw|º  %+06;@FKQUZ_dimrw| $).49>CHNSX]bhmrw|ľ}xrmhb]WRLGB<71,&!  !&+059>CHMRMGA;5/)$   #&)-036:=@CGJMPSWZ]`dgjmptwz} "&)-159<@DHLOSW[_bfjnruy}~zvqmiea\XTPLHC?;73.*&"  #'+/37;?CGKOSW[_cgkosw{ÿ~zvrnjfb^ZUQMIEA=951-)%!  "&*.269=AEIMQUX\`dhlpsw{ÿ~zvrnjfb^ZUQMIEA=951-)%!  !$'*-0369?@BDFHJLNPRTVXZ\^`bdfhknqtwz}  !!"#$%''(()*+,../012346655468:<<=>?@ABDEFGIJKLMNOPRRSSTUVWYZ[\^_`abcdegghijklmnopqstuvwxyz||}}~  !#%&()+-.023568:;=>@BCEGHJKMOPRSUWXZ[]_`bdeghjlmoprtuwyz|}  !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ "%),037:>ADHKORVY]`cgjnqux|  !!!"""##$$$%%%&&'''(()))***++,,,---..///0011122233444667889::;<<=>>?@@BDFGIKMOQSUVXZ\^`bcegikmoqrtvxz|~  !""#$$%&&'(()**+,,-../001223445667889::;<<=>>?@@ABBCDDEFFGHHIJJKLLMNNOPPQRRSTTUVWXZ[\^_`bcdfghjklnoprstvwxz{|~  !!!!"""####$$$$%%%%&&&&'''(((())))****++++,,,----....////0/147:=@CFILORUXZ]`cfilorux{~ #(-27<;:986420/.-,*(&$"    $(,048<@DHLPTX\`dhlptx| !#%&(*,.02568:<>@BDEGIKMOQSTVXZ\^`cdfhjlnprtvxz{}  $(,048<@DHLPUY]aeimquy} !&*.27;?CHLPTY]aejnrv{ÿ~zvrnjfb^ZUQMIEA=951-)%!  !&*.27;?CHLPTY]aejnrv{¾|xtpkgc_[WSOKFB>:62.*&! TTTTTTTTTTTTTTTTTTTTTTTTTTTTTTTܴ@@@@@@@@@@@@@@@@ $(-26:=@DEHJMOPRSUTVWXVWWWUTTTSONMLGFDB<:75.+($!  !*.37?CHLPY]aenrw{&*.37?CHLTY]ajnrwÿ{wnjfaYUPLH?;73*&"   &+05;?DHMQV[_dhmqvzÿ{rnjfaYTPLC?;7.*&" '/7?FNV^fnv~  "$&),/258;?BEHKNRUY]aeilptx|*UŻvlcYOE;2(  !$$&(*-036:=@CFIMRW\`dhlqw} )19AJRZbjs{ %*/5:?EJOUY^bglpuy~ "',17?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~ !#%')+-/13579;=?ACEGIKMOQSUWY[]_acegikmoqsuwy{}|wsokfb^ZUQMID@<83/+'"  "&)-159<@DHLOSW[_bfjnruy}}{ywusqomkigeca_][YWUSQOMKIGECA?=;97531/-+)(&$"   !#%')+-/13579;=?ACEGIKMOQSUWY[]_acegiklnprtvxz|~pp}|{yxvutrqonmkjhgedca`^]\ZYWVTSRPOMLKIHFEDBA?><;:8754310.-+*)'&$#"  !"$%&()*,-.01245689:<=>@ABDEFHIKLMOPQSTUWXY[\]_`acdeghiklmopqstuwxy{|}~}|{zyxwvutsrqponmlkjihgfedcba`_^]\[ZYXWVUTSRQPONMLKJIHGFEDCBA@?>=<;:9876543210/.-,+*)('&%$#"!  !!   $*05:=ADFHIJJJKKLLLMLMNOPQSTUVXY[\[^`bdfhjlmopqstuwxy{|} !#%'*,.1358:BIQT^djpv|~}|zyxwvvtrqpoomlmorsuvx{}Ŀ{uojc]UNJC=6/(!~zvtpkjiihfdcca`^]][ZXXVUSSQPNNLKIHGFECBA?>>;::766321/.-+*)'&$#"   }zvsplifc_\YVUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~  !"#$%&'()*+,-./0123456789:;<=>?@@ABCDEFGHIJKLMNOPQRSTW\afkoty} %,29?FLRY_ekrx~~}|{zyxwvutsrqponmlkjihgfedcba`_^]\[ZYXWVUUTTX[^adgknruy|½}wqkd^XQKE>81*$ÿ|wrnid_ZVSRQPONMLKJIHGFEDCBA@?>=<;:9876543210/.-,+*)('&%$#"!  ywge|zwuspnlTRec`^\YWUB@NLIGEB@>/.7420.+)'   $*0605HNU[agmsaf $*06:51,(# {wrnjfaTPLPLHC?;7-*&&! "*3;=DL]fnwк|zx"3DUfwzÿÿzvr}{ywtrpca_hfca_][PNLRPNLJHF=;9=;97520*(&(&$! λݷveTC2 $-19HQ[dmv˵qoywuu'/79@OW_gowÿzv}{ywtrpcajhfca_][PNTRPNLJHF=;?=;97520*(*(&$! ǷǬwd]_WOG?7/'     $*18@GNU]djqw}yrkcZRI?6,#  &,047899852-'!(5CQ`o~ƷtbQ@/*6@IQW[^__\XRKB7* (<97320.-,,+++,,-./0135679;<=?@@ABCCCCCCBBA@>=<:87520.+)'%"  Һzq_WOH;61,%" "%(16;BOW_hzʱvk`KA8/    &/AKU`vƯzqh_OHB61,("  %(,1;BHW_hqʽk`UK8/&    &/8KU`k66;?DIMRRW[`dinrw{{wrnid`[VRMIDD?;62.*&"  "&*.26;?DDIMRW[`dinrw{{wrniiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiiCCCCCCCBBBA@@?>=<;9876554310//.-,,,+++++,,-./023579<<>ADGJNQUX\`dhllptx||xuqnkhheca_][ZYXXXXXYY[\^`cfimquzƺzqh_WOHB;61,((%"  "%(,116;BHOW_hqzʽvk`UKA8/&    &/8AKU`kvƺzqh_WOHB;661,(%"  "%%(,16;BHOW_hqzPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPQPPPPPPPPPPPPP 0000000000000000@@@@@@@@@@@@@@@@PPPPPPPPPPPPPPPP````````````````ppppppppppppppppPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPPP  !"#$%&''()*+,-../0123456789:;<=>?ABCDFGHJKMNOQRTUVXYZ\]^_abcdefgghijkkllmnnoopqqrrstuuvwxyz{|}!&,3:AIQYbjs||skbYQIA:3,&!!&,3:AIQYbks||sjbYQIA:3,&!!&,3:AIQYbks||sjbYQIA:3,&!!&,3:AIQYbks||sjbYQIA:3,&! "'+/37;?CGKNRVZ]adgknqtwz}¾~{xtqlhc^YSNHA;5.'  ÿ}wpjb[SKC:2)!}tkaWW #'+/37;?CGKOSW[_cgkosw{ #'+/37;?CGKOSW[_cgkosw{ÿ{wsokgc_[WSOKGC?;73/+'# ÿ{wsokgc_[WSOKGC?;73/+'# ||xsojfa]XTOKFB=940+'"   %).27;@DIMRV[_dhmqv{ !&*/38:51,(# RRMID?;62.*&"  "&*.26;?DIMRW[`dinrw{{wrnid`[VRMID?;62.*&"  "&*.26;?DIMRW[`dinrw{{wrnid``  "#%')+-.023578:;<=>?@ABBCCCCCCCCBBA@@?>=<;987654310//.-,,,++++,,-./023579<>ADGJNQUX\`dhlptx||xuqnkheca_][ZYXXXXXY[\^`cfimquzʽvk`UKA8/&    &/8AKU`kvƺzqh_WOHB;61,(%"  "%(,16;BHOW_hqzʽvk`UKA8/&    &/8AKU`kvƺzqh_WOHB;61,(%"  "%(,16;BHOW_hqz@@<9630-*(%#    "%'*,/258;?BFIMPTX\`dhmquz~ý}xrlga\VPKF@;50+&!   $(,048:62/+'" ##(,16:?CHLPTY]`dhlosvy|~{xuqnjgc_[WSOJFB=94/+&!  !%)-158<9641/-*(&$!  !$&(*-/1469<>ADFILORUX[^adgjmpsvy|yyyaH4&"&4H`yyaH4&"&4H`yyaH4&"&4H`yyaH4&"&4H`yyaH4&"&4H`yyaH4&"&4H`yyaH4&"&4H`yy`H4&"&4Hayy`H4&"&4Hayy`H4&"&4Hayy`H4&"&4Hayy`H4&"&4Hayy`H4&"&4Hayy`H4&"&4Hayy`H4&"&4Hayy`H4&"&44|yvspmjgda^[XUROLIFDA><9641/-*(&$!  !$&(*-/1469<>ADFILORUX[^adgjmpsvyyddddddddddddddddddddddddddddddddddddddddddddddddȖȯddddddddddddddddddddddddddddddddddddddddddddddddȠ}}}}}}}}}}}}}}}}222222222222222222222222222222ȖxxxxxxxxxxxxxxxxddddddddddddddddKKKKKKKKKKKKKK $(-2:=@DEHJMOPRSTVWXVWWWUTTTONMLGFDB<:7.+($!  *.37?CHLPY]anrw{&*.37?CHTY]ajnrwÿ{wnjfaYUPL?;73*&"   &+0;?DHMQV[_dhmvzÿ{rnjfYTPLC?;7.*&  $(-2:=@DEHJMOPRSTVWXVWWWUTTTONMLGFDB<:7.+($!  *.37?CHLPY]anrw{&*.37?CHTY]ajnrwÿ{wnjfaYUPL?;73*&"   &+0;?DHMQV[_dhmvzÿ{rnjfYTPLC?;7.*&  B-W LINEAR BLUE/WHITE GRN-RED-BLU-WHT RED TEMPERATURE BLUE/GREEN/RED/YELLOWSTD GAMMA-II PRISM RED-PURPLE GREEN/WHITE LINEAR GRN/WHT EXPONENTIAL GREEN-PINK BLUE-RED 16 LEVEL RAINBOW STEPS STERN SPECIAL Haze Blue - Pastel - Red Pastels Hue Sat Lightness 1 Hue Sat Lightness 2 Hue Sat Value 1 Hue Sat Value 2 Purple-Red + Stripes Beach Mac Style Eos A Eos B Hardcandy Nature Ocean Peppermint Plasma Blue-Red Rainbow Blue Waves Volcano WavesRainbow18 Rainbow + white Rainbow + black frigaut-yorick-yutils-c173974/constants.i000066400000000000000000000253511152651572200204650ustar00rootroot00000000000000/* * constants.i - * Useful constants for physical computations with Yorick. * * Copyright (c) 2000-2003, Eric THIEBAUT. * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * History: * $Id: constants.i,v 1.2 2008-02-15 18:55:27 frigaut Exp $ * $Log: constants.i,v $ * Revision 1.2 2008-02-15 18:55:27 frigaut * fixed UTF-8 encoding problems (crash yorick-doc on amd64) * * Revision 1.1.1.1 2007/12/11 23:55:12 frigaut * Initial Import - yorick-yutils * * Revision 1.4 2003/11/10 12:21:13 eric * - fixed typo; * * Revision 1.3 2003/11/10 12:18:58 eric * - change name: AstrophysicalUnit -> AstronomicalUnit; * - change units: VacuumPermeability; * - add complete documentation in pseudo-symbol "constants"; * - fixed units for EarthRotationalPeriod; * - avoid inconsistencies (and errors) by explicitely compute constants * which depend on others; * * Revision 1.2 2001/10/09 07:05:45 eric * - fixed value of VacuumPermeability * * Revision 1.1 2001/03/23 17:02:53 eric * Initial revision */ local constants; /* DOCUMENT Physical constants defined in "constants.i": Pi ........................ number pi, semi-perimeter of unit circle E ......................... number e Deg2Rad ................... radians per degree Rad2Deg ................... degrees per radian ArcSec .................... radians per arcsecond EulerConstant ............. Euler's constant ElementaryCharge .......... charge of a protron [C] GravitationalConstant ..... gravitational constant [m^3/kg/s^2] FineStructureConstant ..... fine-structure constant LightSpeed ................ speed of light in vacuum [m/s] VacuumPermittivity ........ permittivity of vacuum [F/m] VacuumPermeability ........ permeability of vacuum [N m^2/C^2] PlanckConstant ............ Planck's constant [J s] DiracConstant ............. Dirac's constant [J s] BoltzmannConstant ......... Boltzmann's Constant [J/K] StefanConstant ............ Stefan-Boltzmann's constant [W/m^2/K^4] WienConstant .............. Wien's constant [m K] BohrMagneton .............. Bohr magneton [A m^2] BohrRadius ................ Bohr radius [m] RydbergConstant ........... Rydberg's constant [eV] PerfectGazConstant ........ perfect gaz constant [J/mol] AvogadroConstant .......... Avogadro's constant [1/mol] IcePoint .................. absolute temperature of ice [K] ElectronMass .............. electron mass [kg] ProtonMass ................ protron mass [kg] NeutronMass ............... neutron mass [kg] ElementaryMassUnit ........ elementary mass unit [kg] LightYear ................. light year [m] ParSec .................... astronomical unit per arcsecond [m] AstronomicalUnit .......... semi-major axis of Earth orbit [m] SunLuminosity ............. luminosity of the Sun [W] SunMass ................... mass of the Sun [kg] SunRadius ................. radius of the Sun [m] SunTemperature ............ effective temperature of the Sun [K] SunRotationalPeriod ....... rotational period of the Sun [days] EarthMass ................. mass of the Earth [kg] EarthRadius ............... radius of the Earth [m] EarthRotationalPeriod ..... rotational period of the Earth [hours] EarthOrbitalPeriod ........ orbital period of the Earth [days] */ /*---------------------------------------------------------------------------*/ #if 0 // The following lines were automatically generated by the script: grep '\.\.' constants.i | sed 's,^ *\([^ ]*\)[ .]*\(.*\),local \1;\n/* DOCUMENT \1 - \2\n SEE ALSO constants. */,'; #endif local Pi; /* DOCUMENT Pi - number pi, semi-perimeter of unit circle SEE ALSO constants. */ local E; /* DOCUMENT E - number e SEE ALSO constants. */ local Deg2Rad; /* DOCUMENT Deg2Rad - radians per degree SEE ALSO constants. */ local Rad2Deg; /* DOCUMENT Rad2Deg - degrees per radian SEE ALSO constants. */ local ArcSec; /* DOCUMENT ArcSec - radians per arcsecond SEE ALSO constants. */ local EulerConstant; /* DOCUMENT EulerConstant - Euler's constant SEE ALSO constants. */ local ElementaryCharge; /* DOCUMENT ElementaryCharge - charge of a protron [C] SEE ALSO constants. */ local GravitationalConstant; /* DOCUMENT GravitationalConstant - gravitational constant [m^3/kg/s^2] SEE ALSO constants. */ local FineStructureConstant; /* DOCUMENT FineStructureConstant - fine-structure constant SEE ALSO constants. */ local LightSpeed; /* DOCUMENT LightSpeed - speed of light in vacuum [m/s] SEE ALSO constants. */ local VacuumPermittivity; /* DOCUMENT VacuumPermittivity - permittivity of vacuum [F/m] SEE ALSO constants. */ local VacuumPermeability; /* DOCUMENT VacuumPermeability - permeability of vacuum [N m^2/C^2] SEE ALSO constants. */ local PlanckConstant; /* DOCUMENT PlanckConstant - Planck's constant [J s] SEE ALSO constants. */ local DiracConstant; /* DOCUMENT DiracConstant - Dirac's constant [J s] SEE ALSO constants. */ local BoltzmannConstant; /* DOCUMENT BoltzmannConstant - Boltzmann's Constant [J/K] SEE ALSO constants. */ local StefanConstant; /* DOCUMENT StefanConstant - Stefan-Boltzmann's constant [W/m^2/K^4] SEE ALSO constants. */ local BohrMagneton; /* DOCUMENT BohrMagneton - Bohr magneton [A m^2] SEE ALSO constants. */ local BohrRadius; /* DOCUMENT BohrRadius - Bohr radius [m] SEE ALSO constants. */ local RydbergConstant; /* DOCUMENT RydbergConstant - Rydberg's constant [eV] SEE ALSO constants. */ local PerfectGazConstant; /* DOCUMENT PerfectGazConstant - perfect gaz constant [J/mol] SEE ALSO constants. */ local AvogadroConstant; /* DOCUMENT AvogadroConstant - Avogadro's constant [1/mol] SEE ALSO constants. */ local IcePoint; /* DOCUMENT IcePoint - absolute temperature of ice [K] SEE ALSO constants. */ local ElectronMass; /* DOCUMENT ElectronMass - electron mass [kg] SEE ALSO constants. */ local ProtonMass; /* DOCUMENT ProtonMass - protron mass [kg] SEE ALSO constants. */ local NeutronMass; /* DOCUMENT NeutronMass - neutron mass [kg] SEE ALSO constants. */ local ElementaryMassUnit; /* DOCUMENT ElementaryMassUnit - elementary mass unit [kg] SEE ALSO constants. */ local LightYear; /* DOCUMENT LightYear - light year [m] SEE ALSO constants. */ local ParSec; /* DOCUMENT ParSec - astronomical unit per arcsecond [m] SEE ALSO constants. */ local AstronomicalUnit; /* DOCUMENT AstronomicalUnit - semi-major axis of Earth orbit [m] SEE ALSO constants. */ local SunLuminosity; /* DOCUMENT SunLuminosity - luminosity of the Sun [W] SEE ALSO constants. */ local SunMass; /* DOCUMENT SunMass - mass of the Sun [kg] SEE ALSO constants. */ local SunRadius; /* DOCUMENT SunRadius - radius of the Sun [m] SEE ALSO constants. */ local SunTemperature; /* DOCUMENT SunTemperature - effective temperature of the Sun [K] SEE ALSO constants. */ local SunRotationalPeriod; /* DOCUMENT SunRotationalPeriod - rotational period of the Sun [days] SEE ALSO constants. */ local EarthMass; /* DOCUMENT EarthMass - mass of the Earth [kg] SEE ALSO constants. */ local EarthRadius; /* DOCUMENT EarthRadius - radius of the Earth [m] SEE ALSO constants. */ local EarthRotationalPeriod; /* DOCUMENT EarthRotationalPeriod - rotational period of the Earth [hours] SEE ALSO constants. */ local EarthOrbitalPeriod; /* DOCUMENT EarthOrbitalPeriod - orbital period of the Earth [days] SEE ALSO constants. */ /*---------------------------------------------------------------------------*/ /* MATHEMATICS */ /* 35 significant digits is sufficient for 16-byte IEEE floating point */ Pi = 3.1415926535897932384626433832795029; E = 2.7182818284590452353602874713526625; Deg2Rad = Pi/180.0; Rad2Deg = 180.0/Pi; ArcSec = Deg2Rad/3600.0; /* lim_{n->+infinity} sum_{k=1}{n} 1/k - log(n) */ EulerConstant = 0.5772156649; /*---------------------------------------------------------------------------*/ /* PHYSICS */ LightSpeed = 2.99792458e+8; // [m/s] PlanckConstant = 6.6260755e-34; DiracConstant = PlanckConstant/Pi; BoltzmannConstant = 1.380658e-23; GravitationalConstant = 6.67259e-11; WienConstant = 2.8978e-3; // StefanConstant = 5.67032e-8; StefanConstant = 2.0*Pi^5*BoltzmannConstant^4/(15.0*PlanckConstant^3 *LightSpeed^2); PerfectGazConstant = 8.31441; AvogadroConstant = 6.0221367e+23; IcePoint = 273.15; // kelvin temperature at 0 celcius degree WaterTriplePoint = 273.16; VacuumPermittivity = 8.854187e-12; // VacuumPermeability = 4e-7*Pi; VacuumPermeability = 1.0/(4.0*Pi*VacuumPermittivity); ElectronMass = 9.1093897e-31; ProtonMass = 1.6726231e-27; NeutronMass = 1.6749540e-27; ElementaryMassUnit = 1.6605656e-27; UnifiedAtomicMassUnit = 1.6605402e-27; // +/- 0.0000010e-27 ElementaryCharge = 1.60217733e-19; // +/- 0.00000049e-19 C FineStructureConstant = ElementaryCharge^2/(2.0*PlanckConstant*LightSpeed *VacuumPermittivity); BohrMagneton = ElementaryCharge*PlanckConstant/(4.0*Pi*ElectronMass); BohrRadius = 5.2918e-11; // [m] RydbergConstant = 13.595; // [e V] #if 0 ElectronComptonWavelength = PlanckConstant/(ElectronMass*LightSpeed); ProtonComptonWavelength = PlanckConstant/(ProtonMass*LightSpeed); HydrogenReducedMass = 1.0/(1.0/ElectronMass + 1.0/ProtonMass); HydrogenReducedMass = 9.1045755e-31; // [kg] #endif /*---------------------------------------------------------------------------*/ /* ASTROPHYSICS */ SunLuminosity = 3.826e+26; // [W] SunMass = 1.989e+30; // [kg] SunRadius = 6.9599e+8; // [m] SunTemperature = 5.77025e+3; // [K] SunRotationalPeriod = 25.38; // [hours] EarthMass = 5.976e+24; EarthRadius = 6.378e+6; EarthRotationalPeriod = 23.96; // [hours] EarthOrbitalPeriod = 365.24219879; // [days] AstronomicalUnit = 1.4959787066e+11; LightYear = 24.0*3600.0*EarthOrbitalPeriod*LightSpeed; ParSec = AstronomicalUnit/ArcSec; /*---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/coords.i000066400000000000000000000034611152651572200177400ustar00rootroot00000000000000/* * coords.i * * $Id: coords.i,v 1.1 2008-01-04 13:47:48 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: coords.i,v $ * Revision 1.1 2008-01-04 13:47:48 frigaut * initial import of thibaut's functions * */ extern coords,ndc2pt,pt2inch,inch2cm,ndc2inch,ndc2cm,pt2cm,cm2inch,cm2pt,cm2ndc,inch2pt,inch2ndc,pt2ndc; /* DOCUMENT ndc2pt,pt2inch,inch2cm,ndc2inch,ndc2cm,pt2cm,cm2inch,cm2pt,cm2ndc,inch2pt,inch2ndc,pt2ndc convert between these. */ func ndc2pt(value) { return value/0.0013; } func pt2inch(value) { return value/72.27; } func inch2cm(value) { return value*2.54; } func pt2ndc(value) { return value*0.0013; } func inch2pt(value) { return value*72.27; } func cm2inch(value) { return value/2.54; } func ndc2inch(value) { return value/0.093951; } func inch2ndc(value) { return value*0.093951; } func ndc2cm(value) { return value/0.0369886; } func cm2ndc(value) { return value*0.0369886; } func pt2cm(value) { return value/28.4528; } func cm2pt(value) { return value*28.4528; } frigaut-yorick-yutils-c173974/copy_plot.i000066400000000000000000000444001152651572200204550ustar00rootroot00000000000000/* Functions to copy/save/load Yorick plot * * * Author: Bastien Aracil * Written 2003 * last revision/addition: 2005 Jan 28 * * Main functions: * --------------- * * copy_win : copy all the graphical elements from one window to another * save_plot : save a plot in a ".pdb" file * load_plot : load a plot from a file previously saved with save_plot * * Internally used functions: * -------------------------- * * replot_all : same as copy_win but do not copy the style of the window * replot_one_sys : copy one system of a window to another system of * the same or another window * reshape_prop : convert the result of plq() to a more usefull form. * replot : replot an element from its plq() properties * reshape_XYZ : same as reshape but only for the graphical element * plotted with XYZ (called by reshape) * replot_XYZ : same as reshape but only for the graphical element * plotted with XYZ (called by replot) * decomp_prop : put *plq(n)(i) in prop_i * get_nb_sys : return the numbero of systems in a window * get_color : transform color to rgb encoding * * Copyright (c) 2005, Bastien Aracil * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * */ if(is_func(autoload)!=2) { require,"style.i"; require,"pdb_utils.i"; } func copy_win(wsrc,wout,lmt=,clear=,pal=) /* DOCUMENT copy_win,window_source,window_target Copy the style and the graphic elements of window WINDOW_SOURCE to window WINDOW_TARGET KEYWORDS: lmt= if set, copy also the limits (the default) clear= if set, erase the window before copying (the default) pal= if set, copy the palette too (the default) SEE ALSO:replot_all,replot_one_sys */ { local a,b,c,d; local red,green,blue; if(is_void(clear)) clear=1; if(is_void(pal)) pal=1; wbck=get_selected_system(); window,wsrc; get_style,a,b,c,d; palette,red,green,blue,query=1; window,wout; set_style,a,b,c,d; if(clear) fma; if(pal&&is_array(red)) palette,red,green,blue; replot_all,wsrc,wout,lmt=lmt; set_selected_system,wbck; } func replot_all(wsrc,wout,lmt=) /* DOCUMENT replot_all(window_source,window_target) Copy graphical elements of all systems (but not the style) of window window_source to window_target KEYWORDS: lmt : if set, copy also the limits (the default) SEE ALSO: copy_win,replot_one_sys */ { nbsin =get_nb_sys(wsrc); nbsout=get_nb_sys(wout); if(nbsin!=nbsout) error,"The two windows have not the same number of systems !!"; wbck=get_selected_system(); for(i=0;i<=nbsin;i++) replot_one_sys,wsrc,i,wout,i,lmt=lmt; window,wout;redraw; set_selected_system,wbck; } func replot_one_sys(wsrc,sin,wout,sout,lmt=) /* DOCUMENT replot_one_sys(window_source,sys_source,winow_target,system_target) Copy all the graphical elements of the system sys_source of window_source to the system sys_target of window window_target KEYWORDS: lmt : if set, copy also the limits (the default) SEE ALSO:copy_win,replot_all */ { if(is_void(lmt)) lmt=1; wbck = set_selected_system([wsrc,sin]); lmtin=limits(); nbobj=numberof(plq()); window,wout; plsys,sout; if(lmt) limits,lmtin; for(i=1;i<=nbobj;i++) { window,wsrc; plsys,sin; prop=plq(i); window,wout; plsys,sout; replot,prop; } plsys,old_sout; window,wsrc; plsys,old_sin; } func save_plot(filename,wsrc,pal=) /* DOCUMENT save_plot(filename,win,pal) Save Yorick plot of window win in file 'filename'. The plot can be reload with load_plot. KEYWORDS: pal= : save the palette if any in the file (the default) EXAMPLE: window,0; pli,random(100,100); pltitle,"Random array"; limits,20,60,10,70; plt,"Zoom In",40,40,tosys=1,color="yellow",height=18; save_plot,"rand_array.gdb",0; load_plot,"rand_array.gdb",1; SEE ALSO: load_plot,copy_win */ { local a,b,c,d,x,y,z; local x0,x1,y0,y1,txt; local ireg; local p1,p2,p3,p4,p5; local rp,gp,bp; if(is_void(pal)) pal=1; fstrm=createb(filename); old_win=current_window(); if(old_win>=0) old_sys=plsys(); window,wsrc; get_style,a,b,c,d; ssave,fstrm,"getstyle_p1",a; ssave,fstrm,"getstyle_p2",b; ssave,fstrm,"getstyle_p3",c; ssave,fstrm,"getstyle_p4",d; palette,rp,gp,bp,query=1; if(!is_void(rp)&&pal) { rgb_pal=long(rp)+(long(gp)<<8)+(long(bp)<<16); ssave,fstrm,"palette",rgb_pal; } nbsys=get_nb_sys(wsrc); for(i=0;i<=nbsys;i++) { plsys,i; lmt=limits(); nbobj=numberof(plq()); ssave,fstrm,swrite(format="system_%d",i),i; ssave,fstrm,swrite(format="limits_%d",i),lmt; for(j=1;j<=nbobj;j++) { prop=plq(j); decomp_prop,prop,p1,p2,p3,p4,p5; ssave,fstrm,swrite(format="prop1_%d_%d",i,j),(is_void(p1)?"dummy":p1); ssave,fstrm,swrite(format="prop2_%d_%d",i,j),(is_void(p2)?"dummy":p2); ssave,fstrm,swrite(format="prop3_%d_%d",i,j),(is_void(p3)?"dummy":p3); ssave,fstrm,swrite(format="prop4_%d_%d",i,j),(is_void(p4)?"dummy":p4); rslt=reshape_prop(prop); ssave,fstrm,swrite(format="prop5_%d_%d",i,j),(is_void(rslt)?"dummy":rslt); } } close,fstrm; if(old_win>=0) { window,old_win; plsys,old_sys; } } func load_plot(filename,wout,clear=,lmt=,pal=) /* DOCUMENT load_plot(filename,wout) Load Yorick plot form file 'filename' in window wout The plot have to be saved with save_plot. EXAMPLE: window,0; pli,random(100,100); pltitle,"Random array"; limits,20,60,10,70; plt,"Zoom In",40,40,tosys=1,color="yellow",height=18; save_plot,"rand_array.gdb",0; load_plot,"rand_array.gdb",1; KEYWORDS: lmt= if set (default), restore also the imits clear= if set (default) erase the window before loading pal= use the palette saved in the file if any (the default) SEE ALSO: save_plot,copy_win */ { if(is_void(clear)) clear=1; if(is_void( lmt)) lmt=1; if(is_void( pal)) pal=1; fstrm=openb(filename); old_win=current_window(); if(old_win>=0) old_sys=plsys(); window,wout; set_style,fstrm.getstyle_p1,fstrm.getstyle_p2,fstrm.getstyle_p3,fstrm.getstyle_p4; if(clear) fma; names=*get_vars(fstrm)(1); palette_is_present=anyof(names=="palette"); if(palette_is_present&&pal) { rgb=fstrm.palette; palette,char(rgb&0x0000FF),char((rgb&0x00FF00)>>8),char((rgb&0xFF0000)>>16); } nnames=numberof(names); idx=4+palette_is_present; while(++idx<=nnames) { if(strmatch(names(idx),"system_")) { plsys,get_member(fstrm,names(idx)); limits; continue; } if(strmatch(names(idx),"limits_")) { if(lmt) limits,get_member(fstrm,names(idx)); continue; } if(strmatch(names(idx),"prop1_")) { p1 =get_member(fstrm,names(idx)); p2 =get_member(fstrm,names(++idx)); p3 =get_member(fstrm,names(++idx)); p4 =get_member(fstrm,names(++idx)); rslt=get_member(fstrm,names(++idx)); replot,p1,p2,p3,p4,rslt; continue; } write,format="[WARNING] Unknown variable flag %s !!\n",names(idx); } close,fstrm; redraw; if(old_win>=0) { window,old_win; plsys,old_sys; } } func reshape_prop(prop) /* DOCUMENT reshape_prop(prop) Return an array of pointers that point to the data useful for drawing the graphical element. The size of the array depend of the graphical type, and the order of the pointers is the same than the one of the plq() fifth element. */ { aig=(*prop(1))(1); if(aig==1) return reshape_plg(prop); else if(aig==2) return reshape_pldj(prop); else if(aig==3) return reshape_plt(prop); else if(aig==4) return reshape_plm(prop); else if(aig==5) return reshape_plf(prop); else if(aig==6) return reshape_plv(prop); else if(aig==7) return reshape_plc(prop); else if(aig==8) return reshape_pli(prop); else if(aig==9) return reshape_plfp(prop); else if(aig!=0) error,"Unknown graphical element !!"; } func replot(p1,p2,p3,p4,rslt) /* DOCUMENT replot(prop) replot(p1,p2,p3,p4,rslt) Replot a graphical element with its plq properties. prop is the array return by plq(i). then replot(plq(i)) will replot the graphical element i. SEE ALSO: copy_win,replot_all,replot_one_sys */ { if(is_void(p2)||is_void(p3)||is_void(p4)||is_void(rslt)) { aig=(*prop(1))(1); p1=*prop(1); p2=*prop(2); p3=*prop(3); p4=*prop(4); rslt=reshape_prop(prop); } else aig=p1(1); if(aig==1) replot_plg ,p1,p2,p3,p4,rslt; else if(aig==2) replot_pldj,p1,p2,p3,p4,rslt; else if(aig==3) replot_plt ,p1,p2,p3,p4,rslt; else if(aig==4) replot_plm ,p1,p2,p3,p4,rslt; else if(aig==5) replot_plf ,p1,p2,p3,p4,rslt; else if(aig==6) replot_plv ,p1,p2,p3,p4,rslt; else if(aig==7) replot_plc ,p1,p2,p3,p4,rslt; else if(aig==8) replot_pli ,p1,p2,p3,p4,rslt; else if(aig==9) replot_plfp,p1,p2,p3,p4,rslt; else if(aig!=0) error,"Unknown graphical element !!"; } func reshape_plg(prop) /* DOCUMENT reshape_plg(prop) Return [&x,&y], where x and y are the array used for the plot (plg,y,x). SEE ALSO: reshape_prop */ { local y,x; local p1,p2,p3,p4,p5; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=1) error,"Bad properties !!"; adx=p5(2);reshape,x,adx,double,[1,p5(1)]; ady=p5(3);reshape,y,ady,double,[1,p5(1)]; return [&x,&y]; } func replot_plg(p1,p2,p3,p4,rslt) /* DOCUMENT replot_plg(prop) Same as replot but only for plg graphical elements SEE ALSO: replot */ { if(p1(1)!=1) error,"Bad properties !!"; plg,*rslt(2),*rslt(1),hide=p1(2),legend=p2, color= get_color(p3(1)),type=p3(2),marks= p3(3), mcolor=get_color(p3(4)),marker=p3(5),rays=p3(6), closed=p3(7),smooth=p3(8),width= p4(1),msize=p4(2), mspace=p4(3),rspace=p4(4),rphase=p4(5),arrowl=p4(6),arroww=p4(7); } func reshape_pldj(prop) { local x0,y0,x1,y1; local p1,p2,p3,p4,p5; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=2) error,"Bad properties !!"; adx0=p5(2);reshape,x0,adx0,double,[1,p5(1)]; ady0=p5(3);reshape,y0,ady0,double,[1,p5(1)]; adx1=p5(4);reshape,x1,adx1,double,[1,p5(1)]; ady1=p5(5);reshape,y1,ady1,double,[1,p5(1)]; return [&x0,&y0,&x1,&y1]; } func replot_pldj(p1,p2,p3,p4,rslt) /* DOCUMENT replot_pldj(prop) Same as replot but only for pldj graphical elements SEE ALSO: replot */ { if(p1(1)!=2) error,"Bad properties !!"; pldj,*rslt(1),*rslt(2),*rslt(3),*rslt(4),hide=p1(2),legend=p2, color= get_color(p3(1)),type=p3(2), width= p4(1); } func reshape_plt(prop) { local txt; local p1,p2,p3,p4,p5; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=3) error,"Bad properties !!"; adt=p5(2);reshape,txt,adt,char,[1,p5(1)]; return [&txt]; } func replot_plt(p1,p2,p3,p4,rslt) /* DOCUMENT replot_plt(prop) Same as replot but only for plt graphical elements SEE ALSO: replot */ { if(p1(1)!=3) error,"Bad properties !!"; plt,string(rslt(1)),p4(2),p4(3),hide=p1(2),legend=p2,tosys=plsys(), color= get_color(p3(1)),font=p3(2),orient= p3(3),justify=p3(4),opaque=p3(5), height= p4(1); } func reshape_plm(prop) { local p1,p2,p3,p4,p5; local x,y,ireg; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=4) error,"Bad properties !!"; adx=p5(3);reshape,x,adx,double,[2,p5(1),p5(2)]; ady=p5(4);reshape,y,ady,double,[2,p5(1),p5(2)]; adi=p5(5);reshape,ireg,adi,int,[2,p5(1),p5(2)]; return [&x,&y,&ireg]; } func replot_plm(p1,p2,p3,p4,rlst) /* DOCUMENT replot_plm(prop) Same as replot but only for plm graphical elements SEE ALSO: replot */ { if(p1(1)!=4) error,"Bad properties !!"; plm,*rslt(2),*rslt(1),*rslt(3),legend=p2,hide=p1(2), color=get_color(p3(1)),type=p3(2),region=p3(3), boundary=p3(4),inhibit=p3(5),width=p4(1); } func reshape_plf(prop) { local p1,p2,p3,p4,p5; local z,y,x,ireg; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=5) error,"Bad properties !!"; adx=p5(3);reshape,x,adx,double,[2,p5(1),p5(2)]; ady=p5(4);reshape,y,ady,double,[2,p5(1),p5(2)]; adi=p5(5);reshape,ireg,adi,double,[2,p5(1),p5(2)]; adc=p5(6); if(p3(4)) reshape,z,adc,char,[3,3,p5(1)-1,p5(2)-1]; else reshape,z,adc,char,[2,p5(1)-1,p5(2)-1]; return [&x,&y,&ireg,&z]; } func replot_plf(p1,p2,p3,p4,rslt) /* DOCUMENT replot_plf(prop) Same as replot but only for plf graphical elements SEE ALSO: replot */ { if(p1(1)!=5) error,"Bad properties !!"; plf,*rslt(4),*rslt(2),*rslt(1),legend=p2,hide=p1(2), region=p3(1),edges=p3(2),ecolor=get_color(p3(3)), ewidth=p4(1); } func reshape_plv(prop) { local p1,p2,p3,p4,p5; local x,y,ireg,vx,vy; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=6) error,"Bad properties !!"; adx =p5(3);reshape,x,adx,double,[2,p5(1),p5(2)]; ady =p5(4);reshape,y,ady,double,[2,p5(1),p5(2)]; adi =p5(5);reshape,ireg,adi,int,[2,p5(1),p5(2)]; advx=p5(6);reshape,vx,advx,double,[2,p5(1),p5(2)]; advy=p5(7);reshape,vy,advy,double,[2,p5(1),p5(2)]; return [&x,&y,&ireg,&vx,&vy]; } func replot_plv(p1,p2,p3,p4,rslt) /* DOCUMENT replot_plv(prop) Same as replot but only for plv graphical elements SEE ALSO: replot */ { if(p1(1)!=6) error,"Bad properties !!"; plv,*rslt(5),*rslt(4),*rslt(2),*rslt(1),*rslt(3),hide=p1(2),legend=p2, region=p3(1),color=get_color(p3(2)),hollow=p3(3), width=p4(1),aspect=p4(2),scale=p4(3); } func reshape_plc(prop) { local p1,p2,p3,p4,p5; local x,y,ireg,z,tria,levels; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=7) error,"Bad properties !!"; adx=p5(3);reshape,x,adx,double,[2,p5(1),p5(2)]; ady=p5(4);reshape,y,ady,double,[2,p5(1),p5(2)]; adi=p5(5);reshape,ireg,adi,int,[2,p5(1),p5(2)]; adz=p5(6);reshape,z,adz,double,[2,p5(1),p5(2)]; adt=p5(7);reshape,tria,adt,short,[2,p5(1),p5(2)]; adl=p5(9);reshape,levels,adl,double,[1,p5(8)]; return [&x,&y,&ireg,&z,&tria,&levels]; } func replot_plc(p1,p2,p3,p4,rslt) /* DOCUMENT replot_plc(prop) Same as replot but only for plc graphical elements SEE ALSO: replot */ { if(p1(1)!=7) error,"Bad properties !!"; plc,*rslt(4),*rslt(2),*rslt(1),*rslt(3),levs=*rslt(6),legend=p2,hide=p1(2), region=p3(1),color=get_color(p3(2)),type=p3(3), marks=p3(4),mcolor=p3(5),marker=p3(6),smooth=p3(7), width=p4(1),msize=p4(2),mspace=p4(3),mphase=p4(4), triangle=*rslt(5); } func reshape_pli(prop) { local p1,p2,p3,p4,p5; local colors; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=8) error,"Bad properties !!"; adc=p5(3);reshape,colors,adc,char,[2,p5(1),p5(2)]; return [&colors]; } func replot_pli(p1,p2,p3,p4,rslt) /* DOCUMENT replot_pli(prop) Same as replot but only for pli graphical elements SEE ALSO: replot */ { if(p1(1)!=8) error,"Bad properties !!"; pli,*rslt(1),p4(1),p4(2),p4(3),p4(4),legend=p2,hide=p1(2); } func reshape_plfp(prop) { local p1,p2,p3,p4,p5; local pn,x,y,z; decomp_prop,prop,p1,p2,p3,p4,p5; if(p1(1)!=9) error,"Bad properties !!"; adpn=p5(5);reshape,pn,adpn,long,[1,p5(1)]; adx =p5(3);reshape,x,adx,double,[1,sum(pn)]; ady =p5(2);reshape,y,ady,double,[1,sum(pn)]; adz =p5(4); if(p5(1)&&p5(4)) if(p3(3)) //RGB mode reshape,z,adz,char,[2,3,p5(1)]; else reshape,z,adz,char,[1,p5(1)]; else z=[]; if(is_void(z)) return [&x,&y,&pn]; return [&x,&y,&z,&pn]; } func replot_plfp(p1,p2,p3,p4,rslt) /* DOCUMENT replot_plfp(prop) Same as replot but only for plfp graphical elements SEE ALSO: replot */ { if(p1(1)!=9) error,"Bad properties !!"; if(numberof(rslt)==3) plfp,,*rslt(1),*rslt(2),*rslt(3),hide=p1(2),legend=p2, edges=p3(1),ecolor=get_color(p3(2)),ewidth=p4(1); else plfp,*rslt(3),*rslt(1),*rslt(2),*rslt(4),hide=p1(2),legend=p2, edges=p3(1),ecolor=get_color(p3(2)),ewidth=p4(1); } func decomp_prop(prop,&prop1,&prop2,&prop3,&prop4,&prop5) /* DOCUMENT decomp_prop(prop,&p1,&p2,&p3,&p4,&p5) Put in propi the array *prop(i); */ { prop1=*prop(1); prop2=*prop(2); prop3=*prop(3); prop4=*prop(4); prop5=*prop(5); } func get_nb_sys(win,dims=) /* DOCUMENT get_nb_sys(win) Return the numberof og system in the window 'win'. If win is ommited, return the numberof of system in the current window. This routine does not change the selected window. SEE ALSO: */ { local a,b,c,d; if(is_void(dims)) dims=0; wbck = get_selected_system(); window,win; get_style,a,b,c,d; set_selected_system,wbck; if(dims) return dimsof(b); return numberof(b); } func get_color(color) /* DOCUMENT get_color(color) Check if color is a rgb encoded color. If so return the array [red,green,blue], else just return color. */ { if(!(color&0xF000000)) return color; red =(color&0x00000FF); green=(color&0x000FF00)>>8; blue =(color&0x0FF0000)>>16; return char([red,green,blue]); } func get_selected_system(void) /* DOCUMENT bkp=get_selected_system(); Return the current selected system and window SEE ALSO: set_selected_system */ { cur_win=current_window(); cur_sys=(cur_win>0)?plsys():-1; return [cur_win,cur_sys]; } func set_selected_system(saved_sys) /* DOCUMENT set_selected_system(saved_sys) Set the window number to SAVED_SYS(1) and the system number to SAVED_SYS(2) and return the window and system number before the modification. Use it with get_selected_system. The usual way of using these two functions is: bck = get_selected_system // you can change window and system with window,# // and plsys,# // And to go back to the window and the system // before all these modifications: set_selected_system,bck SEE ALSO: get_selected_system */ { tmp=get_selected_system(); if(saved_sys(1)>=0) { window,saved_sys(1); if(saved_sys(2)>=0) plsys,saved_sys(2); } return tmp; } frigaut-yorick-yutils-c173974/detect.i000066400000000000000000000422501152651572200177160ustar00rootroot00000000000000/* * detect.i -- * Detection of local minima/maxima for Yorick. * * Copyright (c) 2003, Eric THIEBAUT. * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * Routines: * find_1d_minmax - find local minima/maxima in 1-D array. * plot_1d_minmax - plot local minima/maxima in 1-D array. * find_2d_max - find isolated local maxima in 2-D array. * * History: * $Id: detect.i,v 1.1 2007-12-11 23:55:13 frigaut Exp $ * $Log: detect.i,v $ * Revision 1.1 2007-12-11 23:55:13 frigaut * Initial revision * * *----------------------------------------------------------------------------- */ func find_1d_minmax(a, what, inf=, sup=, alev=, rlev=, hysteresis=) /* DOCUMENT find_1d_minmax(a) * -or- find_1d_minmax(a, what) * Find local minima/maxima in 1-D array A. If WHAT is nil or zero, the * function returns an array of integers with same shape as A and set to * +1 where A is a local maximum, to -1 where A is a local minimum and to * 0 elsewhere. Otherwise, the function returns the indices of local * maxima or local minima depending whether WHAT is positive or negative * (the result may be empty). WHAT may also be a string: "any", "min" or * "max". * * Contiguous extrema, say a local maximum LOCMAX and a local minimum * LOCMIN, are separated by a strict hysteresis (or a gap) such that: * * LOCMAX - LOCMIN > HYSTERESIS*(max(A) - min(A)) >= 0 * * The default is HYSTERESIS=0, i.e. all strict local minima/maxima are * detected. However, in order to avoid being too sensitive to local * extrema (for instance because of noise), the hysteresis of the * algorithm can be adjusted by keywords INF, SUP, ALEV, RLEV or * HYSTERESIS. Note that the easiest keywords to play with are * HYSTERESIS or ATOL and RTOL (SUP and INF are more tricky to use). * * HYSTERESIS = level of hysteresis relative to peak-to-peak value of A. * HYSTERESIS must be conformable with A and everywhere * non-negative (this is not checked). HYSTERESIS is another way * to specify the absolute tolerance and is only significant if * ALEV is not specified. Specifying HYSTERESIS gives an absolute * tolerance: * ALEV = (max(A) - min(A))*HYSTERESIS. * Hence the lower is the hysteresis, the more local extrema will * be detected. As a rule of thumb, a good value for the * hysteresis is the 3-4 divided by the signal-to-noise-ratio. * * ALEV = absolute level of hysteresis. ALEV must be conformable with A * and such that ALEV >= 0 everywhere (this is not checked). The * default is the same as with ALEV=0 (unless keyword HYSTERESIS * is specified). * * RLEV = relative level of hysteresis. RLEV must be conformable with A * and such that 0 <= RLEV < 1 everywhere (this is not checked). * The default is the same as with RLEV=0. * * INF = inferior bound with respect to a maximum: A(i) may be a local * maximum with respect to A(j) if and only if A(j) < INF(i). INF * must have the same number of elements as A. If INF is not * specified, it is computed from the value of ALEV and RLEV. * Given ALEV and RLEV, the inferior bound is: * INF = A - (ALEV + RLEV*abs(A)) * * SUP = superior bound with respect to a minimum: A(i) may be a local * minimum with respect to A(j) if and only if A(j) > SUP(i). SUP * must have the same number of elements as A. If SUP is not * specified, it is computed from the value of ALEV and RLEV. * Given ALEV and RLEV, the superior bound is such that: * A = SUP - (ALEV + RLEV*abs(SUP)) * or: * SUP = (A + ALEV)/(1 - sign(SUP)*RLEV) * since 0 <= RLEV < 1 then SUP has the same sign as A + ALEV and * finally: * SUP = (A + ALEV)/(1 - sign(A + ALEV)*RLEV) * * SEE ALSO: plot_1d_minmax. */ { if (structof(what) == string) { if (what == "any") what = 0; else if (what == "max") what = 1; else if (what == "min") what = -1; else error, "bad value for WHAT (must be \"any\", \"min\" or \"max\")"; } if (! is_array(a) || (dimsof(a)(1)) != 1) error, "expecting 1-D array"; if ((s = structof(a)) != double) { if (s == complex) error, "illegal complex array"; a = double(a); } n = numberof(a); /* compute the inferior/superior bounds */ if (is_void(inf) || is_void(sup)) { if (is_void(alev)) { if (is_void(hysteresis)) alev = 0.0; else alev = (max(a) - min(a))*hysteresis; } if (noneof(rlev)) { if (noneof(alev)) { if (is_void(inf)) eq_nocopy, inf, a; if (is_void(sup)) eq_nocopy, sup, a; } else { if (is_void(inf)) inf = a - alev; if (is_void(sup)) sup = a + alev; } } else { if (is_void(inf)) inf = a - rlev*abs(a) - alev; if (is_void(sup)) { sup = a + alev; /* temporary */ sup = sup/(1.0 - sign(sup)*rlev); } } } type = array(long, n); /* start with leftmost element */ imin = imax = i = 1; vmin = vmax = a(1); vinf = inf(1); vsup = sup(1); state = 0; for (;;) { val = a(++i); if (i == n) { /* end-point */ if (state > 0) { type((val > vmax ? i : imax)) = 1; } else if (state < 0) { type((val < vmin ? i : imin)) = -1; } break; } if (state >= 0) { /* seeking for a local maximum */ if (val < vinf) { /* accept maximum value found so far as a local maximum and setup to start seeking for next local minimum */ type(imax) = 1; imin = i; vmin = val; vsup = sup(i); state = -1; } else if (val > vmax) { /* higher maximum found */ imax = i; vmax = val; vinf = inf(i); } } if (state <= 0) { /* seeking for a local minimum */ if (val > vsup) { /* accept maximum value found so far as a local maximum and setup to start seeking for a local minimum */ type(imin) = -1; imax = i; vmax = val; vinf = inf(i); state = 1; } else if (val < vmin) { /* lower minimum found */ imin = i; vmin = val; vsup = sup(i); } } } return (what ? (what > 0 ? where(type > 0) : where(type > 0)) : type); } func plot_1d_minmax(y, x, list, nocurve=, type=, width=, color=, symbol=, size=, fill=, what=, inf=, sup=, alev=, rlev=, hysteresis=) /* DOCUMENT plot_1d_minmax, y; -or- plot_1d_minmax, y, x; -or- plot_1d_minmax, y, x, list; Plot (X,Y) curve with local minima/maxima. LIST is the list of extrema as returned by find_1d_minmax; if LIST is nil, find_1d_minmax is used to find the extrema (with argument Y, and values of keywords WHAT, INF, SUP, ALEV, RLEV and/or HYSTERESIS). Unless keyword NOCURVE is true, the curve (X,Y) is plotted as well (with values of keywords TYPE, WIDTH and/or COLOR). Keywords SYMBOL, SIZE, FILL, and COLOR can be used to customize the plotting of local minima/maxima. If SYMBOL is unspecified and both minima and maxima are to be plotted, triangles pointing to the top (to the bottom) will be used to display maxima (minima). When called as a function, actual LIST is returned. SEE ALSO: find_1d_minmax, plp, plg. */ { if (is_void(list)) list = find_1d_minmax(y, what, inf=inf, sup=sup, alev=alev, rlev=rlev, hysteresis=hysteresis); if (is_void(x)) x = double(indgen(numberof(y))); if (! nocurve) plg, y, x, color=color, type=type, width=width; if (numberof(list) == numberof(y)) { /* plot both minima and maxima */ if (is_array((i = where(list < 0)))) { plp, y(i), x(i), symbol=(is_void(symbol) ? 7 : symbol), size=size, color=color, fill=fill; } if (is_array((i = where(list > 0)))) { plp, y(i), x(i), symbol=(is_void(symbol) ? 3 : symbol), size=size, color=color, fill=fill; } } else if (! is_void(list)) { plp, y(list), x(list), symbol=symbol, size=size, color=color, fill=fill; } return list; } /*---------------------------------------------------------------------------*/ func find_2d_max(img, alev=, rlev=, cmin=, cmax=, bad=, debug=) /* DOCUMENT map = find_2d_max(img) Find disjoint local maxima in 2-D array IMG and return an array of integers MAP with same shape as IMG and set as follow: MAP(x,y) = -1 for bad pixels (or strictly above CMAX) MAP(x,y) = 0 for pixels not assigned to any local maximum MAP(x,y) = N (N>0) for pixels assigned to N-th local maximum The maxima are labelled from the higher to the lower. Hence where(MAP==1) gives the indices of pixels around the stronger maximum. The selection works as follows. The algorithm starts with the next (unassigned) higher maximum and then marks all connected pixels which are greater or equal to a given threshold. If a bad pixel or a pixel already assigned to another maximum is encountered during this stage, the algorithm gives up this maximum and proceeds with the next one. Otherwise, the marked region is assigned to the maximum and the algorithm proceeds with the next one. This algorithm guarantees that the marked regions are all separated (by at least one pixel) from each other and from any bad pixel. The threshold reads: THRESHOLD = PEAK - RLEV*abs(PEAK) - ALEV where PEAK is the current maximum, ALEV (ALEV>=0 everywhere) and RLEV (0<=RLEV<1 everywhere) are the absolute and relative threshold levels. ALEV and RLEV are given by keyword. By default, ALEV=0 and RLEV=0. Keyword CMIN can be used to set the minimum value of a local maximum. Since searching all maxima may be prohibitively long, it is strongly recommended to limit the depth of the search by the keyword CMIN. Keywords BAD and/or CMAX can be used to mark as bad pixels the ones for which BAD is non-zero and/or which are (strictly) above CMAX. If specified, keywords ALEV, RLEV, CMIN, CMAX and BAD must all be conformable with IMG; you can therefore setup things on a per-pixel basis, or columnwise, or rowwise... EXAMPLE: For instance, if SIGMA is the standard deviation of noise in the image and BACKGROUND is its background level (both could be pixelwise), then: find_2d_max(IMG, cmin=BACKGROUND+3*SIGMA, alev=4*SIGMA) will find all the maxima in IMG which are above the background with a 3 SIGMA confidence level and mark the regions around every maximum (with value PEAK) where connected pixels are such that: IMG >= PEAK - 4*SIGMA HINTS: 1. Use keyword CMIN to limit the search (possibly on a per-pixel basis). 2. The search necessitates to sort the pixels elligible to be local maxima (all which are above CMIN, below CMAX and not in BAD), this sorting can be very long for large images (again use CMIN) but also for integer valued images (a drawback of the quicksort algorithm?) to overcome this it is sufficient to add a small amount of random noise in the image, for instance: find_2d_max(IMG + 1e-9*(random(dimsof(IMG)) - 0.5), ...) but beware that this can make the result (slightly) inpredictible. SEE ALSO: sort, find_1d_minmax. */ { if (! is_array(img) || ((dims = dimsof(img))(1)) != 2) error, "expecting 2-D array"; #if 0 if ((s = structof(img)) != double) { if (s == complex) error, "illegal complex array"; img = double(img); } #endif /* mark bad points */ region = array(long, dims); /* needed to make BAD conformable with IMG */ if (is_void(bad)) { if (! is_void(cmax)) bad = (img > cmax); } else if (is_void(cmax)) { bad |= region; /* make BAD conformable with IMG */ } else { bad |= (img > cmax); } if (anyof(bad)) region(where(bad)) = -1; /* sort pixels eligible for being local maxima */ if (debug) write, format="%s...", "sorting"; if (is_void(cmin) && is_void(bad)) { index = sort(img(*)); } else { if (is_void(cmin)) index = where(! bad); else if (is_void(bad)) index = where(img >= cmin); else index = where((! bad) & (img >= cmin)); if (! is_array(index)) { write, "warning no pixel are eligible for being local maxima"; return region; } index = index(sort(img(index))); } if (debug) write, format="%s\n", "done"; bad = cmin = cmax = []; /* free some memory */ /* compute threshold */ if (is_void(rlev)) { if (is_void(alev)) threshold = img(index); else threshold = (img - alev)(index); } else { if (is_void(alev)) threshold = (img - rlev*abs(img))(index); else threshold = (img - alev - rlev*abs(img))(index); } alev = rlev = []; /* free some memory */ /* serach local maxima */ number = numberof(img); width = dims(2); height = dims(3); list = array(long, number); /* indices of pixels in current region */ state = array(long, dims); mark = 1; for (i=numberof(index) ; i>=1 ; --i) { j = index(i); if (region(j)) continue; level = threshold(i); #if 0 if (debug) { write, format="search max around (%d,%d) %g >= %g\n", 1 + (j - 1)%width, 1 + (j - 1)/width,double(img(j)), double(level); } #endif /* Use a kind of non-recursive flood-fill algorithm. * * The 3 following bits are used to indicate the directions to * investigate (so that we limit the number of checks undergone by a * pixel): * * +---+ * | 4 | * +---+---+---+ * | 2 | x | 1 | * +---+---+---+ * | 8 | * +---+ * * region(x,y) = 0 if unused * region(x,y) = -1 if invalid * region(x,y) = n if inside n-th blob * * TO DO: use same array for REGION and STATE * */ region(j) = mark; /* mark current maximum */ state(j) = 15; /* will check all neighbors of current maximum */ count = 1; /* number of pixels in the current region */ list(1) = j; /* current maximum belongs to current region */ discard = 0n; /* no error yet */ for (j=1 ; j<=count ; ++j) { k = list(j); x = 1 + (k - 1)%width; y = 1 + (k - 1)/width; s = state(k); //if (debug) write,format="state(%d,%d)=\n"; if (s & 1) { if (x < width) { l = k + 1; if (! (r = region(l))) { if (img(l) >= level) { region(l) = mark; state(l) = 13; /* (1|2|4|8) & ~2 */ list(++count) = l; } } else if (r == mark) { state(l) = (s & 13); } else { discard = 1n; break; } } } if (s & 2) { if (x > 1) { l = k - 1; if (! (r = region(l))) { if (img(l) >= level) { region(l) = mark; state(l) = 14; /* (1|2|4|8) & ~1 */ list(++count) = l; } } else if (r == mark) { state(l) = (s & 14); } else { discard = 1n; break; } } } if (s & 4) { if (y < height) { l = k + width; if (! (r = region(l))) { if (img(l) >= level) { region(l) = mark; state(l) = 7; /* (1|2|4|8) & ~8 */ list(++count) = l; } } else if (r == mark) { state(l) = (s & 7); } else { discard = 1n; break; } } } if (s & 8) { if (y > 1) { l = k - width; if (! (r = region(l))) { if (img(l) >= level) { region(l) = mark; state(l) = 11; /* (1|2|4|8) & ~4 */ list(++count) = l; } } else if (r == mark) { state(l) = (s & 11); } else { discard = 1n; break; } } } } l = list(1:count); if (discard) { region(l) = 0; } else { ++mark; if (debug) { fma; //pli, region > 0; pli, region; pause, 1; } } } return region; } /*---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/doppler.i000066400000000000000000000127431152651572200201170ustar00rootroot00000000000000/* * doppler.i * * $Id: doppler.i,v 1.1 2008-01-04 13:47:48 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: doppler.i,v $ * Revision 1.1 2008-01-04 13:47:48 frigaut * initial import of thibaut's functions * * */ extern LightSpeed; /* DOCUMENT LightSpeed The velocity of light in vacuum and in m/s. */ LightSpeed=299792458; func voflambda(lambda,lambda0,air=,microns=,coef=,vlsr=) { /* DOCUMENT voflambda(lambda,lambda0) Attention: ALL velocities, including VLSR, are in m/s (NOT in km/s). Returns radial velocity necessary to Doppler-shift lambda0 to lambda. Wavelengths are in vacuum unless AIR is set to non void and non null. If AIR is specified, wavelengths must be in angstroms, or MICRONS or COEF must be specified too (see airvac and vacair). Velocities are in m/s. VLSR keyword can be used to shift the returned value: VLSR must be set to the real velocity in the local standard of rest of an object which radial velocity relative to the earth is zero at the time of observations. In that case, VOFLAMBDA returns velocities in the local standard of rest. If not, it returns velocities relative to the observer. SEE ALSO: lambdaofv */ if (is_void(vlsr)) vlsr=0.; if (air) { lambda=airvac(lambda,microns=microns,coef=coef); lambda0=airvac(lambda0,microns=microns,coef=coef); } lolc2=(lambda/lambda0)^2; return LightSpeed*(lolc2-1)/(lolc2+1)+vlsr; } func lambdaofv(v,lambda0,air=,microns=,coef=,vlsr=) { /* DOCUMENT lambdaofv(v,lambda0) Returns observed wavelength corresponding to lambda0 Doppler-shifted with velocity v. Wavelength are in vacuum unless AIR is set to non void and non null. If AIR is specified, wavelengths must be in angstroms, or MICRONS or COEF must be specified too (see airvac and vacair). Velocities are in m/s. If VLSR keyword is set to the real velocity in the local standard of rest of an object which radial velocity relative to the earth is zero at the time of observations, V is considered a velocities in the local standard of rest and apparent wavelengths at the time of observations are computed. If not, V should not be in the local standard of rest but at the time of observations for the return wavelengths to be accurate. Example: say you have a spectrum of an object, which velocity in the local standard of rest is 0 but at the time of observations, an observed velocity of 0m/s would indeed correspond to a velocity in the local standard of rest of VLSR(m/s). AXIS contains the observed wavelength in micron for this spectrum. Then, lambdaofv(voflambda(AXIS,vlsr=VLSR),vlsr=0) would return the axis, corrected for the earth's motion. Now, if radial velocity of the object in the LSR is not 0, but Vobj, then the axis corrected for both the earth's and object's motions is given by lambdaofv(voflambda(AXIS,vlsr=VLSR),vlsr=-Vobj). (Note: don't trust me, at the time I'm writing these lines, I'm quite tired...) SEE ALSO: voflambda */ if (is_void(vlsr)) vlsr=0.; if (air) lambda0=airvac(lambda0,microns=microns,coef=coef); b=(v-vlsr)/LightSpeed; lambda=lambda0*sqrt((1+b)/(1-b)); if (air) lambda=vacair(lambda,microns=microns,coef=coef); return lambda; } func vacair(VAC,microns=,coef=){ /* DOCUMENT airwl=vacair(vacwl) Compute air wavelength from vacuum wavelength in Angstroms. Information found in; http://www-obs.univ-lyon1.fr/hypercat/pleinpot/imdwaxisc1.html "The IAU standard for conversion from air to vacuum wavelengths is given in Morton (1991, ApJS, 77, 119). For vacuum wavelengths (VAC) in Angstroms, convert to air wavelength (AIR) via: AIR = VAC / (1.0 + 2.735182E-4 + 131.4182 / VAC^2 + 2.76249E8 / VAC^4)" */ if (is_void(coef)) coef=1.; if (microns) coef=10000.; VAC=VAC*coef; AIR = VAC / (1.0 + 2.735182E-4 + 131.4182 / VAC^2 + 2.76249E8 / VAC^4); return AIR/coef; } func airvac(AIR,microns=,coef=){ /* DOCUMENT vacwl=airvac(airwl) Compute vacuum wavelength from air wavelength in Angstroms. Information found in; http://www-obs.univ-lyon1.fr/hypercat/pleinpot/imdwaxisc1.html "The IAU standard for conversion from air to vacuum wavelengths is given in Morton (1991, ApJS, 77, 119). For vacuum wavelengths (VAC) in Angstroms, convert to air wavelength (AIR) via: AIR = VAC / (1.0 + 2.735182E-4 + 131.4182 / VAC^2 + 2.76249E8 / VAC^4)" */ if (is_void(coef)) coef=1.; if (microns) coef=10000.; AIR=AIR*coef; VAC = AIR * (1.0 + 2.735182E-4 + 131.4182 / AIR^2 + 2.76249E8 / AIR^4); return VAC/coef; } frigaut-yorick-yutils-c173974/emulate_yeti.i000066400000000000000000000222351152651572200211350ustar00rootroot00000000000000/* * emulate_yeti.i -- * * Interpreted functions which emulate some builtin functions of Yeti. * * Copyright (c) 2005-2007, Eric Thiebaut, Observatoire de Lyon (France). * * Routines: * swap - exchanges contents of two variables. * unref - returns X, destroying X in the process. * is_vector - check if argument is a vector. * is_matrix - check if argument is a matrix. * is_real - check if argument is of float or double type. * is_complex - check if argument is of complex type. * is_integer - check if argument is of integer type. * is_numerical - check if argument is of numerical type. * make_dimlist - build-up dimension list * * History: * $Id: emulate_yeti.i,v 1.3 2010-04-15 17:17:37 frigaut Exp $ * $Log: emulate_yeti.i,v $ * Revision 1.3 2010-04-15 17:17:37 frigaut * * - protected re-definition of new yorick builtins in emulate_yeti.i * * Revision 1.2 2010/04/07 06:15:23 paumard * - remove strchr, strrchr, is_scalar and is_vector, they are in string.i (beware, no autoloads) ; * - move is_integer_scalar from utils.i to emulate_yeti.i * * Revision 1.1 2010/04/06 15:36:09 paumard * - move emulate-yeti*.i to emulate_yeti*.i * * Revision 1.2 2010/04/06 14:21:51 paumard * - move strlower & strupper from utils.i to emulate-yeti.i; * - move round from util_fr.i to emulate-yeti.i; * - round returns a double, like the Yeti implementation; * - review autoloads (adding emulate-yeti_start.i); * - add missing files to Makefile. * * Revision 1.1 2010/02/10 13:27:12 paumard * - Synchronize files with Eric Thiebaut's: fft_utils.i, img.i, plot.i, utils.i. * - Import emulate_yeti.i * - Remove basename() and dirname(), standard in pathfun.i. * - Remove the accents in Erics name to prevent a crash on amd64. * * Revision 1.1 2007/04/24 06:58:44 eric * Initial revision * * *----------------------------------------------------------------------------- */ if (is_func(yeti_init)) { error, "This file define functions redundant with Yeti package."; } func is_integer_scalar(x) /* DOCUMENT is_integer_scalar(x) Check whether or not X is an integer scalar. SEE ALSO is_scalar, is_integer. */ { return (((s=structof(x))==long || s==int || s==short || s==char) && ! dimsof(x)(1)); } // The following requires Yorick >= 1.6.02 func strlower(s) { return strcase(0, s); } func strupper(s) { return strcase(1, s); } /* DOCUMENT strlower(s) -or- strupper(s) Convert (array of) string(s) S to lower/upper case letters. SEE ALSO strcase */ local make_dimlist; func grow_dimlist(&dimlist, arg) /* DOCUMENT make_dimlist, dimlist, next_argument; * * Builds a dimension list DIMLIST, as used in the array function * (which see). Use like this (all extra arguments in your function * are considered as dimensions or dimension lists): * * func your_function(arg1, arg2, etc, ..) * { * dimlist = [0]; * while (more_args()) make_dimlist, dimlist, next_arg(); * ... * } * * After this, DIMLIST will be an array of the form [ndims, dim1, * dim2,...], compounded from the multiple arguments in the same way * as the array function. Another possibility is to define your * function as: * * func your_function(arg1, arg2, etc, dimlist, ..) * { * while (more_args()) make_dimlist, dimlist, next_arg(); * ... * } * * But in this latter case, if no DIMLIST arguments given, DIMLIST will * be [] instead of [0], which will act the same in most situations. If * that possibility is unacceptable, you may add * * if (is_void(dimlist)) dimlist= [0]; * * before/after the while loop. * * * SEE ALSO: * array, build_dimlist. */ { if (is_array(arg)) { if (structof((n = arg(1)+0)) == long) { if (! (d1 = dimsof(arg)(1))) { if (is_void(dimlist)) { dimlist = [1, n]; } else { grow, dimlist, n; ++dimlist(1); } return; } else if (d1 == 1) { if (is_void(dimlist)) { dimlist = long(arg); return; } else { if (n == numberof(arg)-1) { grow, dimlist, long(arg(2:0)); dimlist(1) += n; return; } } } error, "bad dimension list"; } } else if (is_void(arg)) { if (is_void(dimlist)) dimlist = [0]; return; } error, "bad data type in dimension list"; } if (is_func(make_dimlist) != 2) { make_dimlist = grow_dimlist; /* for old code */ } //======================================================================== // the following are builtin function in yorick 2.1.05x, > april 2010. // we will only redefine these functions if they don't already exist func __unref(&x) /* interpreted version */ /* DOCUMENT unref(x) returns X, destroying X in the process (useful to deal with temporary big arrays). Written after Yorick's FAQ. SEE ALSO: eq_nocopy, swap. */ { local y; eq_nocopy, y, x; x = []; return y; } if (typeof(unref)!="builtin") unref=__unref; func __swap(&a, &b) /* interpreted version */ /* DOCUMENT swap, a, b; Exchanges the contents of variables A and B without requiring any temporary copy. SEE ALSO: eq_nocopy, unref. */ { local tmp; eq_nocopy, tmp, a; eq_nocopy, a, b; eq_nocopy, b, tmp; } if (typeof(swap)!="builtin") swap=__swap; func __is_matrix(x) { return (is_array(x) && dimsof(x)(1) == 2); } /* DOCUMENT is_matrix(x) * Returns true if X is a matrix (i.e. a 2-D array). * * SEE ALSO: dimsof, is_array, is_integer, is_scalar, is_vector */ if (typeof(is_matrix)!="builtin") is_matrix=__is_matrix; func __is_integer(x) {return ((s=structof(x))==long || s==int || s==char || s==short);} func __is_real(x) {return ((s=structof(x))==double || s==float);} func __is_complex(x) {return structof(x)==complex;} func __is_numerical(x) {return ((s=structof(x))==long || s==double || s==int || s==char || s==complex || s==short || s==float);} func __is_string(x) { return structof(x)==string;} /* DOCUMENT is_integer(x) * -or- is_real(x) * -or- is_complex(x) * -or- is_numerical(x) * -or- is_string(x) * These functions return true if X is an array of type: integer, real * (i.e. double or float), complex, numerical (i.e. integer, real or * complex) or string. * * SEE ALSO: structof, dimsof, is_array, is_scalar. */ if (typeof(is_integer)!="builtin") is_integer =__is_integer; if (typeof(is_real)!="builtin") is_real =__is_real; if (typeof(is_complex)!="builtin") is_complex =__is_complex; if (typeof(is_numerical)!="builtin") is_numerical =__is_numerical; if (typeof(is_string)!="builtin") is_string =__is_string; func __round(arg) /* DOCUMENT round(arg) * Returns the rounded version of a floating point argument * modified 2007dec06 to fix problem with negative numbers * F.Rigaut 2001/10, Return double TP 2010/04 * SEE ALSO: ceil, floor */ {return double(long(arg+0.5)-(arg<0));} if (typeof(round)!="builtin") round =__round; /*---------------------------------------------------------------------------*/ #if 0 /* obsolete since Yorick 1.6 */ local _strlower, _strupper; /* DOCUMENT local _strlower, _strupper; Private arrays to convert char to upper/lowercase letters. SEE ALSO strlower, strupper */ (_strlower = char(indgen(0:255)))(1+'A':1+'Z') = _strlower(1+'a':1+'z'); (_strupper = char(indgen(0:255)))(1+'a':1+'z') = _strupper(1+'A':1+'Z'); local strlower, strtolower; /* needed for documentation */ func __strlower(s) /* interpreted version */ /* DOCUMENT strlower(s) -or- strtolower(s) Convert a string or an array of strings S to lower case letters. SEE ALSO strupper */ { /* fool codger */ extern _strlower; n = numberof((r = array(string, dimsof(s)))); for (i=1; i<=n; ++i) r(i)= string(&_strlower(1+*pointer(s(i)))); return r; } local strupper, strtoupper; /* needed for documentation */ func __strupper(s) /* interpreted version */ /* DOCUMENT strupper(s) -or- strtoupper(s) Convert a string or an array of strings S to upper case letters. SEE ALSO strlower */ { /* fool codger */ extern _strupper; n = numberof((r = array(string, dimsof(s)))); for (i=1; i<=n; ++i) r(i)= string(&_strupper(1+*pointer(s(i)))); return r; } /* replace non-builtin functions by interpreted ones */ if (is_func(strupper) != 2) strupper = __strupper; if (is_func(strlower) != 2) strlower = __strlower; if (is_func(strtoupper) != 2) strtoupper = strupper; if (is_func(strtoupper) != 2) strtolower = strtolower; #endif /*---------------------------------------------------------------------------* * Local Variables: * * mode: Yorick * * tab-width: 8 * * fill-column: 75 * * coding: latin-1 * * End: * *---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/emulate_yeti_start.i000066400000000000000000000014041152651572200223450ustar00rootroot00000000000000// Only prepare these autoloads if yeti is not in the path. // Yeti's autoload should also cancel this by calling // autoload, "emulate_yeti.i"; if (!find_in_path("yeti.i", takefirst=1)) { autoload, "emulate_yeti.i"; autoload, "emulate_yeti.i", grow_dimlist, is_integer_scalar; autoload, "emulate_yeti.i", strlower, strupper; } // the following are yorick buildins since 2.1.05x (april 10,2010) if ( (typeof(swap)!="builtin") && (!find_in_path("yeti.i", takefirst=1)) ) { // we're working with yorick pre-apr2010, and // yeti is not in the path. Let's autoload these functions: autoload, "emulate_yeti.i", unref, swap; autoload, "emulate_yeti.i", is_matrix, is_integer, is_real, is_complex; autoload, "emulate_yeti.i", is_numerical, is_string, round; } frigaut-yorick-yutils-c173974/fft_utils.i000066400000000000000000001105551152651572200204510ustar00rootroot00000000000000/* * fft_utils.i -- * * Useful routines for FFT operations in Yorick. * *----------------------------------------------------------------------------- * * Copyright (C) 1995, Eric Thiebaut * * This file is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License version 2 as * published by the Free Software Foundation. * * This file 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. * *----------------------------------------------------------------------------- * * History: * $Id: fft_utils.i,v 1.2 2010-02-10 13:27:12 paumard Exp $ * $Log: fft_utils.i,v $ * Revision 1.2 2010-02-10 13:27:12 paumard * - Synchronize files with Eric Thiebaut's: fft_utils.i, img.i, plot.i, utils.i. * - Import emulate_yeti.i * - Remove basename() and dirname(), standard in pathfun.i. * - Remove the accents in Erics name to prevent a crash on amd64. * * Revision 1.13 2008/07/12 06:38:26 eric * - Considerable speed-up of fft_gaussian_mtf and fft_gaussian_psf for * multidimensional array (accounting for the fact that the Gaussian * is separable). Also FWHM can now be a scalar or a vector with as * many values as number of dimensions. * - New function fft_get_ndims. * * Revision 1.12 2007/04/24 07:11:43 eric * - Function grow_dimlist replaced by make_dimlist. * - Function fft_paste fixed. * * Revision 1.11 2005/10/18 18:20:39 eric * - Oops, the previous bug fix yields a new bug, OK now fft_dist * should work again for n-D arrays (with n>1). * * Revision 1.10 2005/10/18 18:09:19 eric * - new function: fft_paste; * - fixed bug in fft_dist for 1-D dimension lists which affected * functions such as fft_smooth for 1-D arrays (thanks to Christophe * Pichon for pointing the bug); * * Revision 1.1.1.1 2007/12/11 23:55:14 frigaut * Initial Import - yorick-yutils * * Revision 1.9 2004/10/11 11:18:21 eric * - Fix fft_dist() so that it is as flexible as, e.g., array() for * the dimension list. * * Revision 1.8 2004/08/31 16:20:22 eric * - New routines for Fourier interpolation: fft_fine_shift, * fft_unphasor, fft_interp, fft_interp_complex, fft_interp_real. * * Revision 1.7 2003/08/23 09:55:57 eric * - new functions: fft_gaussian_mtf and fft_gaussian_psf; * - *** POSSIBLE INCOMPATIBILITY *** change order of args in * fft_recenter and use fft_setup to speed up FFT's; * * Revision 1.6 2003/01/31 15:58:32 eric * - Added new routines: fft_recenter, fft_smooth and reverse_dims. * * Revision 1.5 2002/11/20 09:20:56 eric * - new keywords SQUARE and NYQUIST in fft_dist * - make use of grow_dimlist in "utils.i" * * Revision 1.4 2002/11/14 10:59:38 eric * - new graphics routines: fft_plh, fft_plc, fft_plfc * - new routines: abs2, fft_roll_1d, fft_roll_2d, __fft & Co * - introduction documentation by: help, fft_utils; * * Revision 1.3 2001/04/23 14:16:15 eric * New routine: fft_symmetric_index. * * Revision 1.2 2001/04/06 16:42:59 eric * - new routine: fft_plg * - fixed routine: fft_recenter_at_max * * Revision 1.1 2001/03/23 16:45:54 eric * Initial revision * *----------------------------------------------------------------------------- */ require, "utils.i"; local fft_utils; /* DOCUMENT: FFT utility routines in "fft_utils.i" This package is mainly written to deal with the particular indexing rules in FFT transformed arrays. The following routines are provided: abs2 - squared absolute value. fft_best_dim - get best dimension to compute FFT. fft_centroid - get centroid in FFT arrays. fft_convolve - compute discrete convolution thanks to FFT. fft_dist - compute length of FFT frequencies/coordinates. fft_fine_shift, fft_unphasor - shift/roll an array by non-integer offset by means of Fourier interpolation. fft_gaussian_mtf - compute Gaussian modulation transfer function. fft_gaussian_psf - compute Gaussian point spread function. fft_indgen - generate index of FFT frequencies/coordinates. fft_interp, fft_interp_complex, fft_interp_real - interpolate array at non-integer offsets. fft_plc - plot contours of 2D FFT. fft_plfc - plot filled contours of 2D FFT. fft_plg - plot 1D FFT as curve. fft_plh - plot 1D FFT with stairs. fft_pli - plot 2D FFT as image. fft_recenter - recenter array with respect to a template. fft_recenter_at_max - recenter FFT arrays at their maximum. fft_roll_1d - roll dimension of 1D arrays. fft_roll_2d - roll dimension of 2D arrays. fft_shift_phasor - get complex phasor for arbitrary shift. fft_smooth - smooth an array by convolution with a gaussian. fft_symmetric_index - get hermitian-symmetry index for FFT arrays. reverse_dims - reverse all dimensions of an array. __fft - expert driver for repeated FFT's with same dimensions. __fft_init - initialization for __fft. SEE ALSO: fft, fftw. */ func abs2(x) /* DOCUMENT abs2(x) Returns abs(X)^2 SEE ALSO: abs. */ { if (structof(x) != complex) return x*x; y = x.im; x = double(x); return x*x + y*y; } func fft_best_dim(len) /* DOCUMENT fft_best_dim(len); Return the smallest integer which is greater or equal LEN and which is a multiple of powers of 2, 3 and/or 5 SEE ALSO fft_indgen, fft. */ { best= 2*len; for (i5=1; i5<=len; i5*=5) { for (i3= i5; i3<=len; i3*=3) { i2= i3; while (i2 < len) i2*=2; if (i2 == len) return len; if (i2-len < best-len) best= i2; } } return best; } func fft_indgen(dim) { return (u= indgen(0:dim-1)) - dim*(u > dim/2); } /* DOCUMENT fft_indgen(len) Return FFT frequencies along a dimension of length LEN. SEE ALSO: indgen, span, fft_dist, fft_freqlist, fft_symmetric_index. */ func fft_dist(.., nyquist=, square=) /* DOCUMENT fft_dist(dimlist); -or- fft_dist(dim1, dim2, ...); Returns Euclidian lenght of spatial frequencies in frequel units for a FFT of dimensions DIMLIST. If keyword NYQUIST is true, the frequel coordinates get rescaled so that the Nyquist frequency is equal to NYQUIST along every dimension. This is obtained by using coordinates: (2.0*NYQUIST/DIM(i))*fft_indgen(DIM(i)) along i-th dimension of lenght DIM(i). If keyword SQUARE is true, the square of the Euclidian norm is returned instead. SEE ALSO: fft_indgen, fft_symmetric_index. */ { /* Build dimension list. */ local arg, dims; while (more_args()) { eq_nocopy, arg, next_arg(); if ((s = structof(arg)) == long || s == int || s == short || s == char) { /* got an integer array */ if (! (n = dimsof(arg)(1))) { /* got a scalar */ grow, dims, arg; } else if (n == 1 && (n = numberof(arg) - 1) == arg(1)) { /* got a vector which is a valid dimension list */ if (n) grow, dims, arg(2:); } else { error, "bad dimension list"; } } else if (! is_void(arg)) { error, "unexpected data type in dimension list"; } } if (! (n = numberof(dims))) return 0.0; /* scalar array */ if (min(dims) <= 0) error, "negative value in dimension list"; /* Build square radius array one dimension at a time, starting with the last dimension. */ if (is_void(nyquist)) { r2 = (u = double(fft_indgen(dims(n))))*u; while (--n >= 1) { r2 = r2(-,..) + (u = double(fft_indgen(dims(n))))*u; } } else { s = 2.0*nyquist; dim = dims(n); r2 = (u = (s/dim)*fft_indgen(dim))*u; while (--n >= 1) { dim = dims(n); r2 = r2(-,..) + (u = (s/dim)*fft_indgen(dim))*u; } } return (square ? r2 : sqrt(r2)); } func fft_freqlist(dimlist) /* DOCUMENT ptr = fft_freqlist(dimlist) returns a vector of DIMLIST(1) pointers with normalized FFT frequencies along all dimensions of DIMLIST (must be dimsof(SOME_ARRAY)) with "adequate" geometry: *ptr(1) = (2*pi/dimlist(2))*fft_indgen(dimlist(2)); *ptr(2) = [(2*pi/dimlist(3))*fft_indgen(dimlist(3))]; *ptr(3) = [[(2*pi/dimlist(4))*fft_indgen(dimlist(4))]]; ... SEE ALSO: fft_indgen, fft_shift_phasor. */ { /* Precompute (scaled) Fourier frequencies along every dimensions (the trick is to build these as "vectors" with adequate dimension list so as to minimize the number of operations during the search). */ PI = 3.1415926535897932384626433832795029; ndims = dimlist(1); ptr = array(pointer, ndims); for (k=1 ; k<=ndims ; ++k) { len = dimlist(k + 1); ws = array(1, k + 1); /* to build dimension list of k-th dimension */ ws(1) = k; ws(0) = len; (ws = array(double, ws))(*) = (2.0*PI/len)*fft_indgen(len); ptr(k) = &ws; } return ptr; } func fft_smooth(a, fwhm, setup=) /* DOCUMENT fft_smooth(a, fwhm) -or- fft_smooth(a, fwhm, setup=workspace) Returns array A smoothed along all its dimensions by convolution by a gaussian with full width at half maximum equals to FWHM. See fft_setup for the meaning of keyword SETUP. SEE ALSO: fft, fft_setup, fft_gaussian_mtf. */ { dims = dimsof(a); if (is_void(setup)) setup=fft_setup(dims); as_double = (structof(a) != complex); a = fft((1.0/numberof(a))*fft_gaussian_mtf(dims, fwhm)* fft(a, +1, setup=setup), -1, setup=setup); return (as_double ? double(a) : a); } local fft_gaussian_psf; local fft_gaussian_mtf; /* DOCUMENT fft_gaussian_psf(dimlist, fwhm) -or- fft_gaussian_mtf(dimlist, fwhm) Returns normalized Gaussian point spread function (PSF) or corresponding modulation transfer function (MTF) with dimension list DIMLIST and full width at half maximum equals to FWHM along each dimensions (in the PSF space). Up to errors due to limited support, numerical precision and finite sampling, the PSF and the MTF obey: sum(PSF) = MTF(1) = 1 (normalization) MTF = fft(PSF, +1) PSF = fft(MTF, -1)/numberof(MTF) where MTF(1) is the 0-th frequency in the MTF. The standard deviation SIGMA and the FWHM are related by: FWHM = sqrt(8*log(2))*SIGMA ~ 2.354820045031*SIGMA Note that, owing to the limited size of the support and/or numerical precision, these properties may not be perfectly met; for that reason, _always_ compute directly what you need, e.g. do not take the FFT of the PSF if what you need is the MTF. Also note that the geometry is that of the FFT and that for unequal dimension lengths, the PSF has the same width (in "pixels") along every dimension but not the MTF. FWHM can be a scalar or a vector with as many values as number of dimensions. SEE ALSO: fft_get_ndims, fft_dist, fft_smooth. */ func fft_gaussian_psf(dims, fwhm) { ndims = fft_get_ndims(dims); if (ndims <= 0L) { if (ndims == 0L) return (1.6651092223153955127063292897904020952612/fwhm); error, "bad dimension list"; } //r = (sqrt(log(16.0)/pi)/fwhm) + array(0.0, ndims); //s = (sqrt(log(16.0))/fwhm) + array(0.0, ndims); r = (0.9394372786996513337723403284101825868414/fwhm) + array(0.0, ndims); s = (1.6651092223153955127063292897904020952612/fwhm) + array(0.0, ndims); j = ndims; u = s(j)*fft_indgen(dims(j)); p = exp(-u*u); q = r(j); while (--j >= 1L) { u = s(j)*fft_indgen(dims(j)); p = exp(-u*u)*p(-,..); q *= r(j); } return q*p; } func fft_gaussian_mtf(dims, fwhm) { ndims = fft_get_ndims(dims); if (ndims <= 0L) { if (ndims == 0L) return 1.0; error, "bad dimension list"; } // s = (pi/sqrt(log(16)))*fwhm/dim s = 1.8867186677527935983734215966417072034386*fwhm/dims; j = ndims; u = s(j)*fft_indgen(dims(j)); p = exp(-u*u); while (--j >= 1L) { u = s(j)*fft_indgen(dims(j)); p = exp(-u*u)*p(-,..); } return p; } func fft_get_ndims(&dims) /* DOCUMENT fft_get_ndims(dimlist) Returns the number of dimensions in dimension list DIMLIST and modify (in-place) DIMLIST to be only the list of dimensions (that is without the number of dimensions). If DIMLIST is invalid, -1 is returned. SEE ALSO: dimsof. */ { if (((s = structof(dims)) == long || s == int || s == short || s == char) && min(dims) > 0) { temp = dimsof(dims)(1); if (temp == 0L) { dims = long(dims); return 1L; } else if (temp == 1L && (ndims = dims(1)) == numberof(dims) - 1L) { dims = (ndims >= 1L ? long(dims(2:0)) : []); return ndims; } return ndims; } else if (is_void(dims)) { return 0L; } return -1L; } /* * Notes: * The FFT of a Gaussian of given FWHM is: * exp(-pi^2*fwhm^2*(k/dim)^2/log(16)) * where K is the FFT index; hence: * Nyquist = sqrt(pi^2*fwhm^2*(dim/2/dim)^2/4/log(2)) * = pi*fwhm/4/sqrt(log(2)) * ~ 0.9433593338763967992*fwhm * The Gaussian is (N is the number of dimensions): * ((sqrt(log(16)/pi)/fwhm)^n)*exp(-log(16)*(k/fwhm)^2) * ~ ((0.9394372786996513337/fwhm)^n)*exp(...) * * Constants (with 40 significant digits): * pi/4/sqrt(log(2)) = 0.9433593338763967991867107983208536017193; * sqrt(log(16)/pi) = 0.9394372786996513337723403284101825868414; * log(16) = 2.772588722239781237668928485832706272302; */ /*---------------------------------------------------------------------------*/ /* SIMPLE FAST FOURIER TRANSFORM */ func __fft_init(dimlist) /* DOCUMENT __fft_init, dimlist; Initializes FFT workspace for further calls to __fft (to see). DIMLIST is the dimension list of the arrays to transform. The routine defines 2 external symbols: __fft_setup - used to store the FFT workspace) __fft_number - used to keep track of the number of calls to __fft In order to avoid namespace pollution/clash, a routine that uses __fft should declare these symbols as local before calling __fft_init, e.g.: local __fft_setup, __fft_number; __fft_init, dimlist; SEE ALSO: fft_setup, __fft. */ { extern __fft_setup, __fft_number; dims = dimlist(2:); ndims = numberof(dims); __fft_setup = array(pointer, ndims); __fft_number = 0; for (i=1 ; i<=ndims ; ++i) { if (! __fft_setup(i)) { dim = dims(i); ws = array(double, 6*dim + 15); fft_init, dim, ws; __fft_setup(where(dims == dim)) = &ws; } } } func __fft(x, dir) /* DOCUMENT __fft(x); -or- __fft(x, dir); Replacement for Yorick's fft to speed up fast Fourier transforms (FFT) in, e.g., iteratives algorithms that necessitate computation of several FFT's of arrays with same dimension list. The FFT is performed on all dimensions of X and DIR must be a scalar (default +1). FFT workspace must be initialized by __fft_init. SEE ALSO: __fft_init, fft. */ { extern __fft_setup, __fft_number; /* Make a private copy of input array even if it is already complex and get its dimension list. */ if (is_void(dir)) dir = +1; x = complex(x); dims = dimsof(x); ndims = dims(1); dims = dims(2:0); if (structof(__fft_setup) != pointer || numberof(__fft_setup) != ndims) error, "unitialized FFT workspace"; /* Do the transform along every dimension of X. */ len = 6*dims + 15; // expected length of workspace vectors std = 1; top = numberof(x); for (i=1 ; i<=ndims ; i++) { dim = dims(i); ws = __fft_setup(i); if (numberof(*ws) != len(i) || structof(*ws) != double) error, swrite(format="bad FFT workspace for dimension length %d", dim); top /= dim; fft_raw, dir, x, std, dim, top, ws; std *= dim; } /* increment counter and return result */ if (is_void(__fft_number)) __fft_number= 0; ++__fft_number; return x; } /*---------------------------------------------------------------------------*/ func fft_symmetric_index(..) /* DOCUMENT fft_symmetric_index(dimlist) -or- fft_symmetric_index(dim1, dim2, ...); Returns indices of hermitian-symmetry transform for a FFT with dimension list DIMLIST. For instance, if A is a N-dimensional array, then: AP= A(fft_symmetric_index(dimsof(A))) is equal to array A with its coordinates negated according to FFT convention: AP(X1, X2, ..., XN) = A(-X1, -X2, ..., -XN) consequently if A is hermitian then: AP= conj(A). SEE ALSO: fft_indgen. */ { /* Build dimension list. */ dimlist = [0]; while (more_args()) make_dimlist, dimlist, next_arg(); /* Compute result starting by last dimension. */ local u; if ((n = numberof(dimlist)) == 1) return 1; /* scalar array */ for (k=n ; k>1 ; --k) { dim = dimlist(k); (q = indgen(dim:1:-1))(1) = 0; // neg. of freq along that dim u= k0 && abs(x0-x0p)>=1); return x1; } func fft_centroid(a, repeat) /* DOCUMENT fft_centroid(a) -or- fft_centroid(a, repeat) Return the position of centroid of N-dimensional array A assuming coordinates along dimensions of A are wrapped as in a FFT (see fft_indgen). The algorithm proceeds by computing the center of gravity of A around its central element which is the maximum of A for the first iteration and the closest to the previously computed centroid for subsequent iterations. The maximum number of iteration is REPEAT (default: 3; in any cases, at least one iteration is performed). The Nyquist frequency along each even dimension is omitted to avoid a bias. SEE ALSO fft_indgen. */ { if (is_void(repeat)) repeat= 3; dims= dimsof(a); if ((ndims= dims(1)) <= 2) { if (ndims==2) return [_fft_centroid(a(,sum), repeat), _fft_centroid(a(sum,), repeat)]; if (ndims==1) return _fft_centroid(a, repeat); return 0.0; // ndims==0 } result= array(double, ndims); for (i=1 ; i<=ndims ; ++i) { dim= dims(i+1); a1= array(double, numberof(a)/dim, dim); a1(*)= (i==ndims ? a(*) : transpose(a, [ndims,i])(*)); a1= a1(sum,); result(i)= _fft_centroid(a1, repeat); } return result; } /*---------------------------------------------------------------------------*/ /* CENTERING / ROLLING */ func reverse_dims(a) /* DOCUMENT reverse_dims(a) Returns array A with all its dimensions reversed. SEE ALSO: fft_recenter. */ { n = dimsof(a)(1); r = ::-1; if (n == 1) return a(r); if (n == 2) return a(r, r); if (n == 3) return a(r, r, r); if (n == 4) return a(r, r, r, r); if (n == 5) return a(r, r, r, r, r); if (n == 6) return a(r, r, r, r, r, r); if (n == 7) return a(r, r, r, r, r, r, r); if (n == 8) return a(r, r, r, r, r, r, r, r); if (n == 9) return a(r, r, r, r, r, r, r, r, r); if (n == 10) return a(r, r, r, r, r, r, r, r, r, r); if (n == 11) return a(r, r, r, r, r, r, r, r, r, r, r); if (n == 12) return a(r, r, r, r, r, r, r, r, r, r, r, r); if (n == 13) return a(r, r, r, r, r, r, r, r, r, r, r, r, r); if (n == 14) return a(r, r, r, r, r, r, r, r, r, r, r, r, r, r); if (n == 15) return a(r, r, r, r, r, r, r, r, r, r, r, r, r, r, r); if (n == 16) return a(r, r, r, r, r, r, r, r, r, r, r, r, r, r, r, r); if (n == 17) return a(r, r, r, r, r, r, r, r, r, r, r, r, r, r, r, r, r); if (n == 18) return a(r, r, r, r, r, r, r, r, r, r, r, r, r, r, r, r, r, r); error, "too many dimensions"; } func fft_recenter(x, template, reverse) /* DOCUMENT fft_recenter(x, template) -or- fft_recenter(x, template, reverse) Returns array X rolled so that it matches most closely array TEMPLATE. X and TEMPLATE may be arrays of real or complex numbers but must have the same dimension lists. The returned value is roll(X, S) where the offsets S minimize: sum(abs(roll(X, S) - TEMPLATE)^2) If optional argument REVERSE is true, X is also allowed to have all its dimensions reversed in order to math TEMPLATE. SEE ALSO: fft, roll, reverse_dims. */ { ws = fft_setup(dimsof(a)); conj_fft_template = conj(fft(template, +1, setup=ws)); c1 = double(fft(conj_fft_template*fft(x, +1, setup=ws), -1, setup=ws)); max_c1 = max(c1); if (reverse) { x2 = reverse_dims(x); c2 = double(fft(conj_fft_template*fft(x2, +1, setup=ws), -1, setup=ws)); if ((max_c2 = max(c2)) > max_c1) { eq_nocopy, x, x2; i = where(c2 == max_c2); } else { i = where(c1 == max_c1); } c2 = []; } else { i = where(c1 == max_c1); } c1 = []; if (numberof(i) != 1) error, swrite("too many maxima (%d)", numberof(i)); index = i(1) - 1; /* 0-based position of the maximum of correlation */ dims = dimsof(x); ndims = dims(1); dims = dims(2:); offset = array(long, ndims); for (i=1 ; i<=ndims ; ++i) { dim = dims(i); offset(i) = index % dim; index /= dim; } //return roll(x, dims - offset); return (anyof(offset) ? roll(x, dims - offset) : x); } func fft_recenter_at_max(z, middle=) /* DOCUMENT fft_recenter_at_max(z) Return Z rolled so that its element with maximum value (or maximum absolute value if Z is complex) is at the origin. If keyword MIDDLE is true (non-zero and non-nil) the center is at the middle of every dimension otherwise the center is the first element of the output array (as assumed by the FFT). SEE ALSO: roll. */ { index = (structof(z) == complex ? abs(z) : z)(*)(mxx) - 1; dims = dimsof(z); ndims = dims(1); dims = dims(2:); offset = array(long, ndims); for (i=1 ; i<=ndims ; ++i) { dim = dims(i); offset(i) = index % dim; index /= dim; } if (middle) dims += (dims+1)/2; return roll(z, dims - offset); } func fft_roll_1d(a, off) { if ((dimlist = dimsof(a))(1) != 1) error, "expecting 1D array"; n = dimlist(2); k = (n + (off%n))%n; /* wrap offset in the range [0, n-1] */ if (! k) return a; b = array(structof(a), dimlist); b(k+1:n) = a(1:n-k); b(1:k) = a(n-k+1:n); return b; } func fft_roll_2d(a, off1, off2) /* DOCUMENT fft_roll_1d(v, off) -or- fft_roll_2d(m, off1, off2) "rolls" dimensions of the vector V (1D array) or matrix M (2D array) and return a result with same data type than original array. SEE ALSO: roll. */ { if ((dimlist = dimsof(a))(1) != 2) error, "expecting 2D array"; n1 = dimlist(2); k1 = (n1 + (off1%n1))%n1; /* wrap offset in the range [0, n1-1] */ n2 = dimlist(3); k2 = (n2 + (off2%n2))%n2; /* wrap offset in the range [0, n2-1] */ case = (! k1) + 2*(! k2); if (case == 3) return a; b = array(structof(a), dimlist); if (case == 0) { b((r1=k1+1:n1), (r2=k2+1:n2)) = a((s1=1:n1-k1), (s2=1:n2-k2)); b(r1, (t2=1:k2)) = a(s1, (u2=n2-k2+1:n2)); b((t1=1:k1), t2) = a((u1=n1-k1+1:n1), u2); b(t1, r2) = a(u1, s2); } else if (case == 1) { b( , k2+1:n2) = a( , 1:n2-k2); b( , 1:k2) = a( , n2-k2+1:n2); } else { b(k1+1:n1, ) = a(1:n1-k1, ); b(1:k1, ) = a(n1-k1+1:n1, ); } return b; } /*---------------------------------------------------------------------------*/ /* FOURIER INTERPOLATION */ func fft_shift_phasor(off, u) /* DOCUMENT fft_shift_phasor(off, dimlist) -or- fft_shift_phasor(off, fft_freqlist(dimlist)) returns complex phasor to apply in FFT space for a shift by OFF cells in the real space. DIMLIST is a list of dimensions -- the second calling sequence is to allow for computing the normalized FFT frequencies only once. The offset OFF must have as many elements as PTR or as many as dimensions in DIMLIST (i.e. a shift for each dimension) and may be fractionnal. This function is intended for Fourier interpolation. For instance, assuming A is 2-D real array: z = fft(a, +1); u = fft_freqlist(dimsof(a)); q = fft_unphasor([0.33, -0.47], u); Then: fft_interp(z, q, real=1); yields the value of A interpolated at coordinate (0.33, -0.47) in FFT frame, i.e. center of lower left cell is at (0,0). The shfited version of A by (0.33, -0.47) can be obtained by: fft_shift(z, q, real=1); SEE ALSO: fft_freqlist, fft_interp, fft_fine_shift, roll. */ { if (structof(u) != pointer) u = fft_freqlist(u); ndims = numberof(u); for (i=1 ; i<=ndims ; ++i) { a = (*u(i))*off(i); if (i == 1) p = cos(a) + 1i*sin(a); else p *= (cos(a) + 1i*sin(a)); } return p; } func fft_unphasor(z, phasor, setup=, real=) { z = fft(z*conj(phasor), -1, setup=setup); return (1.0/numberof(z))*(real ? double(z) : z); } func fft_fine_shift(a, off, setup=) /* DOCUMENT fft_fine_shift(a, off, setup=) -or- fft_unphasor(z, phasor, setup=, real=) The function fft_fine_shift returns array A shifted by offset OFF which can be fractionnal. Alternatively, the function fft_unphasor can be used when the forward FFT of A and/or the complex phasor corresponding to the shift are already computed: fft_unphasor(fft(A, +1), fft_shift_phasor(OFF, dimsof(A)), real=(structof(A) != complex)) yields the same result as fft_fine_shift(A, OFF). These functions can make use of pre-computed FFT workspace specified by keyword SETUP (see fft_setup). TO-DO: Improve code by not Fourier transforming along direction where OFF is zero (or equal to an integer times the length of the dimension). SEE ALSO: fft, fft_setup, fft_shift_phasor, roll. */ { real = (structof(a) != complex); dims = dimsof(a); if (is_void(setup)) setup = fft_setup(dims); a = fft(fft(a, +1, setup=setup)*fft_shift_phasor(-off, dims), -1); return (1.0/numberof(a))*(real ? double(a) : a); } func fft_interp_real(z, phasor) { return (1.0/numberof(z))*double(sum(z*phasor)); } func fft_interp_complex(z, phasor) { return (1.0/numberof(z))*sum(z*phasor); } func fft_interp(a, off, setup=) /* DOCUMENT fft_interp(a, off, setup=) -or- fft_interp_real(z, phasor) -or- fft_interp_complex(z, phasor) returns value obtained by Fourier interpolation of A at offset OFF. The function fft_interp computes the forward FFT of A and can make use of pre-computed FFT workspace specified by keyword SETUP. The two other functions (fft_interp_complex, if A is complex; fft_interp_real otherwise) are usefull when the forward FFT of A and/or the complex phasor corresponding to the shift are already computed, their arguments are: Z = fft(A, +1); PHASOR = fft_shift_phasor(OFF, dimsof(A)); SEE ALSO: fft, fft_fine_shift, fft_shift_phasor. */ { real = (structof(a) != complex); dims = dimsof(a); if (is_void(setup)) setup = fft_setup(dims); n = numberof(a); a = sum(fft(a, +1, setup=setup)*fft_shift_phasor(-off, dims)); return (1.0/n)*(real ? double(a) : a); } /*---------------------------------------------------------------------------*/ /* GRAPHICS */ func fft_plh(y, scale=, legend=, hide=, type=, width=, color=, smooth=, marks=, marker=, mspace=, mphase=) { fft_plg, y, scale=scale, legend=legend, hide=hide, type=type, width=width, color=color, smooth=smooth, marks=marks, marker=marker, mspace=mspace, mphase=mphase, stair=1; } func fft_plg(y, scale=, legend=, hide=, type=, width=, color=, smooth=, marks=, marker=, mspace=, mphase=, stair=) /* DOCUMENT fft_plg, y; -or fft_plh, y; Plot 1-D FFT array Y as a curve, taking care of "rolling" Y and setting correct coordinates. Keyword SCALE can be used to indicate the "frequel" scale along X-axis (SCALE is a scalar); by default, SCALE=1.0. KEYWORDS legend, hide, type, width, color, closed, smooth marks, marker, mspace, mphase. SEE ALSO plh, plg, roll. */ { if (is_void(scale)) scale= 1.0; else if (! is_array(scale) || dimsof(scale)(1)!=0) error, "expecting a scalar for SCALE"; if (! is_array(y) || (dims= dimsof(y))(1)!=1) error, "expecting 1-D array"; dim1= dims(2); min1= (max1= dim1/2) - dim1 + 1; if (stair) { // just= plh, roll(y, -min1), scale*indgen(min1:max1), legend=legend, hide=hide, type=type, width=width, color=color, marks=marks, marker=marker, mspace=mspace, mphase=mphase; } else { plg, roll(y, -min1), scale*indgen(min1:max1), legend=legend, hide=hide, type=type, width=width, color=color, smooth=smooth, marks=marks, marker=marker, mspace=mspace, mphase=mphase; } } func fft_pli(a, scale=, legend=, hide=, top=, cmin=, cmax=) /* DOCUMENT fft_pli, a; Plot 2-D FFT array A as an image, taking care of "rolling" A and setting correct world boundaries. Keyword SCALE can be used to indicate the "frequel" scale along both axis (SCALE is a scalar) or along each axis (SCALE is a 2-element vector: SCALE=[XSCALE,YSCALE]); by default, SCALE=[1.0, 1.0]. KEYWORDS legend, hide, top, cmin, cmax. SEE ALSO pli, fft_roll_2d. */ { local scale1, dim1, min1, max1, scale2, dim2, min2, max2; __fft_pl2d_limits, a, scale; pli, fft_roll_2d(bytscl(a, top=top, cmin=cmin, cmax=cmax), -min1, -min2), scale1*(min1 - 0.5), scale2*(min2 - 0.5), scale1*(max1 + 0.5), scale2*(max2 + 0.5), legend=legend, hide=hide; } func fft_plc(a, scale=, levs=, type=, width=, color=, smooth=, legend=, hide=, marks=, marker=, mspace=, mphase=) /* DOCUMENT fft_plc, a; Plot contour levels of a 2-D FFT array A, taking care of "rolling" A and setting correct world boundaries. Keyword SCALE can be used to indicate the "frequel" scale along both axis (SCALE is a scalar) or along each axis (SCALE is a 2-element vector: SCALE=[XSCALE,YSCALE]); by default, SCALE=[1.0, 1.0]. Other keywords have same meaning as in plc routine. KEYWORDS scale, levs, type, width, color, smooth, legend, hide, marks, marker, mspace, mphase. SEE ALSO plc, roll, fft_plfc. */ { local scale1, dim1, min1, max1, scale2, dim2, min2, max2; __fft_pl2d_limits, a, scale; u1 = (scale1*indgen(min1:max1))(,-:1:dim2); u2 = (scale2*indgen(min2:max2))(-:1:dim1,); plc, roll(a, [-min1, -min2]), u2, u1, levs=levs, type=type, width=width, color=color, smooth=smooth, legend=legend, hide=hide, marks=marks, marker=marker, mspace=mspace, mphase=mphase; } func fft_plfc(a, scale=, levs=, colors=) /* DOCUMENT fft_plfc, a; Plot filled contour levels of a 2-D FFT array A, taking care of "rolling" A and setting correct world boundaries. Keyword SCALE can be used to indicate the "frequel" scale along both axis (SCALE is a scalar) or along each axis (SCALE is a 2-element vector: SCALE=[XSCALE,YSCALE]); by default, SCALE=[1.0, 1.0]. Other keywords have same meaning as in plfc routine. As with plfc routine, the actual level values get saved in external symbol plfc_levs. KEYWORDS scale, levs, colors. SEE ALSO plc, roll, fft_plc. */ { local scale1, dim1, min1, max1, scale2, dim2, min2, max2; __fft_pl2d_limits, a, scale; u1 = (scale1*indgen(min1:max1))(,-:1:dim2); u2 = (scale2*indgen(min2:max2))(-:1:dim1,); plfc, roll(a, [-min1, -min2]), u2, u1, levs=levs, colors=colors; } func __fft_pl2d_limits(z, scale) /* DOCUMENT __fft_pl2d_limits, z, scale; Private routine used by fft_pli, fft_plc and fft_plfc. SEE ALSO fft_pli, fft_plc, fft_plfc. */ { extern scale1, dim1, min1, max1, scale2, dim2, min2, max2; if (is_void(scale)) { scale1 = scale2 = 1.0; } else if (dimsof(scale)(1) == 0) { scale1 = scale2 = scale; } else if (numberof(scale) == 2) { scale1 = scale(1); scale2 = scale(2); } else { error, "bad number of elements in SCALE"; } if ((dims = dimsof(z))(1) != 2) error, "expecting 2-D array"; dim1 = dims(2); min1 = (max1 = dim1/2) - dim1 + 1; dim2 = dims(3); min2 = (max2 = dim2/2) - dim2 + 1; } /*---------------------------------------------------------------------------*/ func fft_convolve(orig, psf, do_not_roll) /* DOCUMENT fft_convolve(orig, psf); -or- fft_convolve(orig, psf, do_not_roll); Return discrete convolution (computed by FFT) of array ORIG by point spread function PSF. Unless argument DO_NOT_ROLL is true, PSF is rolled before. Note: ORIG and PSF must have same dimension list. SEE ALSO: fft, fft_setup, roll. */ { real = (structof(orig) != complex && structof(psf) != complex); dims = dimsof(orig); ws = fft_setup(dims); p = fft(orig, -1, setup=ws) * fft((do_not_roll?psf:roll(psf)), -1, setup=ws); orig = psf = []; // possibly free some memory fft_inplace, p, +1, setup=ws; if (real) p = double(p); return (1.0/numberof(p))*p; } #if 0 func fft_of_two_real_arrays(a, b, &ft_a, &ft_b, ljdir, rjdir, setup=) /* DOCUMENT fft_of_two_real_arrays, a, b, ft_a, ft_b, direction; -or- fft_of_two_real_arrays, a, b, ft_a, ft_b, ljdir, rjdir; Computes the FFT of arrays A and B and stores them in TF_A and FT_B respectively. A and B must have same dimension list. A single FFT is needed. Agrguments DIRECTION, LJDIR, RJDIR, and keyword SETUP have the same meaning as for the fft function (which see). SEE ALSO: fft_setup, fft_inplace. */ { if (structof(a) == complex || structof(b) == complex) error, "A and B must be non-complex"; c = a + 1i*b; fft_inplace, c, ljdir, rjdir, setup=setup; b = c(fft_symmetric_index(dimsof(c))); a = c + b; b = c - b; ft_a = 0.5*double(a) + 0.5i*(b.im); ft_b = 0.5*(a.im) - 0.5i*double(b); } #endif /*---------------------------------------------------------------------------*/ /* Notes: * there are 1 + n/2 "positive" frequencies * there are (n - 1)/2 "negative" frequencies */ func fft_paste(a, b) /* DOCUMENT fft_paste(a, b) * -or- fft_paste, a, b; * Paste array B into array A in the sense of FFT indexing. All * dimensions of A must be greater or equal the corresponding dimension * of B. When called as a subroutine, the operation is done in-place. * * RESTRICTIONS: * For even dimensions, the Nyquist frequency from B is not pasted * into A. * * SEE ALSO: fft_indgen. */ { if (! is_array(a) || ! is_array(b)) error, "expecting array argument(s)"; adim = dimsof(a); bdim = dimsof(b); if ((n = adim(1) - bdim(1)) != 0) { if (n > 0) { grow, bdim, array(1L, n); bdim(1) = adim(1); } else { grow, adim, array(1L, -n); adim(1) = bdim(1); } } if (anyof(adim < bdim)) error, "destination array is too small"; n = numberof(adim); ia = ib = 1L; /* indices start at one in Yorick */ sa = numberof(a); /* stride in A */ sb = numberof(b); /* stride in B */ for (k=n ; k>=2 ; --k) { alen = adim(k); sa /= alen; blen = bdim(k); sb /= blen; if (blen >= 3) { j = (blen - 1)/2; /* maximum absolute frequency */ ja = jb = array(long, 2*j + 1); ja(1:j+1) = indgen(0 : j*sa : sa); jb(1:j+1) = indgen(0 : j*sb : sb); ja(j+2:) = indgen((alen - j)*sa : (alen - 1)*sa : sa); jb(j+2:) = indgen((blen - j)*sb : (blen - 1)*sb : sb); } else { ja = jb = 0L; } if (k == n) { ia += ja; ib += jb; } else { ia = ja + ia(-,..); ib = jb + ib(-,..); } } if (! am_subroutine()) a = a; /* make a copy */ a(ia) = b(ib); return a; } /*---------------------------------------------------------------------------* * Local Variables: * * mode: Yorick * * tab-width: 8 * * fill-column: 75 * * c-basic-offset: 2 * * coding: latin-1 * * End: * *---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/gauss.i000066400000000000000000000215231152651572200175700ustar00rootroot00000000000000/* * gauss.i * * $Id: gauss.i,v 1.3 2008-10-29 15:54:21 paumard Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: gauss.i,v $ * Revision 1.3 2008-10-29 15:54:21 paumard * gauss.i: add gauss2d() * * Revision 1.2 2008/01/04 14:35:40 frigaut * - changed path for require statement * * Revision 1.1 2008/01/04 13:47:48 frigaut * initial import of thibaut's functions * * */ func gauss(x,a,&grad,deriv=) /* DOCUMENT gauss(x,a) Returns a gaussian: I0*exp(-0.5*((x-x0)/dx)^2) [+a(4) [+a(5)*x]] Where: I0=a(1) x0=a(2) dx=a(3) (gaussian sigma) Works with lmfit, and can return derivates. Notes: FHWM=sigma*2*sqrt(2*alog(2)); sum(gauss)=I0*sigma*sqrt(2*pi) SEE ALSO: gauss_fit, asgauss, asgauss_fit */ { nterms=numberof(a); eps=1e-100; if (abs(a(3))3) grad(,4)=1.; if (nterms==5) grad(,5)=x; } if (nterms>3) res=res+a(4); if (nterms==5) res=res+a(5)*x; return res; } func asgauss(x,a,&grad,deriv=) /* DOCUMENT asgauss(x,a) Returns an assymetrical gaussian: I0*exp(-((x-x0)/dx)^2) [+a(5) [+a(6)*x]] Where: I0=a(1) x0=a(2) dx=a(3) for x=x0 Works with lmfit, and can return derivates. SEE ALSO: gauss, gauss_fit, asgauss_fit */ { nterms=numberof(a); ta=(x=a(2)); u1=exp(-0.5*((x-a(2))*(ta/a(3)+tb/a(4)))^2); res=a(1)*u1; if (deriv) { grad=array(double,numberof(x),nterms); grad(,1)=u1; grad(,2)=res*(x-a(2))*(ta/a(3)+tb/a(4))^2; grad(,3)=res*(x-a(2))^2*(ta/a(3))^3; grad(,4)=res*(x-a(2))^2*(tb/a(4))^3; if (nterms>4) grad(,5)=1.; // useless if (nterms==6) grad(,6)=x; } if (nterms>4) res=res+a(5); if (nterms==6) res=res+a(6)*x; return res; } func gauss_fit(y,x,w,guess=,nterms=,fit=,correl=,stdev=,gain=,tol=,deriv=,itmax=,lambda=,eps=,monte_carlo=) { /* DOCUMENT gauss_fit(y,x,w,guess=,nterms=) Fits a gaussian (see gauss) profile on a data set using lmfit (see lmfit). The set of data points Y is the only mandatory argument, X defaults to indgen(numberof(y)), weights W are optional (see lmfit). GAUSS_FIT tries to guess a set of initial parameters, but you can (and should in every non-trivial case) provide one using the GUESS keyword. In case you don't provide a guess, you should set NTERMS to 3 (simple gaussian), 4 (adjust constant baseline) or 5 (adjust linear baseline). The returned fitted parameters have the same format as GUESS, see gauss. SEE ALSO: gauss, asgauss, asgauss_fit */ require,"lmfit.i"; if (is_void(x)) x=indgen(numberof(y)); if (is_void(guess)) { if (is_void(nterms)) nterms=3; if (nterms<3) nterms=3; if (nterms>5) nterms=5; guess=array(double,nterms); if (nterms==4) { base=median(y); guess(4)=base; } else if (nterms==5) { n=numberof(y); y1=median(y(1:long(n/2))); x1=median(x(1:long(n/2))); y2=median(y(-long(n/2):0)); x2=median(x(-long(n/2):0)); guess(5)=(y2-y1)/(x2-x1); if (guess(5)!=0) guess(4)=y1-guess(5)*x1; base=guess(4)+guess(5)*x; } else base=0.; y2=y-base; ind0=abs(y2)(mxx); guess(2)=x(ind0); guess(1)=y2(ind0); if (y2(ind0)==guess(1)) yy=y2; else yy=-y2; ind1=ind0; ind2=ind0; while (ind1>1 && yy(ind1)>0.5*guess(1)) ind1--; if (yy(ind1)<0.5*guess(1)) ind1++; while (ind20.5*guess(1)) ind2++; if (yy(ind2)<0.5*guess(1)) ind2--; guess(3)=abs(x(ind2)-x(ind1))/sqrt(2.); } else nterms=numberof(guess); a=guess; if (is_void(deriv)) deriv=1; result=lmfit(gauss,x,a,y,w,deriv=deriv,fit=fit,correl=correl,stdev=stdev, gain=gain,tol=tol,itmax=itmax,lambda=lambda, eps=eps,monte_carlo=monte_carlo); return a; } func asgauss_fit(y,x,w,guess=,nterms=){ /* DOCUMENT asgauss_fit(y,x,w,guess=,nterms=) Fits an assymetrical gaussian (see asgauss) profile on a data set using lmfit (see lmfit). The set of data points Y is the only mandatory argument, X defaults to indgen(numberof(y)), weights W are optional (see lmfit). ASGAUSS_FIT tries to guess a set of initial parameters, but you can (and should in every non-trivial case) provide one using the GUESS keyword. In case you don't provide a guess, you should set NTERMS to 6 (simple assymmetrical gaussian), 7 (adjust constant baseline) or 8 (adjust linear baseline). The returned fitted parameters have the same format as GUESS, see asgauss. SEE ALSO: asgauss, gauss, gauss_fit */ require,"lmfit.i"; if (is_void(x)) x=indgen(numberof(y)); if (is_void(guess)) { if (is_void(nterms)) nterms=4; if (nterms<4) nterms=4; if (nterms>6) nterms=6; guess=array(double,nterms); if (nterms==5) { base=median(y); guess(5)=base; } else if (nterms==6) { n=numberof(y); y1=median(y(1:long(n/2))); x1=median(x(1:long(n/2))); y2=median(y(-long(n/2):0)); x2=median(x(-long(n/2):0)); guess(6)=(y2-y1)/(x2-x1); if (guess(6)!=0) guess(5)=y1-guess(6)*x1; base=guess(5)+guess(6)*x; } else base=0.; y2=y-base; ind0=abs(y2)(mxx); guess(2)=x(ind0); guess(1)=y2(ind0); if (y2(ind0)==guess(1)) yy=y2; else yy=-y2; ind1=ind0; ind2=ind0; while (ind1>1 && yy(ind1)>0.5*guess(1)) ind1--; if (yy(ind1)<0.5*guess(1)) ind1++; while (ind20.5*guess(1)) ind2++; if (yy(ind2)<0.5*guess(1)) ind2--; guess(3)=2*abs(x(ind0)-x(ind1)); guess(4)=2*abs(x(ind2)-x(ind0)); } else nterms=numberof(guess); a=guess; result=lmfit(asgauss,x,a,y,w,deriv=1); return a; } func gauss2d(xy, a, &grad, deriv=) { /* DOCUMENT gauss(xy,a) Returns a 2D gaussian: I0*exp(-0.5*(X^2+Y^2)) [+a(7) [+a(8)*x [+a(9)*y]]] Where: x=xy(..,1) y=xy(..,2) X=((x-x0)*cos(alpha)+(y-y0)*sin(alpha))/dx Y=((y-y0)*cos(alpha)-(x-x0)*sin(alpha))/dy I0=a(1) x0=a(2) y0=a(3) dx=a(4) (gaussian sigma) dy=a(5) alpha=a(6) Works with lmfit, and can return derivates. Notes: FHWM=sigma*2*sqrt(2*alog(2)); sum(gauss2d)=2*pi*I0*dx*dy astro_util1.i contains two variants of this function: gaussian and gaussianRound. Those two functions do not provide derivatives and take a slightly different A vector (e.g. alpha in degrees instead of radians). SEE ALSO: gauss, gauss_fit, gaussian, gaussianRound */ npars=numberof(a); eps=1e-100; if (abs(a(4))=5) { if (abs(a(5))=6?a(6):0.; X=((deltax=(xy(..,1)-(x0=a(2))))*(cosa=cos(alpha))+ (deltay=(xy(..,2)-(y0=a(3))))*(sina=sin(alpha)))*dx1; Y=(deltay*cosa-deltax*sina)*dy1; u1=exp(-0.5*(r2=(X^2+Y^2))); res=a(1)*u1; if (numberof(a)>=7) res+=a(7); if (numberof(a)>=8) res+=a(8)*xy(..,1); if (numberof(a)>=9) res+=a(7)*xy(..,2); if (deriv) { grad=array(1.,dimsof(X),numberof(a)); grad(..,1)=u1; grad(..,2)=((cosa*dx1)*X-(sina*dy1)*Y)*res; grad(..,3)=((sina*dx1)*X+(cosa*dy1)*Y)*res; grad(..,4)=dx1*X^2*res; if (numberof(a)>=5) grad(..,5)=dy1*Y^2*res; else grad(..,4)+=dy1*Y^2*res; if (numberof(a)>=6) grad(..,6)=X*Y*(dy1/dx1-dx1/dy1)*res;//<== //if (numberof(a)>=7) grad(..,7)=1.; if (numberof(a)>=8) grad(..,8)=xy(..,1); if (numberof(a)>=9) grad(..,9)=xy(..,2); } return res; } frigaut-yorick-yutils-c173974/graphk.i000066400000000000000000000124441152651572200177240ustar00rootroot00000000000000/* * graphk.i * * $Id: graphk.i,v 1.1 2008-01-04 13:47:48 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: graphk.i,v $ * Revision 1.1 2008-01-04 13:47:48 frigaut * initial import of thibaut's functions * * */ extern graphk; /* DOCUMENT graphk.i Alternate syntax for graphic routines: every keywords are set through only one, of type GraphK. Members of GraphK are all pointer, for some graphic keywords support several datatypes. This syntax is useful when one wants to carry graphic keywords trough programs in a handy way, not really for command line. Currently supported: plhk and plgk. SEE ALSO: GraphK, plhk, plgk, plmkk, drawmaskk in drawmask.i */ func plhk(y,x,keywords=) { /* DOCUMENT plhk,y or plhk,y,x Wrapper to plh, which accepts a single keyword: KEYWORDS (of type GraphK). Example: plhk,y,x,keywords=GraphK(color=&string("white")); Sounds nuts, but it can be quite useful to have all graphic keywords in a single variable, that can be made external or belong to a sructure... SEE ALSO: plh, plgk, GraphK, graphk, pltk */ if (is_void(keywords)) plh,y,x; else plh,y,x,just=*keywords.just,legend=*keywords.legend, hide=*keywords.hide, type=*keywords.type, width=*keywords.width, color=*keywords.color, marks=*keywords.marks, marker=*keywords.marker, mspace=*keywords.mspace, mphase=*keywords.mphase; } func plgk(y,x,keywords=) { /* DOCUMENT plhk,y or plhk,y,x Wrapper to plg, which accepts a single keyword: KEYWORDS (of type GraphK). Example: plgk,y,x,keywords=GraphK(color=&string("white")); Sounds nuts, but it can be quite useful to have all graphic keywords in a single variable, that can be made external or belong to a sructure... SEE ALSO: plg, plhk, GraphK, graphk, pltk */ if (is_void(keywords)) plg,y,x; else plg,y,x,legend=*keywords.legend, hide=*keywords.hide, type=*keywords.type, width=*keywords.width, color=*keywords.color, closed=*keywords.closed, smooth=*keywords.smooth, marks=*keywords.marks, marker=*keywords.marker, mspace=*keywords.mspace, mphase=*keywords.mphase, rays=*keywords.rays, arrowl=*keywords.arrowl, arroww=*keywords.arroww, rspace=*keywords.rspace, rphase=*keywords.rphase; } func plmkk(y,x,keywords=){ /* DOCUMENT plmkk,y or plmkk,y,x Wrapper to plmk, which accepts a single keyword: KEYWORDS (of type GraphK). Example: plmkk,y,x,keywords=GraphK(msize=&double(0.2)); Sounds nuts, but it can be quite useful to have all graphic keywords in a single variable, that can be made external or belong to a sructure... SEE ALSO: plg, plhk, GraphK, graphk, plgk, pltk */ if (is_void(keywords)) plmk,y,x; else plmk,y,x,width=*keywords.width,color=*keywords.color, marker=*keywords.marker,msize=*keywords.msize; } func pltk(t,x,y,keywords=){ /* DOCUMENT pltk,text,x,y Wrapper to plt, which accepts a single keyword: KEYWORDS (of type GraphK). Example: pltk,"text",x,y,keywords=GraphK(font=&string("helveticaB")); Sounds nuts, but it can be quite useful to have all graphic keywords in a single variable, that can be made external or belong to a sructure... SEE ALSO: plg, plhk, GraphK, graphk, plgk, plmkk */ if (is_void(keywords)) plt,t,x,y; else plt,t,x,y,legend=*keywords.legend,hide=*keywords.hide, color=*keywords.color,font=*keywords.font,height=*keywords.height, opaque=*keywords.opaque,orient=*keywords.orient, justify=*keywords.justify,tosys=*keywords.tosys; } struct GraphK { /* DOCUMENT GraphK A structure for storing all possible keywords to graphic routines. Members are _pointers_, as a few of these keywords accept several data types. Example: mykeywords=GraphK(color=&string("white"),msize=&double(0.5)[...]); plgk,y,x,keywords=mykeywords; Note: You cannot make a reference to a known value directly like "&0.5", but you can always do "&double(0.5)". Makes the syntax even more awkward, but this still simplifies somewhat implementing some programs... SEE ALSO: plgk, plhk, plg, plh, plmkk, graphk, pltk */ pointer legend, hide,type, width, color, closed, smooth, marks, marker, mspace, mphase, rays, arrowl, arroww, rspace, rphase, just, msize, font, height, opaque, orient, justify, tosys; } frigaut-yorick-yutils-c173974/histo.i000066400000000000000000000253651152651572200176040ustar00rootroot00000000000000/* * histo.i -- * * Yorick routines for histogram computation. * * Public routines: * histo2 driver for the `histogram' function. * histo_stat compute statistics of data grouped in bins. * histo_plot compute (with histo2) and plot histogram of data. * * Private/low-level routines: * _histo_sum sum statistics of data grouped in bins. * * Copyright (c) 1998-1999 Eric THIEBAUT. * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * History: * $Id: histo.i,v 1.1 2007-12-11 23:55:12 frigaut Exp $ * $Log: histo.i,v $ * Revision 1.1 2007-12-11 23:55:12 frigaut * Initial revision * * Revision 1.3 2002/11/14 11:25:08 eric * - changed paths in require/include calls * * Revision 1.2 1999/09/21 10:04:50 eric * - Version saved before new public release. * * Revision 1.1 1998/10/30 13:55:29 eric * Initial revision */ func histo2(data, &hx, weight=, binsize=, binmin=, binmax=, interp=, average=) /* DOCUMENT hy= histo2(data, hx); Returns histogram of DATA, the histogram abscissae get stored into pure output HX (don't forget to declare it as `local', unless you don't care of side effects). The size of the bins can be given by keyword BINSIZE (default 1.0). The minimum and maximum abscissae to consider can specified with keywords BINMIN and BINMAX. Keyword WEIGHT gives data point weights (default all 1). If keyword INTERP is set with a non-zero value, linear interpolation is used to get the weights of the data points to each bin. If keyword AVERAGE is set with a non-zero value, returns an average rather than a sum of the weithed data points. Note that with no weights or uniform weights, the average value will be an array of 1's (now you know!). Averaging is useful for instance to compute the radial profile (average along azimuth direction): x= indgen(xdim)-x0; // abscissa y= indgen(ydim)-y0; // ordinate r= abs(x, y(-,)); // radius a= exp(-r*r/50.0)+(random(xdim, ydim) - 0.5)/10.0; local px; py= histo2(r, px, weight=a, average=1, interp=1); plg, py, px, color="red"; plg, exp(-px*px/50.0), px, color="green"; You can call histo2 one more time to compute the sample noise: py_sigma= sqrt(histo2(r, weight=a*a, average=1, interp=1) - py*py); SEE ALSO: histogram. */ { if (is_void(binsize)) binsize = 1.0; else data *= (1.0/binsize); zero = floor(min(data)); if (interp) { data -= zero; i = 1 + long(data); w = i - data; n = max(i) + 1; if (average) hx = histogram(i, w, top=n) + histogram(i+1, 1.0 - w, top=n); if (is_void(weight)) weight = 1.0; else w *= weight; hy = histogram(i, w, top=n) + histogram(i+1, weight - w, top=n); if (average) hy = hy / (hx + !hx); } else { i = long((1.5 - zero) + data); hy = is_void(weight) ? double(histogram(i)) : histogram(i, weight); if (average) { hx = histogram(i); hy = hy / (hx + !hx); } } hx = binsize*(zero + indgen(0:numberof(hy)-1)); if (! is_void(binmin) && binmin > zero) { if (! is_array((i = where(hx >= binmin)))) { hx = []; return; } i = i(1); hx = hx(i:); hy = hy(i:); } if (! is_void(binmax) && binmax < hx(0)) { if (! is_array((i = where(hx <= binmax)))) { hx = []; return; } i = i(0); hx = hx(:i); hy = hy(:i); } return hy; } func histo_stat(data, x, avg_std=, std=, binsize=, xmin=, xmax=, weight=, interp=) /* DOCUMENT hs= histo_stat(data, x); Compute statistics of response DATA with respect to explanatory variable X. DATA measurements are grouped in bins by rounding X to the nearest integer multiple of BINSIZE and the statistical moments are computed whithin each bin. If you need unevenly spaced bins, you may either operate a change of explicit variable or use Yorick's `digitize' and `histogram' routines. ARGUMENTS: HS <- Result: HS(,1)= value of explanatory variable X in each bin HS(,2)= sum of weights for each bin HS(,3)= average of DATA in each bin only if keyword STD/AVG_STD is non-nil and non-zero: HS(,4)= standard deviation of DATA in each bin only if keyword AVG_STD is non-nil and non-zero: HS(,5)= standard deviation of HS(,3) DATA -> Response data to average. X -> Value of explanatory variable for each data measurement (same geometry as DATA). KEYWORDS: STD= Compute standard deviation per data sample in HS(,4). AVG_STD= Compute standard deviation of average in HS(,5) (Note: this also implies STD=1). WEIGHT= Statistical weight (e.g., 0.0 where data is not significant). XMAX= Maximum X value to account for (default max(X)). XMIN= Minimum X value to account for (default min(X)). BINSIZE= Resolution for data bins, i.e. value of HS(,1)(dif) (default 1.0) INTERP= Use linear interpolation, instead of rounding to the nearest integer multiple of BINSIZE? SEE ALSO: digitize, histogram, _histo_sum. */ { local hx, h0, h1, h2, h3; order= avg_std ? 3 : (std ? 2 : 1); n= _histo_sum(data, x, order, hx, h0, h1, h2, h3, weight=weight, binsize=binsize, xmax=xmax, xmin=xmin, interp=interp); if (n<=0) return; hs= array(double, n, order+2); hs(,1)= hx; hs(,2)= h0; hs(,3)= (h1*= (h0= 1.0/(h0 + !h0))); if (order>=2) hs(,4)= sqrt(h2*h0 - h1*h1); if (order>=3) hs(,5)= sqrt((h2*h0 - h1*h1)*h3)*h0; return hs; } /* ------------------------------------------------------------------------- */ func histo_plot(data, weight=, binsize=, binmin=, binmax=, interp=, average=, just=, legend=, hide=, type=, width=, color=, marks=, marker=, mspace=, mphase=, prenormalize=, postnormalize=, scale=) /* DOCUMENT histo_plot, data; Compute (with histo2) an histogram of DATA and plot it (with plh). All keywords of plh and histo2 can be used. Further keywords PRENORMALIZE and POSTNORMALIZE can be used to normalize the histogram so that its sum is equal to PRE/POSTNORMALIZE: normalization to PRENORMALIZE (POSTNORMALIZE) is performed *BEFORE* (respectively *AFTER*) data values less than BINMIN or greater than BINMAX have been rejected. Keyword SCALE can be used to multiply ordinates of histogram by SCALE (default SCALE=1); this is useful to compare histograms of the same data set with different BINSIZE. KEYWORDS: weight, binsize, binmin, binmax, interp, average, just, legend, hide, type, width, color, marks, marker, mspace, mphase, prenormalize, postnormalize, scale. SEE ALSO: histo2, plh. */ { require, "plot.i"; local hx; if (prenormalize) { if (is_void(weight)) { weight= array(prenormalize/double(numberof(data)), dimsof(data)); } else { weight*= prenormalize / double(sum(weight)); } } hy= histo2(data, hx, weight=weight, binsize=binsize, binmin=binmin, binmax=binmax, interp=interp, average=average); if (postnormalize) hy*= postnormalize / sum(hy); plh, (is_void(scale) ? hy : scale*hy), hx, legend=legend, hide=hide, type=type, width=width, color=color, marks=marks, marker=marker, mspace=mspace, mphase=mphase; } /* ------------------------------------------------------------------------- */ func _histo_sum(data, x, order, &hx, &h0, &h1, &h2, &h3, binsize=, xmin=, xmax=, weight=, interp=) /* DOCUMENT n= _histo_sum(data, x, order, hx, h0, h1, h2); Worker for histo_stat routine: sum moments of response DATA with respect to explanatory variable X. See documentation of histo_stat for further explanations and description of keywords. Return number of elements in output arrays (if N=0, outputs can be discarded...). ARGUMENTS: DATA -> Response data to average. X -> Value of explanatory variable for each data measurement (same geometry as DATA). HX <- Value of X in each bin. H0 <- Sum of WEIGHT in each bin. H1 <- Sum of WEIGHT*DATA in each bin. H2 <- Sum of WEIGHT*DATA^2 in each bin. H3 <- Sum of WEIGHT*WEIGHT in each bin. ORDER-> 0 to compute only HX and H0, >=1 to also compute H1 >=2 to also compute H2 >=3 to also compute H3. KEYWORDS: binsize, xmin, xmax, weight, interp. SEE ALSO: histo_stat, histogram, digitize. */ { /* Instanciate WEIGHT array. */ if (is_void(weight)) weight= array(1.0, dimsof(data)); else weight+= 0.0*data; /* Make sure WEIGHT is double precision and same geometry as DATA. */ if (! is_void(xmax) && is_array((i= where(x>xmax)))) weight(i)= 0.0; if (! is_void(xmin) && is_array((i= where(x0.0) x/= binsize; else error, "bad BINSIZE"; zero= floor(min(x)); if (interp) { w2= x-zero; i2= 1 + (i1= 1+long(w2)); w2= 1.0 - (w1= i1-w2); n= max(i1)+1; h0= histogram(i1, (w1*= weight), top=n) + histogram(i2, (w2*= weight), top=n); if (order>=3) h3= histogram(i1, w1*w1, top=n) + histogram(i2, w2*w2, top=n); if (order>=1) h1= histogram(i1, (w1*= data), top=n) + histogram(i2, (w2*= data), top=n); if (order>=2) h2= histogram(i1, (w1*= data), top=n) + histogram(i2, (w2*= data), top=n); } else { i= long(1.5-zero+x); h0= histogram(i, weight); if (order>=3) h3= histogram(i, weight*weight); if (order>=1) h1= histogram(i, (weight*= data)); if (order>=2) h2= histogram(i, (weight*= data)); } hx= binsize*(zero+indgen(0:numberof(h0)-1)); if (! is_void(xmax) && xmax < hx(0)) { if (! is_array((i= where(hx <= xmax)))) return 0; i= i(0); hx= hx(:i); h0= h0(:i); if (order>=1) h1= h1(:i); if (order>=2) h2= h2(:i); if (order>=3) h3= h3(:i); } if (! is_void(xmin) && xmin > hx(1)) { if (! is_array((i= where(hx >= xmin)))) return 0; i= i(1); hx= hx(i:); h0= h0(i:); if (order>=1) h1= h1(i:); if (order>=2) h2= h2(i:); if (order>=3) h3= h3(i:); } return numberof(hx); } frigaut-yorick-yutils-c173974/idl-colors.i000066400000000000000000000063061152651572200205170ustar00rootroot00000000000000/* * idl-colors.i -- * * Routines to manipulate IDL color files. * Provides functions: * - loadct: load IDL color table / get names of IDL color tables. * * $Id: idl-colors.i,v 1.2 2007-12-13 21:15:28 frigaut Exp $ * * Copyright (c) 1996, Eric THIEBAUT (thiebaut@obs.univ-lyon1.fr, Centre de * Recherche Astrophysique de Lyon, 9 avenue Charles Andre, F-69561 Saint * Genis Laval Cedex). * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). */ require,"string.i"; require,"pathfun.i"; func loadct(which, file=) /* DOCUMENT loadct, which; color_names= loadct(); In the first form, load IDL color table identified by WHICH (either a number or a name). When called as a function, e.g., second form, returns an array of names of color tables. Keyword FILE can be used to indicate an alternate file name (default is Y_SITE + "data/colors1.tbl"). SEE ALSO palette. */ { /* Open color tables file. */ if (is_void(file)) { file = find_in_path("../data/colors1.tbl",takefirst=1); if (is_void(file)) error,"Can't find colors1.tbl"; } file= open(file, "rb"); /* Get number of color tables. */ ntables= char(); if (_read(file, 0, ntables) != sizeof(ntables)) { error, "cannot read number of color tables"; } ntables= long(ntables); /* Eventually, seek names of color tables. */ if (structof(which) == string || !am_subroutine()) { buf= array(char, 32, ntables); if (_read(file, ntables * 768 + 1, buf) != sizeof(buf)) { error, "cannot read names of color tables"; } names= array(string, ntables); for (i=1; i<=ntables; i++) { names(i)= strtrim(string(&buf(,i))); } if (structof(which)==string) { i= where(strtolower(names) == strtolower(which)); if (numberof(i) == 0) { error, "bad color table name"; } which= i(1); } } else if (which < 1 || which > ntables) { error, "bad color table number"; } /* Read color table data. */ if (!is_void(which)) { if (structof(which) != long || dimsof(which)(1) != 0) { error, "color table number must be a LONG scalar"; } local r, g, b; lut= array(char, 256, 3); if (_read(file, 1 + (which - 1) * 768, lut) != sizeof(lut)) { error, "cannot read color table"; } //lut= long(lut); palette, r, g, b, query=1; x= span(0., 1., 256); xp= span(0., 1., numberof(r)); palette, int(.5+interp(lut(,1), x, xp)), int(.5+interp(lut(,2), x, xp)), int(.5+interp(lut(,3), x, xp)); } /* Close file and return. */ close, file; if (!am_subroutine()) { return names; } } frigaut-yorick-yutils-c173974/img.i000066400000000000000000001105611152651572200172230ustar00rootroot00000000000000/* * img.i -- * * Routines for dealing with images (i.e. 2D arrays) in Yorick. * *----------------------------------------------------------------------------- * * Copyright (C) 2000, Eric Thiebaut * * This file is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License version 2 as * published by the Free Software Foundation. * * This file 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. * *----------------------------------------------------------------------------- * * Routines: * img_dims - returns dimension [WIDTH,HEIGHT] of an image * img_plot - plot an image * img_cbar - add a color to an image plot * img_convolve - convolution/correlation of images * img_interpolate - bi-linear interpolation of an image * img_extract_parallelogram_as_rectangle - (as its name says) * img_max - get coordinates of maximum in a 2-D array * img_fft_centered_at_max - recenter an image at its maximum according * to fft indexing * img_pad - expand an image * img_paste - copy an image into another one at a given location * img_photometry - measure integrated intensity inside a circular region * img_flt_max - filter an image * img_flt_flac - flipped-local-auto-convolution of an image * ing_get_type - get image file type * img_read, img_write - read/write PNM/JPEG/PNG/TIFF/FITS/GIF image * img_tmpnam - get name of temporary file * * History: * $Id: img.i,v 1.3 2010-02-10 13:27:12 paumard Exp $ * $Log: img.i,v $ * Revision 1.3 2010-02-10 13:27:12 paumard * - Synchronize files with Eric Thiebaut's: fft_utils.i, img.i, plot.i, utils.i. * - Import emulate_yeti.i * - Remove basename() and dirname(), standard in pathfun.i. * - Remove the accents in Erics name to prevent a crash on amd64. * * Revision 1.6 2008/07/12 06:44:04 eric * - Added final comment for setting local variables of Emacs. * * Revision 1.5 2007/06/29 13:04:34 eric * - New function img_convolve. * * Revision 1.2 2008/02/15 18:55:27 frigaut * fixed UTF-8 encoding problems (crash yorick-doc on amd64) * * Revision 1.1.1.1 2007/12/11 23:55:12 frigaut * Initial Import - yorick-yutils * * Revision 1.4 2004/10/14 09:54:53 eric * - "img_protect_path" and "img_expand_path" removed and replaced by * their counterparts, "expand_file_name" and "expand_file_name", * in "utils.i" (which was already required by "img.i"). * * Revision 1.3 2004/10/13 10:18:32 eric * - New functions (img_read, img_write, img_get_type, * img_protect_path, img_expand_path, img_tmpnam) to * implement reading/writing of various image file formats * (PNM/PBM/PGM/PPM, JPEG, PNG, TIFF, FITS, and GIF). * * Revision 1.2 2004/09/17 11:21:18 eric * - removed jped_read and jpeg_write (backup in jpeg_img.i) which * are provided by jpeg.i plugin in Yorick from version >= 1.6 * * Revision 1.1 2004/07/17 13:37:40 eric * Initial revision * *----------------------------------------------------------------------------- */ require, "utils.i"; func img_dims(img) /* DOCUMENT img_dims(img) Returns dimensions of image IMG: [WIDTH,HEIGHT]. IMG must be a 2 dimensional array. SEE ALSO dimsof. */ { if (! is_array(img) || (dims = dimsof(img))(1) != 2) error, "expecting 2D array"; return dims(2:3); } /*---------------------------------------------------------------------------*/ func img_plot(img, first=, scale=, cmin=, cmax=, top=) /* DOCUMENT img_plot, img; Plot image IMG using pli. Keyword FIRST can be used to set coordinates of center of first (lower left) pixel, default is FIRST=1.0 (i.e. same coordinates as Yorick's indexing rules). Keyword SCALE can be used to set the step size between adjacent pixels (default is SCALE=1.0). Keywords FIRST and/or SCALE may have one or two values depending whether or not both axis have same value. SEE ALSO pli, img_dims. */ { if (is_array(img)) { dims = dimsof(img); ndims = dims(1); } if (ndims == 2) { dims = dims(2:3); } else if (ndims == 3 && structof(img) == char) { dims = dims(3:4); } else { error, "expecting 2-D array or RGB image"; } if (is_void(scale)) scale = 1.0; if (is_void(first)) first = 1.0; ll = first - scale/2.0; // lower-left corner coordinates ur = ll + scale*dims; // upper-right corner coordinates pli, img, ll(1), ll(0), ur(1), ur(0), top=top, cmin=cmin, cmax=cmax; } func img_cbar(img, cmin=, cmax=, top=, levs=, labs=, nticks=, vert=, adjust=, vport=, format=, color=, width=, height=, ticklen=, font=) /* DOCUMENT img_cbar, img; or img_cbar, cmin=cmin, cmax=cmax; Draw a color bar below the current coordinate system. If LEVS is not specified uses plfc_levs (set by previous call to plfc). If COLORS is specified, it should have one more value than LEVS, otherwise equally spaced colors are chosen, or plfc_colors if plfc_levs was used. With the VERT=1 keyword the color bar appears to the left of the current coordinate system (vert=0 is default). By default, color_bar will attempt to label some of the color interfaces. With the LABS keyword, you can force the labelling algorithm as follows: LABS=0 supresses all labels, LABS=n forces a label at every n-th interface, LABS=[i,n] forces a label at every n-th interface starting from interface i (0<=i<=numberof(LEVS)). You can specify the viewport coordinates by keyword VPORT=[xmin,xmax,ymin,ymax]; by default the colorbar is drawn next to the current viewport. You can use the ADJUST keyword to move the bar closer to (adjust<0) or further from (adjust>0) the viewport. You can specify the string format for labels with keyword FORMAT (default "%g"), the font type with keyword FONT (default "helvetica") and the font height with keyword HEIGHT (default 14 points). Keyword COLOR can be used to specify the color of the labels, the ticks and the frame of the colorbar. Default is foreground color. Keyword WIDTH can be used to set the width of the lines used to draw the frame and the ticks of the colorbar. Keyword TICKLEN can be used to set the lenght (in NDC units) of the ticks. Default is 0.005 NDC. SEE ALSO: plfc. */ { nil = string(0); if (is_void(cmin)) { if (is_void(img)) error, "keyword CMIN must be given"; cmin = min(img); } if (is_void(cmax)) { if (is_void(img)) error, "keyword CMAX must be given"; cmax = max(img); } cmin = double(cmin); /* make sure CMIN is double */ cmax = double(cmax); /* make sure CMAX is double */ if (is_void(top)) { /* get indices in colormap */ crange = long(bytscl([0,1],cmin=0,cmax=1)); ncolors = crange(2) - crange(1) + 1; } else { ncolors = top + 1; } if (structof(labs) == string) { nticks = numberof(labs); if (is_void(levs)) { levs = array(double, nticks); if (sread(labs, levs) != nticks) error, "cannot convert tick labels into values from LABS, use keyword LEVS"; } else if (numberof(levs) != nticks) { error, "LABS and LEVS must have the same number of elements"; } } else if (is_void(labs)) { if (is_void(levs)) { if (is_void(nticks)) nticks = 11; /* avoid rounding errors in span() */ levs = cmin + ((cmax - cmin)/(nticks - 1))*indgen(0:nticks-1); } else { nticks = numberof(levs); } if (nticks) labs= swrite(format=(is_void(format)?"%g":format), levs); } else { error, "LABS must be nil or an array of strings"; } if (is_void(font)) font= "helvetica"; if (is_void(vport)) vport = viewport(); if (is_void(adjust)) adjust = 0.0; if (is_void(ticklen)) ticklen = 0.005; oldsys = plsys(0); /* _after_ calling viewport() */ if (vert) { x0 = vport(2) + adjust + 0.022; x1 = x0 + 0.020; y0 = vport(3); y1 = vport(4); if (nticks) { x = x1(-::nticks); y = y0 + (y1 - y0)/(cmax - cmin)*(levs - cmin); if (ticklen) pldj, x, y, x + ticklen, y, legend=nil, color=color, width=width; else ticklen = 0.005; x += 2*ticklen; justify="LH"; } } else { x0 = vport(1); x1 = vport(2); y0 = vport(3) - adjust - 0.045; y1 = y0 - 0.020; if (nticks) { x = x0 + (x1 - x0)/(cmax - cmin)*(levs - cmin); y = y1(-::nticks); if (ticklen) pldj, x, y, x, y - ticklen, legend=nil, color=color, width=width; else ticklen = 0.005; y -= 2*ticklen; justify="CT"; } } for (i=1 ; i<=nticks ; ++i) { plt, labs(i), x(i), y(i), justify=justify, height=height, font=font, color=color; } colors = char(indgen(0:ncolors-1)); colors = (vert ? colors(-,) : colors(,-)); /* FIXME: there is a bug in Yorick, I have to make the colorbar at least 2 pixel wide to avoid division by zero in pli... */ pli, colors, x0, y0, x1, y1; if (width) { plg, [y0,y0,y1,y1,y0], [x0,x1,x1,x0,x0], closed=0, width=width, color=color, legend=nil, marks=0, type=1; } plsys, oldsys; } /*---------------------------------------------------------------------------*/ /* BI-LINEAR INTERPOLATION */ func img_interpolate(z, x, y) /* DOCUMENT img_interpolate(img, x, y) Returns image IMG interpolated (by bi-linear interpolation) at positions (X,Y). The coordinates X and Y must be conformable and the result has dimension list dimsof(X,Y). Note that coordinates run like Yorick indices, for instance (1,1) is the location of the lower-left pixel in the image. SEE ALSO: interp. */ { if (! is_array(z) || (dims = dimsof(z))(1) != 2) { error, "expecting 2-D array"; } if ((width = dims(2)) < 2 || (height = dims(3)) < 2) { error, "array to interpolate must have at least 2 elements in every dimension"; } x -= (i = ceil(x)); i = long(i); if (min(i) < 1) { k = where(i < 1); i(k) = 1; x(k) = 0.0; } if (max(i) >= width) { k = where(i >= width); i(k) = width - 1; x(k) = 1.0; } y -= (j = ceil(y)); j = long(j); if (min(j) < 1) { k = where(j < 1); j(k) = 1; y(k) = 0.0; } if (max(j) >= height) { k = where(j >= height); j(k) = height - 1; y(k) = 1.0; } i += (j - 1)*width; /* univariate index */ return ((1.0 - x)*((1.0 - y)*z(i) + y*z(i + width)) + x*((1.0 - y)*z(i + 1) + y*z(i + (1 + width)))); } func img_extract_parallelogram_as_rectangle(img, x1, y1, x2, y2, x3, y3, w, h) /* DOCUMENT img_extract_parallelogram_as_rectangle(img, x1, y1, x2, y2, x3, y3, width, height) Returns a WIDTH-by-HEIGHT rectangle obtained by bi-linear interpolation of a parallelogram region from image IMG. The parallelogram is specified by the coordinates of 3 of its corner: (X1,Y1) is the upper-left corner, (X2,Y2) is the lower-left corner and (X3,Y3) is the lower-right corner. Note that coordinates run like Yorick indices: (1,1) is the location of the lower-left pixel in the image. SEE ALSO: img_interpolate, LUsolve. */ { a = LUsolve([[1,0,1,0,1,0], [1,0,1,0,w,0], [h,0,1,0,1,0], [0,1,0,1,0,1], [0,1,0,1,0,w], [0,h,0,1,0,1]], [x1, y1, x2, y2, x3, y3]); u = double(indgen(w)); v = double(indgen(h)(-,)); return img_interpolate(img, a(1) + a(2)*u + a(3)*v, a(4) + a(5)*u + a(6)*v); } /*---------------------------------------------------------------------------*/ func img_max(img) /* DOCUMENT img_max(img) Returns coordinates of first image maximum. SEE ALSO: img_dims, img_flt_max. */ { width = img_dims(img)(1); i = img(*)(mxx) - 1; return [i%width + 1, i/width + 1]; } func img_fft_centered_at_max(img) /* DOCUMENT img_fft_centered_at_max(img) Returns image IMG rolled so that its maximum is at coordinates (1,1). SEE ALSO: img_dims, img_max, img_flt_max, roll. */ { type = structof(img); img = roll(img, 1 - img_max(img)); return type == structof(img) ? img : type(img); } /*---------------------------------------------------------------------------*/ /* CONVOLUTION/CORRELATION OF IMAGES */ func img_convolve(a, b, unroll=, pad=, correl=) /* DOCUMENT img_convolve(a, b) * * Convolve image B by image A using FFT's. If Yeti FFTW plugin is * loaded, FFTW is used; otherwise Yorick's FFT is used. * * If keyword UNROLL is true, the result is centered at pixel * ((WIDTH + 1)/2, (HEIGHT + 1)/2) where WIDTH and HEIGHT are the * dimensuon of the result (and integere division is applied); the * default is to have the result centered at pixel (1,1) according * to FFT conventions. * * If keyword CORREL is true, the correlation of B by A instead of * the convolution is computed. * * If keyword PAD is true, then A and B are padded with zeroes to * match good dimensions for the FFT. As a special case, with PAD=2 * the padding is such that there is no aliasing in the result, * i.e. dimensions of the result are such that: * WIDTH >= DIMSOF(A)(2) + DIMSOF(B)(2) - 1 * HEIGHT >= DIMSOF(A)(2) + DIMSOF(B)(2) - 1 * * * SEE ALSO: fft_best_dim, fft, fftw. */ { real = (structof(a) != complex && structof(b) != complex); if (pad) { if (! is_array(a) || (adims = dimsof(a))(1) != 2 || ! is_array(b) || (bdims = dimsof(b))(1) != 2) { error, "expecting 2-D arrays"; } if (! is_func(fft_best_dim)) { require, "fft_utils.i"; } if (pad == 2) { width = fft_best_dim(adims(2) + bdims(2) - 1); height = fft_best_dim(adims(3) + bdims(3) - 1); } else { width = fft_best_dim(max(adims(2), bdims(2))); height = fft_best_dim(max(adims(3), bdims(3))); } cdims = [2, width, height]; if (adims(2) != width || adims(3) != height) { temp = array((real?double:complex), cdims); temp(1:adims(2), 1:adims(3)) = a; a = temp; } if (bdims(2) != width || bdims(3) != height) { temp = array((real?double:complex), cdims); temp(1:bdims(2), 1:bdims(3)) = b; b = temp; } // FIXME: check unroll offsets if (unroll) { off0 = ((adims(2:) - 1)/2); off1 = ((cdims(2:) - 1)/2) - ((bdims(2:) - 1)/2); offset = (correl ? off1 + off0 : off1 - off0); } } else { cdims = dimsof(a, b); if (is_void(cdims)) { error, "non-conformable arrays"; } if (unroll) { offset = ((cdims(2:) - 1)/2); } } if (is_func(fftw)) { fwd = fftw_plan(cdims, +1, real=real); a = fftw(a, fwd); b = fftw(b, fwd); p = fftw((correl?conj(a):a)*b, fftw_plan(cdims, -1, real=real)); a = b = []; // possibly free some memory } else { ws = fft_setup(cdims); a = fft(a, +1, setup=ws); b = fft(b, +1, setup=ws); p = fft((correl?conj(a):a)*b, -1, setup=ws); a = b = []; // possibly free some memory if (real) p = double(p); } #if 0 p = (1.0/numberof(p))*(unroll?roll(p,offset):p); i = where(p == max(p))(1) - 1; write, format="max at offset: %d %d\n", i%width, i/width; return p; #endif return (1.0/numberof(p))*(unroll?roll(p,offset):p); } /*---------------------------------------------------------------------------*/ func img_pad(img, .., bg=, just=) /* DOCUMENT img_pad(img) -or- img_pad(img, dimlist) -or- img_pad(img, width, height) Pad an image to another size, one of: - the smallest square 2D array that contains the image - an 2D array with dimension list DIMLIST - a WIDTH-by-HEIGHT array The padding value can be specified with keyword BG (for "background"), the default is 0. The type of the result depends on the types of IMG and BG. The justification is set by keyword JUST: JUST = 0 or nil -> lower-left (the default) 1 -> center -1 -> at corners to preserve FFT indexing SEE ALSO: img_paste, img_dims. */ { /* Get new dimension list. */ local new1, new2; dims = img_dims(img); old1 = dims(1); old2 = dims(2); nargs = 0; while (more_args()) { arg = next_arg(); ++nargs; if ((s = structof(arg)) != long && s != int && s != short && s != char) error, "invalid non-integer dimension list"; if ((arg_dims = dimsof(arg))(1) == 0) { /* got a scalar argument */ if (nargs == 1) new1 = long(arg); else if (nargs == 2) new2 = long(arg); else error, "too many new dimensions"; } else if (nargs==1 && arg_dims(1)==1 && arg_dims(2)==3 && arg(1)==2) { /* got a valid dimlist */ new1 = arg(2); new2 = arg(3); } else error, "bad dimension list"; } if (nargs==0) new1 = new2 = max(dims); else if (nargs == 1 && is_void(new2)) new2 = new1; if (new1=1 && y0<=dst_dims(2) && y1>=1) { /* maybe clip SRC along 1st dimension */ if ((clip= x0<1)) { s0 = 2 - x0; x0 = 1; } else s0 = 1; if (x1>dst_dims(1)) { x1 = dst_dims(1); clip = 1n; } if (clip) src = src(s0:s0+x1-x0,); /* maybe clip SRC along 2nd dimension */ if ((clip = y0<1)) { s0 = 2 - y0; y0 = 1; } else s0 = 1; if (y1>dst_dims(2)) { y1 = dst_dims(2); clip = 1n; } if (clip) src = src(,s0:s0+y1-y0); /* paste SRC in-place */ dst(x0:x1, y0:y1) = src; } return dst; } /*---------------------------------------------------------------------------*/ func img_flatten(a, n) { if (! is_array(a)) error, "expecting array argument"; dims = dimsof(a); ndims = dims(1); if (ndims <= 2) return a; width = dims(2); height = dims(3); depth = numberof(a)/(width*height); if (is_void(n)) { n = max(1, long(0.5 + sqrt(double(height*depth)/double(width)))); } w = n*width; h = ((depth + n - 1)/n)*height; out = array(structof(a), w, h); for (k=0 ; k R <= sqrt((X - X0)^2 + (Y - Y0)^2) + 0.5 < R + 1 * <==> R - 0.5 <= sqrt((X - X0)^2 + (Y - Y0)^2) < R + 0.5 * * Disk of radius R and center (X0,Y0) rounded to nearest pixel: * * floor(sqrt((X - X0)^2 + (Y - Y0)^2) + 0.5) <= R * <==> sqrt((X - X0)^2 + (Y - Y0)^2) + 0.5 < R + 1 * <==> sqrt((X - X0)^2 + (Y - Y0)^2) < R + 0.5 * <==> (X - X0)^2 + (Y - Y0)^2 < (R + 0.5)^2 * * Corresponding rectangular region of interest: * * Y = Y0 ==> abs(X - X0) < R + 0.5 * -(R + 0.5) < X - X0 < R + 0.5 * X0 - (R + 0.5) < X < X0 + (R + 0.5) * */ func img_photometry(img, x, y, r, bg=) /* DOCUMENT img_photometry(img, x, y, r) Returns sum of pixel values in image IMG whithin circular area of radius R and centered at (X,Y). Arrays X, Y and R are in pixel units, they may have any geometry but must be conformable. Coordinates have the same origin as array indices: the first pixel in IMG has coordinates (1,1). SEE ALSO dimsof, avg. */ { /* Get dimensions of image and make X, Y and R arrays conformable. */ if (! is_array(img) || (dims = dimsof(img))(1) != 2) error, "expecting 2D array"; nx = dims(2); ny = dims(3); if (is_void((dims = dimsof(x, y, r)))) error, "X, Y and R not conformable"; zero = array(double, dims); if (structof((x += zero)) != double || structof((y += zero)) != double || structof((r += zero)) != double) error, "bad data type"; zero = []; rp = r + 0.5; i1 = max(1, long(ceil(x - rp))); i2 = min(nx, long(floor(x + rp))); j1 = max(1, long(ceil(y - rp))); j2 = min(ny, long(floor(y + rp))); rp *= rp; result = array((structof(img) == complex ? complex : double), dims); n = numberof(x); for (k=1 ; k<=n ; ++k) { if ((i1k = i1(k)) <= (i2k = i2(k)) && (j1k = j1(k)) <= (j2k = j2(k))) { irng = i1k:i2k; jrng = j1k:j2k; u = indgen(irng) - x(k); v = indgen(jrng) - y(k); if (is_array((i = where(u*u + (v*v)(-,) < rp(k))))) { result(k) = avg(img(irng, jrng)(i)); } } } if (! is_void(bg)) result -= bg; PI = 3.14159265358979323848; return (2*PI*r*r)*result; } /*---------------------------------------------------------------------------*/ /* FILTERS */ func img_flt_max(img, width, uniq=) /* DOCUMENT img_flt_max(img, width) Return indices of pixels in image IMG that have the maximum value in a local WIDTH-by-WIDTH box (WIDTH must be odd). If keyword UNIQ is true, a uniq maximum is selected in every WIDTH-by-WIDTH box, in this case the intensity of the maxima will be in ascending order. SEE ALSO: img_flt_flac. */ { if (width%2 != 1) error, "width must be odd"; w = (width-1)/2; if (w<=0) { if (w<0) error, "width must be non-negative"; return img; } dims = img_dims(img); dim1 = dims(1); dim2 = dims(2); /* Filter image to replace pixel value by local maximum value. */ if (w+1 >= dim1) { tmp = img(max,)(-:1:dim1,); } else { tmp = img; for (i=1 ; i<=dim1 ; ++i) tmp(i,) = img(max:max(i-w,1):min(i+w,dim1),); } if (w+1 >= dim2) { lmx = tmp(,max)(,-:1:dim2); } else { lmx = tmp; for (i=1 ; i<=dim2 ; ++i) lmx(,i) = tmp(,max:max(i-w,1):min(i+w,dim2)); } tmp = []; /* Get indices of local maxima. */ i = where(img >= lmx); if (! uniq || ! is_array(i)) return i; lmx = []; /* Sort maxima (because we already know that close maxima must have the same value) and remove multiples. */ z = img(i); s = sort(z); i = i(s); x = 1 + (i-1)%dim1; y = 1 + (i-1)/dim1; z = z(s); if (numberof(z) > 1) { j = 1; k = where((z(dif)!=0) + (abs(x(dif)) > w) + (abs(y(dif)) > w)); if (is_array(k)) grow, j, 1+k; i = i(j); } return i; } func img_flt_flac(img, width) /* DOCUMENT img_flt_flac(img, width) Compute ``flipped-local-auto-convolution'' (sic!) of image IMG. The output pixel value is the local convolution -- in a box of WIDTH-by-WIDTH pixels (WIDTH must be odd) -- of the input image by itself rotated by 180 degrees. This is usefull to locate spikes in IMG that may have different shapes but are all nearly symmetrical with respect to both axis (i.e. each spike has its shape nearly unchanged by a 180 degrees rotation). This processing is a kind of adaptive filtering. WIDTH should be roughly as large as the typical spike width. The impact of input noise in the result is reduced by using a larger WIDTH. But WIDTH should remain smaller than half the smallest separation between spikes. The computation time is proportional to WIDTH^2. SEE ALSO: img_flt_max. */ { if (width%2 != 1) error, "width must be odd"; w = (width-1)/2; dims = img_dims(img); dim1 = dims(1); dim2 = dims(2); if (max(dim1,dim2)0?-w:1) ; w1<=w ; ++w1) { s1 = img(w+1+w1 : w1-w, w+1+w2 : w2-w); s2 = img(w+1-w1 : -w1-w, w+1-w2 : -w2-w); s += s1*s2; } } out = array(double, dim1, dim2); out(w+1:-w, w+1:-w) = 2.0*s; return out; } /*---------------------------------------------------------------------------*/ /* READING/WRITING IMAGES */ local IMG_PNM, IMG_JPEG, IMG_PNG, IMG_TIFF, IMG_FITS, IMG_GIF; func img_get_type(filename, type=, reading=) /* DOCUMENT img_get_type(filename) Returns image type for file FILENAME. If keyword READING is true, then FILENAME must exists and the image type is obtained from the file signature (the 4 first bytes in the file). Otherwise, if keyword TYPE is true it must be one of the string: "pnm", "jpeg", "png", "tiff", "fits", or "gif". Finally if none of this keywords is set, the image type is guessed form the file extension. The returned value is one of: 1 = IMG_PNM portable anymap (PBM/PGM/PPM) image; 2 = IMG_JPEG JPEG image; 3 = IMG_PNG, portable network graphic image; 4 = IMG_TIFF TIFF image; 5 = IMG_FITS FITS (flexible image transport system) file; 6 = IMG_GIF GIF image; SEE ALSO: img_read, img_write. */ { if (reading) { /* Guess file type from 4 byte header, according to magic numbers: * \377 \330 = JPEG * \211 "PNG" = PNG * "GIF8" = GIF * "MM" \000 \052 = TIFF image data, big-endian * "II" \052 \000 = TIFF image data, little-endian * "P1" space = ascii PBM (portable bitmap) * "P2" space = ascii PGM (portable graymap) * "P3" space = ascii PPM (portable pixmap) * "P4" space = raw PBM * "P5" space = raw PGM * "P6" space = raw PPM */ magic = array(char, 4); n = _read(open(filename, "rb"), 0, magic); c1 = (n >= 1 ? magic(1) : char(0)); c2 = (n >= 2 ? magic(2) : char(0)); c3 = (n >= 3 ? magic(3) : char(0)); c4 = (n >= 4 ? magic(4) : char(0)); if (c1 == '\377' && c2 == '\330') return IMG_JPEG; if (c1 == '\211' && c2 == 'P' && c3 == 'N' && c4 == 'G') return IMG_PNG; if ((c1 == 'M' && c2 == 'M' && c3 == '\000' && c4 == '\052') || (c1 == 'I' && c2 == 'I' && c3 == '\052' && c4 == '\000')) return IMG_TIFF; if (c1 == 'S' && c2 == 'I' && c3 == 'M' && c4 == 'P') return IMG_FITS; if (c1 == 'P' && c2 >= '1' && c2 <= '6' && (c3 == '\n' || c3 == '\r' || c3 == ' ' || c3 == '\t')) return IMG_PNM; if (c1 == 'G' && c2 == 'I' && c3 == 'F' && c4 == '8') return IMG_GIF; error, "cannot guess image file format"; } if (is_void(type)) { /* Guess file type from its extension. */ ext = strpart(filename, -3:0); if (ext == ".png" || ext == ".PNG") return IMG_PNG; if (ext == ".jpg" || ext == ".JPG") return IMG_JPEG; if (ext == ".tif" || ext == ".TIF") return IMG_TIFF; if (ext == ".fit" || ext == ".FIT" || ext == ".fts" || ext == ".FTS") return IMG_FITS; if (ext == ".gif" || ext == ".GIF") return IMG_GIF; if (ext == ".pnm" || ext == ".PNM" || ext == ".pbm" || ext == ".PBM" || ext == ".pgm" || ext == ".PGM" || ext == ".ppm" || ext == ".PPM") return IMG_PNM; ext = strpart(filename, -4:0); if (ext == ".jpeg" || ext == ".JPEG") return IMG_JPEG; if (ext == ".tiff" || ext == ".TIFF") return IMG_TIFF; if (ext == ".fits" || ext == ".FITS") return IMG_FITS; error, "cannot guess image file format from file extension"; } if (type == "pnm") return IMG_PNM; if (type == "jpeg") return IMG_JPEG; if (type == "png") return IMG_PNG; if (type == "tiff") return IMG_TIFF; if (type == "fits") return IMG_FITS; if (type == "gif") return IMG_GIF; error, "bad image type name, expecting: pnm, jpeg, png, tiff, fits or gif"; } IMG_PNM = 1; IMG_JPEG = 2; IMG_PNG = 3; IMG_TIFF = 4; IMG_FITS = 5; IMG_GIF = 6; func img_read(filename, tmp=) /* DOCUMENT img_read(filename) Returns image read from FILENAME. Supported image formats are: PNM (PBM/PBM/PPM), JPEG, PNG, TIFF, FITS and GIF. For some formats, a temporary PNM image needs to be created; the name of the temporary file can be specified with keyword TMP. SEE ALSO: system, pnm_read, fits_read, img_get_type, img_tmpnam, expand_file_name, protect_file_name. */ { filename = expand_file_name(filename); if (! open(filename,"r",1)) error, "input file does not exists"; type = img_get_type(filename, reading=1); if (type == IMG_PNM) { convert = 0; /* no needs for conversion */ } else if (type == IMG_JPEG) { convert = "jpegtopnm"; } else if (type == IMG_PNG) { convert = "pngtopnm"; } else if (type == IMG_TIFF) { convert = "tifftopnm"; } else if (type == IMG_FITS) { /* TO DO: read compressed FITS file */ if (! is_func(fits_read)) require, "fits.i"; return fits_read(filename); } else if (type == IMG_GIF) { convert = "giftopnm"; } /* read image as PNM file, possibly after conversion */ if (! is_func(pnm_read)) require, "pnm.i"; if (convert) { if (is_void(tmp)) tmp = img_tmpnam(filename); if (catch(-1)) { remove, tmp; error, catch_message; } system, swrite(format="%s %s 2>/dev/null >%s", convert, protect_file_name(filename), protect_file_name(tmp)); img = pnm_read(tmp); remove, tmp; } else { img = pnm_read(filename); } return img; } func img_write(img, filename, type=, cmin=, cmax=, tmp=, noflip=, quality=, optimize=, grey=, gray=, progressive=, comment=, smooth=, eps=, compression=, interlace=, /* transparent=, gamma=, */ bitpix=) /* DOCUMENT img_write, img, filename; Writes image IMG into file FILENAME as PNM (PBM/PBM/PPM), JPEG, PNG, TIFF or FITS image. Except for a FITS file, if pixel type of IMG is not 'char', the pixel values are scaled to unsigned bytes (0-255) with bytscl function (which see). The image type can be specified by the keyword TYPE otherwise it is automatically guessed from FILENAME extension (see img_get_type). KEYWORDS Keywords common to all format: TYPE - Output image type, one of: "jpeg", "pnm", "png", "tiff" or "fits". TMP - Name of the temporary file (format PBM, PGM, or PPM, see pnm_write) to creates. Default is FILENAME~NUMBER where NUMBER is the smallest integer such that no file with the same name already exists (note that under race conditions the name of the default temporary file is not guaranteed to be unique). NOFLIP - See pnm_write -- not used for FITS format. CMIN, CMAX - Optional lower/upper cutoff (see bytscl) -- not used for FITS format. Keywords for JPEG images: EPS - If true, "jpeg2ps" is used to generate an encapsulated PostScript (level 2) image named FILENAME.eps (the JPEG image is not removed). QUALITY - JPEG quality (default 75). OPTIMIZE - Creates optimized JPEG image. GRAY/GREY - Creates grayscale JPEG image. PROGRESSIVE - Creates a progressive JPEG file. COMMENT - Text comment. SMOOTH=0-100 - Smooth the input image to eliminate dithering noise, 0 (the default) means no smoothing. Keywords for PNG images: COMPRESSION=1-9 - Level of compression (default is 6). INTERLACE - Creates an interlaced PNG file. Keywords for FITS images: BITPIX=n - Bits-per-pixel value. SEE ALSO: pnm_write, bytscl, system, img_get_type, img_tmpnam, expand_file_name, protect_file_name. */ { filename = expand_file_name(filename); type = img_get_type(filename, type=type); if (type == IMG_PNM) { convert = 0; /* no needs for conversion */ } else if (type == IMG_JPEG) { if (! is_void(quality)) quatlity = 75; convert = swrite(format="pnmtojpeg --quality=%d", quality); if (optimize) convert += " --optimize"; if (grey || gray) convert += " --grayscale"; if (progressive) convert += " --progressive"; if (! is_void(comment)) convert += swrite(format=" --comment=\"%s\"", comment); if (! is_void(smooth)) convert += swrite(format=" --smooth=%d", smooth); } else if (type == IMG_PNG) { convert = "pnmtopng"; if (! is_void(compression)) convert += swrite(format=" -compression=%d", compression); if (interlace) convert += " -interlace"; } else if (type == IMG_TIFF) { convert = "pnmtotiff"; } else if (type == IMG_FITS) { /* TO DO: read compressed FITS file */ if (! is_func(fits_write)) require, "fits.i"; return fits_write(filename, img, overwrite=1, bitpix=bitpix); } else if (type == IMG_GIF) { error, "GIF format not supported for writting"; } /* byte scale image */ if (structof(img) != char) img = bytscl(img, top=255, cmin=cmin, cmax=cmax); /* write image as PNM file then convert to output type */ if (! is_func(pnm_write)) require, "pnm.i"; if (convert) { if (is_void(tmp)) tmp = img_tmpnam(filename); if (catch(-1)) { remove, tmp; error, catch_message; } pnm_write, img, tmp, noflip; filename_p = protect_file_name(filename); system, swrite(format="%s %s 2>/dev/null >%s", convert, protect_file_name(tmp), filename_p); remove, tmp; } else { pnm_write, img, filename, noflip; } if (eps && type == IMG_JPEG) { /* make an encapsulated poscript file with JPEG image */ if (is_void(filename_p)) filename_p = protect_file_name(filename); system, swrite(format="jpeg2ps %s >%s.eps", filename_p, filename_p); } } /*---------------------------------------------------------------------------*/ /* UTILITIES */ func img_tmpnam(name) /* DOCUMENT img_tmpnam(name) Return a string in the form: NAME~# where # is an integer chosen so that file NAME~# does not exists. Beware that there is no absolute warranty that the returned name is not used elsewhere (for instance if two programs run at the same time and call the same function) but this is highly improbable. In order to limit the probabilty of such clash to occur, an empty file named NAME~# is created by the function. SEE ALSO: open. */ { fmt = "%s~%d"; i = 0; do { tmp = swrite(format=fmt, name, ++i); } while (open(tmp, "r", 1)); open, tmp, "w"; /* create empty file */ return tmp; } /*---------------------------------------------------------------------------* * Local Variables: * * mode: Yorick * * tab-width: 8 * * fill-column: 75 * * c-basic-offset: 2 * * coding: latin-1 * * End: * *---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/linalg.i000066400000000000000000000327541152651572200177240ustar00rootroot00000000000000/* * linalg.i - * * Linear Algebra functions for Yorick. * *----------------------------------------------------------------------------- * * Copyright (C) 2003-2004 Eric THIEBAUT. * * This file is part of OptimPack. * * OptimPack 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. * * OptimPack 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 Yeti (file "COPYING" in the top source directory); if * not, write to the Free Software Foundation, Inc., 59 Temple Place, * Suite 330, Boston, MA 02111-1307 USA. * *----------------------------------------------------------------------------- * * History: * $Id: linalg.i,v 1.2 2008-02-15 18:55:28 frigaut Exp $ * $Log: linalg.i,v $ * Revision 1.2 2008-02-15 18:55:28 frigaut * fixed UTF-8 encoding problems (crash yorick-doc on amd64) * * Revision 1.1.1.1 2007/12/11 23:55:10 frigaut * Initial Import - yorick-yutils * */ func gram_schmidt_orthonormalization(b) /* DOCUMENT gram_schmidt_orthonormalization, b; -or- gram_schmidt_orthonormalization(b) Performs Gram-Schmidt orthonormalization of basis functions B. If B is an array of pointers, then the input basis vectors are *B(i) for i=1,..,numberof(B); otherwise, the input basis vectors are B(..,i) for i=1,..,dimsof(B)(0). When called as a subroutine, the operation is done "in-place". SEE ALSO: SVdec. */ { local b_i, b_j; /* NOTE: type conversion of array X, e.g. double(X), is a no-operation if X already of given type. */ if (! is_array(b)) error, "expecting array parameter"; type = double; if ((s = structof(b)) == pointer) { ptr = 1; n = numberof(b); if (! am_subroutine()) b = b; /* make a private copy */ for (i=1 ; i<=n ; ++i) { if ((s = structof(*b(i))) == complex) type = complex; else if (s != double && s != float && s != long && s != int && s != short && s != char) error, "bad data type"; } } else { ptr = 0; n = dimsof(b)(0); if ((s = structof(b)) == complex) type = complex; else if (s != double && s != float && s != long && s != int && s != short && s != char) error, "bad data type"; if (s != type) { if (am_subroutine()) error, "bad data type for in-place conversion"; b = type(b); } } if (type == complex) error, "complex data type not yet implemented"; /* Gram-Schmidt Orthonormalization. */ for (i=1 ; i<=n ; ++i) { /* get i-th basis vector */ if (prt) eq_nocopy, b_i, type(*b(i)); else b_i = b(.., i); /* make the i-th vector othogonal to previous ones */ if (i > 1) { if (prt) eq_nocopy, b_j, type(*b(1)); else b_j = b(.., 1); s = sum(b_i*b_j)*b_j; for (j=2 ; j 0.0 ? (1.0/sqrt(s))*b_i : array(double, dimsof(b_i)))); } else { b(..,i) = (s > 0.0 ? (1.0/sqrt(s))*b_i : array(double, dimsof(b_i))); } } return b; } func trace(a) /* DOCUMENT trace(a) Returns the trace of matrix A. SEE ALSO: diag. */ { if (! is_array(a) || (dims = dimsof(a))(1) != 2) error, "expecting a 2D array"; m = dims(2); n = dims(3); return a(sum:1:m*min(m,n):m+1); } func diag(a) /* DOCUMENT diag(a) Returns the diagonal of matrix A (if A is a 2D array) or a square diagonal matrix with diagonal elements equal to those of vector A (if A is a 1D array). SEE ALSO: trace, unit. */ { if (is_array(a)) { if ((dims = dimsof(a))(1) == 1) { m = dims(2); (mx = array(structof(a), m, m))(1:m*m:m+1) = a; return mx; } else if (dims(1) == 2) { m = dims(2); n = dims(3); return a(1:m*min(m,n):m+1); } } error, "expecting a 1D or 2D array"; } func euclidean_norm(x) /* DOCUMENT euclidean_norm(x) Returns the Euclidian norm of X: sqrt(sum(X*X)), taking care of overflows. */ { if (! (s = max(-min(x), max(x)))) return 0.0; x *= 1.0/s; return s*sqrt(sum(x*x)); } func pm(a, ndigits=, file=, format=) /* DOCUMENT pm, a; Prints matrix A. Keyword FILE can be set to the name/stream of output file; the default is to use standard output. If keyword NDIGITS is set, floating-point values get printed with that number of significant digits; alternatively, keyword FORMAT may be set with the format for each element of A -- for complex numbers, the real and imaginary parts use the same format. SEE ALSO: write. */ { if (! is_array(a) || (dims = dimsof(a))(1) != 2) { error, "expecting a 2-dimensional array"; } m = dims(2); n = dims(3); s = structof(a); if (s == complex) { if (is_void(format)) { if (is_void(ndigits)) ndigits = 5; format = swrite(format="%%.%dg+%%.%dgi", ndigits, ndigits); } else { format += "+" + format + "i"; } a = swrite(format=format, double(a), a.im); } else if (s == pointer) { a = swrite(a); } else { if (is_void(format)) { if (s == double) { if (is_void(ndigits)) ndigits = 5; format = swrite(format="%%.%dg", ndigits); } else if (s == float) { if (is_void(ndigits)) ndigits = 3; format = swrite(format="%%.%dg", ndigits); } else if (s == long || s == int || s == short) { format = "%d"; } else if (s == char) { format = "0x%02x"; } else if (s == string) { /* should escape quotes in input strings */ format = "\"%s\""; } else { error, "bad data type"; } } a = swrite(format=format, a); } if (structof(file) == string) file = open(file, "w"); cols = swrite(format="(,%d)",indgen(n)); rows = swrite(format="(%d,)",indgen(m)); fmt0 = swrite(format="%%%ds", max(strlen(rows))); fmt1 = swrite(format=" %%-%ds", max(max(strlen(cols)), max(strlen(a)))); fmt2 = " %s\n"; write, file, format=fmt0, ""; for (j=1 ; j EPS*max(SIGMA); 0 otherwise. SEE ALSO: sv_dcmp, sv_intro, sv_solve_wiener. */ { local sigma, u, vt; _sv_get_dcmp, a, full; if (is_void(eps)) eps = 1e-1; w = double(sigma > eps*sigma(1))/(sigma + !sigma); return (w*vt)(+,)*(u(+,)*b(+,..))(+,..); } func sv_solve_wiener(a, b, eps, full=) /* DOCUMENT sv_solve_wiener(a, b, eps) Solve linear problem A.x = b by Wiener filtering of the singular values. A is either a matrix or the singular value value decomposition as returned by sv_dcmp (to see). B is the right hand side vector (or array to solve for several right hand sides at a time). EPS (in the range [0,1]) is the relative singular value filter level. The result is: (W*VT)(+,)*(U(+,)*B(+,..))(+,..) where SIGMA, U and VT are the components of the singular value decomposition of A and W is: W = SIGMA/(SIGMA^2 + (EPS*max(SIGMA))^2) SEE ALSO: sv_dcmp, sv_intro, sv_solve_trunc. */ { local sigma, u, vt; _sv_get_dcmp, a, full; if (is_void(eps)) eps = 1e-1; w = sigma/(sigma*sigma + (eps*sigma(1))^2); return (w*vt)(+,)*(u(+,)*b(+,..))(+,..); } /*---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/lmfit.i000066400000000000000000000355271152651572200175720ustar00rootroot00000000000000/* * lmfit.i -- * * Non-linear least-squares fit by Levenberg-Marquardt method. * * Copyright (c) 1997, Eric THIEBAUT (thiebaut@obs.univ-lyon1.fr, Centre de * Recherche Astrophysique de Lyon, 9 avenue Charles Andre, F-69561 Saint * Genis Laval Cedex). * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * History: * $Id: lmfit.i,v 1.1 2007-12-11 23:55:12 frigaut Exp $ * $Log: lmfit.i,v $ * Revision 1.1 2007-12-11 23:55:12 frigaut * Initial revision * * Revision 1.4 2003/06/17 12:17:10 eric * - fix doc. * * Revision 1.3 1998/09/08 15:31:06 eric * - Make sure that input parameters have floating-point values. * * Revision 1.2 1997/07/28 08:26:25 eric * - Fix the doc. * * Revision 1.1 1997/04/21 08:34:04 eric * Initial revision *----------------------------------------------------------------------------- */ require, "random.i"; struct lmfit_result { /* DOCUMENT lmfit_result -- structure returned by lmfit */ long neval; long niter; long nfit; long nfree; long monte_carlo; double chi2_first; double chi2_last; double conv; double sigma; double lambda; pointer stdev; pointer stdev_monte_carlo; pointer correl; } func lmfit(f, x, &a, y, w, fit=, correl=, stdev=, gain=, tol=, deriv=, itmax=, lambda=, eps=, monte_carlo=) /* DOCUMENT lmfit -- Non-linear least-squares fit by Levenberg-Marquardt method. DESCRIPTION: Implement Levenberg-Marquardt method to perform a non-linear least squares fit to a function of an arbitrary number of parameters. The function may be any non-linear function. If available, partial derivatives can be calculated by the user function, else this routine will estimate partial derivatives with a forward difference approximation. CATEGORY: E2 - Curve and Surface Fitting. SYNTAX: result= lmfit(f, x, a, y, w, ...); INPUTS: F: The model function to fit. The function must be written as described under RESTRICTIONS, below. X: Anything useful for the model function, for instance: independent variables, a complex structure of data or even nothing!. The LMFIT routine does not manipulate or use values in X, it simply passes X to the user-written function F. A: A vector that contains the initial estimate for each parameter. Y: Array of dependent variables (i.e., the data). Y can have any geometry, but it must be the same as the result returned by F. W: Optional weight, must be conformable with Y and all values of W must be positive or null (default = 1.0). Data points with zero weight are not fitted. Here are some examples: - For no weighting (lest square fit): W = 1.0 - For instrumental weighting: W(i) = 1.0/Y(i) - Gaussian noise: W(i) = 1.0/Var(Y(i)) OUTPUTS: A: The vector of fitted parameters. Returns a structure lmfit_result with fields: NEVAL: (long) number of model function evaluations. NITER: (long) number of iteration, i.e. successful CHI2 reductions. NFIT: (long) number of fitted parameters. NFREE: (long) number of degrees of freedom (i.e., number of valid data points minus number of fitted parameters). MONTE_CARLO: (long) number of Monte Carlo simulations. CHI2_FIRST: (double) starting error value: CHI2=sum(W*(F(X,A)-Y)^2). CHI2_LAST: (double) last best error value: CHI2=sum(W*(F(X,A)-Y)^2). CONV: (double) relative variation of CHI2. SIGMA: (double) estimated uniform standard deviation of data. If a weight is provided, a value of SIGMA different from one indicates that, if the model is correct, W should be multiplied by 1/SIGMA^2. Computed so that sum(W*(F(X,A)-Y)^2)/SIGMA^2=NFREE. LAMBDA: (double) last value of LAMBDA. STDEV: (pointer) standard deviation vector of the parameters. STDEV_MONTE_CARLO: (pointer) standard deviation vector of the parameters estimated by Monte Carlo simulations. CORREL: (pointer) correlation matrice of the parameters. KEYWORDS: FIT: List of indices of parameters to fit, the others remaing constant. The default is to tune all parameters. CORREL: If set to a non zero and non-nil value, the correlation matrice of the parameters is stored into LMFIT result. STDEV: If set to a non zero and non-nil value, the standard deviation vector of the parameters is stored into LMFIT result. DERIV: When set to a non zero and non-nil value, indicates that the model function F is able to compute its derivatives with respect to the parameters (see RESTRICTIONS). By default, the derivatives will be estimated by LMFIT using forward difference. If analytical derivatives are available they should always be used. EPS: Small positive value used to estimate derivatives by forward difference. Must be such that 1.0+EPS and 1.0 are numerically different and should be about sqrt(machine_precision)/100 (default = 1e-6). TOL: Stop criteria for the convergence (default = 1e-7). Should not be smaller than sqrt(machine_precision). The routine returns when the relative decrease of CHI2 is less than TOL in an interation. ITMAX: Maximum number of iterations. Default = 100. GAIN: Gain factor for tuning LAMBDA (default = 10.0). LAMBDA: Starting value for parameter LAMBDA (default = 1.0e-3). MONTE_CARLO: Number of Monte Carlo simulations to perform to estimate standard deviation of parameters (by default no Monte Carlo simulations are undergone). May spend a lot of time if you use a large number; but should not be too small! GLOBAL VARIABLES: None. SIDE EFFECTS: The values of the vector of parameters A are modified. PROCEDURE: The function to be fitted must be defined as follow: func F(x, a) {....} and returns a model with same shape as data Y. If you want to provide analytic derivatives, F should be defined as: func F(x, a, &grad, deriv=) { y= ...; if (deriv) { grad= ...; } return y; } Where X are the independent variables (anything the function needs to compute synthetic data except the model parameters), A are the model parameters, DERIV is a flag set to non-nil and non-zero if the gradient is needed and the output gradient GRAD is a numberof(Y) by numberof(A) array: GRAD(i,j) = derivative of ith data point model with respect to jth parameter. LMFIT tune parameters A so as to minimize: CHI2=sum(W*(F(X,A)-Y)^2). The Levenberg-Marquardt method consists in varying between the inverse-Hessian method and the steepest descent method where the quadratic expansion of CHI2 does not yield a better model. The initial guess of the parameter values should be as close to the actual values as possible or the solution may not converge or may give a wrong answer. RESTRICTIONS: Beware that the result does depend on your initial guess A. In the case of numerous local minima, the only way to get the correct solution is to start with A close enough to this solution. The estimates of standard deviation of the parameters are rescaled assuming that, for a correct model and weights, the expected value of CHI2 should be of the order of NFREE=numberof(Y)-numberof(A) (LMFIT actually compute NFREE from the number of valid data points and number of fitted parameters). If you don't like this you'll have to rescale the returned standard deviation to meet your needs (all necessary information are in the structure returned by LMFIT). EXAMPLE: This example is from ODRPACK (version 2.01). The function to fit is of the form: f(x) = a1+a2*(exp(a3*x)-1.0)^2 Starting guess: a= [1500.0, -50.0, -0.1]; Independent variables: x= [ 0.0, 0.0, 5.0, 7.0, 7.5, 10.0, 16.0, 26.0, 30.0, 34.0, 34.5, 100.0]; Data: y= [1265.0, 1263.6, 1258.0, 1254.0, 1253.0, 1249.8, 1237.0, 1218.0, 1220.6, 1213.8, 1215.5, 1212.0]; Function definition (without any optimization): func foo(x, a, &grad, deriv=) { if (deriv) grad= [array(1.0, dimsof(x)), (exp(a(3)*x)-1.0)^2, 2.0*a(2)*x*exp(a(3)*x)*(exp(a(3)*x)-1.0)]; return a(1)+a(2)*(exp(a(3)*x)-1.0)^2; } Fitting this model by: r= lmfit(foo, x, a, y, 1., deriv=1, stdev=1, monte_carlo=500, correl=1) produces typically the following result: a = [1264.84, -54.9987, -0.0829835] r.neval = 12 r.niter = 6 r.nfit = 3 r.nfree = 9 r.monte_carlo = 500 r.chi2_first = 40.4383 r.chi2_last = 40.4383 r.conv = 3.84967e-09 r.sigma = 0.471764 r.lambda = 1e-09 *r.stdev = [1.23727, 1.78309, 0.00575123] *r.stdev_monte_carlo = [1.20222, 1.76120, 0.00494790] *r.correl = [[ 1.000, -0.418, -0.574], [-0.418, 1.000, -0.340], [-0.574, -0.340, 1.000]] HISTORY: - Basic ideas borrowed from "Numerical Recipes in C", CURVEFIT.PRO (an IDL version by DMS, RSI, of the routine "CURFIT: least squares fit to a non-linear function", Bevington, Data Reduction and Error Analysis for the Physical Sciences) and ODRPACK ("Software for Weigthed Orthogonal Distance Regression" freely available at: www.netlib.org). - Added: fitting of a subset of the parameters, Monte-Carlo simulations... */ { local grad; /* Maybe subset of parameters to fit. */ if (structof(a)!=double) { a+= 0.0; if (structof(a)!=double) error, "bad data type for parameters (complex unsupported)"; } na= numberof(a); if (is_void(fit)) fit= indgen(na); else if (dimsof(fit)(1) == 0) fit= [fit]; nfit= numberof(fit); if (!nfit) error, "no parameters to fit."; /* Check weights. */ if (is_void(w)) w= 1.0; else if (anyof(w < 0.0)) error, "bad weights."; if (numberof(w) != numberof(y)) w += array(0.0, dimsof(y)); nfree= sum(w != 0.0) - nfit; // Degrees of freedom if (nfree <= 0) error, "not enough data points."; /* Other settings. */ diag= indgen(1:nfit^2:nfit+1); // Subscripts of diagonal elements if (is_void(lambda)) lambda= 1e-3; if (is_void(gain)) gain= 10.0; if (is_void(itmax)) itmax= 100; if (is_void(eps)) eps= 1e-6; // sqrt(machine_precision)/100 if (1.0+eps <= 1.0) error, "bad value for EPS."; if (is_void(tol)) tol= 1e-7; monte_carlo= is_void(monte_carlo) ? 0 : long(monte_carlo); warn_zero= 0; warn= "*** Warning: LMFIT "; neval= 0; conv= 0.0; niter= 0; while (1) { if (deriv) { m= f(x, a, grad, deriv=1); neval++; grad= nfit == na ? grad(*,) : grad(*,fit); } else { if (!niter) { m= f(x, a); neval++; } inc= eps * abs(a(fit)); if (numberof((i= where(inc <= 0.0)))) inc(i)= eps; grad= array(double, numberof(y), nfit); for (i=1; i<=nfit; i++) { anew= a; // Copy current parameters anew(fit(i)) += inc(i); grad(,i)= (f(x,anew)-m)(*)/inc(i); } neval += nfit; } beta= w * (chi2= y-m); if (niter) chi2= chi2new; else chi2= chi2_first= sum(beta * chi2); beta= grad(+,) * beta(*)(+); alpha= ((w(*)(,-) * grad)(+,) * grad(+,)); gamma= sqrt(alpha(diag)); if (anyof(gamma <= 0.0)) { /* Some derivatives are null (certainly because of rounding * errors). */ if (!warn_zero) { write, warn+"founds zero derivatives."; warn_zero= 1; } gamma(where(gamma <= 0.0))= eps * max(gamma); /* goto done; */ } gamma= 1.0 / gamma; beta *= gamma; alpha *= gamma(,-) * gamma(-,); while (1) { alpha(diag)= 1.0 + lambda; anew= a; anew(fit) += gamma * LUsolve(alpha, beta); m= f(x, anew); neval++; d= y-m; chi2new= sum(w*d*d); if (chi2new < chi2) break; lambda *= gain; if (allof(anew == a)) { /* No change in parameters. */ write, warn+"makes no progress."; goto done; } } a= anew; lambda /= gain; niter++; conv= 2.0*(chi2-chi2new)/(chi2+chi2new); if (conv <= tol) break; if (niter >= itmax) { write, format=warn+"reached maximum number of iterations (%d).\n", itmax; break; } } done: sigma= sqrt(nfree/chi2); result= lmfit_result(neval=neval, niter=niter, nfree=nfree, nfit=nfit, lambda=lambda, chi2_first=chi2_first, chi2_last=chi2, conv=conv, sigma=sigma); if (correl || stdev) { /* Compute correlation matrice and/or standard deviation vector. */ alpha(diag)= 1.0; alpha= LUsolve(alpha); if (anyof((tmp1= alpha(diag)) < 0.0)) write, format=warn+"%s\n", "found negative variance(s)"; tmp1= sqrt(abs(tmp1)); if (stdev) { /* Standard deviation is rescaled assuming that statistically * chi2 = nfree +/- sqrt(2*nfree). */ (tmp2= array(double,na))(fit)= gamma * tmp1 / sigma; result.stdev= &tmp2; } if (correl) { gamma= 1.0 / tmp1; alpha *= gamma(-,) * gamma(,-); if (nfit == na) { result.correl= α } else { (tmp2= array(double, na, na))(fit,fit)= alpha; result.correl= &tmp2; } } } alpha= beta= gamma= []; // Free some memory. if (monte_carlo >= 1) { saa= 0.0*a; sig= (w > 0.0) /(sqrt(max(nfree/chi2*w, 0.0)) + (w == 0.0)); for (i=1; i<=monte_carlo; i++) { anew= a; ynew= y + sig * random_n(dimsof(y)); lmfit, f, x, anew, ynew, w, fit=fit, gain=gain, tol=tol, deriv=deriv, itmax=itmax, lambda=lambda, eps=eps; anew -= a; saa += anew * anew; } result.monte_carlo= monte_carlo; result.stdev_monte_carlo= &sqrt(saa / monte_carlo); } return result; } frigaut-yorick-yutils-c173974/moffat.i000066400000000000000000000352251152651572200177260ustar00rootroot00000000000000/* * moffat.i * * $Id: moffat.i,v 1.1 2008-10-29 15:53:38 paumard Exp $ * * This file is part of Yutils * Copyright (C) 2008 Thibaut Paumard * * 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. * * $Log: moffat.i,v $ * Revision 1.1 2008-10-29 15:53:38 paumard * moffat.i, multiprofile.i: initial import * * */ func moffat1d(x,a2,&grad,deriv=){ /* DOCUMENT moffat1d(x,a) Returns a (1D) Moffat profile: I=I0*(1+((x-x0)/dx)^2)^-b [+ k0 [+ k1*x]] Where: I0=a(1) x0=a(2) ; deriv: 2*I0*b*(x-x0)/(dx^2)*(1+((x-x0)/dx)^2)^(-b-1) dx=a(3) ; deriv: 2*I0*b*(x-x0)^2/(dx^3)*(1+((x-x0)/dx)^2)^(-b-1) b=a(4) and if a is of length 5 or 6: k0=a(5) k1=a(6) This function can be used directly with lmfit. Limitation: "b" should always be positive. In order to force it, especially in fitting routines, its abolute value is taken (except at some point in the computation of derivates). SEE ALSO: moffat1d_fit, asmoffat1d, asmoffat1d_fit */ a=double(a2); extern __moffat_betamax,__moffat_vmax,__moffat_gradmax; if (is_void(__moffat_gradmax)) __moffat_gradmax=1e150; if (__moffat_betamax) big=__moffat_betamax ; else big=1e18; // higher value yield math errors, but a more meaningfull max can be set using __moffat_betamax nterms=numberof(a); if (__moffat_vmax) { if (abs(a(2)>__moffat_vmax)) { grad=array(double,numberof(x),nterms); return x*0; } } small=1e-80; if (a(3)__moffat_gradmax); if (numberof(ind)) { u2(ind)=sign(u2(ind))*__moffat_gradmax; write,"*** Warning: MOFFAT caught overflows."; } u4=u2^2; u3=1+u4; if (abs(a(4))>big) { u1=u3*0; u1b=u1; ind=where(u4==0); if (numberof(ind)) { u1(ind)=1; u1b(ind)=1; } } else { u1=u3^-abs(a(4)); u1b=u3^(-abs(a(4))-1); } res=a(1)*u1; if (nterms>4) res=res+a(5); if (nterms==6) res=res+a(6)*x; if (deriv) { grad=array(double,numberof(x),nterms); grad(,1)=u1; if (max(u1b)) grad(,2)=2*a(1)*(a(4))*u2/a(3)*u1b; if (max(u1b)) grad(,3)=2*a(1)*(a(4))*u4/a(3)*u1b; grad(,4)=-a(1)*log(u3)*u1; // Useless line due to initialisation: //if (nterms>4) grad(,5)=0; if (nterms==6) grad(,6)=x; // try to avoid overflows in lmfit. ind1=where(grad>__moffat_gradmax); if (numberof(ind1)) { grad(ind1)=__moffat_gradmax; write,"*** Warning: MOFFAT caught overflows."; } ind2=where(grad<-__moffat_gradmax); if (numberof(ind2)) { grad(ind2)=-__moffat_gradmax; write,"*** Warning: MOFFAT caught overflows."; } // try to avoid underflows in lmfit. ind3=where(abs(grad)<1/__moffat_gradmax); if (numberof(ind3)) { grad(ind3)=0; //write,"MOFFAT warning: grad underflows caught, grad is inaccurate."; } } return res; } func asmoffat1d(x,a2,&grad,deriv=){ /* DOCUMENT asmoffat1d(x,a) Returns a (1D) asymmetrical Moffat profile: I=I0*(1+((x-x0)/dx)^2)^-b [+ k0 [+ k1*x]] Where: I0=a(1) x0=a(2) ; deriv: 2*I0*b*(x-x0)/(dx^2)*(1+((x-x0)/dx)^2)^(-b-1) dx for x=x0 =a(5) ; deriv: 2*I0*b*(x-x0)^2/(dx^3)*(1+((x-x0)/dx)^2)^(-b-1) b for x>=x0 =a(6) and if a is of length 7 or 8: k0=a(7) k1=a(8) This function can be used directly with lmfit. SEE ALSO: moffat1d, moffat1d_fit, asmoffat1d_fit */ a=double(a2); extern __moffat_betamax,__moffat_vmax,__moffat_gradmax; if (is_void(__moffat_gradmax)) __moffat_gradmax=1e150; if (__moffat_betamax) big=__moffat_betamax ; else big=1e18; // higher value yield math errors, but a more meaningfull max can be set using __moffat_betamax nterms=numberof(a); if (__moffat_vmax) { if (abs(a(2)>__moffat_vmax)) { grad=array(double,numberof(x),nterms); return x*0; } } small=1e-80; if (a(3)=a(2)); u2a=(x-a(2))/a(3); u2b=(x-a(2))/a(5); u4a=u2a^2; u4b=u2b^2; u3a=1+u4a; u3b=1+u4b; u3=u3a*ta+u3b*tb; if (abs(a(4))>big) { u1a=u3a*0; u1ab=u1a; ind=where(u4a==0); if (numberof(ind)) { u1a(ind)=1; u1ab(ind)=1; } } else { u1a=u3a^-abs(a(4)); u1ab=u3a^(-abs(a(4))-1); } if (abs(a(6))>big) { u1b=u3b*0; u1bb=u1b; ind=where(u4b==0); if (numberof(ind)) { u1b(ind)=1; u1bb(ind)=1; } } else { u1b=u3b^-abs(a(6)); u1bb=u3b^(-abs(a(6))-1); } u1=u1a*ta+u1b*tb; u1B=u1ab*ta+u1bb*tb; res=a(1)*u1; if (nterms>6) res=res+a(7); if (nterms==8) res=res+a(8)*x; if (deriv) { grad=array(double,numberof(x),nterms); grad(,1)=u1; if (max(u1B)) grad(,2)=2*a(1)*(a(4)*u2a/a(3)*u1ab*ta+a(6)*u2b/a(5)*u1bb*tb); if (max(u1ab)) grad(,3)=2*a(1)*(a(4)*u4a/a(3)*u1ab*ta); grad(,4)=-a(1)*log(u3a)*u1a*ta; if (max(u1bb)) grad(,5)=2*a(1)*(a(6)*u4b/a(5)*u1bb*tb); grad(,6)=-a(1)*log(u3b)*u1b*tb; // Useless line due to initialisation: //if (nterms>6) grad(,7)=0; if (nterms==8) grad(,8)=x; // try to avoid overflows in lmfit. ind1=where(grad>__moffat_gradmax); if (numberof(ind1)) { grad(ind1)=__moffat_gradmax; write,"MOFFAT warning: grad overflows caught, grad is inaccurate."; } ind2=where(grad<-__moffat_gradmax); if (numberof(ind2)) { grad(ind2)=-__moffat_gradmax; write,"MOFFAT warning: grad overflows caught, grad is inaccurate."; } // try to avoid underflows in lmfit. ind3=where(abs(grad)<1/__moffat_gradmax); if (numberof(ind3)) { grad(ind3)=0; //write,"MOFFAT warning: grad underflows caught, grad is inaccurate."; } } return res; } /*func asmoffat(x,a,&grad,deriv=){ /* DOCUMENT asmoffat(x,a) Returns a (1D) asymmetrical Moffat profile: I=I0*(1+((x-x0)/dx)^2)^-b [+ k0 [+ k1*x]] Where: I0=a(1) x0=a(2) ; deriv: 2*I0*b*(x-x0)/(dx^2)*(1+((x-x0)/dx)^2)^(-b-1) dx for x=x0 =a(5) ; deriv: 2*I0*b*(x-x0)^2/(dx^3)*(1+((x-x0)/dx)^2)^(-b-1) b for x>=x0 =a(6) and if a is of length 7 or 8: k0=a(7) k1=a(8) This function can be used directly with lmfit. SEE ALSO: moffat, moffat_fit, asmoffat_fit nterms=numberof(a); ta=(x=a(2)); //xa=x*ta; //xb=x*tb; u2a=(x-a(2))/a(3); u2b=(x-a(2))/a(5); u4a=u2a^2; u4b=u2b^2; u3a=1+u4a; u3b=1+u4b; u3=u3a*ta+u3b*tb; u1a=u3a^-a(4); u1b=u3b^-a(6); u1=u1a*ta+u1b*tb; res=a(1)*u1; if (nterms>6) res=res+a(7); if (nterms==8) res=res+a(8)*x; if (deriv) { grad=array(double,numberof(x),nterms); grad(,1)=u1; grad(,2)=2*a(1)*(a(4)*u2a/a(3)*u3a^(-a(4)-1)*ta+a(6)*u2b/a(5)*u3b^(-a(6)-1)*tb); grad(,3)=2*a(1)*(a(4)*u4a/a(3)*u3a^(-a(4)-1)*ta); grad(,4)=-a(1)*log(u3)*u1*ta; grad(,5)=2*a(1)*(a(6)*u4b/a(5)*u3b^(-a(6)-1)*tb); grad(,6)=-a(1)*log(u3)*u1*tb; //if (nterms>6) grad(,7)=0; if (nterms==8) grad(,8)=x; } return res; }*/ func moffat1d_fit(y,x,w,guess=,nterms=,itmax=){ /* DOCUMENT asmoffat1d_fit(y,x,w,guess=,nterms=) Fits a moffat (see moffat1d) profile on a data set using lmfit (see lmfit). The set of data points Y is the only mandatory argument, X defaults to indgen(numberof(y)), weights W are optional (see lmfit). MOFFAT1D_FIT tries to guess a set of initial parameters, but you can (and should in every non-trivial case) provide one using the GUESS keyword. In case you don't provide a guess, you should set NTERMS to 4 (simple moffat), 5 (adjust constant baseline) or 6 (adjust linear baseline). The returned fitted parameters have the same format as GUESS, see moffat1d. SEE ALSO: moffat1d, asmoffat1d, asmoffat1d_fit */ require,"lmfit.i"; if (is_void(x)) x=indgen(numberof(y)); if (is_void(guess)) { if (is_void(nterms)) nterms=4; if (nterms<4) nterms=4; if (nterms>6) nterms=6; guess=array(double,nterms); if (nterms==5) { base=median(y); guess(5)=base; } else if (nterms==6) { n=numberof(y); y1=median(y(1:long(n/2))); x1=median(x(1:long(n/2))); y2=median(y(-long(n/2):0)); x2=median(x(-long(n/2):0)); guess(6)=(y2-y1)/(x2-x1); if (guess(6)!=0) guess(5)=y1-guess(6)*x1; base=guess(5)+guess(6)*x; } else base=0.; y2=y-base; ind0=abs(y2)(mxx); guess(2)=x(ind0); guess(1)=y2(ind0); if (y2(ind0)==guess(1)) yy=y2; else yy=-y2; ind1=ind0; ind2=ind0; while (ind1>1 && yy(ind1)>0.5*guess(1)) ind1--; if (yy(ind1)<0.5*guess(1)) ind1++; while (ind20.5*guess(1)) ind2++; if (yy(ind2)<0.5*guess(1)) ind2--; guess(3)=abs(x(ind2)-x(ind1)); guess(4)=1.; } else nterms=numberof(guess); a=guess; result=lmfit(moffat1d,x,a,y,w,deriv=1,itmax=itmax); return a; } func asmoffat1d_fit(y,x,w,guess=,nterms=){ /* DOCUMENT asmoffat1d_fit(y,x,w,guess=,nterms=) Fits an assymetrical moffat (see asmoffat1d) profile on a data set using lmfit (see lmfit). The set of data points Y is the only mandatory argument, X defaults to indgen(numberof(y)), weights W are optional (see lmfit). ASMOFFAT1D_FIT tries to guess a set of initial parameters, but you can (and should in every non-trivial case) provide one using the GUESS keyword. In case you don't provide a guess, you should set NTERMS to 6 (simple assymmetrical moffat), 7 (adjust constant baseline) or 8 (adjust linear baseline). The returned fitted parameters have the same format as GUESS, see asmoffat1d. SEE ALSO: asmoffat1d, moffat1d, moffat1d_fit */ require,"Eric/lmfit.i"; if (is_void(x)) x=indgen(numberof(y)); if (is_void(guess)) { if (is_void(nterms)) nterms=6; if (nterms<6) nterms=6; if (nterms>8) nterms=8; guess=array(double,nterms); if (nterms==7) { base=median(y); guess(7)=base; } else if (nterms==8) { n=numberof(y); y1=median(y(1:long(n/2))); x1=median(x(1:long(n/2))); y2=median(y(-long(n/2):0)); x2=median(x(-long(n/2):0)); guess(8)=(y2-y1)/(x2-x1); if (guess(8)!=0) guess(7)=y1-guess(8)*x1; base=guess(7)+guess(8)*x; } else base=0.; y2=y-base; ind0=abs(y2)(mxx); guess(2)=x(ind0); guess(1)=y2(ind0); if (y2(ind0)==guess(1)) yy=y2; else yy=-y2; ind1=ind0; ind2=ind0; while (ind1>1 && yy(ind1)>0.5*guess(1)) ind1--; if (yy(ind1)<0.5*guess(1)) ind1++; while (ind20.5*guess(1)) ind2++; if (yy(ind2)<0.5*guess(1)) ind2--; guess(3)=abs(x(ind2)-x(ind1)); // guess(3)=2*abs(x(ind0)-x(ind1)); // if (guess(3)==0) guess(3)=1; guess(4)=1.; guess(5)=abs(x(ind2)-x(ind1)); // guess(5)=2*abs(x(ind2)-x(ind0)); // if (guess(5)==0) guess(5)=1; guess(6)=1.; guess; } else nterms=numberof(guess); a=guess; result=lmfit(asmoffat1d,x,a,y,w,deriv=1); return a; } func moffat2d(xy, a, &grad, deriv=) { /* DOCUMENT moffat2d(xy,a) Returns a (2D) Moffat profile: I=I0*(1+(X/dx)^2+(Y/dy)^2)^-b Where: X=(x-x0)*cos(alpha)+(y-y0)*sin(alpha); Y=(y-y0)*cos(alpha)-(x-x0)*sin(alpha); x=xy(..,1); y=xy(..,2); Paramater "a" is a vector with 5 or 7 elements: a = [I0, x0, y0, dx=dy, b] (then alpha=0) or a = [I0, x0, y0, dx, dy, b, alpha]. This function can be used directly with lmfit and provides derivatives. Contrary to the similar functions gauss(), moffat1d() and gauss2d(), moffat2d() does not offer the possibility to add a linear background. See multiprofile.i for compositing several lmfit functions. Limitation: "b" should always be positive. In order to force it, especially in fitting routines, its abolute value is taken (except at some point in the computation of derivates). astro_util1.i contains two variants of this function: moffat and moffatRound. Those two functions do not provide derivatives, take alpha in degrees instead of radians, and allow fitting a allow fitting a cnstant background, and take a slightly different A vector. SEE ALSO: moffat1d, gauss2d, moffat, moffatRound */ a=double(a); npars=numberof(a); I0=a(1); x0=a(2); y0=a(3); dx=a(4); dy=(npars>=6?a(5):dx); b=(npars>=6?a(6):a(5)); alpha=(npars>=7?a(7):0.); small=1e-80; if (abs(dx)=6) grad(..,5)=grad(..,3)*Y; else grad(..,4)+=grad(..,3)*Y; grad(..,-1)=-log(u3)*mof; grad(..,0)=(2.*b*I0*(dx*dy1-dy*dx1))*X*Y*u1b; } return mof; } frigaut-yorick-yutils-c173974/multiprofile.i000066400000000000000000000452651152651572200211720ustar00rootroot00000000000000/* * multiprofile.i * * $Id: multiprofile.i,v 1.1 2008-10-29 15:53:38 paumard Exp $ * * This file is part of Yutils * Copyright (C) 2008 Thibaut Paumard * * 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. * * $Log: multiprofile.i,v $ * Revision 1.1 2008-10-29 15:53:38 paumard * moffat.i, multiprofile.i: initial import * * */ require,"lmfit.i"; local multiprofile; /* DOCUMENT multiprofile.i PURPOSE multiprofile.i is a helper library for use with lmfit. It allows creating complex user functions by adding up already existing, simpler ones. RATIONALE Remember the lmfit calling sequence: result=lmfit(f, x, a, y, w, ...). where F is the model function to fit, X the "independent variables", which can indeed be anything required by F, A is the vector of parameters, and Y the observed values. lmfit finds the optimal values for A, in order to minimize the distance between F(X,A) and Y. In order for lmfit to converge efficiently, it is better if F is able to compute its own gradient when called as f(x, a, grad, deriv=1). Writing model functions that provide derivatives can be tiresome and error-prone. The goal of multiprofile.i is to make this process faster and more reliable, by allowing one to build complex model functions from pre-existing, well-optimized and well-tested primitives with derivatives. Of course, multiprofile.i is limited to a particular sub-set of all the types of functions one might want to use lmfit on: it concentrates on the case where the model function is the sum of simpler profiles, either of the same type (produced by the same primitive function, like 4 Gaussian), or different from each other (e.g. a Gaussian plus a Moffat). To do that, the multiprofile model function mp_func(x, a, grad, deriv=) accepts as first positional argument X a complex object which has to be set-up using the helper function mp_setx. X contains in itself a description of the profile: the primitive functions to use, the number of instances of each type of primitive function, and, naturally, whatever X parameter each primitive function requires to function properly. You then call lmfit with mp_func as its first argument and this complex X as its second argument. EXAMPLE For instance, assume you want to fit an observed Y, which seems to be well described as a sum of 3 Gaussian profiles. The usual process would require you to write a new function (e.g. gaussx3) specifically for this purpose. gaussx3() would have to compute both the sum of 3 Gaussian profiles, and the corresponding gradient. This is how you can do it with multiprofile.i (assuming x and y are already known, and you have found a reasonable first guess a1, a2 and a3 for each of the 3 components). #include "gauss.i" #include "multiprofile.i" MultiX=mp_setx(profile=gauss, realX=x, npar=3, ncomp=3); a=_(a1, a2, a3); result=mpfit(mp_func, MultiX, a, y, deriv=1); Now, assume you want to add a linear baseline to the three Gaussian profiles (note that linear() is provided by multiprofile.i). You have "guessed" as l0 and l1 the two corresponding parameters: linX=mp_setx(profile=linear, realX=x, npar=2); MultiX=mp_setx(profile=gauss, realX=x, npar=3, ncomp=3, more=linX); a=_(a1, a2, a3, [l0, l1]); result=mpfit(mp_func, MultiX, a, y, deriv=1); FUNCTIONS PROVIDED BY MULTIPROFILE.I mp_func: the F parameter to lmfit when using multiprofile.i; mp_setx: helper function to set-up the complex model function; mp_getx: reverse from mp_setx mp_seta: helper function to combine individual first guesses for each component into a first guess for the complex model function (use GET keyword fro the reverse); linear : a*x+b, with lmfit-friendly calling sequence and derivatives; linear2d: a*x+b*y+c, with lmfit-friendly calling sequence and derivatives; poly_lmfit : same as poly() (compute 1D polynomials), with lmfit-friendly calling sequence and derivatives. offsetlines: an lmfit-friendly function for fitting lines on a spectrum. It exemplifies advanced usage of multiprofile. ol_setx: helper function akin to mp_setx, for use with offsetlines. SEE ALSO: lmfit, mp_func, mp_setx, mp_getx, mp_seta, linear, linear2d, poly_lmfit, gauss, gauss2d, moffat1d, moffat2d, offsetlines, ol_setx */ func mp_func(x,a,&grad,&comps,deriv=,returncomps=){ /* DOCUMENT mp_func(x,a,&grad,deriv=) A general purpose routine to easily create multicomponents profiles. The parameter scheme may seem odd, but it is intended to be easily used with lmfit. See "multiprofile" for an introduction. X: this parameter should be set using MP_SETX (which see). It contains both the "real" independent variables and a description of the model, split into several components. A: vector of parameters. MP_SETA can be used to set it up. If base profile needs NPAR parameters, MP_FUNC will transmit A(NPAR*I+1:NPAR*(I+1)) to Ith instance of PROFILE. In case some parameters must be equal for every components, give their index in X (using mp_setx(equal=...)), and simply suppress this parameter from the list of parameters for all components except the first. For instance, if three components of parameters [a1,b1,c1], [a2,b2,c2], and [a3,b3,c3] are to be adjusted with the restriction that b1=b2=b3, A is of the form A=[a1,b1,c1,a2,c2,a3,c3] and equal=[2] in the call to mp_setx. GRAD: upon return, derivatives of output Y relative to each parameter in A, if DERIV is set to non void an non null. Can be used only if base profile function is able to compute derivatives. DERIV: whether or not to compute derivatives. COMPS: multiprofile can return the individual profiles of each component in a 4th positional argument. Set RETURNCOMPS for this to happen. COMPS(,C) is the C-th component. EXAMPLE: require,"gauss.i" require,"multiprofile.i" axis=span(-10,10,101); more=mp_setx(profile=linear,npar=2); x=mp_setx(profile=gauss,npar=3,ncomp=2,realX=axis,more=more); a=[10,-5,2.,7,4,1.5,100,0.5]; y=mp_func(x,a); plg,y,axis; SEE ALSO: lmfit, multiprofile */ mp_getx, x, profile, realX, npar, ncomp, equal, more; y=profile(realX,a(1:npar),gradc,deriv=deriv); if (returncomps) { comps=array(double,numberof(y),ncomp); comps(,1)=y; } if (deriv) { grad=array(y,numberof(a)); grad(..,1:npar)=gradc; } if (is_void(equal)){ for (i=1;i1 && npeq >0) peigne(2:)+=npeq; for (p=1;p<=npars;p++){ if (noneof(equal==p)) { if (!is_void(get)) params(,p)=a(p+peigne); else a(p+peigne)=params(,p); } else { if (!is_void(get)) params(,p)=a(p); else a(p)=params(1,p); if (ncomp >1) peigne(2:)--; } } if (!is_void(more)) { if (!is_void(get)) more=a(1-numberof(more):); a(1-numberof(more):)=more; } return a; } // primitives func linear(x,a,&grad,deriv=) { /* DOCUMENT linear(x,a) or linear(x,a,grad,deriv=1) a(1)+x*a(2) Returns derivatives if DERIV set to a "true" value. Very simplistic, but might come in handy, as it is compatible with lmfit (and multiprofile). SEE ALSO: linear2d, poly_lmfit, lmfit, multiprofile */ if (deriv) grad=[array(1.,dimsof(x)), x]; return a(1)+a(2)*x; } func linear2d(xy,a,&grad,deriv=) { /* DOCUMENT linear2d(xy,a) or linear2d(xy,a,grad,deriv=1) a(1)+x*a(2)+y*a(3) where x=xy(..,1); y=xy(..,2). Returns derivatives if DERIV set to a "true" value. Very simplistic, but might come in handy, as it is compatible with lmfit (and multiprofile). SEE ALSO: linear, lmfit, multiprofile */ if (deriv) grad=_(array(1.,dimsof(xy(..,1)),1), xy); return a(1)+a(2)*xy(..,1)+a(3)*xy(..,2); } func poly_lmfit(x,a,&grad,deriv=) { /* DOCUMENT poly_lmfit(x,a) or poly_lmfit(x,a,grad,deriv=1) Returns the polynomial sum(a(n)*x^(n-1)), with derivatives in GRAD if DERIV set to a "true" value. Very simplistic, but might come in handy, as it is compatible with lmfit (and multiprofile). SEE ALSO: poly, linear, lmfit, multiprofile */ degp1=numberof(a); if (deriv){ grad=array(1.,dimsof(x),degp1); //grad(,1)=0; //useless grad(..,1)=1; if (degp1>=2) grad(..,2)=x; for (n=2;n * * This file is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License version 2 as * published by the Free Software Foundation. * * This file 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. * *----------------------------------------------------------------------------- * * Routines: * color_bar: add a color bar to a plot; * pl3dj: plot disjoint lines in 3D space; * pl3s: plot 3D surface; * pl3t: plot text in 3D space; * pl_box: draw a rectangle; * pl_cbar: add a color bar to a plot; * pl_cbox: draw a centered rectangle; * pl_circle: draw a circle; * pl_ellipse: draw an ellipse; * pl_get_axis: parse axis settings; * pl_get_color: parse color value/name; * pl_get_font: parse font value/name; * pl_get_symbol: parse symbol value/name; * pl_img: plot an image with many options; * pl_map: apply a function to all the elements of an array; * pla: plot several curves at the same time; * plh: plot in an "histogram" style; * plhline: plot horizontal line across viewport; * plp: plot points/error bars; * pls: plot surface as a filled mesh with contours; * plvline: plot vertical line across viewport; * ps2png, ps2jpeg: convert PostScript file into bitmap image; * win2png, win2jpeg: dump graphical window into bitmap image; * win_copy_lim: copy plot limits between graphic windows; * xbtn_plot: plot pseudo-GUI buttons; * xbtn_which: manage pseudo-GUI buttons; * xmouse: extended mouse interface; * xmouse_box: interactively select and draw a rectangular region; * xmouse_demo: simple demonstration of xmouse capabilities; * xmouse_length: interactively measure a distance; * xmouse_line: interactively select and draw a line; * xmouse_point: interactively select and draw point(s); * xwindow: setup viewport and graphic style of graphic windows; * * History: * $Id: plot.i,v 1.3 2010-02-10 13:27:11 paumard Exp $ * $Log: plot.i,v $ * Revision 1.3 2010-02-10 13:27:11 paumard * - Synchronize files with Eric Thiebaut's: fft_utils.i, img.i, plot.i, utils.i. * - Import emulate_yeti.i * - Remove basename() and dirname(), standard in pathfun.i. * - Remove the accents in Erics name to prevent a crash on amd64. * * Revision 1.22 2008/09/04 07:19:30 eric * - Some documentation fixes. * * Revision 1.21 2008/07/12 06:41:25 eric * - Added c-basic-offset for Emacs. * * Revision 1.20 2008/07/11 20:43:17 eric * - New routines: pl_img and pl_cbar. * * Revision 1.19 2007/07/25 17:02:19 eric * - Some changes in pl_get_palette. * * Revision 1.18 2007/07/02 22:16:42 eric * - Added "utils.i" as a required file. * * Revision 1.17 2007/07/02 22:15:18 eric * - New routines: ps2png, ps2jpeg, win2png and win2jpeg. * * Revision 1.16 2007/05/31 07:14:09 eric * - Fixed pl_get_color when argument is already a RGB triplet. * * Revision 1.15 2007/03/19 16:52:48 eric * - Automatically include "style.i" is function `xwindow`. * * Revision 1.14 2007/02/06 12:05:18 eric * Heavy changes in pl_get_color: * a. allow for named colors from the X11 RGB database (more than 600 * color names); * b. always return a color as a char array (either indexed color * or [R,G,B] triplet); this should fix a bug which prevent to * choose the inside color in plp; * c. allow for multiple colors (array of colors); * d. allow for packed RGB colors. * * Revision 1.13 2007/02/01 10:20:16 eric * Quick reference for all routines added in top comment of this file. * * Revision 1.12 2007/02/01 10:09:22 eric * There are a lot of changes this time: * * - 'plp' improved so that it is possible to draw 'transparent' * symbols and to specify a different color for the inside and * outline of the symbols; * * - new routines: 'pl_get_symbol', 'pl_get_color', 'pl_get_font', * 'pl_get_axis' to parse and check values of standard graphic * keywords; * * - new routine: 'xwindow' to manage graphic windows and setup * viewport and graphic style; * * - new routines: 'xbtn_plot', 'xbtn_which' to create and manage * GUI buttons in graphic windows; * * - new interactive routines: 'xmouse', 'xmouse_point', 'xmouse_box', * 'xmouse_line', 'xmouse_length' and 'xmouse_demo'; * * - new plotting routines to draw simple shapes: 'pl_box', 'pl_cbox', * 'pl_circle', 'pl_ellipse'; * * - new utility routine: 'pl_map' to apply a function to all the * elements of an array. * * Revision 1.11 2007/01/16 08:15:01 eric * - Fixed coding style and (some) documentation. * - New functions plhline and plvline. * * Revision 1.2 2008/10/29 15:58:13 paumard * utils.i: reform would not work with empty dimlist. Fixed. * plot.i, util_fr.i, utils.i: rename functions now standard in Yorick (color_bar, rdfile, reform) * * Revision 1.1.1.1 2007/12/11 23:55:14 frigaut * Initial Import - yorick-yutils * * Revision 1.10 2002/05/14 10:03:49 eric * - plp: use directly plfp instead of plmk to plot symbols and ticks. * - plp: draw each symbol inside a unit circle so that they look the * same size. * - plp: new "star" symbol (SYMBOL=8) and draw polygon for SYMBOL>=9. * - plp: new keywords XLO, XHI, YLO, YHI to draw non-symmetrical error * bars and FILL to draw filled symbols. * - plp: removed unused keyword HIDE. * * Revision 1.9 2001/11/15 09:46:19 eric * - Mock check-in to synchronize version numbers because RCS * master file was lost: * - plp: use plmk to plot symbols and ticks. * - plp: change usage of keywords SYMBOL and SIZE. * - plp: remove keyword ASPECT. * * Revision 1.8 2001/06/21 12:45:17 eric * - fix indentation and floating point representation. * * Revision 1.7 1997/04/03 15:52:39 eric * Added routines color_bar and pl_fc. * * Revision 1.6 1996/11/22 11:42:02 eric * - Add keyword ASPECT for plp. * * 02/20/96 Eric THIEBAUT: plp; * 02/20/96 release 1.1. * 02/21/96 Eric THIEBAUT: plh; * 02/21/96 release 1.2. * 02/21/96 Christophe PICHON and Eric THIEBAUT: pla; * 03/04/96 Eric THIEBAUT (from routines written by Christophe PICHON * and David MUNRO): pl3s, pl3dj pl3t; * 03/04/96 release 1.3. * 03/04/96 Eric THIEBAUT: added more symbols in plp; * 24/03/96 Eric THIEBAUT: added "box" keyword in pl3s and fix some bugs; * 24/03/96 release 1.4. * May 3, 1996 by Eric THIEBAUT: added point symbol in routine plp; * *----------------------------------------------------------------------------- */ require, "utils.i"; func pl_fc(z, y, x, ireg, levs=, legend=, hide=, type=, width=, color=, colors=, smooth=, marks=, marker=, mspace=, mphase=, triangle=, region=) { d= dimsof(z); if (d(1) != 2) error, "expecting a 2D array for Z"; nx= d(2); ny= d(3); if (is_void(x)) x= span(1, nx, nx)(,-:1:ny); else if (dimsof(x)(1) == 1) x= x(,-:1:ny); if (is_void(y)) y= span(1, ny, ny)(-:1:nx,); else if (dimsof(y)(1) == 1) y= y(-:1:nx,); if (is_void(levs)) { zmin= min(z); zmax= max(z); if (zmin >= zmax) levs= zmin; else levs= zmin+indgen(9)*0.1*(zmax-zmin); } plfc, z, y, x, ireg, levs=levs, colors=colors, triangle=triangle, region=region; plc, z, y, x, ireg, levs=levs, legend=legend, hide=hide, type=type, width=width, color=color, smooth=smooth, marks=marks, marker=marker, mspace=mspace, mphase=mphase, triangle=triangle, region=region; } /*---------------------------------------------------------------------------*/ func pl_img(img, clear=, cmin=, cmax=, zformat=, keeplimits=, normalize=, pixelbias=, pixelsize=, pixelref=, pixelunits=) /* DOCUMENT pl_img, img; * * Plot image IMG in current graphics window. * * Keyword CLEAR can be used to call fma command (which see): if CLEAR > * 0, fma is called prior to drawing the image; if CLEAR < 0, fma is * called after drawing the image (useful in animate mode); if CLEAR = 0 * or undefined, then fma is not called. * * Keyword ZFORMAT can be used to specify the format for the color bar * labels (see pl_cbar). * * Keywords PIXELSIZE, PIXELBIAS and PIXELREF can be set to specify the * pixel coordinates. The coordinate of the center of j-th pixel is * given by: * * PIXELBIAS + PIXELSIZE*(j - PIXELREF) * * The default settings are PIXELBIAS=1.0, PIXELSCALE=1.0 and * PIXELREF=1.0 (i.e. same coordinates as Yorick's indexing rules). * * Keyword PIXELUNITS can be used to specify the label(s) of the axis. * * PIXELSIZE, PIXELBIAS, PIXELREF and PIXELUNITS can have 1 or 2 elements * to specify same or different settings for the X and Y axis. * * Keywords CMIN and CMAX can be used to specify cut levels for the * display (see pli). If keyword NORMALIZE (see below) is true, CMIN and * CMAX are in units of normalized intensity. * * If keyword NORMALIZE is true, the flux is normalized --- divided by * the pixel area that is: PIXELSIZE(1)*PIXELSIZE(0). * * * SEE ALSO: * pli, fma, animate, pl_cbar, xytitles. */ { dims = dimsof(img); if (is_void(dims) || dims(1) != 2) { error, "expecting a 2-D image"; } width = dims(2); height = dims(3); if (is_void(pixelref)) { pixelref = 1.0; } if (is_void(pixelbias)) { pixelbias = 1.0; } if (is_void(pixelsize)) { pixelsize = 1.0; } if (is_void(normalize)) { scl = 1.0; } else { scl = 1.0/(pixelsize(1)*pixelsize(0)); if (scl != 1.0) { img *= scl; } } if (is_void(cmin)) cmin = min(img); if (is_void(cmax)) cmax = max(img); xsize = pixelsize(1); ysize = pixelsize(0); xbias = pixelbias(1); ybias = pixelbias(0); xref = pixelref(1); yref = pixelref(0); x0 = xbias + xsize*(0.5 - xref); x1 = xbias + xsize*(width + 0.5 - xref); y0 = ybias + ysize*(0.5 - yref); y1 = ybias + ysize*(height + 0.5 - yref); if (clear && clear > 0) { fma; } pli, img, x0, y0, x1, y1, cmin=cmin, cmax=cmax; local red, green, blue; palette, red, green, blue, query=1; ncolors = numberof(red); levs = span(cmin, cmax, ncolors + 1); colors = indgen(ncolors); pl_cbar, cmin=cmin, cmax=cmax, vert=1, nlabs=11, format=zformat; if (! is_void(pixelunits)) { xytitles, pixelunits(1), pixelunits(0); } if (clear && clear < 0) { fma; } } func pl_cbar(z, cmin=, cmax=, vert=, nlabs=, adjust=, color=, font=, height=, opaque=, orient=, width=, ticklen=, thickness=, vport=, format=) /* DOCUMENT pl_cbar, z; * -or- pl_cbar, cmin=CMIN, cmax=CMAX; * * Draw a color bar below the current coordinate system the colors and * the associated label values are from min(Z) to max(Z) -- alternatively * keywords CMIN and CMAX can be specified. With the VERT=1 keyword the * color bar appears to the left of the current coordinate system (vert=0 * is the default). * * Keyword NLABS can be used to choose the number of displayed labels; by * default, NLABS=11 which correspond to a label every 10% of the * dynamic; use NLABS=0 to suppress all labels. The format of the labels * can be specified with keyword FORMAT; by default FORMAT= "%.3g". The * font type, font height and text orientation for the labels can be set * with keywords FONT (default "helvetica"), HEIGHT (default 14 points) * and ORIENT respectively. * * By default the colorbar is drawn next to the current viewport; other * viewport coordinates can be given by VPORT=[xmin,xmax,ymin,ymax]. * Keyword ADJUST can be used to move the bar closer to (adjust<0) or * further from (adjust>0) the viewport. * * Keyword COLOR can be used to specify the color of the labels, the * ticks and the frame of the colorbar. Default is foreground color. * * Keyword WIDTH can be used to set the width of the lines used to draw * the frame and the ticks of the colorbar. * * Keyword TICKLEN can be used to set the lenght (in NDC units) of the * ticks. Default is 0.007 NDC. * * Keyword THICKNESS can be used to set the thickness of the colorbar (in * NDC units). Default is 0.020 NDC. * * * SEE ALSO: pl_img, pli, plt, pldj, plg, viewport. */ { if (is_void(cmin)) cmin = min(z); if (is_void(cmax)) cmax = max(z); if (is_void(vport)) vport = viewport(); if (is_void(adjust)) adjust = 0.0; if (is_void(ticklen)) ticklen = 0.007; if (is_void(thickness)) thickness = 0.020; if (is_void(nlabs)) nlabs = 11; local red, green, blue; palette, red, green, blue, query=1; ncolors = numberof(red); if (ncolors < 2) { ncolors = 240; } levs = span(cmin, cmax, ncolors + 1); cells = char(indgen(0 : ncolors - 1)); linetype = 1; /* "solid" */ if (vert) { x0 = vport(2) + adjust + 0.022; x1 = x0 + thickness; y0 = vport(3); y1 = vport(4); cells = cells(-,); } else { x0 = vport(1); x1 = vport(2); y0 = vport(3) - adjust - 0.045; y1 = y0 - thickness; cells = cells(,-); } sys = plsys(0); pli, cells, x0, y0, x1, y1; if (is_void(width) || width != 0) { plg, [y0,y0,y1,y1], [x0,x1,x1,x0], closed=1, color=color, width=width, type=linetype, marks=0; } if (nlabs) { if (is_void(format)) format= "%.3g"; text = swrite(format=format, span(cmin, cmax, nlabs)); local lx0, lx1, lx2, ly0, ly1, ly2; if (vert) { lx0 = array(x1, nlabs); lx1 = array(x1 + ticklen, nlabs); lx2 = array(x1 + 1.67*ticklen, nlabs); ly0 = span(y0, y1, nlabs); eq_nocopy, ly1, ly0; eq_nocopy, ly2, ly0; justify = "LH"; } else { ly0 = array(y1, nlabs); ly1 = array(y1 - ticklen, nlabs); ly2 = array(y1 - 1.67*ticklen, nlabs); lx0 = span(x0, x1, nlabs); eq_nocopy, lx1, lx0; eq_nocopy, lx2, lx0; justify = "CT"; } if (ticklen && (is_void(width) || width != 0)) { pldj, lx0, ly0, lx1, ly1, color=color, width=width, type=linetype; } for (i = 1; i <= nlabs; ++i) { plt, text(i), lx2(i), ly2(i), tosys=0, color=color, font=font, height=height, opaque=opaque, orient=orient, justify=justify; } } plsys, sys; } func __color_bar(levs, colors, vert=, labs=, adjust=, color=, width=, height=, ticklen=, vport=, format=, font=) /* DOCUMENT color_bar; or color_bar, levs, colors; Note: pl_cbar (which see) is probably a better routine. Draw a color bar below the current coordinate system. If LEVS is not specified uses plfc_levs (set by previous call to plfc). If COLORS is specified, it should have one more value than LEVS, otherwise equally spaced colors are chosen, or plfc_colors if plfc_levs was used. With the VERT=1 keyword the color bar appears to the left of the current coordinate system (vert=0 is default). By default, color_bar will attempt to label some of the color interfaces. With the LABS keyword, you can force the labelling algorithm as follows: LABS=0 supresses all labels, LABS=n forces a label at every n-th interface, LABS=[i,n] forces a label every n-th interface starting at i-th interface (0<=i<=numberof(LEVS)). You can specify the viewport coordinates by keyword VPORT=[xmin,xmax,ymin,ymax]; by default the colorbar is drawn next to the current viewport. You can use the ADJUST keyword to move the bar closer to (adjust<0) or further from (adjust>0) the viewport. You can specify the string format for labels with keyword FORMAT (default "%g"), the font type with keyword FONT (default "helvetica") and the font height with keyword HEIGHT (default 14 points). Keyword COLOR can be used to specify the color of the labels, the ticks and the frame of the colorbar. Default is foreground color. Keyword WIDTH can be used to set the width of the lines used to draw the frame and the ticks of the colorbar. Keyword TICKLEN can be used to set the lenght (in NDC units) of the ticks. Default is 0.005 NDC. SEE ALSO: pl_cbar, plfc. */ { nil = string(0); if (is_void(levs)) { if (is_void(plfc_levs)) error, "no levels specified"; levs = plfc_levs; n = numberof(levs)+1; if (is_void(colors)) colors = plfc_colors; } else { n = numberof(levs) + 1; if (is_void(colors)) colors = bytscl(span(1,n,n),cmin=0.5,cmax=n+0.5); } if (n != numberof(colors)) error, "numberof(colors) must be one more than numberof(levs)"; if (is_void(vport)) vport = viewport(); if (is_void(adjust)) adjust = 0.0; if (is_void(ticklen)) ticklen = 0.005; dx = dy = 0.0; if (vert) { x = (vport(2)+adjust+[0.022,0.042])(-:1:n+1,); dx = ticklen; y = span(vport(3),vport(4),n+1)(,-:1:2); } else { y = (vport(3)-adjust-[0.045,0.065])(-:1:n+1,); dy = -ticklen; x = span(vport(1),vport(2),n+1)(,-:1:2); } sys = plsys(0); plf,[colors],y,x,edges=1,ecolor=color,legend=nil; plsys, sys; if (is_void(labs) || labs(0) > 0) { if (numberof(levs) > 1) { dz = levs(dif); if (numberof(dz) != numberof(levs) - 1 || anyof((dz > 0.0) != (dz(1) > 0.0)) || !dz(1)) error, "levs must be monotone 1D"; levs = levs(1:0); levs = grow([2*levs(1)-levs(2)],levs,[2*levs(0)-levs(-1)]); } else { levs= double(levs(1)); if (!levs) levs= [-1.0,levs,1.0]; else levs= [0.0,levs,2*levs]; } if (numberof(labs)<2) { if (is_void(labs)) labs= (n-1)/4 + 1; orig= where(levs<1.0e-9*max(levs(dif))); if (numberof(orig)==1) labs= [orig(1)%labs,labs]; else labs= [(n%labs)/2,labs]; } list= where(indgen(0:n)%labs(2)==labs(1)); x= x(list,); y= y(list,); if (is_void(format)) format= "%g"; labs= swrite(format=format,levs(list)); plsys, 0; pldj, x(,2),y(,2),x(,2)+dx,y(,2)+dy, legend=nil, color=color, width=width; plsys, sys; if (is_void(font)) font= "helvetica"; plt1, labs,x(,2)+2*dx,y(,2)+2*dy, justify=(vert?"LH":"CT"), height=height, font=font, color=color; } } if (!color_bar) color_bar=__color_bar; /*---------------------------------------------------------------------------*/ func pla(y, x, every=, legend=, hide=, type=, width=, color=, closed=, smooth=, marks=, marker=, mspace=, mphase=, rays=, arrowl=, arroww=, rspace=, rphase=) /* DOCUMENT pla, y, x or pla, y Plot the buddle of curves Y versus X labelled by their last dimension. Y must be 2-dimensional, and X may be 2-dimensional, 1-dimensional or omitted. If X is 2-dimensional, it must have the same dimensions as Y and Y(,i) versus X(,i) is plotted for each last indice i. If X is 1-dimensional, it must have the same length as the 1st dimension of Y and Y(,i) versus X is plotted for each last indice i. If X is omitted, it defaults to [1, 2, ..., numberof(Y(,1))]. The plotting keywords of plg are accepted plus the optional keyword EVERY=N which can be used to plot every N curves in the bundle (default N=1). EXAMPLE x = span(0,1,25)(,-:1:25); pla, x*transpose(x), marks=0, every=3; SEE ALSO plg, plp. */ { if (is_void(every)) { n = 1; } else if (! is_array(every) || dimsof(every)(1) || (n = long(every)) <= 0) { error, "EVERY must be a scalar >= 1"; } if (! is_array(y) || dimsof(y)(1) != 2) { error, "Y must be 2-dimensional"; } imax = dimsof(y)(3); if (is_void(x)) { x2d = 0N; } else { x2d = dimsof(x)(1) >= 2; } for(i = (n+1)/2; i <= imax; i += n) { px = (x2d ? &x(,i) : &x); plg, y(, i), *px, legend=legend, hide=hide, type=type, width=width, color=color, closed=closed, smooth=smooth, marks=marks, marker=marker, mspace=mspace, mphase=mphase, rays=rays, arrowl=arrowl, arroww=arroww, rspace=rspace, rphase=rphase; } } /*---------------------------------------------------------------------------*/ func pls_mesh(&x, &xx, d, which=, inhibit=) /* DOCUMENT err_msg= pls_mesh(x, xx, dimsof(z), which=1/2, inhibit=1/2) build X and/or XX arrays of coordinates (abscissa if last argument is 0/nil; otherwise ordinate) for 2-D array Z. Normally, the returned value is string(0) otherwise it is an error message. X is input and output, it will have the same shape as Z and will be suitable for contour plots. XX is purely output, it will have 1 more element than Z in each dimension and will be suitable for mesh plots. In other words, X(i,j) will furnish the coordinate of the centre of cell Z(i,j) whereas XX(i,j), XX(i,j+1), XX(i+1,j) and XX(i+1,j+1) will give the coordinates of the corners of cell Z(i,j). Assuming the length of Z along the considered dimension is N (N must be >= 2) there are 3 possibilities: (1) if X is a vector with N elements or has the same shape as Z, then X is considered to give the coordinates at the centre of Z cells: X is unchanged and output XX is build by interpolating (and extrapolating at the edges) X ; (2) if X is a vector with N+1 elements or has 1 more element than Z in each dimension, then X is considered to give the coordinates at the corners of Z cells: output XX is set to input X and output X is build by interpolating output XX; (3) if X is nil, it defaults to [0.5, 1.5, ..., N-0.5] and XX defaults to [0, 1, ..., N] along the considered dimension. Finally, if X is 1-D, it is expanded in the other direction. If keyword WHICH is 1 (the default), abscissa is the dimension of interest; otherwise WHICH must be 2 and ordinate is the dimension of interest. If keyword INHIBIT is 1, then only X output is computed; if INHIBIT is 2 then only XX output is computed. SEE ALSO: pls, pl3s, plmesh. */ { xx= []; if (is_void(which)) which= 1; do_x= inhibit != 1; do_xx= inhibit != 2; expand=1; if (d(1) != 2 || anyof(d < 2)) return "Z must be 2-dimensional and have at least 2-by-2 elements"; n1= d(2); n2= d(3); n= d(which+1); if (is_void((dx= dimsof(x)))) { if (do_x) x= span(0.5, n-0.5, n); if (do_xx) xx= span(0, n, n+1); } else if (dx(1) == 1) { if (dx(2) == n) { if (do_xx) { xx= x(pcen); xx(1)= 2.0 * x(1) - x(2); xx(0)= 2.0 * x(0) - x(-1); } } else if (dx(2) == n+1) { xx= x; x= do_x ? xx(zcen) : []; } } else if (dx(1) == 2) { expand= 0; if (allof(dx == d)) { if (do_xx) { t= x(pcen,); t(1,)= 2.0 * x(1,) - x(2,); t(0,)= 2.0 * x(0,) - x(-1,); xx= t(,pcen); xx(,1)= 2.0 * t(,1) - t(,2); xx(,0)= 2.0 * t(,0) - t(,-1); t= []; } } else if (allof(dx == d + [0,1,1])) { xx= x; x= do_x ? xx(zcen,zcen) : []; } } if (is_void(xx) && is_void(x)) { return "X, Y and Z are not compatible"; } if (expand) { if (which == 1) { if (do_x) x= x(,-:1:n2); if (do_xx) xx= xx(,-:1:n2+1); } else { if (do_x) x= x(-:1:n1,); if (do_xx) xx= xx(-:1:n1+1,); } } return string(0); } func pls(z, y, x, cbar=, viewport=, title=, xtitle=, ytitle=, legend=, hide=, top=, cmin=, cmax=, edges=, ecolor=, ewidth=, height=, font=, levs=, nlevs=, type=, width=, color=, marks=, marker=, mspace=, mphase=, smooth=) /* DOCUMENT pls, z, y, x or pls, z draws surface plot of Z versus (X,Y) as a filled mesh with optional contours. The Z array must be a 2-dimensional array, see documentation of pls_mesh for the meaning of X and Y. If keyword CBAR is set to non-zero, a color bar is drawn on the right of the plot. The current viewport (in NDC) may be specified with keyword VIEWPORT, default is: [0.19, 0.60, 0.44, 0.85]. The appearance of the filled mesh can be modified by means of keywords: LEGEND, HIDE, TOP, CMIN, CMAX, EDGES, ECOLOR and EWIDTH (see plf documentation). Optional contour plot of Z may be superimposed by either keyword NLEVS to set the number of contours or by with keyword LEVS to specify the level values. The appearance of the contour plot can be modified by means of keywords: LEGEND, HIDE, TYPE, WIDTH, COLOR, MARKS, MARKER, MSPACE, MPHASE and SMOOTH (see plc documentation). SEE ALSO: pls_mesh, pl3s, plc, plf, plmesh. */ { local r, g, b; // these variables are used to query colors local xx, yy; /* * Set some defaults. */ if (is_void(edges)) edges= 0; if (is_void(height)) { height= 12; small=10; } else { s= [8,10,12,14,18,24]; i= where(height == s); if (numberof(i) != 1) error, "bad font HEIGHT"; i= i(1); small= i > 1 ? s(i-1) : height; } if (numberof(levs)) { nlevs= numberof(levs); } else if (is_void(nlevs)) { nlevs= 8; } /* * Compute mesh coordinates. */ i= nlevs >= 1 ? 0 : 1; if ((msg= pls_mesh(x, xx, dimsof(z), which=1, inhibit=i)) != string(0) || (msg= pls_mesh(y, yy, dimsof(z), which=2, inhibit=i)) != string(0)) error, msg; /* * Plot color bar and titles. */ vpmax= [0.127, 0.672, 0.363, 0.908]; if (numberof(viewport) != 4) viewport= [0.19, 0.60, 0.44, 0.85]; // standard viewport if (cbar) { local r, g, b; plsys, 0; margin= vpmax(2)-viewport(2); x0= viewport(2) + 0.7 * margin; x1= viewport(2) + 0.9 * margin; y0= viewport(3); y1= viewport(4); palette, r, g, b, query=1; n= numberof(r); r= g= b= []; pli, char(indgen(n)-1)(-,), legend=string(0), x0, y0, x1, y1; plg, [y0,y0,y1,y1,y0], [x0,x1,x1,x0,x0], legend=string(0), marks=0, width=1; plsys, 1; } xc= 0.5*(viewport(1)+viewport(2)); yc= 0.5*(viewport(3)+viewport(4)); if (!is_void(title)) { plt, title, xc, viewport(4) + 0.9 * (vpmax(4) - viewport(4)), tosys=0, legend=string(0), justify="CT", path=0, font=font, height=height, opaque=opaque; } if (!is_void(xtitle)) { plt, xtitle, xc, vpmax(3) + 0.05 * (viewport(3) - vpmax(3)), tosys=0, legend=string(0), justify="CB", path=0, font=font, height=small, opaque=opaque; } if (!is_void(ytitle)) { plt, ytitle, vpmax(1) + 0.05 * (viewport(1) - vpmax(1)), yc, tosys=0, legend=string(0), justify="LH", path=1, font=font, height=small, opaque=opaque; } /* * Plot filled mesh. */ plf, z, yy, xx, legend=legend, hide=hide, top=top, cmin=cmin, cmax=cmax, edges=edges, ecolor=ecolor, ewidth=ewidth; xx= yy= []; /* * Plot contours. */ if (nlevs) { if (is_void(levs)) { zmax= double(max(z)); zmin= double(min(z)); levs= zmin + (zmax-zmin) / double(nlevs+1) * indgen(nlevs); } plc, z, y, x, levs=levs, legend=legend, hide=hide, type=type, width=width, color=color, marks=marks, marker=marker, mspace=mspace, mphase=mphase, smooth=smooth; } } /*---------------------------------------------------------------------------*/ func plh(y, x, just=, legend=, hide=, type=, width=, color=, marks=, marker=, mspace=, mphase=) /* DOCUMENT plh, y, x or plh, y plots a graph of Y versus X in an "histogram" style (i.e., with steps). Y and X must be 1-D arrays of equal length; if X is omitted, it defaults to [1, 2, ..., numberof(Y)]. The optional keyword JUST set justification of the histogram: JUST=1, 2 or 3 makes the graph be left justified, centered or right justified respectively along X axis. Default is centered. Other plotting keywords (legend, hide, type, width, color, marks, marker, mspace, and mphase) are passed to the plg routine. SEE ALSO: plg, plm, plc, plv, plf, pli, plt, pldj, plfp limits, logxy, range, fma, hcp */ { // parse/check arguments if (!is_array(y) || dimsof(y)(1)!=1 || (n= numberof(y)) < 2) error, "Y must be a vector of at least 2 elements"; if (is_void(x)) x= double(indgen(numberof(y))); else if (!is_array(x) || dimsof(x)(1)!=1 || numberof(x) != n) error, "X must be a vector of same length as Y"; if (is_void(just)) just= 2; // build new X vector n2= 2 * n; x2= array(double, n2); if (just == 1) { // left justify x2(1::2)= x; x2(2:-1:2)= x(2:); x2(0)= 2 * x(0) - x(-1); } else if (just == 2) { // center d= 0.5 * x(dif); dx= d(1); grow, dx, d, d(0); d= []; x2(1::2)= x - dx(:-1); x2(2::2)= x + dx(2:); dx= []; } else if (just == 3) { // right justify x2(1)= 2 * x(1) - x(2); x2(2::2)= x; x2(3::2)= x(:-1); } else { error, "bad value for JUST"; } // build new Y vector y2= array(double, n2); y2(1::2)= y2(2::2)= y; // plot the graph plg, y2, x2, legend=legend, hide=hide, type=type, width=width, color=color, marks=marks, marker=marker, mspace=mspace, mphase=mphase; } /*---------------------------------------------------------------------------*/ func plhline(y, x0, x1, color=, width=, type=) { lim = limits(); one = array(1.0, dimsof(y)); pldj, one*(is_void(x0) ? lim(1) : x0), y, one*(is_void(x1) ? lim(2) : x1), y, color=color, width=width, type=type; } func plvline(x, y0, y1, color=, width=, type=) { lim = limits(); one = array(1.0, dimsof(x)); pldj, x, one*(is_void(y0) ? lim(3) : y0), x, one*(is_void(y1) ? lim(4) : y1), color=color, width=width, type=type; } /* DOCUMENT plhline, y; -or- plhline, y, x0, x1; -or- plvline, x; -or- plhline, x, y0, y1; Plots an horizontal/vertical line. KEYWORDS color, type, width. SEE ALSO pldj. */ /*---------------------------------------------------------------------------*/ /* PLP - PLOTTING POINTS */ func plp(y, x, dx=, xlo=, xhi=, dy=, ylo=, yhi=, size=, symbol=, ticks=, legend=, type=, width=, color=, fill=) /* DOCUMENT plp, y, x; * -or- plp, y, x, dx=sigma_x, dy=sigma_y; * * Plots points (X,Y) with symbols and/or error bars. X, and Y may have * any dimensionality, but must have the same number of elements. If X * is nil, it defaults to indgen(numberof(Y)). * * Keyword SYMBOL may be used to choose the shape of each symbol (see * pl_get_symbol). * * Keyword SIZE may be used to change the size of the symbols and tick * marks (SIZE acts as a multiplier, default value is 1.0). * * If value of keyword FILL is true (non-nil and non-zero), symbols are * filled with COLOR. The default is to draw open symbols. You can * specify different colors for the outline and the inside of the symbol * by using keyword COLOR = [EDGE_COLOR, FILL_COLOR]. * * Keywords XLO, XHI, YLO, and/or YHI can be used to indicate the bounds * of the optional error bars (default is to draw no error bars). Only * specified bounds get plotted as error bars. If value of keyword TICKS * is true (non-nil and non-zero), ticks get drawn at the endpoints of * the error bars. Alternatively, keywords DX and/or DY can be used to * plot error bars as segments from XLO=X-DX to XHI=X+DX and/or from * YLO=Y-DY to YHI=Y+DY. If keyword DX (respectively DY) is used, any * value of XLO and XHI (respectively YLO and YHI) is ignored. * * The other keywords are the same as for pldj: LEGEND, TYPE, WIDTH, * COLOR (TYPE is only used to draw error bars). * * * EXAMPLES: * plp, y, x, symbol='*', color=["orange","DarkSlateBlue"], fill=1, * size=3, width=5; * * * KEYWORDS: * legend, type, width, color. * * * SEE ALSO: * pl_get_symbol, pl_get_color, * pldj, plg, plm, plc, plv, plf, pli, plt, pldj, plfp, plmk, * limits, logxy, range, fma, hcp. */ { /* NDC units for symbols/ticks (one pixel = 0.00125268 NDC at 75 DPI) */ u0 = 0.0; // zero u1 = 0.0100214; // radius of about 8 pixels at 75 DPI if (! is_void(size)) u1 *= size; /* parse color(s) */ if (is_array(color) && dimsof(color)(0) == 2) { edge_color = pl_get_color(color(..,1)); if (fill) { fill_color = pl_get_color(color(..,2)); } } else { edge_color = pl_get_color(color); if (fill) { fill_color = edge_color; } } /* default X */ if (is_void(x)) (x = array(double, dimsof(y)))(*) = indgen(numberof(y)); /* error bars */ if (is_void(dx)) { err = (! is_void(xlo)) + 2*(! is_void(xhi)); } else { xlo = x - dx; xhi = x + dx; err = 3; } if (err) { pldj, (is_void(xlo) ? x : xlo), y, (is_void(xhi) ? x : xhi), y, type=type, width=width, color=color; if (ticks) { xm = [ u0, u0]; ym = [-u1, u1]; if (err == 1) __plp, y, xlo; else if (err == 2) __plp, y, xhi; else __plp, [y, y], [xlo, xhi]; } xhi = xlo = []; } if (is_void(dy)) { err = (! is_void(ylo)) + 2*(! is_void(yhi)); } else { ylo = y - dy; yhi = y + dy; err = 3; } if (err) { pldj, x, (is_void(ylo) ? y : ylo), x, (is_void(yhi) ? y : yhi), type=type, width=width, color=color; if (ticks) { xm = [-u1, u1]; ym = [ u0, u0]; if (err == 1) __plp, ylo, x; else if (err == 2) __plp, yhi, x; else __plp, [ylo, yhi], [x, x]; } yhi = ylo = []; } /* symbols */ symbol = pl_get_symbol(symbol); if (! symbol) { return; } if (symbol == 1) { /* square */ fillable = 1n; u2 = u1*sqrt(0.5); xm = [-u2, u2, u2,-u2]; ym = [ u2, u2,-u2,-u2]; } else if (symbol == 2) { /* + cross */ fillable = 0n; xm = [-u1, u1, u0, u0, u0, u0]; ym = [ u0, u0, u0, u1,-u1, u0]; fill = 0; } else if (symbol == 3) { /* triangle */ fillable = 1n; u2 = u1*0.5; u3 = u1*sqrt(0.75); xm = [u0, u3,-u3]; ym = [u1,-u2,-u2]; } else if (symbol == 4) { /* hexagon */ fillable = 1n; u2 = u1*0.5; u3 = u1*sqrt(0.75); xm = [ u1, u2,-u2,-u1,-u2, u2]; ym = [ u0, u3, u3, u0,-u3,-u3]; } else if (symbol == 5) { /* diamond */ fillable = 1n; xm = [u1, u0,-u1, u0]; ym = [u0, u1, u0,-u1]; } else if (symbol == 6) { /* x cross (rotated 45 degrees) */ fillable = 0n; u2 = u1*sqrt(0.5); xm = [u2,-u2, u0, u2,-u2, u0]; ym = [u2,-u2, u0,-u2, u2, u0]; fill = 0; } else if (symbol == 7) { /* triangle (upside down) */ fillable = 1n; u2 = u1*0.5; u3 = u1*sqrt(0.75); xm = [ u0, u3,-u3]; ym = [-u1, u2, u2]; } else if (symbol == 8) { /* 5 branch star * C18 = cos(18*ONE_DEGREE) * S18 = sin(18*ONE_DEGREE) * C54 = cos(54*ONE_DEGREE) * S54 = sin(54*ONE_DEGREE) */ fillable = 1n; u2 = 0.224514*u1; // C54*S18/S54 u3 = 0.309017*u1; // S18 u4 = 0.951057*u1; // C18 u5 = 0.363271*u1; // C18*S18/S54 u6 = 0.118034*u1; // S18*S18/S54 u7 = 0.587785*u1; // C54 u8 = 0.809017*u1; // S54 u9 = 0.381966*u1; // S18/S54 xm = [ u0, u2, u4, u5, u7, u0,-u7,-u5,-u4,-u2]; ym = [ u1, u3, u3,-u6,-u8,-u9,-u8,-u6, u3, u3]; } else { /* N-side polygon in unit circle */ fillable = 1n; PI = 3.141592653589793238462643383279503; a = (2.0*PI/symbol)*indgen(0:symbol-1); xm = u1*cos(a); ym = u1*sin(a); } __plp, y, x; } func __plp(y, x) /* DOCUMENT __plp, x, y; Private routine used by plp. */ { extern xm, ym, edge_color, fill_color, fill, legend, width; local z; n = array(1, 1 + numberof(y)); m = numberof(ym); if (m > 2) { if (fill) { z = array(fill_color, numberof(n)); } else if (fillable) { /* Draw inside and ouside edges to emulate 'open' (transparent) symbols. */ m += m; grow, xm, xm(1), xm(0:2:-1); grow, ym, ym(1), ym(0:2:-1); } } n(1) = m; plfp, z, grow(ym,y(*)), grow(xm,x(*)), n, legend=legend, edges=1, ewidth=width, ecolor=edge_color; } /*---------------------------------------------------------------------------*/ /* PARSING OF PLOTTING KEYWORDS */ local PL_BG, PL_FG, PL_BLACK, PL_WHITE, PL_RED, PL_GREEN, PL_BLUE, PL_CYAN; local PL_MAGENTA, PL_YELLOW, PL_GRAYD, PL_GRAYC, PL_GRAYB, PL_GRAYA; local PL_XOR, PL_EXTRA; local _PL_COLOR_NAMES, _PL_COLOR_RGB, _PL_COLOR_PACKED; func pl_get_color(color, flags) /* DOCUMENT pl_get_color(color); * -or- pl_get_color(color, flags); * * The function pl_get_color parses its argument and returns the * corresponding numerical color(s). Input COLOR can be specified by * color name, color index, packed RGB triplet or non-packed [R,G,B] * triplet. In any case, the output is an array of char's and either * indexed color(s) or [R,G,B] triplet(s). * * The default is to accept only a single input color and to return * the corresponding color index or [R,G,B] triplet. Optional argument * FLAGS can be specified to change this default behaviour: * FLAGS = 1 - to force to RGB triplet * FLAGS = 2 - force to indexed color * FLAGS |= 4 - to accept multiple colors (can be OR'ed with one of the * other values) * hence: * 0 - (default) means: only scalar color accepted, result is either * an index or a triplet; * 1 - means: only scalar color accepted, result is always a triplet; * 2 - means: only scalar color accepted, result is always an index; * 4 - means: multiple colors accepted, result is either an index or * a triplet; * 5 - means: multiple colors accepted, result is always a triplet; * 6 - means: multiple colors accepted, result is always an index; * * If COLOR is nil, the returned value is 254 (index for "fg" color). * * The following predefined color names, vales and constants (as Yorick * global variables) are supported: * * NAME INTEGER CONSTANT NAME INTEGER CONSTANT * --------------------------- ------------------------------- * "bg" 255 -1 PL_BG "magenta" 247 -9 PL_MAGENTA * "fg" 254 -2 PL_FG "yellow" 246 -10 PL_YELLOW * "black" 253 -3 PL_BLACK "grayd" 245 -11 PL_GRAYD * "white" 252 -4 PL_WHITE "grayc" 244 -12 PL_GRAYC * "red" 251 -5 PL_RED "grayb" 243 -13 PL_GRAYB * "green" 250 -6 PL_GREEN "graya" 242 -14 PL_GRAYA * "blue" 249 -7 PL_BLUE "xor" 241 -15 PL_XOR * "cyan" 248 -8 PL_CYAN "extra" 240 -16 PL_EXTRA * --------------------------- ------------------------------- * * Color names are case insensitive and a most X11 color names are * available (thanks to a builtin database). For instance * "darkslateblue" and "DarkSlateBlue" are valid color names. * * * SEE ALSO: * color, pl_get_symbol, pl_get_font, pl_get_palette. */ { /* Parse flags (default is to get a single color in a numerical form which is usable as the value of the COLOR keyword in Yorick plotting functions). */ if (is_void(flags)) { mode = 0; /* any */ single = 1n; } else { mode = (flags & 3); single = ! (flags & 4); } /* Parse color value(s). */ /**/extern _PL_COLOR_NAMES, _PL_COLOR_RGB; if (is_void(color)) { return (mode == 1 ? _PL_COLOR_RGB(,2) : char(254)); } if ((s = structof(color)) == string) { dims = dimsof(color); if (single && dims(1)) error, "color name must be a scalar"; ndx = array(long, dims); len = strlen(color); n = numberof(color); for (k = 1; k <= n; ++k) { /* Timing Issues: It is slightly faster to use strfind (no string duplication). Searching the color database, takes ~ 10 microseconds per color on my 2GHz Centrino. */ sel = strfind(color(k), _PL_COLOR_NAMES, case=0); if (is_array((i = where(! sel(1,..)))) && is_array((j = where(sel(2, i) == len(k))))) { ndx(k) = i(j(1)); } else { error, ("unrecognized color name: \"" + color(k) + "\""); } } if (! mode) { return (max(ndx) <= 16 ? char(256 - ndx) : _PL_COLOR_RGB(, ndx)); } else if (mode == 1) { return _PL_COLOR_RGB(, ndx); } else { if (max(ndx) > 16) { error, "named color is not an indexed one"; } return char(256 - ndx); } } if (s == char) { /* can be an indexed color or a triplet */ dims = dimsof(color); n = dims(1); is_rgb = (n >= 1 && dims(2) == 3); if (single && n != is_rgb) { error, "expecting a single color"; } if (is_rgb) { if (mode == 2) { /* FIXME: cannot force triplet to index */ error, "unsupported conversion of [R,G,B] to indexed color"; } } else if (mode == 1) { return pl_get_palette(win)(, 1 + color); } return color; } if (s == long || s == short || s == int) { dims = dimsof(color); if (single && dims(1)) { error, "expecting a single color"; } if ((cmin = min(color)) < 0) { if (cmin < -16) { error, "out of range indexed color"; } color = long(color); /* force copy/conversion */ color(where(color < 0)) += 256; cmin = min(color); } cmax = max(color); if (cmax <= 255) { /* Assume all colors are indexed ones. */ if (mode == 1) { return pl_get_palette(win)(, 1 + color); } return char(color); } if (mode == 2) { /* FIXME: cannot force triplet to index */ error, "unsupported conversion of [R,G,B] to indexed color"; } rgb = array(char, 3, dims); if (cmin >= 256) { /* Assume all colors are packed RGB triplets. */ rgb(1, ..) = (color & 0xff); rgb(2, ..) = ((color >> 8) & 0xff); rgb(3, ..) = ((color >> 16) & 0xff); return rgb; } else { /* There is a mixture of indexed and packed RGB colors. */ lut = pl_get_palette(win); ndx = (color <= 255); if (is_array((i = where(nxd)))) { rgb(, i) = lut(, 1 + color(i)); } if (is_array(( i = where(! nxd)))) { color = color(i); rgb(1, i) = (color & 0xff); rgb(2, i) = ((color >> 8) & 0xff); rgb(3, i) = ((color >> 16) & 0xff); } } return rgb; } error, "bad data type for color"; } /* Color codes as defined in 'play.h': */ PL_BG = 255; PL_FG = 254; PL_BLACK = 253; PL_WHITE = 252; PL_RED = 251; PL_GREEN = 250; PL_BLUE = 249; PL_CYAN = 248; PL_MAGENTA = 247; PL_YELLOW = 246; PL_GRAYD = 245; PL_GRAYC = 244; PL_GRAYB = 243; PL_GRAYA = 242; PL_XOR = 241; PL_EXTRA = 240; local PL_RGB_BG, PL_RGB_FG, PL_RGB_XOR, PL_RGB_EXTRA; local PL_RGB_BLACK, PL_RGB_WHITE, PL_RGB_RED, PL_RGB_GREEN, PL_RGB_BLUE; local PL_RGB_CYAN, PL_RGB_MAGENTA, PL_RGB_YELLOW; local PL_RGB_GRAYD, PL_RGB_GRAYC, PL_RGB_GRAYB, PL_RGB_GRAYA; func pl_get_palette(win) /* DOCUMENT rgb = pl_get_palette(); * -or- rgb = pl_get_palette(win); * * Returns color table for current graphics window or for winddow WIN if * it is specified. The color table is a 3-by-256 array of char's such * that: RGB(1,i), RGB(2,i) and RGB(3,i) are the red, green and blue * levels for color index i respectively. * * Note that some color index cannot be obtained ("bf", "fg", "xor" and * "extra") and are left as black/white in the returned color table. It * is possible to change the predefined colors by setting the global * variables such as PL_RGB_BG with a given [r,g,b] triplet. * * SEE ALSO: palette, pl_get_color. */ { local r, g, b, old_win; if (! is_void(win)) { old_win = current_window(); window, win; } palette, r, g, b, query=1; lut = array(char, 3, 256); if (is_array(r)) { lut(1, 1:numberof(r)) = r; lut(2, 1:numberof(g)) = g; lut(3, 1:numberof(b)) = b; } else { /* Default is a gray colormap with K=240 colors and there are M=256 * levels. The formula is: * * y = (2*M*x + M)/(2*K) * * where integer arithmetic must be used and x = 0, ..., K - 1 is the * 0-based color index and y = 0, ..., M - 1 is the color level. * After simplification (with K=240 and M=256): */ lut( , 1:240) = (indgen(8:3832:16)/15)(-, ); } lut(, 1 + PL_BG) = PL_RGB_BG; lut(, 1 + PL_FG) = PL_RGB_FG; lut(, 1 + PL_BLACK) = PL_RGB_BLACK; lut(, 1 + PL_WHITE) = PL_RGB_WHITE; lut(, 1 + PL_RED) = PL_RGB_RED; lut(, 1 + PL_GREEN) = PL_RGB_GREEN; lut(, 1 + PL_BLUE) = PL_RGB_BLUE; lut(, 1 + PL_CYAN) = PL_RGB_CYAN; lut(, 1 + PL_MAGENTA) = PL_RGB_MAGENTA; lut(, 1 + PL_YELLOW) = PL_RGB_YELLOW; lut(, 1 + PL_GRAYD) = PL_RGB_GRAYD; lut(, 1 + PL_GRAYC) = PL_RGB_GRAYC; lut(, 1 + PL_GRAYB) = PL_RGB_GRAYB; lut(, 1 + PL_GRAYA) = PL_RGB_GRAYA; lut(, 1 + PL_XOR) = PL_RGB_XOR; lut(, 1 + PL_EXTRA) = PL_RGB_EXTRA; if (win != old_win) { window, old_win; } return lut; } PL_RGB_BG = char([214, 214, 214]); PL_RGB_FG = char([ 0, 0, 0]); PL_RGB_BLACK = char([ 0, 0, 0]); PL_RGB_WHITE = char([255, 255, 255]); PL_RGB_RED = char([255, 0, 0]); PL_RGB_GREEN = char([ 0, 255, 0]); PL_RGB_BLUE = char([ 0, 0, 255]); PL_RGB_CYAN = char([ 0, 255, 255]); PL_RGB_MAGENTA = char([255, 0, 255]); PL_RGB_YELLOW = char([255, 255, 0]); PL_RGB_GRAYD = char([100, 100, 100]); PL_RGB_GRAYC = char([150, 150, 150]); PL_RGB_GRAYB = char([190, 190, 190]); PL_RGB_GRAYA = char([214, 214, 214]); PL_RGB_XOR = char([ 0, 0, 0]); PL_RGB_EXTRA = char([ 0, 0, 0]); local PL_COURIER, PL_TIMES, PL_HELVETICA, PL_SYMBOL, PL_NEWCENTURY; local PL_GUI_FONT, PL_BOLD, PL_ITALIC, PL_OPAQUE; local _PL_FONT_TABLE; func pl_get_font(value, default) /* DOCUMENT pl_get_font(value, default); * Parse font VALUE which can have any value recognized by Yorick * for the "font" keyword in builtin plotting functions and return the * corresponding integer value. In addition, if VALUE is void, DEFAULT * is returned. * * SEE ALSO: * font, pl_get_color, , pl_get_symbol, xwindow. */ { extern _PL_FONT_TABLE; if (is_void(value)) return default; if (is_array(value) && ! dimsof(value)(1)) { if ((s = structof(value)) == long) return value; if (s == string) { n = strmatch(value, "B") | 2*strmatch(value, "I"); fn = (n==3 ? strpart(value, 1:-2) : (n ? strpart(value, 1:-1) : value)); if (is_func(h_new)) { if (! is_hash(_PL_FONT_TABLE)) { _PL_FONT_TABLE = h_new("courier",1, "times",2, "helvetica",3, "symbol",4,"schoolbook",5); } index = _PL_FONT_TABLE(fn); if (index) return n + 4*(index - 1); } else { if (fn == "courier") return n; if (fn == "times") return n+4; if (fn == "helvetica") return n+8; if (fn == "symbol") return n+12; if (fn == "schoolbook") return n+16; } error, "bad font name \""+value+"\""; } if (s == char || s == short || s == int) return long(value); } error, "bad font value"; } /* Font codes/flags as defined in 'play.h': */ PL_COURIER = 0; PL_TIMES = 4; PL_HELVETICA = 8; PL_SYMBOL = 12; PL_NEWCENTURY = 16; PL_GUI_FONT = 20; PL_BOLD = 1; PL_ITALIC = 2; PL_OPAQUE = 32; local PL_SQUARE, PL_PLUS, PL_TRIANGLE, PL_UP_TRIANGLE, PL_CIRCLE; local PL_DIAMOND, PL_CROSS, PL_DOWN_TRIANGLE, PL_STAR; local _PL_SYMBOL_TABLE; func pl_get_symbol(symbol) /* DOCUMENT pl_get_symbol(symbol); * * Get symbol value as an integer, SYMBOL must be a scalar and may be either * an integer, a character or a string: * * INT CHAR STRING DESCRIPTION * ---------------------------------------------------------------------- * 0 nothing (just draw error bars if any) * 1 # "square" a square * 2 + "plus" a plus sign * 3 ^ "triangle" "uptriangle" a triangle * 4 o "circle" a circle (actually an hexagon) * 5 @ "diamond" a square rotated by 45 degrees * 6 x "cross" an X-cross <- this is the default * 7 v "downtriangle" an upside down triangle * 8 * "star" a star * >=9 a polygon with SYMBOL sides * ---------------------------------------------------------------------- * * The one-character symbol may given as lower/upper case and as a string * or a char; e.g. 'v', 'V', "v" and "V" all stand for an upside down * triangle. * * For convenience, global variables PL_SQUARE, PL_PLUS, PL_TRIANGLE, * PL_UP_TRIANGLE, PL_CIRCLE; local PL_DIAMOND, PL_CROSS, * PL_DOWN_TRIANGLE and PL_STAR are defined with the corresponding symbol * code. * * SEE ALSO: plp, pl_get_color. */ { if (is_void(symbol)) { return 6; } if (! is_array(symbol) || dimsof(symbol)(1)) { error, "symbol must be a scalar"; } s = structof(symbol); if (s == string || s == char) { if (is_func(h_new)) { /* Use Yeti hash-table to speed-up symbol identification. */ extern _PL_SYMBOL_TABLE; if (! is_hash(_PL_SYMBOL_TABLE)) { _PL_SYMBOL_TABLE = h_new("square",1, "#",1, "plus",2, "+",2, "triangle",3, "uptriangle",3, "^",3, "circle",4, "o",4, "O",4, "diamond",5, "@",5, "cross",6, "x",6, "X",6, "downtriangle",7, "v",7, "V",7, "star",8, "*",8); } if (s == char) { symbol = strchar(symbol); } symbol = _PL_SYMBOL_TABLE(symbol); if (symbol) { return symbol; } } else { /* Use vanilla Yorick. */ local c; if (s == char) { len = 1; eq_nocopy, c, symbol; } else { len = strlen(symbol); c = strchar(symbol)(1); } if (len == 1) { if (c=='#') return 1; if (c=='+') return 2; if (c=='^') return 3; if (c=='o' || c =='O') return 4; if (c=='@') return 5; if (c=='x' || c=='X') return 6; if (c=='v' || c=='V') return 7; if (c=='*') return 8; } else { /* must be a string */ if (c=='s') { if (symbol=="square") return 1; if (symbol == "star") return 8; } else if (c=='p') { if (symbol=="plus") return 2; } else if (c=='t') { if (symbol == "triangle") return 3; } else if (c=='c') { if (symbol == "circle") return 4; if (symbol == "cross") return 6; } else if (c=='d') { if (symbol == "diamond") return 5; if (symbol == "downtriangle") return 7; } else if (c=='u') { if (symbol=="uptriangle") return 3; } } } } else if ((s == long || s == int || s == short) && symbol >= 0) { return long(symbol); } error, "bad symbol value"; } /* Symbol codes as used by 'plp': */ PL_SQUARE = 1; PL_PLUS = 2; PL_TRIANGLE = 3; PL_UP_TRIANGLE = 3; PL_CIRCLE = 4; PL_DIAMOND = 5; PL_CROSS = 6; PL_DOWN_TRIANGLE = 7; PL_STAR = 8; func pl_get_axis_flags(value, default) /* DOCUMENT pl_get_axis_flags(value, default); * Parse axis specification VALUE which can be an integer or a string * where each bits/character toggle an option (see table below). If VALUE * is void, DEFAULT is returned. * * char bit option * ---- ----- ---------------------------------------------------- * t 0x001 Draw ticks on bottom or left edge of viewport * T 0x002 Draw ticks on top or right edge of viewport * c 0x004 Draw ticks centered on origin in middle of viewport * i 0x008 Ticks project inward into viewport * o 0x010 Ticks project outward away from viewport (0x18 for both) * l 0x020 Draw tick label numbers on bottom or left edge of viewport * L 0x040 Draw tick label numbers on top or right edge of viewport * g 0x080 Draw all grid lines down to gridLevel * z 0x100 Draw single grid line at origin * * SEE ALSO: * xwindow. */ { if (is_void(value)) return default; if (is_array(value) && ! dimsof(value)(1)) { if ((s = structof(value)) == long) return value; if (s == string) { flags = 0; if (strmatch(value, "t")) flags|= 0x001; if (strmatch(value, "T")) flags|= 0x002; if (strmatch(value, "c")) flags|= 0x004; if (strmatch(value, "i")) flags|= 0x008; if (strmatch(value, "o")) flags|= 0x010; if (strmatch(value, "l")) flags|= 0x020; if (strmatch(value, "L")) flags|= 0x040; if (strmatch(value, "g")) flags|= 0x080; if (strmatch(value, "z")) flags|= 0x100; return flags; } if (s == char || s == short || s == int) return long(value); } error, "bad axis flag value"; } /* Line types as defined in 'play.h': */ PL_SOLID = 0; PL_DASH = 1; PL_DOT = 2; PL_DASHDOT = 3; PL_DASHDOTDOT = 4; PL_SQUARE = 8; /*---------------------------------------------------------------------------*/ /* * 3D TRANSFORM: * ------------- * Let (X,Y,Z) be the data coordinates (in a direct frame) and * (XP,YP,ZP) be the coordinates in the view frame (also direct, XP is * from left to right, YP is from bottom to top and ZP points toward * the observer), then for an altitude ALT (angle of view above * XY-plane) and an azimuth AZ (angle of view around Z-axis) the * coordinates transform is obtained by a rotation around Oz with * angle AZ (azimuth), followed by a rotation around Ox with angle AX * (AX = ALT - 90deg): * XP = X cos(AZ) - Y sin(AZ) * YP = U cos(AX) - Z sin(AX) = U sin(ALT) + Z cos(ALT) * ZP = U sin(AX) + Z cos(AX) = - U cos(ALT) + Z sin(ALT) * where: * U = X sin(AZ) + Y cos(AZ) */ func _pl3xyz(&xp, &yp, &zp, x, y, z) { /* DOCUMENT _pl3xyz, xp, yp, zp, x, y, z transform data coordinates (X,Y,Z) into viewer coordinates (XP,YP,ZP) for an externally defined altitude ALT and azimuth AZ (in degrees). */ extern alt, az; if (is_void(az)) az= 30.0; // angle of view around z-axis if (is_void(alt)) alt= 45.0; // angle of view above xy-plane d2r= pi / 180.0; xp= x * (c= cos(az * d2r)) - y * (s= sin(az * d2r)); zp= x * s + y * c; yp= z * (c= cos(alt * d2r)) + zp * (s= sin(alt * d2r)); zp= z * s - zp * c; } func _pl3xy(&xp, &yp, x, y, z) { /* DOCUMENT _pl3xy, xp, yp, x, y, z transform data coordinates (X,Y,Z) into viewer coordinates (XP,YP) for an externally defined altitude ALT and azimuth AZ (in degrees). */ extern alt, az; if (is_void(az)) az= 30.0; // angle of view around z-axis if (is_void(alt)) alt= 45.0; // angle of view above xy-plane d2r= pi / 180.0; xp= x * (c= cos(az * d2r)) - y * (s= sin(az * d2r)); yp= z * cos(alt * d2r) + (x * s + y * c) * sin(alt * d2r); } /*---------------------------------------------------------------------------*/ func pl3t(text, x, y, z, alt=, az=, legend=, hide=, color=, font=, height=, opaque=, path=, justify=, tosys=) { /* DOCUMENT pl3t, text, x, y, z, alt=alt, az=az, tosys=0/1 plots TEXT (a string) at the point (X,Y,Z) in a 3-dimensional graph view from altitude ALT (default 45) and azimuth AZ (default 30) both in degrees. TEXT, X, Y and Z may be arrays with the same number of elements. Other optional keywords are: legend, hide, color, font, height, opaque, path, justify and tosys and have the same meaning as in plt. SEE ALSO: plt. */ local xp, yp; _pl3xy, xp, yp, x, y, z; n= numberof(text); if (n == 1) { plt, text, xp, yp, legend=legend, hide=hide, color=color,font=font, height=height, opaque=opaque, path=path, justify=justify, tosys=tosys; } else { for (i=1; i<=n; i++) { plt, text(i), xp(i), yp(i), legend=legend, hide=hide, color=color,font=font, height=height, opaque=opaque, path=path, justify=justify, tosys=tosys; } } } /*---------------------------------------------------------------------------*/ func pl3dj(x0, y0, z0, x1, y1, z1, alt=, az=, legend=, hide=, type=, width=, color=) { /* DOCUMENT pl3dj, x0, y0, z0, x1, y1, z1, alt=alt, az=az plots disjoint lines from (X0,Y0,Z0) to (X1,Y1,Z1) in a 3-dimensional graph view from altitude ALT (default 45) and azimuth AZ (default 30) both in degrees. X0, Y0, Z0, X1, Y1 and Z1 must have the same shapes. Additional keywords are those accepted by pldj: legend, hide, type, width, and color. SEE ALSO: pldj, pl3t, pl3s. */ local x0p, y0p, x1p, y1p; _pl3xy, x0p, y0p, x0, y0, z0; _pl3xy, x1p, y1p, x1, y1, z1; pldj, x0p, y0p, x1p, y1p, legend=legend, hide=hide, type=type, width=width, color=color; } /*---------------------------------------------------------------------------*/ func pl3s(z, y, x, alt=, az=, axis=, box=, acolor=, fill=, legend=, hide=, edges=, ecolor=, ewidth=, height=, font=) /* DOCUMENT pl3s, z, y, x, fill=0/1/2 or pl3s, z, fill=0/1/2 draws 3-D surface plot of Z versus (X,Y). The Z array must be a 2-dimensional array, say NX-by-NY and X and Y must have the same shape as Z or be vectors of length NX and NY respectively. If omitted, X and Y are set to the first and second indice value of Z respectively. The FILL keyword indicates the kind of plot: 0 (default) for 3D wire frames, 1 for 3D mesh filled with intensity, 2 for 3D mesh shaded with light source aligned with observer. The altitude and azimuth angles (in degrees) can be set with keywords ALT and AZ, their default values are 30 and 45 deg. A solid edge can optionally be drawn around each zone by setting the EDGES keyword non-zero. ECOLOR and EWIDTH determine the edge color and width. Frame axis can optionally be drawn around the plot by setting the AXIS keyword non-zero. The color of the axis and label can be modified with keyword ACOLOR. If BOX keyword non-zero, the 3-D box borders are drawn (with the same color as the axis, i.e., ACOLOR). EXAMPLE It is usually better to select an eventually new window and choose the "nobox" style: window, max(0, current_window()), wait=1, style="nobox.gs"; x= span(-3,3,50); y= span(-2,2,40); z= cos(x(,-) * y(-,)); pl3s, z, y, x, axis=1, fill=2, edges=1, font="timesBI", height=10; The following keywords are legal (each has a separate help entry): KEYWORDS: legend, hide, region, edges, ecolor, ewidth, font, height. SEE ALSO: pl3dj, pl3t, plg, plm, plc, plv, plf, pli, plt, pldj, plfp, plmesh, limits, range, fma, hcp, palette, bytscl, ... */ { /* * Check dimensions of input arrays. */ local tmp; if ((msg= pls_mesh(x, tmp, dimsof(z), which=1, inhibit=2)) != string(0) || (msg= pls_mesh(y, tmp, dimsof(z), which=2, inhibit=2)) != string(0)) error, msg; tmp= []; /* * Rescale arrays. */ xspan= (xmax= max(x)) - (xmin= min(x)); yspan= (ymax= max(y)) - (ymin= min(y)); zspan= (zmax= max(z)) - (zmin= min(z)); if (xspan <= 0.0 || yspan <= 0.0) error, "X and/or Y are constant"; if (zspan <= 0.0) { zmin= -1.0; zmax= +1.0; zspan= 2.0; z(*)= 0.0; } else { z= (z - zmin) / zspan; } x= (x - xmin) / xspan; y= (y - ymin) / yspan; /* * Insure that angles are in the range [-180,180]. */ if (is_void(alt)) alt = 45.0; else if ((alt %= 360.0) > 180.0) alt -= 360.0; else if (alt < -180.0) alt += 360.0; if (is_void(az)) az = 30.0; else if ((az %= 360.0) > 180.0) az -= 360.0; else if (az < -180.0) az += 360.0; /* * Plot an invisible box around the plot to left some space * around for the axis labels. */ if (axis) { local bxp, byp; if (is_void(height)) height= 10.0; q= height / 75.0; _pl3xy, bxp, byp, [0, 1, 1, 0, 0, 1, 1, 0] + q * [-1, 1, 1,-1,-1, 1, 1,-1], [0, 0, 1, 1, 0, 0, 1, 1] + q * [-1,-1, 1, 1,-1,-1, 1, 1], [0, 0, 0, 0, 1, 1, 1, 1] + q * [-1,-1,-1,-1, 1, 1, 1, 1]; bxmin= min(bxp); bxmax= max(bxp); bymin= min(byp); bymax= max(byp); pldj, bxmin, bymin, bxmax, bymax, type="none"; pldj, bxmin, bymax, bxmax, bymin, type="none"; } /* * Plot the rear of the 3-D box: must figure out which box faces * are seen, and then which box edges are seen. The plotting order * is (1) rear part of the box, (2) surface mesh and (3) front * part of the box and axis. */ if (box) { local bxp0, byp0, bxp1, byp1; // end-points of box edges local nxp, nyp, nzp; // vectors normal to box faces _pl3xy, bxp0, byp0, [0,1,1,0,0,1,1,0,0,1,1,0], [0,0,1,1,0,0,1,1,0,0,1,1], [0,0,0,0,1,1,1,1,1,1,1,1]; _pl3xy, bxp1, byp1, [1,1,0,0,1,1,0,0,0,1,1,0], [0,1,1,0,0,1,1,0,0,0,1,1], [0,0,0,0,1,1,1,1,0,0,0,0]; _pl3xyz, nxp, nyp, nzp, [ 0, 0, 0, 1, 0,-1], [ 0, 0,-1, 0, 1, 0], [-1, 1, 0, 0, 0, 0]; face_edges=[[1,2,3,4], [5,6,7,8], [1,5,9,10], [2,6,10,11], [3,7,11,12], [4,8,9,12]]; visible = array(0, 12); visible(face_edges(, where(nzp >= 0.0))(*)) = 1; fore= where(visible); back= where(!visible); pldj, bxp0(back), byp0(back), bxp1(back), byp1(back), type=1, color=acolor; } /* * Rotate the surface so as to have the drawing starting at back * end (i.e., hidden surfaces are drawn first). To this end, the * first thing to do is to localize the corner of surface z=0 * which is the farest from the observer. Depending on the * position of the farest corner, X, Y and Z arrays * may have to be scrambled. After what, the 3-D projection * of the surface can be computed. */ local xp, yp, zp; _pl3xyz, xp, yp, zp, [x(0,1), x(1,0), x(0,0), x(1,1)], [y(0,1), y(1,0), y(0,0), y(1,1)], 0; far = zp(mnx)(1); // index of farest point if (far == 1) { x= x(::-1,); y= y(::-1,); z= z(::-1,); } else if (far == 2) { x= x(,::-1); y= y(,::-1); z= z(,::-1); } else if (far == 3) { x= x(::-1,::-1); y= y(::-1,::-1); z= z(::-1,::-1); } _pl3xyz, xp, yp, zp, x, y, z; /* * Plot surface. */ if (!fill) { colors= []; edges= 1; } else if (fill == 1) { colors= bytscl(z, cmin=0.0, cmax=1.0); } else { /* compute the two median vectors for each cell */ m0x= xp(dif,zcen); m0y= yp(dif,zcen); m0z= zp(dif,zcen); m1x= xp(zcen,dif); m1y= yp(zcen,dif); m1z= zp(zcen,dif); /* define the normal vector to be their cross product */ nx= m0y*m1z - m0z*m1y; ny= m0z*m1x - m0x*m1z; nz= m0y*m1x - m0x*m1y; m0x= m0y= m0z= m1x= m1y= m1z= []; colors= bytscl(nz); //colors= bytscl(nz / abs(nx, ny, nz), cmin=0.0, cmax=1.0); nx= ny= nz= []; } plf, colors, yp, xp, legend=legend, hide=hide, edges=edges, ecolor=ecolor, ewidth=ewidth; xp= yp= zp= colors= []; /* * Plot the axis and the front of the box. */ if (axis) { if (far == 1) { px= [ 0, 1, 0]; vx= [ 0, 1, 0]; py= [ 0, 0, 0]; vy= [-1, 0, 0]; pz= [ 1, 1, 0]; vz= [ 1, 0, 0]; } else if (far == 2) { px= [ 0, 0, 0]; vx= [ 0,-1, 0]; py= [ 1, 0, 0]; vy= [ 1, 0, 0]; pz= [ 0, 0, 0]; vz= [-1, 0, 0]; } else if (far == 3) { px= [ 0, 0, 0]; vx= [ 0,-1, 0]; py= [ 0, 0, 0]; vy= [-1, 0, 0]; pz= [ 0, 1, 0]; vz= [ 0, 1, 0]; } else { px= [ 0, 1, 0]; vx= [ 0, 1, 0]; py= [ 1, 0, 0]; vy= [ 1, 0, 0]; pz= [ 1, 0, 0]; vz= [ 0,-1, 0]; } _pl3tick, xmin, xmax, px, [1,0,0], 0.02 * vx, height=height, font=font, color=acolor; _pl3tick, ymin, ymax, py, [0,1,0], 0.02 * vy, height=height, font=font, color=acolor; _pl3tick, zmin, zmax, pz, [0,0,1], 0.02 * vz, height=height, font=font, color=acolor; } if (box) { pldj, bxp0(fore), byp0(fore), bxp1(fore), byp1(fore), type=1, color=acolor; } } /*---------------------------------------------------------------------------*/ func _pl3tick(tmin, tmax, p, d, v, color=, font=, height=, opaque=, path=) /* DOCUMENT _pl3tick, p, d, v draw axis between (P(1),P(2),P(3)) and ((P+D)(1),(P+D)(2),(P+D)(3)) and ticks with vectorial length (V(1),V(2),V(3)). */ { extern alt, az; local px, py, dx, dy, vx, vy; /* * Compute projections, draw axis and figure out which * justification is the best one.. */ _pl3xy, px, py, p(1), p(2), p(3); _pl3xy, dx, dy, d(1), d(2), d(3); _pl3xy, vx, vy, v(1), v(2), v(3); pldj, px, py, px+dx, py+dy, color=color; if (where(d != 0)(1) == 3) { // horizontal ticks for z-axis vx= vx <= 0.0 ? -max(abs(v)) : max(abs(v)); vy= 0.0; } justify= vx > 0.0 ? "L" : (vx ? "R" : "C"); justify += vy > 0.0 ? "B" : (vy ? "T" : "H"); /* * Compute step size in axis direction to get approximatively 6 ticks * and plot ticks. */ tspan= tmax - tmin; tstep= 10.0^floor(log10(0.2 * tspan) + 0.5); if (tspan / tstep < 4) tstep *= 0.5; else if (tspan / tstep > 8) tstep *= 2.0; imin= ceil(tmin / tstep); imax= floor(tmax / tstep); ni= long(imax - imin + 1.0); t= tstep * span(imin, imax, ni); tn= (t - tmin) / tspan; x= px + dx * tn; y= py + dy * tn; pldj, x, y, x+vx, y+vy, legend=string(0), color=color; /* * Write tick labels. */ x += 2 * vx; y += 2 * vy; t= swrite(format="%.3g", t); for (i = 0; i <= ni; i++) { plt, t(i), x(i), y(i), legend=string(0), justify=justify, tosys=1, color=color, font=font, height=height, opaque=opaque; } } /*---------------------------------------------------------------------------*/ /* EXTENDED WINDOW/VIEWPORT/STYLE INTERFACE */ func xwindow(win, width=, height=, dpi=, display=, private=, dump=, hcp=, parent=, xpos=, ypos=, landscape=, viewport=, units=, font=, size=, color=, keep=, xopt=, yopt=, xmargin=, ymargin=) /* DOCUMENT xwindow, win; -or- xwindow; -or- xwindow(...); Create/switch to graphic window WIN. This routine allows one to create a window of given size with viewport(s) different from the default one. Otherwise its behaviour should mimics that of the "window" builtin routine. If called as a function, the return value is an array of 6 double values: [WIN, ONE_PIXEL, XMIN, XMAX, YMIN, YMAX] where WIN is the window number, ONE_PIXEL is the pixel size in NDC units and [XMIN,XMAX,YMIN,YMAX] is the bounding box of the window in NDC units. KEYWORDS DPI, DISPLAY, PRIVATE, DUMP, HCP, PARENT, XPOS, YPOS - Same options as for the window builtin routine. WIDTH, HEIGHT - Window width/height in pixels; default: 450 at 75dpi and 600 at 100dpi. LANDSCAPE - If true, use lanscape orientation; else portrait. VIEWPORT - Viewport coordinates: [XMIN, XMAX, YMIN, YMAX]. Several viewports can be specified at the same time, in this case, first dimension of VIEWPORT must be a 4 and XMIN is VIEWPORT(1,..), XMAX is VIEWPORT(2,..) and so on. UNITS - Units for the viewport keyword: 0 for NDC (default), 1 for relative, and 2 for pixels. FONT - Font to use to label axes (see pl_get_font); default is Helvetica. SIZE - Text size for axis labels in points; default is 12. COLOR - Axis color (see pl_get_color); default is foreground. KEEP - Keep WIN if it already exists? Otherwise the window is forced to be recreated (this is the default behaviour). XOPT - Options for X-axis of viewport (see pl_get_axis_flags). YOPT - Options for Y-axis of viewport (see pl_get_axis_flags). XMARGIN, YMARGIN - Note: If you specify multiple viewports, FONT, SIZE, COLOR, XOPT and YOPT can be arrays to specify different options for each viewport (except that multiple colors cannot be specifed as RGB triplets). SEE ALSO pl_get_axis_flags, pl_get_color, pl_get_font, window. */ { if (! is_array(GfakeSystem)) { include, "style.i", 1; } /* DPI can be set by pldefault but we have no way to know this value -- see graph.c */ if (is_void(dpi)) dpi = 100; else dpi = (dpi < 25 ? 25 : (dpi > 300 ? 300 : long(dpi))); /* Define some constants -- see gist.h */ ONE_POINT = 0.0013000; // one point in NDC units ONE_INCH = 72.27*ONE_POINT; // one inch in NDC units ONE_PIXEL = ONE_INCH/dpi; // one pixel in NDC units /* Figure out window size in pixels (without top text line) -- called "topWidth" and "topHeight" in xfancy.c */ if (is_void(width)) width = 6*dpi; else width = (width <= 31 ? 31 : long(width)); if (is_void(height)) height = 6*dpi; else height = (height <= 31 ? 31 : long(height)); /* Page size (8.5 x 11 inches) in NDC and pixels -- see xfancy.c */ if (is_void(landscape)) landscape = (width > height); if (landscape) { pageWidthNDC = 1.033461; pageHeightNDC = 0.798584; } else { pageWidthNDC = 0.798584; pageHeightNDC = 1.033461; } pageWidth = long(pageWidthNDC/ONE_PIXEL); pageHeight = long(pageHeightNDC/ONE_PIXEL); if (width > pageWidth) width= pageWidth; if (height > pageHeight) height= pageHeight; /* Compute offsets (really tricky to figure out!) and bounding viewport -- see xfancy.c */ xoff = (pageWidth - width)/2; if (landscape) { //yoff = (pageHeight - height)/2; yoff = (pageHeight - height + 3)/2; } else { //yoff = (pageHeight - height) - (pageWidth - height)/2; yoff = pageHeight - (pageWidth + height)/2; } if (xoff < 0) xoff = 0; if (yoff < 0) yoff = 0; vp0_offsets = [ONE_PIXEL*xoff, ONE_PIXEL*xoff, ONE_PIXEL*yoff, ONE_PIXEL*yoff]; vp0_pixel = [width, width, height, height] - 1.0; vp0_ndc = vp0_offsets + ONE_PIXEL*vp0_pixel; /* Fix viewport coordinates and figure out how many viewports to make. */ if (is_void(viewport)) { viewport = [0.15, 0.85, 0.1, 0.8]; units = 1; } else if (is_void(units)) { units = 0; } else if (is_array(units) && ! dimsof(units)(1)) { if ((s = structof(units)) == string) { if (units == "ndc") units = 0; else if (units == "pixel") units = 2; else if (units == "relative") units = 1; else units = -1; } else if (s != long && s != char && s != short && s != int) { units = -1; } } else { units = -1; } if (units) { /* Compute viewport size in pixels, then in NDC. */ if (units == 1) { /* relative units: 0 is min and 1 is max */ viewport *= vp0_pixel; } else if (units != 2) { error, "bad value for keyword UNITS (0 or \"ndc\", 1 or \"relative\", 2 or \"pixel\")"; } viewport = vp0_offsets + ONE_PIXEL*viewport; } if (! is_array(viewport) || (dims = dimsof(viewport))(1) < 1 || dims(2) != 4) error, "bad VIEWPORT array"; nvps = numberof(viewport)/4; /* Parse other parameters. */ if (is_void(xmargin)) xmargin = 2.0; if (is_void(ymargin)) ymargin = 2.0; if (is_void(size)) size = 12; font = pl_map(pl_get_font, font, 8); color = pl_map(pl_get_color, color, 254 /* fg */); xopt = pl_map(pl_get_axis_flags, xopt, 0x33); yopt = pl_map(pl_get_axis_flags, yopt, 0x33); if (nvps>1) { /* Multiple viewports: fix per-viewport settings. */ dims = dims(2:); dims(1)= numberof(dims)-1; zero = array(long, dims); if (is_void(dimsof(xopt, zero))) error, "bad XOPT dimensions"; xopt += zero; if (is_void(dimsof(yopt, zero))) error, "bad YOPT dimensions"; yopt += zero; if (is_void(dimsof(size, zero))) error, "bad SIZE dimensions"; size += zero; if (is_void(dimsof(font, zero))) error, "bad FONT dimensions"; font += zero; if (is_void(dimsof(color, zero))) error, "bad COLOR dimensions"; color += zero; } if (numberof(xopt) != nvps) error, "bad XOPT dimensions"; if (numberof(yopt) != nvps) error, "bad YOPT dimensions"; if (numberof(size) != nvps) error, "bad SIZE dimensions"; if (numberof(font) != nvps) error, "bad FONT dimensions"; if (numberof(color) != nvps) error, "bad COLOR dimensions"; /* Build up systems. */ nHDigits = 5; nVDigits = 6; tickLen = ONE_PIXEL*[5.0, 3.0, 1.0, 0.0, 0.0]; system = array(GfakeSystem, nvps); viewport = viewport(,*); // concatenate extra dims for (i=1 ; i<=nvps ; ++i) { fontHeight = size(i)*ONE_POINT; xFlags = xopt(i); yFlags = yopt(i); tickStyle = GpLineAttribs(color=color(i), type=1, width=1); frameStyle = GpLineAttribs(color=color(i), type=1, width=1); gridStyle = GpLineAttribs(color=color(i), type=3, width=1); textStyle = GpTextAttribs(color=color(i), font=font(i), height=fontHeight, alignH=0, alignV=0, opaque=0); xLabelOff = (xFlags&0x08 ? max(tickLen) : 0) + fontHeight/1.5; yLabelOff = (yFlags&0x08 ? max(tickLen) : 0) + 0.75*fontHeight; xTickOff = (xmargin ? xmargin*ONE_PIXEL + ((xFlags&0x08) ? max(tickLen) : 0.0) : 0.0); yTickOff = (ymargin ? ymargin*ONE_PIXEL + ((yFlags&0x08) ? max(tickLen) : 0.0) : 0.0); xTickLen = ((xFlags&0x018)==0x018 ? 2.0*tickLen : tickLen); yTickLen = ((yFlags&0x018)==0x018 ? 2.0*tickLen : tickLen); horiz = GaAxisStyle(nMajor=7.5, nMinor=50, logAdjMajor=1.2, logAdjMinor=1.2, nDigits=nHDigits, gridLevel=1, flags=xFlags, tickOff=xTickOff, labelOff=xLabelOff, tickLen=xTickLen, tickStyle=tickStyle, gridStyle=gridStyle, textStyle=textStyle, xOver=viewport(2,i), yOver=viewport(3,i)-fontHeight); vert = GaAxisStyle(nMajor=7.5, nMinor=50, logAdjMajor=1.2, logAdjMinor=1.2, nDigits=nVDigits, gridLevel=1, flags=yFlags, tickOff=yTickOff, labelOff=yLabelOff, tickLen=yTickLen, tickStyle=tickStyle, gridStyle=gridStyle, textStyle=textStyle, xOver=viewport(1,i), yOver=viewport(4,i)+fontHeight); system(i) = GfakeSystem(viewport=viewport(,i), ticks=GaTickStyle(horiz=horiz, vert=vert, frame=1, frameStyle=frameStyle), legend=swrite(format="System %d", i)); } /* layout of the plot legends */ legends = GeLegendBox(); /* layout of the contour legends */ clegends = GeLegendBox(); /* create window and apply plot-style settings */ if (! keep) { wn = (is_void(win) ? current_window() : win); if (wn >= 0) window, wn, display="", hcp=""; } window, win, wait=1, width=width, height=height, display=display, private=private, dump=dump, hcp=hcp, dpi=dpi, parent=parent, xpos=xpos, ypos=ypos; set_style, landscape, system, legends, clegends; fma; #if 0 for (i=1;i<=nvps;++i) pl_box, viewport(1,i), viewport(3,i), viewport(2,i), viewport(4,i), color="red", system=0; #endif if (! am_subroutine()) { result = array(double, 6); result(1) = win; result(2) = ONE_PIXEL; result(3:6) = vp0_ndc; return result; } } /*---------------------------------------------------------------------------*/ /* SIMPLE BUTTON WIDGETS (based on button.i) */ struct XButton { double x, y; /* NDC coordinates of button center */ double dx, dy; /* button half widths in NDC */ string text; /* button text */ string font; /* text font (0 for helvetica) */ string color; /* text and border color (0 for fg) */ double height; /* text height */ double width; /* width of line around button (0 is 1.0, <0 no box) */ } func xbtn_plot(..) /* DOCUMENT xbtn_plot, button1, button2, ... plot the specified BUTTONs. Each button in the list may be an array of XButton structure. Void arguments are no-ops. SEE ALSO: XButton, xbtn_which. */ { while (more_args()) { btns = next_arg(); nbtns = numberof(btns); for (i=1 ; i<=nbtns ; ++i) { btn = btns(i); if (!(font= btn.font)) font= "helvetica"; if (!(color= btn.color)) color= "fg"; if ((h = btn.height)<=0.0) h= 14.0; x = btn.x; y = btn.y; plt, btn.text, x, y, justify="CH", font=font, height=h, color=color, opaque=1; dx = btn.dx; dy = btn.dy; if (!(w = btn.width)) w= 1.0; if (w>0.0) { oldSys = plsys(0); plg, [y-dy,y-dy,y+dy,y+dy],[x-dx,x+dx,x+dx,x-dx], closed=1, width=w, type=1, marks=0, color=color; plsys, oldSys; } } } } func xbtn_which(button, x, y) /* DOCUMENT xbtn_which(button, x, y) Return index of element in button array BUTTON that contains NDC coordinates (X,Y). Return -1 if coordinates do not match any buttons and -N if coordinates match N>1 buttons. SEE ALSO: XButton, xbtn_plot. */ { i = where((abs(y-button.y) < button.dy) & (abs(x-button.x) < button.dx)); if ((n = numberof(i)) == 1) return i(1); if (n == 0) return -1; return -n; } /*---------------------------------------------------------------------------*/ /* EXTENDED MOUSE ROUTINES */ func xmouse_point(nil,win=,prompt=,system=,forever=) /* DOCUMENT xmouse_point() -or- xmouse_point Interactively define a point as with xmouse("point"). The same keywords as xmouse (which see) can be specified. SEE ALSO: xmouse. */ { m = __xmouse(0, "click mouse to choose a position"); if (am_subroutine()) { if (is_void(m)) write, "aborted"; else write, format="position is (%g,%g)\n", m(1), m(2); } else if (is_array(m)) return m(1:2); } func xmouse_box(nil,win=,prompt=,system=,forever=) /* DOCUMENT xmouse_box() -or- xmouse_box Interactively define a rectangular box as with xmouse("box"). The same keywords as xmouse (which see) can be specified. SEE ALSO: xmouse. */ { m = __xmouse(1, "click and drag mouse to select a region"); if (am_subroutine()) { if (is_void(m)) write, "aborted"; else write, format="region is [%g : %g]x[%g : %g]\n", min(m(1), m(3)), max(m(1), m(3)), min(m(2), m(4)), max(m(2), m(4)); } else if (is_array(m)) return [min(m(1), m(3)), max(m(1), m(3)), min(m(2), m(4)), max(m(2), m(4))]; } func xmouse_line(nil,win=,prompt=,system=,forever=) /* DOCUMENT xmouse_line() -or- xmouse_line Interactively define a line as with xmouse("line"). The same keywords as xmouse (which see) can be specified. SEE ALSO: xmouse. */ { m = __xmouse(2, "click and drag mouse to choose a line"); if (am_subroutine()) { if (is_void(m)) { write, "aborted"; } else { x0 = m(1); y0 = m(2); x1 = m(3); y1 = m(4); dx = x1 - x0; dy = y1 - y0; write, format="line end-points are (%g,%g) and (%g,%g), lenght = %g, angle=%g deg\n", x0, y0, x1, y1, abs(dx, dy), atan(dy, dx)*(180/pi); } } else if (is_array(m)) { return m(1:4); } } func xmouse_length(nil,win=,prompt=,system=,forever=) /* DOCUMENT xmouse_length() -or- xmouse_length Interactively measure a length as with xmouse("length"). The same keywords as xmouse (which see) can be specified. SEE ALSO: xmouse. */ { m = __xmouse(2, "click and drag mouse to measure a distance"); if (am_subroutine()) { if (is_void(m)) write, "aborted"; else write, format="distance from (%g,%g) to (%g,%g) = %g\n", m(1), m(2), m(3), m(4), abs(m(1) - m(3), m(2) - m(4)); } else if (is_array(m)) return abs(m(1) - m(3), m(2) - m(4)); } func xmouse(type,win=,prompt=,system=,forever=) /* DOCUMENT xmouse(); * -or- xmouse(type); * -or- xmouse; * -or- xmouse, type; * Asks the user to click into a graphic window to indicate a position * (the default if TYPE is not specified), or to define a segment or a * rectangular box, or to measure a distance. The possible values for * TYPE are: * * TYPE RESULT * --------- ---------------- * 0 "point" [X,Y] * 1 "box" [XMIN, XMAX, YMIN, YMAX] * 2 "line" [X0, Y0, X1, Y1] * 3 "length" LENGHT * * When called as a function, the coordinates of the result get returned; * when called as a subroutine, the position is printed out. If the user * cancel the operation (see mouse function) or click into another window * than the target one, no position is selected (nil get returned). This * behaviour can be changed by setting keyword FOREVER to true in which * case the function loop until a valid selection is done. * * Keyword WIN can be used to specify the target graphic window which is * by default the curent graphic window. * * Keyword PROMPT can be used to specify a prompt string different from * the default one. * * Keyword SYSTEM can be used to specify the coordinate system to use, * the default being to use the coordinate system that is under the * mouse. The returned coordinates/lenght are in units of that * coordinate system. * * * SEE ALSO: * mouse, xmouse_demo, xmouse_point, xmouse_box, xmouse_line, * xmouse_length. */ { if (is_void(type)) { op = xmouse_point; } else if (is_array(type) && ! dimsof(type)(1)) { if ((s = structof(type)) == string) { op = symbol_def("xmouse_"+type); if (is_func(op) != 1) error, "unrecognized type name: \""+type+"\""; } else if (s == long || s == int || s == char || s == short) { /**/ if (type == 0) op = xmouse_point; else if (type == 1) op = xmouse_box; else if (type == 2) op = xmouse_line; else if (type == 3) op = xmouse_length; else error, "bad mouse selection type"; } else { error, "bad mouse selection type must be a scalar integer of string"; } } else { error, "bad mouse selection type"; } if (am_subroutine()) op, win=win, system=system, prompt=prompt, forever=forever; else return op(win=win, system=system, prompt=prompt, forever=forever); } func __xmouse(style, default_prompt) /* DOCUMENT __xmouse() Private function used by xmouse and xmouse_[...] routines. SEE ALSO: xmouse. */ { extern win, prompt, system, forever; oldwin = current_window(); if (! is_void(win)) window, win; if (is_void(system)) system = -1; if (is_void(prompt)) prompt = default_prompt; for (;;) { m = mouse(system, style, prompt); if (is_array(m) && m(10)) break; /* m(10) is the depressed button */ if (! forever) { m = []; break; } } if (oldwin >= 0) window, oldwin; return m; } func xmouse_demo /* DOCUMENT xmouse_demo * Run a simple demonstration of the 'xmouse' functions. * * SEE ALSO:xmouse_point, xmouse_line, xmouse_box, xmouse_length. */ { t=xmouse_point(); plp,t(2),t(1),symbol=PL_STAR,color=PL_BLUE,width=5,fill=0; t=xmouse_line(); pldj,t(1),t(2),t(3),t(4),color=PL_GREEN; t=xmouse_box(); pl_box,t,color=PL_GREEN; xmouse_length; } /*---------------------------------------------------------------------------*/ /* PLOTTING OF SIMPLE SHAPES */ func pl_box(xmin,xmax,ymin,ymax,color=,width=,type=) /* DOCUMENT pl_box, xmin, xmax, ymin, ymax; -or- pl_box, [xmin, xmax, ymin, ymax]; Plots a rectangular box onto the current graphic device. As for plg (which see), keywords COLOR, WIDTH and TYPE can be specified. SEE ALSO: plg, pl_get_color, pl_cbox, pl_circle, pl_ellipse. */ { if (is_void(xmax) && numberof(xmin)==4) { ymax = xmin(4); ymin = xmin(3); xmax = xmin(2); xmin = xmin(1); } plg, [ymin,ymin,ymax,ymax], [xmin,xmax,xmax,xmin], closed=1, color=pl_get_color(color), width=width, type=type; } func pl_cbox(x0, y0, xsize, ysize, color=, width=, type=, legend=) /* DOCUMENT pl_cbox, x0, y0, size; -or- pl_cbox, x0, y0, xsize, ysize; Draw a SIZE by SIZE square box or a XSIZE by YSIZE rectangular box centered around (X0,Y0). Keywords COLOR, WIDTH and TYPE can be used and have the same meaning as for builtin routine "plg". If keyword LEGEND is not set, an empty legend will be used. SEE ALSO plg, pl_box, pl_circle, pl_ellipse. */ { if (is_void(ysize)) ysize= xsize; if (is_void(legend)) legend=string(0); plg, x0 + xsize * [-0.5, -0.5, +0.5, +0.5], y0 + ysize * [-0.5, +0.5, +0.5, -0.5], color=color, width=width, type=type, marks=0, closed=1, legend=legend; } func pl_circle(x0, y0, r, color=, width=, number=, type=, legend=) /* DOCUMENT pl_circle, x0, y0, r; Draw circle(s) of radius R around (X0,Y0). Value of keyword NUMBER tells how many segments to use to approximate the circle (default 20). Keywords COLOR, WIDTH and TYPE can be used and have the same meaning as for "plg" routine (which see). If keyword LEGEND is not set, an empty legend will be used. Arguments may be conformable arrays to draw several circles in one call (but keywords must have scalar values if any). SEE ALSO plg, pl_box, pl_cbox, pl_ellipse. */ { if (is_void(legend)) legend = string(); if (is_void(number)) number = 20; PI = 3.14159265358979323848; t = (2.0*PI/number)*indgen(number); cos_t = cos(t); sin_t = sin(t); if (is_void((dims = dimsof(x0, y0, r)))) error, "non conformable arguments"; if (dims(1)) { /* Draw several circles. */ dummy = array(double, dims); x0 += dummy; y0 += dummy; r += dummy; n = numberof(dummy); for (i=1 ; i<=n ; ++i) { plg, y0(i) + r(i)*cos_t, x0(i) + r(i)*sin_t, width=width, color=color, type=type, marks=0, closed=1, legend=legend; } } else { /* Draw a single circle. */ plg, y0 + r*cos_t, x0 + r*sin_t, width=width, color=color, type=type, marks=0, closed=1, legend=legend; } } func pl_ellipse(x0, y0, a, b, theta, color=, width=, number=, type=, legend=) /* DOCUMENT pl_ellipse, x0, y0, a, b, theta; Draw ellipse(s) centered at (X0,Y0) with semi-axis A and B. THETA is the angle (in degrees counterclockwise) of the axis of semi-length A with horizontal axis. Value of keyword NUMBER tells how many segments to use to approximate the circle (default 20). Keywords COLOR, WIDTH and TYPE can be used and have the same meaning as for "plg" routine (which see). If keyword LEGEND is not set, an empty legend will be used. Arguments may be conformable arrays to draw several ellipses in one call (but keywords must have scalar values if any). SEE ALSO plg, pl_box, pl_cbox, pl_circle. */ { if (is_void(legend)) legend = string(); if (is_void(number)) number = 20; PI = 3.14159265358979323848; t = (2.0*PI/number)*indgen(number); cos_t = cos(t); sin_t = sin(t); if (is_void((dims = dimsof(x0, y0, a, b, theta)))) error, "non conformable arguments"; if (dims(1)) { /* Draw several ellipses. */ dummy = array(double, dims); x0 += dummy; y0 += dummy; a += dummy; b += dummy; theta = (PI/180.0)*theta + dummy; n = numberof(dummy); for (i=1 ; i<=n ; ++i) { u = a(i)*cos_t; v = b(i)*sin_t; t = theta(i); cs = cos(t); sn = sin(t); plg, y0(i) + u*sn + v*cs, x0(i) + u*cs - v*sn, width=width, color=color, type=type, marks=0, closed=1, legend=legend; } } else { /* Draw a single ellipse. */ theta *= (PI/180.0); u = a*cos_t; v = b*sin_t; cs = cos(theta); sn = sin(theta); plg, y0 + u*sn + v*cs, x0 + u*cs - v*sn, width=width, color=color, type=type, marks=0, closed=1, legend=legend; } } /*---------------------------------------------------------------------------*/ /* CONVERT POSTSCRIPT FILE INTO BITMAP IMAGE */ local ps2png, ps2jpeg, _ps2any_worker; /* DOCUMENT ps2png, inp; * -or- ps2png, inp, out; * -or- ps2png(inp); * -or- ps2png(inp, out); * -or- ps2jpeg, inp; * -or- ps2jpeg, inp, out; * -or- ps2jpeg(inp); * -or- ps2jpeg(inp, out); * * * Convert PostScript or PDF file INP into a PNG or JPEG image. If * the name of the output file OUT is not specified, it get * automatically derived from INP by replacing extension ".eps", * ".ps" or ".pdf" by ".png" or ".jpg" (if INP do not have any of * the extensions ".eps", ".ps" nor ".pdf", the ".png" or ".jpg" * extension is simply appended). * * When called as a subroutine, the conversion script is executed * (by the system built-in function); when called as a function, the * command is returned but not executed. * * The conversion is handled by GhostScript and by various commands * from the netpbm package. The gs command and the netpbm commands * must be found in the shell PATH. * * The following keywords are supported: * * GRAY = flag: convert to grayscale (default is color)? * * DPI = resolution in pixel per inch (default 300). * * BORDER = border in pixels (default 3). * * ALPHABITS = number of antialiasing bits for both text and * graphics: 0 (for none), 1, 2 or 4 (default is 0). * * TEXTALPHABITS = same as ALPHABITS but for text only (default * is ALPHABITS). * * GRAPHICSALPHABITS = same as ALPHABITS but for graphics only * (default is ALPHABITS). * * SMOOTH = flag: smooth image (default is false)? * * DEVICE = GhostScript output device to use (default is "ppmraw"); * it is probably better to not change this option. * * The following keywords are only for conversion to PNG images: * * TRANSPARENT = name of transparent color COLOR (default none); * * * The following keywords are only for conversion to JPEG images: * * QUALITY = quality (in percent) for JPEG image (default 85%). * * * SEE ALSO: system. */ func ps2png(inp, out, gray=, smooth=, dpi=, border=, device=, alphabits=, graphicsalphabits=, textalphabits=, transparent=) { local status; command = _ps2any_worker(inp, out, 0); if (status) { error, command; } if (am_subroutine()) { system, command; } else { return command; } } func ps2jpeg(inp, out, gray=, smooth=, dpi=, border=, device=, alphabits=, graphicsalphabits=, textalphabits=, quality=) { local status; command = _ps2any_worker(inp, out, 1); if (status) { error, command; } if (am_subroutine()) { system, command; } else { return command; } } func _ps2any_worker(inp, out, jpg) { /* Status and all options as external variables. */ extern status; extern alphabits, graphicsalphabits, textalphabits, quality; extern gray, smooth, dpi, border, device, transparent; status = -1; /* assume we have an error */ /* Parse common options. */ if (is_void(gray)) { gray = 0n; } else if (is_scalar(gray)) { gray = !(!gray); } else { return "bad value for GRAY keyword"; } if (is_void(smooth)) { smooth = 0n; } else if (is_scalar(smooth)) { smooth = !(!smooth); } else { return "bad value for SMOOTH keyword"; } if (is_void(dpi)) { dpi = 300.0; } else if (! is_scalar(dpi) || ! (is_integer(dpi) || is_real(dpi)) || dpi <= 0.0) { return "bad value for DPI keyword"; } else { dpi = double(dpi); } if (is_void(border)) { border = 3.0; } else if (! is_scalar(border) || ! (is_integer(border) || is_real(border)) || border < 0.0) { return "bad value for BORDER keyword"; } else { border = double(border); } if (is_void(device)) { device = "ppmraw"; } else if (! is_scalar(device) || ! is_string(device)) { return "bad value for DEVICE keyword"; } if (is_scalar(alphabits) && is_integer(alphabits) && 0 <= alphabits && alphabits <= 4) { alphabits = long(alphabits); } else if (is_void(alphabits)) { alphabits = 0; } else { return "bad value for keyword ALPHABITS"; } if (is_scalar(textalphabits) && is_integer(textalphabits) && 0 <= textalphabits && textalphabits <= 4) { textalphabits = long(textalphabits); } else if (is_void(textalphabits)) { textalphabits = alphabits; } else { return "bad value for keyword TEXTALPHABITS"; } if (is_scalar(graphicsalphabits) && is_integer(graphicsalphabits) && 0 <= graphicsalphabits && graphicsalphabits <= 4) { graphicsalphabits = long(graphicsalphabits); } else if (is_void(graphicsalphabits)) { graphicsalphabits = alphabits; } else { return "bad value for keyword GRAPHICSALPHABITS"; } /* Buil up the code. */ command = swrite(format="gs -dSAFER -dNOPAUSE -dBATCH -q -sDEVICE=%s -r%.0f", device, dpi); if (graphicsalphabits > 0) { command += swrite(format=" -dGraphicsAlphaBits=%d", graphicsalphabits); } if (textalphabits > 0) { command += swrite(format=" -dTextAlphaBits=%d", textalphabits); } command += swrite(format=" -sOutputFile=- \'%s\'", inp); if (smooth) { command += " | pnmalias"; } command += " | pnmcrop"; if (border > 0) { command += swrite(format=" | pnmpad -white -left %.0f -right %.0f -top %.0f -bottom %.0f", border, border, border, border); } if (is_void(out)) { out = strip_file_extension(inp, ".ps", ".eps") + (jpg ? ".jpg" : ".png"); } if (jpg) { /* Convert to JPEG file. */ if (is_void(quality)) { quality = 85.0; } else if (! is_scalar(quality) || ! (is_integer(quality) || is_real(quality)) || quality < 0.0 || quality > 100.0) { return "bad value for QUALITY keyword"; } else { quality = double(quality); } command += swrite(format=" | pnmtojpeg > '%s' --optimize --quality=%.0f", out, quality); } else { /* Convert to PNG file. */ command += swrite(format=" | pnmtopng > '%s' -compression 9", out); if (is_scalar(transparent) && is_string(transparent)) { command += swrite(format=" -transparent '%s'", transparent); } else if (! is_void(transparent)) { return "bad value for TRANSPARENT keyword"; } } /* Clear error status and return code. */ status = 0; return command; } /*---------------------------------------------------------------------------*/ /* DUMP GRAPHICAL WINDOW AS BITMAP IMAGE */ local win2png, win2jpeg, _win2any_worker; /* DOCUMENT win2png, filename; * -or- win2png, format, value; * -or- win2jpeg, filename; * -or- win2jpeg, format, value; * * Dump contents of current graphical window into a PNG or JPEG * image. FILENAME is the name of the output file. If can also be * specified by the two arguments FORMAT and VALUE, in which case * FILENAME is computed by: * * FILENAME = swrite(format=FORMAT, VALUE); * * for instance: * * win2png, "img-%04d.png", 3; * * to save image into file "img-0003.png". * * Keyword WIN can be set to specify another graphical window * than the current one. * * Keyword TEMPS can be set to specify the name of the temporary * PostScript file. * * If keyword DEBUG is true, the conversion script get printed out * and the temporary PostScript file is not deleted (you can guess * its name from the conversion script). * * In addition, the same keywords as ps2png and ps2jpeg (which see) * are available. Note that, if not specified, a default value is * provided for the DPI keyword of ps2png and ps2jpeg so that the * resulting image has the same resolution as the graphical window * (this however require Yeti plugin). * * * SEE ALSO: ps2png, ps2jpeg, hcps, tempfile, current_window, window. */ func win2png(filename, counter, win=, debug=, temp=, gray=, smooth=, dpi=, border=, device=, alphabits=, graphicsalphabits=, textalphabits=, transparent=) { result = _win2any_worker(filename, counter, 0); if (result) { error, result; } } func win2jpeg(filename, counter, win=, debug=, temp=, gray=, smooth=, dpi=, border=, device=, alphabits=, graphicsalphabits=, textalphabits=, quality=) { result = _win2any_worker(filename, counter, 1); if (result) { error, result; } } func _win2any_worker(filename, counter, jpg) { /* All options as external variables. */ extern temp, dpi, win; local inp, out, status; status = -1; /* assume we have an error */ /* Prepare name of output file. */ if (is_string(filename) && is_scalar(filename)) { if (is_void(counter)) { eq_nocopy, output, filename; } else { output = swrite(format=filename, counter); } } else { return "expecting a scalar string for FILENAME"; } /* Figure out which window to dump. */ old_win = current_window(); if (is_void(win)) { tgt_win = old_win; } else if (window_exists(win)) { tgt_win = long(win); } else { tgt_win = -1; } if (tgt_win < 0) { return "bad graphical window"; } if (is_void(dpi)) { if (! is_func(window_geometry)) { require, "yeti.i"; } geom = window_geometry(tgt_win); dpi = long(floor(geom(1) + 0.5)); } /* Temporary input PS file. */ if (is_void(temp)) { temp = tempfile("/tmp/png_dump-XXXXXX.ps"); } else if (! is_string(temp) || ! is_scalar(temp)) { return "expecting a scalar string for TEMP"; } /* Build command. */ script = _ps2any_worker(temp, output, jpg); if (status) { return script; } /* Dump graphics window. */ window, tgt_win, hcp=temp, dump=1, legends=0, wait=1; hcp; window, tgt_win, hcp=""; if (tgt_win != old_win && old_win != -1) { window, old_win; } pause, 1; if (debug) { write, format="%s\n", script; } system, script; if (! debug) { remove, temp; } } /*---------------------------------------------------------------------------*/ /* UTILITIES */ func pl_map(op, arg, default) /* DOCUMENT pl_map(op, arg) * -or- pl_map(op, arg, default) * Maps scalar function OP onto array argument ARG to mimics element-wise * unary operation. Returns DEFAULT if ARG is void. * * SEE ALSO xwindow. */ { if (is_array(arg)) { /* use structof to avoid unecessary string duplication for string result */ out = array(structof((out1 = op(arg(1)))), dimsof(arg)); out(1) = out1; n = numberof(arg); for (i=2 ; i<=n ; ++i) out(i) = op(arg(i)); return out; } if (is_void(arg)) return default; error, "unexpected argument"; } func win_copy_lim(src, dst) /* DOCUMENT win_copy_lim, src, dst; * Make limits of window DST the same as those in window SRC. * * SEE ALSO: current_window, limits, window. */ { win = current_window(); window, src; l = limits(); window, dst; limits,l; if (win >= 0) window, win; /* restore old current window */ } /*---------------------------------------------------------------------------*/ /* COLOR DATABASE */ func pl_database_index_to_rgb(color) { return _PL_COLOR_RGB(, color); } func pl_database_index_to_packed(color) { return _PL_COLOR_PACKED(color); } func pl_rgb_to_packed(color) { return (0x01000000 | long(color(1,..)) | (long(color(2,..)) << 8) | (long(color(3,..)) << 16)); } func pl_packed_to_rgb(color) { rgb = array(char, 3, dimsof(color)); rgb(1, ..) = (color & 0xff); rgb(2, ..) = ((color >> 8) & 0xff); rgb(3, ..) = ((color >> 16) & 0xff); return rgb; } /* Names of known colors (the 16 indexed ones must come first). */ _PL_COLOR_NAMES = \ ["bg", "fg", "black", "white", "red", "green", "blue", "cyan", "magenta", "yellow", "grayd", "grayc", "grayb", "graya", "extra", "xor", "aliceblue", "antiquewhite", "antiquewhite1", "antiquewhite2", "antiquewhite3", "antiquewhite4", "aquamarine", "aquamarine1", "aquamarine2", "aquamarine3", "aquamarine4", "azure", "azure1", "azure2", "azure3", "azure4", "beige", "bisque", "bisque1", "bisque2", "bisque3", "bisque4", "blanchedalmond", "blue1", "blue2", "blue3", "blue4", "blueviolet", "brown", "brown1", "brown2", "brown3", "brown4", "burlywood", "burlywood1", "burlywood2", "burlywood3", "burlywood4", "cadetblue", "cadetblue1", "cadetblue2", "cadetblue3", "cadetblue4", "chartreuse", "chartreuse1", "chartreuse2", "chartreuse3", "chartreuse4", "chocolate", "chocolate1", "chocolate2", "chocolate3", "chocolate4", "coral", "coral1", "coral2", "coral3", "coral4", "cornflowerblue", "cornsilk", "cornsilk1", "cornsilk2", "cornsilk3", "cornsilk4", "cyan1", "cyan2", "cyan3", "cyan4", "darkblue", "darkcyan", "darkgoldenrod", "darkgoldenrod1", "darkgoldenrod2", "darkgoldenrod3", "darkgoldenrod4", "darkgray", "darkgreen", "darkgrey", "darkkhaki", "darkmagenta", "darkolivegreen", "darkolivegreen1", "darkolivegreen2", "darkolivegreen3", "darkolivegreen4", "darkorange", "darkorange1", "darkorange2", "darkorange3", "darkorange4", "darkorchid", "darkorchid1", "darkorchid2", "darkorchid3", "darkorchid4", "darkred", "darksalmon", "darkseagreen", "darkseagreen1", "darkseagreen2", "darkseagreen3", "darkseagreen4", "darkslateblue", "darkslategray", "darkslategray1", "darkslategray2", "darkslategray3", "darkslategray4", "darkslategrey", "darkturquoise", "darkviolet", "deeppink", "deeppink1", "deeppink2", "deeppink3", "deeppink4", "deepskyblue", "deepskyblue1", "deepskyblue2", "deepskyblue3", "deepskyblue4", "dimgray", "dimgrey", "dodgerblue", "dodgerblue1", "dodgerblue2", "dodgerblue3", "dodgerblue4", "firebrick", "firebrick1", "firebrick2", "firebrick3", "firebrick4", "floralwhite", "forestgreen", "gainsboro", "ghostwhite", "gold", "gold1", "gold2", "gold3", "gold4", "goldenrod", "goldenrod1", "goldenrod2", "goldenrod3", "goldenrod4", "gray", "gray0", "gray1", "gray10", "gray100", "gray11", "gray12", "gray13", "gray14", "gray15", "gray16", "gray17", "gray18", "gray19", "gray2", "gray20", "gray21", "gray22", "gray23", "gray24", "gray25", "gray26", "gray27", "gray28", "gray29", "gray3", "gray30", "gray31", "gray32", "gray33", "gray34", "gray35", "gray36", "gray37", "gray38", "gray39", "gray4", "gray40", "gray41", "gray42", "gray43", "gray44", "gray45", "gray46", "gray47", "gray48", "gray49", "gray5", "gray50", "gray51", "gray52", "gray53", "gray54", "gray55", "gray56", "gray57", "gray58", "gray59", "gray6", "gray60", "gray61", "gray62", "gray63", "gray64", "gray65", "gray66", "gray67", "gray68", "gray69", "gray7", "gray70", "gray71", "gray72", "gray73", "gray74", "gray75", "gray76", "gray77", "gray78", "gray79", "gray8", "gray80", "gray81", "gray82", "gray83", "gray84", "gray85", "gray86", "gray87", "gray88", "gray89", "gray9", "gray90", "gray91", "gray92", "gray93", "gray94", "gray95", "gray96", "gray97", "gray98", "gray99", "green1", "green2", "green3", "green4", "greenyellow", "grey", "grey0", "grey1", "grey10", "grey100", "grey11", "grey12", "grey13", "grey14", "grey15", "grey16", "grey17", "grey18", "grey19", "grey2", "grey20", "grey21", "grey22", "grey23", "grey24", "grey25", "grey26", "grey27", "grey28", "grey29", "grey3", "grey30", "grey31", "grey32", "grey33", "grey34", "grey35", "grey36", "grey37", "grey38", "grey39", "grey4", "grey40", "grey41", "grey42", "grey43", "grey44", "grey45", "grey46", "grey47", "grey48", "grey49", "grey5", "grey50", "grey51", "grey52", "grey53", "grey54", "grey55", "grey56", "grey57", "grey58", "grey59", "grey6", "grey60", "grey61", "grey62", "grey63", "grey64", "grey65", "grey66", "grey67", "grey68", "grey69", "grey7", "grey70", "grey71", "grey72", "grey73", "grey74", "grey75", "grey76", "grey77", "grey78", "grey79", "grey8", "grey80", "grey81", "grey82", "grey83", "grey84", "grey85", "grey86", "grey87", "grey88", "grey89", "grey9", "grey90", "grey91", "grey92", "grey93", "grey94", "grey95", "grey96", "grey97", "grey98", "grey99", "honeydew", "honeydew1", "honeydew2", "honeydew3", "honeydew4", "hotpink", "hotpink1", "hotpink2", "hotpink3", "hotpink4", "indianred", "indianred1", "indianred2", "indianred3", "indianred4", "ivory", "ivory1", "ivory2", "ivory3", "ivory4", "khaki", "khaki1", "khaki2", "khaki3", "khaki4", "lavender", "lavenderblush", "lavenderblush1", "lavenderblush2", "lavenderblush3", "lavenderblush4", "lawngreen", "lemonchiffon", "lemonchiffon1", "lemonchiffon2", "lemonchiffon3", "lemonchiffon4", "lightblue", "lightblue1", "lightblue2", "lightblue3", "lightblue4", "lightcoral", "lightcyan", "lightcyan1", "lightcyan2", "lightcyan3", "lightcyan4", "lightgoldenrod", "lightgoldenrod1", "lightgoldenrod2", "lightgoldenrod3", "lightgoldenrod4", "lightgoldenrodyellow", "lightgray", "lightgreen", "lightgrey", "lightpink", "lightpink1", "lightpink2", "lightpink3", "lightpink4", "lightsalmon", "lightsalmon1", "lightsalmon2", "lightsalmon3", "lightsalmon4", "lightseagreen", "lightskyblue", "lightskyblue1", "lightskyblue2", "lightskyblue3", "lightskyblue4", "lightslateblue", "lightslategray", "lightslategrey", "lightsteelblue", "lightsteelblue1", "lightsteelblue2", "lightsteelblue3", "lightsteelblue4", "lightyellow", "lightyellow1", "lightyellow2", "lightyellow3", "lightyellow4", "limegreen", "linen", "magenta1", "magenta2", "magenta3", "magenta4", "maroon", "maroon1", "maroon2", "maroon3", "maroon4", "mediumaquamarine", "mediumblue", "mediumorchid", "mediumorchid1", "mediumorchid2", "mediumorchid3", "mediumorchid4", "mediumpurple", "mediumpurple1", "mediumpurple2", "mediumpurple3", "mediumpurple4", "mediumseagreen", "mediumslateblue", "mediumspringgreen", "mediumturquoise", "mediumvioletred", "midnightblue", "mintcream", "mistyrose", "mistyrose1", "mistyrose2", "mistyrose3", "mistyrose4", "moccasin", "navajowhite", "navajowhite1", "navajowhite2", "navajowhite3", "navajowhite4", "navy", "navyblue", "oldlace", "olivedrab", "olivedrab1", "olivedrab2", "olivedrab3", "olivedrab4", "orange", "orange1", "orange2", "orange3", "orange4", "orangered", "orangered1", "orangered2", "orangered3", "orangered4", "orchid", "orchid1", "orchid2", "orchid3", "orchid4", "palegoldenrod", "palegreen", "palegreen1", "palegreen2", "palegreen3", "palegreen4", "paleturquoise", "paleturquoise1", "paleturquoise2", "paleturquoise3", "paleturquoise4", "palevioletred", "palevioletred1", "palevioletred2", "palevioletred3", "palevioletred4", "papayawhip", "peachpuff", "peachpuff1", "peachpuff2", "peachpuff3", "peachpuff4", "peru", "pink", "pink1", "pink2", "pink3", "pink4", "plum", "plum1", "plum2", "plum3", "plum4", "powderblue", "purple", "purple1", "purple2", "purple3", "purple4", "red1", "red2", "red3", "red4", "rosybrown", "rosybrown1", "rosybrown2", "rosybrown3", "rosybrown4", "royalblue", "royalblue1", "royalblue2", "royalblue3", "royalblue4", "saddlebrown", "salmon", "salmon1", "salmon2", "salmon3", "salmon4", "sandybrown", "seagreen", "seagreen1", "seagreen2", "seagreen3", "seagreen4", "seashell", "seashell1", "seashell2", "seashell3", "seashell4", "sienna", "sienna1", "sienna2", "sienna3", "sienna4", "skyblue", "skyblue1", "skyblue2", "skyblue3", "skyblue4", "slateblue", "slateblue1", "slateblue2", "slateblue3", "slateblue4", "slategray", "slategray1", "slategray2", "slategray3", "slategray4", "slategrey", "snow", "snow1", "snow2", "snow3", "snow4", "springgreen", "springgreen1", "springgreen2", "springgreen3", "springgreen4", "steelblue", "steelblue1", "steelblue2", "steelblue3", "steelblue4", "tan", "tan1", "tan2", "tan3", "tan4", "thistle", "thistle1", "thistle2", "thistle3", "thistle4", "tomato", "tomato1", "tomato2", "tomato3", "tomato4", "turquoise", "turquoise1", "turquoise2", "turquoise3", "turquoise4", "violet", "violetred", "violetred1", "violetred2", "violetred3", "violetred4", "wheat", "wheat1", "wheat2", "wheat3", "wheat4", "whitesmoke", "yellow1", "yellow2", "yellow3", "yellow4", "yellowgreen"]; _PL_COLOR_RGB = \ [[255,255,255], [ 0, 0, 0], [ 0, 0, 0], [255,255,255], [255, 0, 0], [ 0,255, 0], [ 0, 0,255], [ 0,255,255], [255, 0,255], [255,255, 0], [100,100,100], [150,150,150], [190,190,190], [214,214,214], [ 0, 0, 0], [ 0, 0, 0], [240,248,255], [250,235,215], [255,239,219], [238,223,204], [205,192,176], [139,131,120], [127,255,212], [127,255,212], [118,238,198], [102,205,170], [ 69,139,116], [240,255,255], [240,255,255], [224,238,238], [193,205,205], [131,139,139], [245,245,220], [255,228,196], [255,228,196], [238,213,183], [205,183,158], [139,125,107], [255,235,205], [ 0, 0,255], [ 0, 0,238], [ 0, 0,205], [ 0, 0,139], [138, 43,226], [165, 42, 42], [255, 64, 64], [238, 59, 59], [205, 51, 51], [139, 35, 35], [222,184,135], [255,211,155], [238,197,145], [205,170,125], [139,115, 85], [ 95,158,160], [152,245,255], [142,229,238], [122,197,205], [ 83,134,139], [127,255, 0], [127,255, 0], [118,238, 0], [102,205, 0], [ 69,139, 0], [210,105, 30], [255,127, 36], [238,118, 33], [205,102, 29], [139, 69, 19], [255,127, 80], [255,114, 86], [238,106, 80], [205, 91, 69], [139, 62, 47], [100,149,237], [255,248,220], [255,248,220], [238,232,205], [205,200,177], [139,136,120], [ 0,255,255], [ 0,238,238], [ 0,205,205], [ 0,139,139], [ 0, 0,139], [ 0,139,139], [184,134, 11], [255,185, 15], [238,173, 14], [205,149, 12], [139,101, 8], [169,169,169], [ 0,100, 0], [169,169,169], [189,183,107], [139, 0,139], [ 85,107, 47], [202,255,112], [188,238,104], [162,205, 90], [110,139, 61], [255,140, 0], [255,127, 0], [238,118, 0], [205,102, 0], [139, 69, 0], [153, 50,204], [191, 62,255], [178, 58,238], [154, 50,205], [104, 34,139], [139, 0, 0], [233,150,122], [143,188,143], [193,255,193], [180,238,180], [155,205,155], [105,139,105], [ 72, 61,139], [ 47, 79, 79], [151,255,255], [141,238,238], [121,205,205], [ 82,139,139], [ 47, 79, 79], [ 0,206,209], [148, 0,211], [255, 20,147], [255, 20,147], [238, 18,137], [205, 16,118], [139, 10, 80], [ 0,191,255], [ 0,191,255], [ 0,178,238], [ 0,154,205], [ 0,104,139], [105,105,105], [105,105,105], [ 30,144,255], [ 30,144,255], [ 28,134,238], [ 24,116,205], [ 16, 78,139], [178, 34, 34], [255, 48, 48], [238, 44, 44], [205, 38, 38], [139, 26, 26], [255,250,240], [ 34,139, 34], [220,220,220], [248,248,255], [255,215, 0], [255,215, 0], [238,201, 0], [205,173, 0], [139,117, 0], [218,165, 32], [255,193, 37], [238,180, 34], [205,155, 29], [139,105, 20], [190,190,190], [ 0, 0, 0], [ 3, 3, 3], [ 26, 26, 26], [255,255,255], [ 28, 28, 28], [ 31, 31, 31], [ 33, 33, 33], [ 36, 36, 36], [ 38, 38, 38], [ 41, 41, 41], [ 43, 43, 43], [ 46, 46, 46], [ 48, 48, 48], [ 5, 5, 5], [ 51, 51, 51], [ 54, 54, 54], [ 56, 56, 56], [ 59, 59, 59], [ 61, 61, 61], [ 64, 64, 64], [ 66, 66, 66], [ 69, 69, 69], [ 71, 71, 71], [ 74, 74, 74], [ 8, 8, 8], [ 77, 77, 77], [ 79, 79, 79], [ 82, 82, 82], [ 84, 84, 84], [ 87, 87, 87], [ 89, 89, 89], [ 92, 92, 92], [ 94, 94, 94], [ 97, 97, 97], [ 99, 99, 99], [ 10, 10, 10], [102,102,102], [105,105,105], [107,107,107], [110,110,110], [112,112,112], [115,115,115], [117,117,117], [120,120,120], [122,122,122], [125,125,125], [ 13, 13, 13], [127,127,127], [130,130,130], [133,133,133], [135,135,135], [138,138,138], [140,140,140], [143,143,143], [145,145,145], [148,148,148], [150,150,150], [ 15, 15, 15], [153,153,153], [156,156,156], [158,158,158], [161,161,161], [163,163,163], [166,166,166], [168,168,168], [171,171,171], [173,173,173], [176,176,176], [ 18, 18, 18], [179,179,179], [181,181,181], [184,184,184], [186,186,186], [189,189,189], [191,191,191], [194,194,194], [196,196,196], [199,199,199], [201,201,201], [ 20, 20, 20], [204,204,204], [207,207,207], [209,209,209], [212,212,212], [214,214,214], [217,217,217], [219,219,219], [222,222,222], [224,224,224], [227,227,227], [ 23, 23, 23], [229,229,229], [232,232,232], [235,235,235], [237,237,237], [240,240,240], [242,242,242], [245,245,245], [247,247,247], [250,250,250], [252,252,252], [ 0,255, 0], [ 0,238, 0], [ 0,205, 0], [ 0,139, 0], [173,255, 47], [190,190,190], [ 0, 0, 0], [ 3, 3, 3], [ 26, 26, 26], [255,255,255], [ 28, 28, 28], [ 31, 31, 31], [ 33, 33, 33], [ 36, 36, 36], [ 38, 38, 38], [ 41, 41, 41], [ 43, 43, 43], [ 46, 46, 46], [ 48, 48, 48], [ 5, 5, 5], [ 51, 51, 51], [ 54, 54, 54], [ 56, 56, 56], [ 59, 59, 59], [ 61, 61, 61], [ 64, 64, 64], [ 66, 66, 66], [ 69, 69, 69], [ 71, 71, 71], [ 74, 74, 74], [ 8, 8, 8], [ 77, 77, 77], [ 79, 79, 79], [ 82, 82, 82], [ 84, 84, 84], [ 87, 87, 87], [ 89, 89, 89], [ 92, 92, 92], [ 94, 94, 94], [ 97, 97, 97], [ 99, 99, 99], [ 10, 10, 10], [102,102,102], [105,105,105], [107,107,107], [110,110,110], [112,112,112], [115,115,115], [117,117,117], [120,120,120], [122,122,122], [125,125,125], [ 13, 13, 13], [127,127,127], [130,130,130], [133,133,133], [135,135,135], [138,138,138], [140,140,140], [143,143,143], [145,145,145], [148,148,148], [150,150,150], [ 15, 15, 15], [153,153,153], [156,156,156], [158,158,158], [161,161,161], [163,163,163], [166,166,166], [168,168,168], [171,171,171], [173,173,173], [176,176,176], [ 18, 18, 18], [179,179,179], [181,181,181], [184,184,184], [186,186,186], [189,189,189], [191,191,191], [194,194,194], [196,196,196], [199,199,199], [201,201,201], [ 20, 20, 20], [204,204,204], [207,207,207], [209,209,209], [212,212,212], [214,214,214], [217,217,217], [219,219,219], [222,222,222], [224,224,224], [227,227,227], [ 23, 23, 23], [229,229,229], [232,232,232], [235,235,235], [237,237,237], [240,240,240], [242,242,242], [245,245,245], [247,247,247], [250,250,250], [252,252,252], [240,255,240], [240,255,240], [224,238,224], [193,205,193], [131,139,131], [255,105,180], [255,110,180], [238,106,167], [205, 96,144], [139, 58, 98], [205, 92, 92], [255,106,106], [238, 99, 99], [205, 85, 85], [139, 58, 58], [255,255,240], [255,255,240], [238,238,224], [205,205,193], [139,139,131], [240,230,140], [255,246,143], [238,230,133], [205,198,115], [139,134, 78], [230,230,250], [255,240,245], [255,240,245], [238,224,229], [205,193,197], [139,131,134], [124,252, 0], [255,250,205], [255,250,205], [238,233,191], [205,201,165], [139,137,112], [173,216,230], [191,239,255], [178,223,238], [154,192,205], [104,131,139], [240,128,128], [224,255,255], [224,255,255], [209,238,238], [180,205,205], [122,139,139], [238,221,130], [255,236,139], [238,220,130], [205,190,112], [139,129, 76], [250,250,210], [211,211,211], [144,238,144], [211,211,211], [255,182,193], [255,174,185], [238,162,173], [205,140,149], [139, 95,101], [255,160,122], [255,160,122], [238,149,114], [205,129, 98], [139, 87, 66], [ 32,178,170], [135,206,250], [176,226,255], [164,211,238], [141,182,205], [ 96,123,139], [132,112,255], [119,136,153], [119,136,153], [176,196,222], [202,225,255], [188,210,238], [162,181,205], [110,123,139], [255,255,224], [255,255,224], [238,238,209], [205,205,180], [139,139,122], [ 50,205, 50], [250,240,230], [255, 0,255], [238, 0,238], [205, 0,205], [139, 0,139], [176, 48, 96], [255, 52,179], [238, 48,167], [205, 41,144], [139, 28, 98], [102,205,170], [ 0, 0,205], [186, 85,211], [224,102,255], [209, 95,238], [180, 82,205], [122, 55,139], [147,112,219], [171,130,255], [159,121,238], [137,104,205], [ 93, 71,139], [ 60,179,113], [123,104,238], [ 0,250,154], [ 72,209,204], [199, 21,133], [ 25, 25,112], [245,255,250], [255,228,225], [255,228,225], [238,213,210], [205,183,181], [139,125,123], [255,228,181], [255,222,173], [255,222,173], [238,207,161], [205,179,139], [139,121, 94], [ 0, 0,128], [ 0, 0,128], [253,245,230], [107,142, 35], [192,255, 62], [179,238, 58], [154,205, 50], [105,139, 34], [255,165, 0], [255,165, 0], [238,154, 0], [205,133, 0], [139, 90, 0], [255, 69, 0], [255, 69, 0], [238, 64, 0], [205, 55, 0], [139, 37, 0], [218,112,214], [255,131,250], [238,122,233], [205,105,201], [139, 71,137], [238,232,170], [152,251,152], [154,255,154], [144,238,144], [124,205,124], [ 84,139, 84], [175,238,238], [187,255,255], [174,238,238], [150,205,205], [102,139,139], [219,112,147], [255,130,171], [238,121,159], [205,104,137], [139, 71, 93], [255,239,213], [255,218,185], [255,218,185], [238,203,173], [205,175,149], [139,119,101], [205,133, 63], [255,192,203], [255,181,197], [238,169,184], [205,145,158], [139, 99,108], [221,160,221], [255,187,255], [238,174,238], [205,150,205], [139,102,139], [176,224,230], [160, 32,240], [155, 48,255], [145, 44,238], [125, 38,205], [ 85, 26,139], [255, 0, 0], [238, 0, 0], [205, 0, 0], [139, 0, 0], [188,143,143], [255,193,193], [238,180,180], [205,155,155], [139,105,105], [ 65,105,225], [ 72,118,255], [ 67,110,238], [ 58, 95,205], [ 39, 64,139], [139, 69, 19], [250,128,114], [255,140,105], [238,130, 98], [205,112, 84], [139, 76, 57], [244,164, 96], [ 46,139, 87], [ 84,255,159], [ 78,238,148], [ 67,205,128], [ 46,139, 87], [255,245,238], [255,245,238], [238,229,222], [205,197,191], [139,134,130], [160, 82, 45], [255,130, 71], [238,121, 66], [205,104, 57], [139, 71, 38], [135,206,235], [135,206,255], [126,192,238], [108,166,205], [ 74,112,139], [106, 90,205], [131,111,255], [122,103,238], [105, 89,205], [ 71, 60,139], [112,128,144], [198,226,255], [185,211,238], [159,182,205], [108,123,139], [112,128,144], [255,250,250], [255,250,250], [238,233,233], [205,201,201], [139,137,137], [ 0,255,127], [ 0,255,127], [ 0,238,118], [ 0,205,102], [ 0,139, 69], [ 70,130,180], [ 99,184,255], [ 92,172,238], [ 79,148,205], [ 54,100,139], [210,180,140], [255,165, 79], [238,154, 73], [205,133, 63], [139, 90, 43], [216,191,216], [255,225,255], [238,210,238], [205,181,205], [139,123,139], [255, 99, 71], [255, 99, 71], [238, 92, 66], [205, 79, 57], [139, 54, 38], [ 64,224,208], [ 0,245,255], [ 0,229,238], [ 0,197,205], [ 0,134,139], [238,130,238], [208, 32,144], [255, 62,150], [238, 58,140], [205, 50,120], [139, 34, 82], [245,222,179], [255,231,186], [238,216,174], [205,186,150], [139,126,102], [245,245,245], [255,255, 0], [238,238, 0], [205,205, 0], [139,139, 0], [154,205, 50]]; #if 0 _PL_COLOR_PACKED = (0x01000000 | _PL_COLOR_RGB(1,) | (_PL_COLOR_RGB(2,) << 8) | (_PL_COLOR_RGB(3,) << 16)); #endif _PL_COLOR_RGB = char(_PL_COLOR_RGB); /*---------------------------------------------------------------------------* * Local Variables: * * mode: Yorick * * tab-width: 8 * * fill-column: 75 * * c-basic-offset: 2 * * coding: latin-1 * * End: * *---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/plot_demo.i000066400000000000000000000160561152651572200204350ustar00rootroot00000000000000/* * plot_demo.i -- * * Demonstration of routines in "plot.i". * Provides routines: plot_demo, plot_demo1, plot_demo2. * * Copyright (c) 1996, Eric THIEBAUT (thiebaut@obs.univ-lyon1.fr, Centre de * Recherche Astrophysique de Lyon, 9 avenue Charles Andre, * F-69561 Saint Genis Laval Cedex). * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * History: * $Id: plot_demo.i,v 1.1 2007-12-11 23:55:14 frigaut Exp $ * $Log: plot_demo.i,v $ * Revision 1.1 2007-12-11 23:55:14 frigaut * Initial revision * * Revision 1.2 2002/11/14 11:20:52 eric * - changed paths in require calls * */ require, "plot.i"; require, Y_SITE+"include/random.i"; func plot_demo {plot_demo1; plot_demo2;} func plot_demo1 { /* * Select an eventually new window and choose "work" style. */ win = max(0, current_window()); window, win, wait=1, style="work.gs"; limits; animate, 0; pldefault, font="helveticaBI", width=5, height=10, marks=0; /* * Some data. */ x= span(0., 2., 500); y= sin(-pi*exp(x))*exp(-x); xp= x(15::30); yp= y(15::30); dx= 0.05; dy= 0.05 + yp/5.; // RSB ~ 5 xn= dx*random_n(dimsof(xp)); yn= dy*random_n(dimsof(yp)); write, " - true model and data points (in green)"; plg, y, x; plp, yp+yn, xp+xn, color="green"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - data points (in green) with error bars (in red)"; plg, y, x; plp, yp+yn, xp+xn, dx=dx, dy=dy, ticks=0, color="red", symbol=0; plp, yp+yn, xp+xn, color="green"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - data points with error bars and ticks (in blue)"; plg, y, x; plp, yp+yn, xp+xn, dx=dx, dy=dy, ticks=3, color="blue"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - data points with error bars, ticks and symbol (in green)"; plg, y, x; plp, yp+yn, xp+xn, dx=dx, dy=dy, ticks=3, symbol=5, size=1.5, width=1, color="green"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - data points with various symbols and colors"; plg, y, x; colors= ["red", "green", "blue", "magenta", "cyan", "yellow"]; for (i=1; i<=numberof(colors);i++) { xn= dx*random_n(dimsof(xp)); yn= dy*random_n(dimsof(yp)); plp, yp+yn, xp+xn, symbol=i-1, size=1.5, color=colors(i); } fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - histograms with different justification (plh)"; pldefault, font="helveticaBI", width=1, height=10, marks=0; plh, y(::10)-.1, x(::10), just=1, marks=0, color="blue"; plh, y(::10), x(::10), just=2, marks=0; plh, y(::10)+.1, x(::10), just=3, marks=0, color="cyan"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; } func plot_demo2 { write, "WARNING - demo under construction ..."; return; local alt, az; x= span(-1, 1, 30)(,-:1:30); y= transpose(x); a= abs(x, y); a= exp(-32.*a^2); a= a + .3 * roll(a, [5,-5]) - .7 * roll(a, [-5,-10]); /* * Select an eventually new window and choose "nobox" style. */ win = max(0, current_window()); window, win, wait=1, style="nobox.gs"; palette, "rainbow.gp"; limits; animate, 1; pldefault, font="helveticaBI", height=10; write, " - deformation of a surface mesh"; pl3s, a, y, x, edges=1, fill=1, axis=1; fma; q= [100, 60, 45, 35, 25, 20, 15, 12, 9, 7, 6, 5]; for (k = 1; k <= numberof(q); k++) { z= x+1i*y; z= q(k)*z/(q(k)+z*z); xx= z.re; yy= z.im; pl3s, a, yy, xx, edges=1, fill=1, axis=1; fma; } if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - surface mesh as wireframe (fill=0 or nil)"; pl3s, a, yy, xx, edges=1, fill=0, axis=1, box=1; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - surface mesh filled with brightness (fill=1)"; pl3s, a, yy, xx, edges=1, fill=1, axis=1, box=1; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - surface mesh shaded (fill=2)"; pl3s, a, yy, xx, edges=1, fill=2, axis=1, box=1; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - rotation of the point of view"; step= 20; az= 35.; alt= 35.; while (az <= 360.) { for (x=0; x<=360; x+=step) { pl3s, a, yy, xx, az=az, alt=alt+x, box=1, edges=1, fill=1, axis=0; fma; } for (x=step; x<=90; x+=step) { pl3s, a, yy, xx, az=az+x, alt=alt, box=1, edges=1, fill=1, axis=0; fma; } az += 90.; } if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; /* * Restore plot defaults. */ animate, 0; /* * 2-D surface plot. */ window, win, wait=1, style="work.gs"; pldefault, width=1; write, " - filled mesh with contour (pls routine)"; pls, a, cbar=1, nlevs=10, xtitle="abscissa", ytitle="ordinate", title="Example of PLS routine", font="timesBI", height=14, marks=0; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - filled mesh with contour (pls routine)"; pls, a, yy, xx, cbar=1, nlevs=10, xtitle="abscissa", ytitle="ordinate", title="Example of PLS routine", font="timesBI", height=14, marks=0; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; } func plot_demo3(step) { local alt, az; x=span(-1, 1, 40)(,-:1:30); y=span(-2, 4, 30)(-:1:40,); z=sin(x*x+y*x); /* * Select an eventually new window and choose "nobox" style. */ win = max(0, current_window()); window, win, wait=1, style="nobox.gs"; palette, "rainbow.gp"; limits; animate, 1; pldefault, font="helveticaBI", height=10; write, " - rotation of the point of view"; if (!step) { step = 20; } az= 35.; alt= 35.; while (az <= 360.) { for (a=0; a<=360; a+=step) { pl3s, z, y, x, az=az, alt=alt+a, box=1, edges=1, fill=1, axis=1; fma; //rdline, prompt="hit Enter to continue"; } for (a=step; a<=90; a+=step) { pl3s, z, y, x, az=az+a, alt=alt, box=1, edges=1, fill=1, axis=1; fma; //rdline, prompt="hit Enter to continue"; } az += 90; } if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; /* * Restore plot defaults. */ animate, 0; } frigaut-yorick-yutils-c173974/plot_demo2.i000066400000000000000000000156431152651572200205200ustar00rootroot00000000000000/* * plot_demo.i -- * * Demonstration of routines in "plot.i". * Provides routines: plot_demo, plot_demo1, plot_demo2. * * $Id: plot_demo2.i,v 1.1 2007-12-11 23:55:10 frigaut Exp $ * * Copyright (c) 1996, Eric THIEBAUT (thiebaut@obs.univ-lyon1.fr, Centre de * Recherche Astrophysique de Lyon, 9 avenue Charles Andre, F-69561 Saint * Genis Laval Cedex). * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). */ require,"plot.i"; require,"random.i"; func plot_demo {plot_demo1; plot_demo2; plot_demo3,5;} func plot_demo1 { /* * Select an eventually new window and choose "work" style. */ win = max(0, current_window()); window, win, wait=1, style="work.gs"; limits; animate, 0; pldefault, font="helveticaBI", width=5, height=10, marks=0; /* * Some data. */ x= span(0., 2., 500); y= sin(-pi*exp(x))*exp(-x); xp= x(15::30); yp= y(15::30); dx= 0.05; dy= 0.05 + yp/5.; // RSB ~ 5 xn= dx*random_n(dimsof(xp)); yn= dy*random_n(dimsof(yp)); write, " - true model and data points (in green)"; plg, y, x; plp, yp+yn, xp+xn, color="green"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - data points (in green) with error bars (in red)"; plg, y, x; plp, yp+yn, xp+xn, dx=dx, dy=dy, ticks=0, color="red", symbol=0; plp, yp+yn, xp+xn, color="green"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - data points with error bars and ticks (in blue)"; plg, y, x; plp, yp+yn, xp+xn, dx=dx, dy=dy, ticks=3, color="blue"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - data points with error bars, ticks and symbol (in green)"; plg, y, x; plp, yp+yn, xp+xn, dx=dx, dy=dy, ticks=3, symbol=5, size=1.5, width=1, color="green"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - data points with various symbols and colors"; plg, y, x; colors= ["red", "green", "blue", "magenta", "cyan", "yellow"]; for (i=1; i<=numberof(colors);i++) { xn= dx*random_n(dimsof(xp)); yn= dy*random_n(dimsof(yp)); plp, yp+yn, xp+xn, symbol=i-1, size=1.5, color=colors(i); } fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - histograms with different justification (plh)"; pldefault, font="helveticaBI", width=1, height=10, marks=0; plh, y(::10)-.1, x(::10), just=1, marks=0, color="blue"; plh, y(::10), x(::10), just=2, marks=0; plh, y(::10)+.1, x(::10), just=3, marks=0, color="cyan"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; } func plot_demo2 { local alt, az; x= span(-1, 1, 30)(,-:1:30); y= transpose(x); a= abs(x, y); a= exp(-32.*a^2); a= a + .3 * roll(a, [5,-5]) - .7 * roll(a, [-5,-10]); /* * Select an eventually new window and choose "nobox" style. */ win = max(0, current_window()); window, win, wait=1, style="nobox.gs"; palette, "rainbow.gp"; limits; animate, 1; pldefault, font="helveticaBI", height=10; write, " - deformation of a surface mesh"; pl3s, a, y, x, edges=1, fill=1, axis=1; fma; // q= [100, 60, 45, 35, 25, 20, 15, 12, 9, 7, 6, 5]; q = spanl(100,5,30); for (k = 1; k <= numberof(q); k++) { z= x+1i*y; z= q(k)*z/(q(k)+z*z); xx= z.re; yy= z.im; pl3s, a, yy, xx, edges=1, fill=1, axis=1; fma; } if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - surface mesh as wireframe (fill=0 or nil)"; pl3s, a, yy, xx, edges=1, fill=0, axis=1, box=1, ecolor="red"; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - surface mesh filled with brightness (fill=1)"; pl3s, a, yy, xx, edges=1, fill=1, axis=1, box=1; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - surface mesh shaded (fill=2)"; pl3s, a, yy, xx, edges=1, fill=2, axis=1, box=1; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - rotation of the point of view"; step= 20; az= 35.; alt= 35.; while (az <= 360.) { for (x=0; x<=360; x+=step) { pl3s, a, yy, xx, az=az, alt=alt+x, box=1, edges=1, fill=1, axis=0; fma; } for (x=step; x<=90; x+=step) { pl3s, a, yy, xx, az=az+x, alt=alt, box=1, edges=1, fill=1, axis=0; fma; } az += 90.; } if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; /* * Restore plot defaults. */ animate, 0; // write, "WARNING - demo under construction ..."; // return; /* * 2-D surface plot. */ window, win, wait=1, style="work.gs"; pldefault, width=1; write, " - filled mesh with contour (pls routine)"; pls, a, cbar=1, nlevs=10, xtitle="abscissa", ytitle="ordinate", title="Example of PLS routine", font="timesBI", height=14, marks=0; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; write, " - filled mesh with contour (pls routine)"; pls, a, yy, xx, cbar=1, nlevs=10, xtitle="abscissa", ytitle="ordinate", title="Example of PLS routine", font="timesBI", height=14, marks=0; fma; if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; } func plot_demo3(step) { local alt, az; x=span(-1, 1, 40)(,-:1:30); y=span(-2, 4, 30)(-:1:40,); z=sin(x*x+y*x); /* * Select an eventually new window and choose "nobox" style. */ win = max(0, current_window()); window, win, wait=1, style="nobox.gs"; palette, "rainbow.gp"; limits; animate, 1; pldefault, font="helveticaBI", height=10; write, " - rotation of the point of view"; if (!step) { step = 20; } az= 35.; alt= 35.; while (az <= 360.) { for (a=0; a<=360; a+=step) { pl3s, z, y, x, az=az, alt=alt+a, box=1, edges=1, fill=1, axis=1; fma; //rdline, prompt="hit Enter to continue"; } for (a=step; a<=90; a+=step) { pl3s, z, y, x, az=az+a, alt=alt, box=1, edges=1, fill=1, axis=1; fma; //rdline, prompt="hit Enter to continue"; } az += 90; } if (strtok(rdline(prompt="hit Enter to continue, Q to quit"))(1)=="q") return; /* * Restore plot defaults. */ animate, 0; } frigaut-yorick-yutils-c173974/plvp.i000066400000000000000000000324401152651572200174270ustar00rootroot00000000000000/* Easily manipulate viewport properties (2up, 4up, split, merge viewports) * * * Author: Francois Rigaut * Written 2004 * last revision/addition: 2007 * * Copyright (c) 2003-2007, Francois Rigaut * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * */ require,"style.i"; func plsplit(nx,ny,win=,margin=,style=,dpi=,sys=,square=,save=,vp=,height=,width=) /* DOCUMENT plsplit,nx,ny,margin=,style=,dpi=,sys= Split the viewport into nx x ny viewports nx = number of horizontal viewports ny = number of vertical viewports margin = margin correction for each viewport (+/- a few hundreth) style = if style is set, the given style is loaded before the split occurs. style can be a string vector of styles, one per viewport to be created. dpi = if dpi is set, the current window is re-created with said dpi sys = system number on which the split operation is to be performed. sys can be used to create complex, multi-level viewports. square = if set, created viewports will be square. vp = a 4 element vector to get a specific viewport, as returned by : get_style,landscape, systems, legends, clegends; write,systems.viewport; height and width as in the call to window. examples: plsplit,2,2,style="work.gs" define a 2x2 viewport with style "work.gs" plsplit,2,2,style=["work.gs","work.gs","work.gs","nobox.gs"] define a 2x2 viewport with style "work.gs", except for viewport#4 which gets "nobox.gs" plsplit,1,2,sys=2 start from graphic system with >1 viewport. viewport#2 will be split in 1x2 sub-viewports plsplit,1,2,sys=2,style=["boxed.gs","nobox.gs"] start from graphic system with >1 viewport. viewport#2 will be split in 1x2 sub-viewports with styles as in the style keyword. plsplit,3,3,style=_(array("boxed.gs",7),"nobox.gs","boxed.gs"),\ dpi=100,margin=0.005; pljoin,[2,3,5,6]; testViewports; SEE ALSO: */ { extern pltitle_height_vp,pltitle_margin,xytitle_margin; n = current_window(); if (sys && (n==-1)) error,"sys keyword: No window to draw system from"; if (sys) get_style,landscape, systems, legends, clegends; // if dpi is set, have to kill the current window, if it exist if (win) { winkill,win; n=win; } else { if (n!=-1) winkill; if (n==-1) n=0; } // create new window window,n,dpi=dpi,wait=1,height=height,width=width; keep_sys=keep_pltitle_height=keep_pltitle_margin=keep_xytitle_margin=[]; if (sys) { // we reload the old systems set_style,landscape, systems, legends, clegends; // keep all but the one we want to modify w = where(indgen(numberof(systems))!=sys); keep_sys = systems(w); keep_pltitle_height = pltitle_height_vp(w); keep_pltitle_margin = pltitle_margin(w); keep_xytitle_margin = xytitle_margin(,w); systems = systems(sys); } else { // we get the current system get_style,landscape, systems, legends, clegends; } cvp = systems(1).viewport; if (vp!=[]) cvp = vp; if (!is_void(style)) { systems = []; // load all styles for (i=1;i<=numberof(style);i++) { read_style,style(i),landscape, tmp, legends, clegends; tmp.viewport=cvp; grow,systems,tmp; } } nx = clip(nx,1,); ny = clip(ny,1,); nvp = nx*ny; ex = 0.75; if (numberof(systems)!=nvp) { // complete using last grow,systems,array(systems(0),nvp-numberof(systems)); } pltitle_height_vp = array(float,nvp); pltitle_margin = array(float,nvp); xytitle_margin = array(float,[2,2,nvp]); plmargin = array(float,[2,2,nvp]); // now systems contains the system array to tweak for (i=1;i<=nx;i++) { for (j=1;j<=ny;j++) { ns = (j-1)*nx+i; // set each VP margin: plmargin(,ns) = [0.026,0.026]; // if tick project outward of viewport, adjust default margin: plticks = [systems(ns).ticks.horiz.flags(1), systems(ns).ticks.vert.flags(1)]; if (plticks(1) & 0x010) plmargin(2,ns)=0.032; if (plticks(2) & 0x010) plmargin(1,ns)=0.032; if (!is_void(margin)) plmargin(,ns)+=margin; marginx = plmargin(1,ns); // marginy = (cvp(4)-cvp(3))/(cvp(2)-cvp(1))*plmargin(2); marginy = plmargin(2,ns); x1 = cvp(1)-marginx; x2 = cvp(2)+marginx; y1 = cvp(3)-marginy; y2 = cvp(4)+marginy; xsize = (x2-x1)/nx; ysize = (y2-y1)/ny; if (square) { // find max margin: if (xsize>ysize) { x1 = x1+(xsize-ysize)/2.; xsize=ysize; } else { y1 = y1+(ysize-xsize)/2.; ysize=xsize; } } vp = array(double,4); vp(1) = x1+(i-1)*xsize+marginx; vp(2) = x1+i*xsize-marginx; vp(3) = y1+(j-1)*ysize+marginy; vp(4) = y1+j*ysize-marginy; systems(ns).viewport = vp; xs = vp(dif:1:2); ys = vp(dif:3:4); // adjust xytitle_margins xytitle_margin(1,ns)= 0.015/xs^0.25- max(systems(ns).ticks.vert.tickLen)*((plticks(2) & 0x010) > 0); xytitle_margin(2,ns)= 0.021/ys^0.20- max(systems(ns).ticks.horiz.tickLen)*((plticks(1) & 0x010) > 0); // adjust tick lenght: systems(ns).ticks.horiz.tickLen /= ny^ex; systems(ns).ticks.vert.tickLen /= nx^ex; // adjust text height: systems(ns).ticks.horiz.textStyle.height= \ systems(ns).ticks.vert.textStyle.height = max([0.008,0.055*min([xs,ys])^1]); // adjust xytitle/pltitle text height: pltitle_height_vp(ns)= systems(ns).ticks.horiz.textStyle.height*900; // adjust pltitle_margin if ((plticks(1) & 0x010) > 0) { pltitle_margin(ns)= max(systems(ns).ticks.horiz.tickLen); } else { pltitle_margin(ns) = 0.; } // adjust distance to labels systems(ns).ticks.horiz.labelOff /= ny^0.7; systems(ns).ticks.vert.labelOff /= nx^0.7; } } grow,keep_pltitle_height,pltitle_height_vp; pltitle_height_vp = keep_pltitle_height; pltitle_height_vp = max(pltitle_height_vp,8); grow,keep_pltitle_margin,pltitle_margin; pltitle_margin = keep_pltitle_margin; grow,keep_xytitle_margin,xytitle_margin; xytitle_margin = keep_xytitle_margin; grow,keep_sys,systems; set_style,landscape, keep_sys, legends, clegends; if (save) write_style, save, landscape, keep_sys, legends, clegends; } func pltitle_vp(title, adjust, pos=) /* DOCUMENT pltitle_vp, title, deltay Plot TITLE centered above the coordinate system for any of the standard Gist styles. You may want to customize this for other plot styles. pos = -1 (left), 0 (default, centered) or 1 (right) SEE ALSO: plt, xytitles */ { extern pltitle_height_vp; // try to solve the problem of pltitle_height_vp once and for all: if (pltitle_height_vp==[]) pltitle_height_vp = array(pltitle_height,100); if (is_void(pltitle_margin)) { marg=0.; csys=1; } else { csys = min(plsys(),numberof(pltitle_margin)); marg=pltitle_margin(csys); } //pltitle_height is always set if (numberof(pltitle_height_vp)>1) { csys = min(plsys(),numberof(pltitle_height_vp)); _pltheight = pltitle_height_vp(csys); } else _pltheight = pltitle_height_vp(1); if (is_void(adjust)) adjust=0.; adjust +=marg; port= viewport(); if (!pos) { plt, title, port(zcen:1:2)(1), port(4)+adjust, font=pltitle_font, justify="CB", height=_pltheight; } else if (pos==-1) { plt, title, port(1), port(4)+adjust, font=pltitle_font, justify="LB", height=_pltheight; } else if (pos==1) { plt, title, port(2), port(4)+adjust, font=pltitle_font, justify="RB", height=_pltheight; } else { error,"pos keyword can only be -1,0 or 1"; } } func xytitles_vp(xtitle, ytitle, adjust) /* DOCUMENT xytitles_vp, xtitle, ytitle -or- xytitles_vp, xtitle, ytitle, [deltax,deltay] Plot XTITLE horizontally under the viewport and YTITLE vertically to the left of the viewport. If the tick numbers interfere with the labels, you can specify the [DELTAX,DELTAY] in NDC units to displace the labels. (Especially for the y title, the adjustment may depend on how many digits the numbers on your scale actually have.) Note that DELTAX moves YTITLE and DELTAY moves XTITLE. WARNING: There is no easy way to ensure that this type of title will not interfere with the tick numbering. Interference may make the numbers or the title or both illegible. SEE ALSO: plt, pltitle */ { // multi viewport margins if (is_void(xytitle_margin)) { marg=0.; } else if ((_d=dimsof(xytitle_margin))(1)!=2) { marg=xytitle_margin(1); } else { // this is if the mutli viewport was created by other means than // plsplit and xytitle_margin has not been set for each viewport csys = min(plsys(),_d(3)); marg=xytitle_margin(,csys); } //pltitle_height is always set if (numberof(pltitle_height_vp)>1) { csys = min(plsys(),numberof(pltitle_height_vp)); _pltheight = pltitle_height_vp(csys); } else if (numberof(pltitle_height_vp)==0) { pltitle_height_vp = pltitle_height; _pltheight = pltitle_height; } else _pltheight = pltitle_height_vp(1); if (is_void(adjust)) adjust=[0.,0.]; adjust +=marg; port= viewport(); if (xtitle && strlen(xtitle)) plt, xtitle, port(zcen:1:2)(1), port(3)-0.050+adjust(2), font=pltitle_font, justify="CT", height=_pltheight; if (ytitle && strlen(ytitle)) plt, ytitle, port(1)-0.050+adjust(1), port(zcen:3:4)(1), font=pltitle_font, justify="CB", height=_pltheight, orient=1; } if (pltitle_orig==[]) pltitle_orig = pltitle; if (xytitles_orig==[]) xytitles_orig = xytitles; func pltitle(title, adjust, pos=) { get_style,landscape,systems; if (numberof(systems)==1) pltitle_orig,title; else pltitle_vp,title,adjust,pos=pos; } func xytitles(xtitle, ytitle, adjust) { get_style,landscape,systems; if (numberof(systems)==1) xytitles_orig,xtitle, ytitle, adjust; else xytitles_vp,xtitle,ytitle,adjust; } func pljoin(sys2join) { get_style,landscape, systems, legends, clegends; sys = []; nsys = numberof(systems); //w=1 where valid, i.e. keep: w = where(!(indgen(nsys)==sys2join(-,))(,sum)); nonw = where((indgen(nsys)==sys2join(-,))(,sum)); //w=1 where invalid sys = systems(w); _pltheight = pltitle_height_vp(w); _pltmargin = pltitle_margin(w); _xytmargin = xytitle_margin(,w); grow,sys,systems(sys2join(1)); sys(0).viewport([1,3]) = systems(sys2join).viewport(,min)([1,3]); sys(0).viewport([2,4]) = systems(sys2join).viewport(,max)([2,4]); grow,_pltheight,pltitle_height_vp(nonw(1)); grow,_pltmargin,pltitle_margin(nonw(1)); grow,_xytmargin,xytitle_margin(,nonw(1)); pltitle_height_vp = _pltheight; pltitle_margin = _pltmargin; xytitle_margin = _xytmargin; xs = sys(0).viewport(dif:1:2); ys = sys(0).viewport(dif:3:4); plticks = [systems(0).ticks.horiz.flags(1), systems(0).ticks.vert.flags(1)]; // adjust xytitle_margins xytitle_margin(1,0)= 0.015/xs^0.25- max(systems(0).ticks.vert.tickLen)*((plticks(2) & 0x010) > 0); xytitle_margin(2,0)= 0.021/ys^0.20- max(systems(0).ticks.horiz.tickLen)*((plticks(1) & 0x010) > 0); // adjust text height: sys(0).ticks.horiz.textStyle.height= \ sys(0).ticks.vert.textStyle.height = \ max([0.008,0.055*min([xs,ys])^1]); // adjust xytitle/pltitle text height: pltitle_height_vp(0)= sys(0).ticks.horiz.textStyle.height*900; // adjust pltitle_margin if ((plticks(1) & 0x010) > 0) { pltitle_margin(0)= max(sys(0).ticks.horiz.tickLen); } else { pltitle_margin(0) = 0.; } set_style,landscape, sys, legends, clegends; } func testViewports(void) { fma; x = span(0.,50.,200); y=1-cos(x)*exp(-x/5.); get_style,landscape, systems, legends, clegends; nviewports = numberof(systems); im = indgen(32)(-:1:32,)-16.; im = sqrt(im^2+transpose(im)^2.); for (i=1;i<=nviewports;i++) { plsys,i; if (nallof([systems(i).ticks.horiz.flags,systems(i).ticks.vert.flags])) { pli,im; limits; } else { plg,y*random()*1000.,x; xytitles_vp,"Time after shock [s]","Damping [N]"; plmargin,0.02; } pltitle_vp,swrite(format="Viewport %d",i),pos=-1; } redraw; } func plmargin(margin,xy) /* DOCUMENT plmargin(margin,xy) redefines the limits to leave a margin around the inner plot. Margin are in fraction of the plot width. Default 0.05. xy = 1 only sets margin for the x axis. xy = 2 only sets margin for the y axis. SEE ALSO: */ { if (is_void(margin)) margin=0.05; limits; l = limits(); x = l(2)-l(1); y = l(4)-l(3); x*=margin; y*=margin; if (xy==1) limits,l(1)-x,l(2)+x; \ else if (xy==2) range,l(3)-y,l(4)+y; \ else limits,l(1)-x,l(2)+x,l(3)-y,l(4)+y; } frigaut-yorick-yutils-c173974/poly.i000066400000000000000000000360351152651572200174350ustar00rootroot00000000000000/* * poly.i -- * * 1D and 2D polynomial routines (evaluation, fit, ...). * * Copyright and warranty: * Copyright (c) 1999, Eric THIEBAUT (thiebaut@obs.univ-lyon1.fr, Centre * de Recherche Astrophysique de Lyon, 9 avenue Charles Andre, F-69561 * Saint Genis Laval Cedex). * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., * 675 Mass Ave, Cambridge, MA 02139, USA). * * History: * $Id: poly.i,v 1.2 2008-02-15 18:41:59 frigaut Exp $ * $Log: poly.i,v $ * Revision 1.2 2008-02-15 18:41:59 frigaut * UTF-> ascii issue * * Revision 1.1.1.1 2007/12/11 23:55:13 frigaut * Initial Import - yorick-yutils * */ func poly1(x, c) /* DOCUMENT: poly1(x, c); Returns value of the 1D polynomial: C(1) + C(2)*X + C(3)*X^2 + ... SEE ALSO: poly, poly1_deriv, poly1_fit, poly2. */ { y= c((i= numberof(c))); while (--i>0) y= x*y + c(i); return y; } func poly1_deriv(x, c) /* DOCUMENT: y= poly1_deriv(x, c); Returns value of the derivative of the 1D polynomial: C(1) + C(2)*X + C(3)*X^2 + ... in other words: Y= C(2) + 2*C(3)*X + 3*C(4)*X^2 + ... SEE ALSO: poly1. */ { if ((n= numberof(c))==1) return array(0.0, dimsof(x)); return poly1(x, c(2:)*double(indgen(n-1))); } /*---------------------------------------------------------------------------*/ func poly2(x1, x2, c) /* DOCUMENT: poly2(x1, x2, c); Returns value of the 2D polynomial: C(1) + C(2)*X1 + C(3)*X2 + C(4)*X1^2 + C(5)*X1*X2 + C(6)*X2^2 + ... X1 and X2 must be conformable. For a 2D polynomial of degree 1, 2 or 3 (3, 6 and 10 coefficients respectively) poly2 uses hard-coded factorized expressions to minimize the number of operations. SEE ALSO: poly, poly1. */ { n= numberof(c); /* Optimized factorizations (just cut out this block if you don't want to use or don't trust the following expressions). */ #if 1 if (n <= 10) { if (n==3) return c(1)+c(2)*x1+c(3)*x2; if ((d1= dimsof(x1))(1)==(d2= dimsof(x2))(1) && allof(d1==d2)) { if (n==6) return c(1)+(c(2)+c(5)*x2+c(4)*x1)*x1+(c(3)+c(6)*x2)*x2; if (n==10) return c(1)+(c(2)+c(5)*x2+(c(4)+c(7)*x1+c(8)*x2)*x1)*x1+ (c(3)+(c(6)+c(9)*x1+c(10)*x2)*x2)*x2; } else { /* Use a different factorization to optimize number of operations. */ if (n==6) return c(1)+(c(2)+c(4)*x1)*x1+c(5)*x1*x2+(c(3)+c(6)*x2)*x2; if (n==10) return c(1)+(c(2)+(c(4)+c(7)*x1)*x1)*x1+ (c(3)+(c(6)+c(10)*x2)*x2)*x2+ (c(5)+c(8)*x1)*x1*x2+c(9)*x2*x2*x1; } } #endif /* For a 2D polynomial of degree M, there are N=(M+1)*(M+2)/2 coefficients. => M = (sqrt(8*N+1)-3)/2 */ m= long((sqrt(8*n+1)-2)/2); /* -2 (instead of -3) to get nearest integer */ /* Pre-compute powers of X1 and X2. */ xp1= array(pointer, m); xp1(1)= &(tmp1= x1); xp2= array(pointer, m); xp2(1)= &(tmp2= x2); for (k=2 ; k<=m ; k++) { xp1(k)= &(tmp1*= x1); xp2(k)= &(tmp2*= x2); } tmp1= tmp2= x1= x2= []; /* Current degree is: K=K1+K2=0..M; K1, K2 are the powers of X1 and X2. */ y= c((i= 1)); /* K=0, K1=0, K2=0 */ for (k=1 ; k<=m ; k++) { y+= c(++i) * (*xp1(k)); /* K1=K, K2=0 */ for (k1=k-1, k2=1 ; k1>0 ; k1--, k2++) y+= c(++i) * (*xp1(k1)) * (*xp2(k2)); /* K1=K-1..1, K2=1..K-1 */ y+= c(++i) * (*xp2(k)); /* K1=0, K2=K */ } if (i!=n) error, "bad number of coefficients"; return y; } func poly2_deriv(x1, x2, c) /* DOCUMENT drv= poly2_deriv(x1, x2, c); Return derivatives of 2D polynomial poly2(X1,X2,C) with respect to X1 and X2: DRV(..,1)= d poly2(X1,X2,C) / d X1 DRV(..,2)= d poly2(X1,X2,C) / d X2 BUGS: Only works for polynomials of degree 1 to 4 (needs factorization for degree 4). */ { dims= dimsof(x,y); dims(1)++; grow, dims, 2; drv= array(double, dims); n= numberof(c); if (n==14) { drv(..,1)= c(2) + 2*c(4)*x + c(5)*y + 3*c(7)*x*x + 2*c(8)*x*y + c(9)*y*y + 4*c(11)*x*x*x + 3*c(12)*x*x*y + 2*c(13)*x*y*y + c(14)*y*y*y; drv(..,2)= c(3) + c(5)*x + 2*c(6)*y + c(8)*x*x + 2*c(9)*x*y + 3*c(10)*y*y + c(12)*x*x*x + 2*c(13)*x*x*y + 3*c(14)*x*y*y + 4*c(15)*y*y*y; } else if (n==10) { drv(..,1)= c(2)+(2*c(4)+3*c(7)*x+2*c(8)*y)*x+(c(5)+c(9)*y)*y; drv(..,2)= c(3)+(c(5)+c(8)*x+2*c(9)*y)*x+(2*c(6)+3*c(10)*y)*y; } else if (n==6) { drv(..,1)= c(2)+2*c(4)*x+c(5)*y; drv(..,2)= c(3)+c(5)*x+2*c(6)*y; } else if (n==2) { drv(..,1)= c(2); drv(..,2)= c(3); } else { error, "bad number of coefficients"; } return drv; } /*---------------------------------------------------------------------------*/ /* NOTES ABOUT LEAST SQUARES FIT: * Chi2 = Sum_k( weight_k * (model_k - data_k)^2 ) * * d Chi2 d model_k * ------- = 2 Sum_k( weight_k * (model_k - data_k) * --------- ) * d alpha d alpha * */ func poly1_fit(y, x, m, w) /* DOCUMENT: c= poly1_fit(y, x, m); -or- c= poly1_fit(y, x, m, w); Returns coefficients of the 1D polynomial of degree M: C(1) + C(2)*X + C(3)*X^2 + ... + C(M+1)*X^M which best fits Y in the least squares sense: C = arg min sum(W*(poly1(X,C) - Y)^2) The weights W are optional (by default, W=1.0). The array X and Y must have the same shape. SEE ALSO: poly1. */ { if (structof(x)!=double) x= double(x); n= m+1; /* number of coefficients */ /* Compute powers of X. */ xp= array(pointer, n); if (is_void(w)) { xp(1)= &array(1.0); if (n>1) { xp(2)= &(tmp= x); for (i=3 ; i<=n ; i++) { xp(i)= &(tmp*= x); } } } else { /* Apply weights (if any, also do apply scalar weight to let the user rescale the problem in case of overflows). */ xp(1)= &(w= sqrt(w)); /* raise a SIGFPE if any of W < 0 */ if (n>1) { xp(2)= &(w * (tmp= x)); for (i=3 ; i<=n ; i++) { xp(i)= &(w * (tmp*= x)); } } y*= w; w= []; } tmp= x= []; /* Solve. */ return solve_lfit(y, xp); } /*---------------------------------------------------------------------------*/ func poly2_fit(y, x1, x2, m, w) /* DOCUMENT: c= poly2_fit(y, x1, x2, m); -or- c= poly2_fit(y, x1, x2, m, w); Returns the (M+1)*(M+2)/2 coefficients of the 2D polynomial of degree M: C(1) + C(2)*X1 + C(3)*X2 + C(4)*X1^2 + C(5)*X1*X2 + C(6)*X2^2 + ... which best fits Y in the least squares sense: C = arg min sum(W*(poly2(X1,X2,C) - Y)^2) The weights W are optional (by default, W=1.0). SEE ALSO: poly2. */ { if (structof(x1)!=double) x1= double(x1); if (structof(x2)!=double) x2= double(x2); /* Pre-compute powers of X1 and X2. */ xp1= array(pointer, m); xp1(1)= &(tmp1= x1); xp2= array(pointer, m); xp2(1)= &(tmp2= x2); for (k=2 ; k<=m ; k++) { xp1(k)= &(tmp1*= x1); xp2(k)= &(tmp2*= x2); } tmp1= tmp2= x1= x2= []; /* Compute powers: X1^K1 * X2^K2 (with current degree K = K1+K2 = 0..M). */ n= (m+1)*(m+2)/2; /* number of coefficients */ xp= array(pointer, n); if (is_void(w)) { xp((i= 1))= &array(1.0); /* K=0, K1=0, K2=0 */ for (k=1 ; k<=m ; k++) { xp(++i)= xp1(k); /* K1=K, K2=0 */ for (k1=k-1, k2=1 ; k1>0 ; k1--, k2++) xp(++i)= &(*xp1(k1) * *xp2(k2)); /* K1=K-1..1, K2=1..K-1 */ xp(++i)= xp2(k); /* K1=0, K2=K */ } } else { /* Apply weights (if any, also do apply scalar weight to let the user rescale the problem in case of overflows). */ w= sqrt(w); /* SIGFPE if any of W < 0 */ xp((i= 1))= &w; /* K=0, K1=0, K2=0 */ for (k=1 ; k<=m ; k++) { xp(++i)= &(w * *xp1(k)); /* K1=K, K2=0 */ for (k1=k-1, k2=1 ; k1>0 ; k1--, k2++) xp(++i)= &(w * *xp1(k1) * *xp2(k2)); /* K1=K-1..1, K2=1..K-1 */ xp(++i)= &(w * *xp2(k)); /* K1=0, K2=K */ } y*= w; w= []; } xp1= xp2= []; /* Solve. */ return solve_lfit(y, xp); } /*---------------------------------------------------------------------------*/ func solve_lfit(y, yp, w) /* DOCUMENT x= solve_lfit(data, ptr); -or- x= solve_lfit(data, ptr, wght); Return solution of a weighted least square linear fit: X= arg min sum( WGHT * (MODEL(X) - DATA)^2 ) where the model is obtained by linear combination of the "basic model components" stored in the array of pointers PTR: MODEL(X)= X(1) * *PTR(1) + ... + X(N) * *PTR(N) where N=numberof(PTR). Each component *PTR(i) must be conformable with the DATA array. If the weights WGHT array is missing, the result is the same as with WGHT=1.0 (actually WGHT set to any strictly positive scalar yields the same result). SEE ALSO: poly1_fit, poly2_fit. */ { n= numberof(yp); /* Apply weights (if any, also do apply scalar weight to let the user rescale the problem in case of overflows). */ if (! is_void(w)) { yp= tmp= yp; /* Make a local copy, so that further assignations like YP(i)= ... do not affect the contents of PTR for the caller. */ w= sqrt(w); /* SIGFPE if any of W negative */ for (i=1 ; i<=n ; i++) yp(i)= &(w * *yp(i)); y*= w; w= tmp= []; } /* Compute left hand-side matrix A and right-hand side vector B. */ a= array(double, n, n); b= array(double, n); one= array(1.0, dimsof(y)); /* Multiplying by this array ensure that all the *YP(i) and Y have the same shape, being conformable is not sufficient, because the sum(...)'s below would be incorrect. */ for (i=1 ; i<=n ; i++) { b(i)= sum(y * (ypi= one * *yp(i))); for (j=1 ; j numberof(y)) y*= array(1.0, dimsof(x)); n= numberof(x); if (is_void(w)) { w= array(1.0, dimsof(y)); } else { if (numberof(w) < numberof(y)) w*= array(1.0, dimsof(y)); if (numberof((i= where(w>0))) != n) { if (!is_array(i) || anyof(w<0)) error, "bad weight W"; w= w(i); x= x(i); y= y(i); n= numberof(x); } } if (numberof(degree)==2) { degree_min= min(degree); degree_max= max(degree); } else if (numberof(degree)==1) { degree_min= 0; degree_max= degree; } else { degree_min= 0; degree_max= n-2; } if (degree_min<0) error, "DEGREE_MIN too small"; if (degree_max>n-2) error, "DEGREE_MAX too large"; if (get_info) { out= array(double, 2, degree_max-degree_min+1); out(1,)= indgen(degree_min:degree_max); } if (verbose) { s= " DEGREE:"; for (degree=degree_min ; degree<=degree_max ; degree++) { s+= swrite(format=" %-3d", degree); } write, format="%s\n%s", s, " GCV CHI2:"; } best_chi2= -1; best_degree= -1; sw= sum(w); for (degree=degree_min ; degree<=degree_max ; degree++) { for (chi2=0.0, i=1 ; i<=n ; i++) { wp= w; wp(i)= 0; chi2+= w(i) * (y(i) - poly1(x(i), poly1_fit(y, x, degree, wp)))^2; } gcv_rms= sqrt(chi2 / sw); if (verbose) write, format=" %8.3g", gcv_rms; if (get_info) out(2, degree-degree_min+1)= gcv_rms; /* With same CHI2, we favor the least polynomial degree: to be retained, the new CHI2 must be STRICTLY LESS than the previous one. */ if (best_chi2<0 || chi2 "; return; } /* must be prepared for python output to dribble back a fraction of * a line at a time, or multiple lines at a time * _pyk_linebuf holds the most recent incomplete line, * assuming the the remainder will arrive in future callbacks */ _pyk_linebuf += line; selist = strword(_pyk_linebuf, "\n", 256); line = strpart(_pyk_linebuf, selist); line = line(where(line)); n = numberof(line); if (n && selist(2*n)==strlen(_pyk_linebuf)) { /* final character of input not \n, store fragment in _pyk_linebuf */ _pyk_linebuf = line(0); if (n==1) return; line = line(1:-1); } else { _pyk_linebuf = string(0); } strtrim, line; line = line(where(strlen(line))); if (pyk_debug) write, "from python:", line; /* record whether final line is a sync message, remove it */ mask =(line != "-s+y-n+c-+p-y+k-"); synchronized = !allof(mask); line = line(where(mask)); nofline = numberof(line); /* parse and execute yorick command lines */ for (i=1 ; i<=nofline ; i++) funcdef(line(i)); /* permit pyk function to continue after successful synchronization */ if (synchronized && _pyk_sync) { _pyk_sync = 0; resume; } } frigaut-yorick-yutils-c173974/pyk.py000077500000000000000000000006431152651572200174540ustar00rootroot00000000000000#!/usr/bin/env python def pyk(self,msg): # sends string command to yorick sys.stdout.write(msg) sys.stdout.flush() # if this flag set, yorick is blocked waiting for tyk_resume _tyk_blocked=0 def pyk_sync(self): _tyk_blocked=1 sys.stdout.write('-s+y-n+c-+p-y+k-') sys.stdout.flush() def pyk_resume(self): sys.stdout.write('pyk_resume'+msg) sys.stdout.flush() _tyk_blocked=0 frigaut-yorick-yutils-c173974/random_et.i000066400000000000000000000217531152651572200204230ustar00rootroot00000000000000/* random_et.i: random number for Yorick * * Copyright (c) 1996, Eric THIEBAUT (thiebaut@obs.univ-lyon1.fr, Centre de * Recherche Astrophysique de Lyon, 9 avenue Charles Andre, F-69561 Saint * Genis Laval Cedex). * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * HISTORY * Nov. 22, 1995 by Eric THIEBAUT: * - random_normal * - random_poisson * - kolmogorov * Nov. 27, 1995 by Eric THIEBAUT: * - fixed a bug for the borders in kolmogorov * $Id: random_et.i,v 1.1 2007-12-11 23:55:12 frigaut Exp $ */ require, "gamma.i"; local random_normal_prev; /* DOCUMENT random_normal_prev= [] if not nil, is the previous value computed by random_normal. */ random_normal_prev= []; func random_uniform(dims, seed=) /* DOCUMENT random_uniform(dimemsion_list, seed=) returns an array of uniformly distributed random double values with the given DIMENSION_LIST (nil for a scalar result). Keyword SEED is a scalar between 0.0 and 1.0 non-inclusive and is used to reinitialized the random sequence. If SEED is out of range, the sequence is reinitialized as when Yorick starts. SEE ALSO: random, random_poisson, random_normal_prev. */ { if (!is_void(seed)) random_seed, seed; return random(dims); } func random_normal(dims, seed=) /* DOCUMENT random_normal(dimemsion_list) returns an array of normally distributed random double values with the given DIMENSION_LIST (nil for a scalar result). Keyword SEED is a scalar between 0.0 and 1.0 non-inclusive and is used to reinitialized the random sequence. If SEED is out of range, the sequence is reinitialized as when Yorick starts. The algorithm follows the Box-Muller method (see Numerical Recipes by Press et al.). SEE ALSO: random, random_poisson, random_normal_prev. */ { if (!is_void(seed)) random_seed, seed; if (is_void(dims)) { if (is_void(random_normal_prev)) { while (!(v1= random())); v1= sqrt(-2.*log(v1)); v2= (2.*pi)*random(); random_normal_prev= v1*sin(v2); return v1*cos(v2); } else { a= random_normal_prev; random_normal_prev= []; } } else { a= array(0., dims); if ((n= numberof(a)) % 2) a(0)= random_normal(); if ((n /= 2)) { i= where(!(v1= random(n))); while ((ni= numberof(i))) { j= where(!(v1(i)= random(ni))); i= numberof(j) ? i(j) : []; } v1= sqrt(-2.*log(v1)); v2= (2.*pi)*random(n); a(1:n)= v1*cos(v2); a(n+1:2*n)= v1*sin(v2); } } return a; } func random_poisson(xm, seed=, threshold=) /* DOCUMENT random_poisson(mean) returns an array of random double values which follow a Poisson law of parameter MEAN (the output has the same geometry of the input). Keyword SEED is a scalar between 0.0 and 1.0 non-inclusive and is used to reinitialized the random sequence. If SEED is out of range, the sequence is reinitialized as when Yorick starts. The code is adapted from `POIDEV' an IDL routine by Wayne Landsman and the algorithm is from Numerical Recipes by Press et al. SEE ALSO: random, random_normal. */ { if (is_void(threshold)) threshold= 20; if (!is_void(seed)) random_seed, seed; if (!(N= numberof(xm))) error, "ERROR - Poisson mean vector is undefined"; if (N == 1 && dimsof(xm)(1) == 0) { output_is_scalar= 1n; xm= [xm]; } else { output_is_scalar= 0n; } Ni= numberof((i= where(xm <= threshold))); if (Ni > 0) { g= exp(-xm(i)); // To compare with exponential distribution em= array(-1, Ni); // Counts number of events t= array(1., Ni); // Counts (log) of total time Nk= Nj= Ni; // J indexes the original array, k= j= indgen(Ni); // K indexes the J vector for (;;) { em(j)++; // Increment event counter t= t(k)*random(Nk); // Add exponential deviate, equivalent // to multiplying random deviate k= where(t > g(j)); // Has sum of exponential deviates //exceeded specified mean? if (!(Nk= numberof(k))) break; j= j(k); Nj= Nk; } } output= array(double, dimsof(xm)); if (Ni > 0) output(i)= em; if (Ni == N) return (output_is_scalar ? output(1) : output); Ni= numberof((i = where(xm > threshold))); xi= xm(i); sq = sqrt(2.*xi); alxm= log(xi); g= xi * alxm - ln_gamma(xi+1.); k= j= indgen((Nk= Nj= Ni)); em= y= array(double, Nj); for (;;) { for (;;) { y(j)= tan(pi * random(Nj)); l= where((em(j)= floor(sq(j)*y(j) + xi(j))) < 0.); if (!(Nj= numberof(l))) break; j= j(l); } t = 0.9*(1.+y(k)^2)*exp(em(k)*alxm(k)-ln_gamma(em(k)+1.)-g(k)); l = where(random(Nk) > t); if (!(Nk= numberof(l))) break; j= k= k(l); Nj= Nk; } output(i)= em; return (output_is_scalar ? output(1) : output); } func kolmogorov(diam, r0, all=, orig=, seed=) /* DOCUMENT kolmogorov(diam, r0, all=, orig=, seed=) kolmogorov(diam, all=, orig=, seed=) returns an array of random phases which follow Kolmogorov law on a square pupil of DIAM pixels per side with a Fried's parameter equal to R0 (in pixels, default is to set R0=DIAM). If a Point Spread Function is to be calculated from the generated phase screen, it should be conveniently sampled (i.e., R0 greater or equal 2 or 3 pixels). The algorithm is the mid-point method of R.G. Lane, A. Glindemann and J.C. Dainty (``Simulation of a Kolmogorov phase screen'' in Waves in Random Media, 2, 209-224, 1992). Keyword ORIG is a flag which indicates whether or not the original method by Lane et al. should be used (default is to use the original algorithm). Keyword ALL is a flag which indicates whether or not all the computed phase screen should be returned. The default behaviour is to return the smallest array into which a pupil with diameter DIAM can fit. The computed phase screen is a (2^N+1)*(2^N+1) array. Keyword SEED is a scalar between 0.0 and 1.0 non-inclusive and is used to reinitialized the random sequence. If SEED is out of range, the sequence is reinitialized as when Yorick starts. SEE ALSO: random_normal. */ { diam= double(diam); if (is_void(r0)) r0= diam; // default is to have R0=DIAM if (is_void(orig)) orig=1n; // default is to use original algorithm if (is_void(all)) all=0n; // default is to return a DIAM*DIAM array if (!is_void(seed)) random_seed, seed; n=2^long(ceil(log(diam-1.)/log(2.))); delta = sqrt(6.88*(diam/double(r0))^(5./3.)); diam= long(ceil(diam)); // size of the minimum array which holds the // phase screen over the pupil beta = 1.7817974; c1 = 3.3030483e-1*delta; c2 = 6.2521894e-1*delta; c3 = 5.3008502e-1*delta; c4 = 3.9711507e-1*delta; if (orig) { c5 = 4.5420202e-1*delta; } else { c5 = 4.4355177e-1*delta; l5 = 4.5081546e-1; m5 = 9.8369088e-2; } a = random_normal([2,n+1,n+1]); b = c2*random_normal(2); // 4 first corners a(1,1) = c1*a(1,1)+b(1); a(0,0) = c1*a(0,0)-b(1); a(0,1) = c1*a(0,1)+b(2); a(1,0) = c1*a(1,0)-b(2); // all other points h = n; while (h >= 2) { s = h; // step size h /= 2; // half the step size c3 /= beta; c4 /= beta; c5 /= beta; i= indgen(h+1:n+1-h:s); // mid-point coordinates ip= i-h; // coordinates of previous point in= i+h; // coordinates of next point // centre of squares a(i,i) = c3*a(i,i) + .25*(a(ip,ip)+a(ip,in)+a(in,ip)+a(in,in)); if (2*s <= n) { // centre of losanges j= indgen(s+1:n+1-s:s); // vertice coordinates jp= j-h; // coordinates of previous point jn= j+h; // coordinates of next point a(i,j) = c4*a(i,j) + .25*(a(i,jp)+a(i,jn)+a(ip,j)+a(in,j)); a(j,i) = c4*a(j,i) + .25*(a(j,ip)+a(j,in)+a(jp,i)+a(jn,i)); } // borders if (orig) { a(1,i) = c5*a(1,i) + .5*(a(1,ip)+a(1,in)); a(0,i) = c5*a(0,i) + .5*(a(0,ip)+a(0,in)); a(i,1) = c5*a(i,1) + .5*(a(ip,1)+a(in,1)); a(i,0) = c5*a(i,0) + .5*(a(ip,0)+a(in,0)); } else { a(1,i) = c5*a(1,i) + l5*(a(1,ip)+a(1,in))+m5*a(h,i); a(0,i) = c5*a(0,i) + l5*(a(0,ip)+a(0,in))+m5*a(-h,i); a(i,1) = c5*a(i,1) + l5*(a(ip,1)+a(in,1))+m5*a(i,h); a(i,0) = c5*a(i,0) + l5*(a(ip,0)+a(in,0))+m5*a(i,-h); } } return (all ? a : a(1:diam, 1:diam)); } frigaut-yorick-yutils-c173974/rdcols.i000066400000000000000000000240431152651572200177340ustar00rootroot00000000000000/* * rdcols.i -- $Id: rdcols.i,v 1.1 2007-12-11 23:55:12 frigaut Exp $ * routines to assist in reading columns from ascii files * * Author: David Munro * Written 2002 * * Copyright (c) 2002, David Munro * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). */ func rdcols(f, ncols, width=, delim=, type=, missing=, marker=, comment=, nskip=, nlines=) /* DOCUMENT cols = rdcols(f) * or cols = rdcols(f, ncols) * eq_nocopy, col1, *cols(1) * eq_nocopy, col2, *cols(2) * ... * eq_nocopy, colN, *cols(ncols) * * cracks ascii file F into NCOLS columns, returning an array of * pointers to the columns. A "column" is defined by either its * width in characters, or by the appearance of a delimiting * character (such as a blank, a comma, or a tab). Multiple * delimiting characters may either be skipped (as usual if the * character is a blank), or may represent a number of empty * columns (as for reading a typical text file exported from a * spreadsheet or database program). * * rdcols returns an array of pointers COLS, with *COLS(i) the * contents of the i-th column. The NCOLS parameter may be omitted * in which case rdcols will guess the number of columns. * * F may be either a file handle or a filename. * * nskip=m skip the first M lines of the file (M=0 by default) * nlines=n read only the first M+N lines of the file * comment=text interpret lines beginning with TEXT (possibly preceded * by blanks) as comments (blank lines are always comments) * width=w column width, or list of widths (w=0 means any width) * delim=d column delimiters (as for strtok), or list of delimiters * type=t column type, or list of types * t=0 means guess, t=1 means string, t=2 means integer, t=3 means real, * t=4 means either integer or real * marker=k marker column delimiters (as for strtok) * missing=m missing value, or list of values * for empty numeric columns * * The width=, delim=, type=, and missing= keywords may either be scalar * values to apply to every column, or lists to apply to successive * columns. The marker= keyword is similar to the delim= keyword, * except that multiple consecutive occurrences indicate empty * columns. If any list is shorter than NCOLS, its final value * applies to all remaining columns. If any list is longer than * NCOLS, its trailing values are silently ignored. * * By default, width=0. Non-zero width is very tricky, since a * column begins wherever the previous column ended; if the previous * column had width=0, its delimiter is treated as a part of it, so * it is not included in the width count. Consequently, the width= * keyword is best suited to situations in which only the final * width value is 0. * * By default, marker=[]. If present, then every column is delimited * by a character in marker, and every occurrence of such a character * indicates a new column. Use marker="\t" to read tab-delimited text * files exported from a spreadsheet or database program. Non-zero * width= values supersede marker=, but delim= is ignored if marker * is present. * * By default, delim=" \t", and type=0, so that blanks and tabs delimit * columns, and rdcols guesses whether a column contains string or * numeric data. A numeric column ends at the first character that * cannot be interpreted as part of the number, whether or not that is * a character in delim. If you use type= to force a numeric column, * empty rows or rows which are not numbers get the value 0.0 by * default, or the value specified by the missing= keyword. Missing * values in string columns always get the value "". * * If you need finer control of the returned types than provided by * the type= keyword, see rdconvert. * * SEE ALSO: read, rdline, rdconvert */ { if (structof(f) == string) f = open(f); if (is_void(ncols)) nc = 1; else if (ncols < 1) return []; else nc = ncols; result = array(pointer, nc); if (!is_void(nskip) && nskip>0) rdline, f, nskip; arb = is_void(nlines); if (arb) nlines = 10000; if (nlines < 1) return result; /* ingest entire file as string array * note each read grabs twice as many lins as previous, * so grow operation scales as nlines*log(nlines), which is ok */ lines = _rc_rdline(f, nlines); if (arb) { for (l=lines ; ; nlines*=2) { l = _rc_rdline(f, nlines); grow, lines, l; if (numberof(l) < nlines) break; } } if (!numberof(lines)) return result; /* remove blank and comment lines */ tok = strtok(lines)(1,); mask = !tok; if (is_void(comment) && is_void(marker)) comment = "#"; if (comment && strlen(comment)) { comment = strtok(comment)(1); mask |= strpart(tok, 1:strlen(comment))==comment; } if (anyof(mask)) { list = where(!mask); if (!numberof(list)) return result; lines = lines(list); } if (is_void(width)) width = 0; else width = long(width); nw = numberof(width); if (is_void(type)) type = 0; else type = long(type); nt = numberof(type); if (is_void(missing)) missing = 0.0; else missing = double(missing); nm = numberof(missing); if (is_void(delim)) delim = is_void(marker)? " \t" : string(0); nk = 0; if (!is_void(marker)) { if (strlen(marker) > 0) { nk = 1; /* valid is a character not in marker */ valid = strtok(string(&char(indgen(255))), marker)(1); valid = strpart(valid,1:1); } else { marker = []; } } nd = numberof(delim); for (i=1 ; ; i++) { w = width(min(i,nw)); d = delim(min(i,nd)); if (!strlen(d)) d = string(0); t = type(min(i,nt)); m = missing(min(i,nm)); if (w > 0) { /* column delimited by its width */ lines = strpart(lines, w+1:0); col = _rc_convert(strpart(lines, 1:w), t, m); } else if (nk) { /* column delimited by marker= */ col = strtok(valid+lines, marker); lines = col(2,); col = _rc_convert(strpart(col(1,),2:0), t, m); } else { /* column delimited by delim= */ col = _rc_convert(lines, t, m, d, lines); } result(i) = &col; if (!is_void(ncols) && i==ncols) break; if (noneof(strlen(lines))) break; if (i == nc) { grow, result, array(pointer, nc); nc *= 2; } } if (is_void(ncols)) result = result(1:i); return result; } func rdconvert(cols, ..) /* DOCUMENT rdconvert, cols, type1, type2, type3, ... * or cols = rdconvert(cols, type1, type2, type3, ...) * * converts the data types of the COLS, so that COLS(1) becomes * TYPE1, COLS(2) TYPE2, COLS(3) TYPE3, and so on. The COLS * array is an array of pointers as returned by rdcols. If any * of the TYPEi is nil, that column is not altered. This function * is only useful if you are not satisfied with either the long * or double types returned by rdcols, e.g.- * cols = rdcols("datafile", 5); * rdconvert, cols, , short, float, , int; * * SEE ALSO: rdcols */ { for (i=1 ; more_args() ; i++) { type = next_arg(); if (!is_void(type)) cols(i) = &type(*cols(i)); } return cols; } func _rc_rdline(f, nlines) { /* read at most nlines lines from f */ lines = rdline(f, nlines); n = sum(!lines); if (n) { nlines -= n; lines = nlines? lines(1:nlines) : []; } return lines; } func _rc_guess(lines) { tok = strtok(lines, " \t")(1,); t = strpart(tok, 1:1); list = where((t=="-") | (t=="+")); if (numberof(list)) { tok(list) = x = strpart(tok(list), 2:0); t(list) = strpart(x, 1:1); } list = where(t=="."); if (numberof(list)) t(list) = strpart(tok(list), 2:2); guess = ((t>="0") & (t<="9")); list = where(guess); if (numberof(list)) { tok = tok(list); t = strpart(strtok(tok, "0123456789")(1,), 1:1) r = (t=="."); maybe = where((t=="e") | (t=="E") | (t=="d") | (t=="D")); if (numberof(maybe)) { u = strtok(tok(maybe), "eEdD")(2,); t = strpart(u, 1:1); l = where((t=="-") | (t=="+")); if (numberof(l)) t(l) = strpart(u(l), 2:2); r(maybe) = ((t>="0") & (t<="9")); } guess(list) += r; } /* 1 where string, 2 where integer, 3 where real */ return guess+1; } func _rc_convert(lines, type, missing, delim, &remains) { if (type != 1) { guess = _rc_guess(lines); if (type == 0) { /* if more than 80% of a column is numbers, guess it is numbers */ if (sum(guess==1)>numberof(lines)/5) type = 1; else if (anyof(guess==3)) type = 3; else type = 2; } else if (type!=2 && type!=3) { if (anyof(guess==3)) type = 3; else type = 2; } } if (type == 1) { if (delim) { lines = strtok(lines, delim); remains = lines(2,); lines = lines(1,); } else { remains = array(string, numberof(lines)); } return lines; } /* change non-numeric lines into numeric ones */ list = where(guess==1); if (numberof(list)) { vals = lines(list); lines(list) = "0"+vals; if (delim) rems = strtok(vals, delim)(2,); } /* make sure all lines have at least one non-numeric char at end */ lines += "?"; vals = array(0.0, numberof(lines)); remains = array(string, numberof(lines)); if (sread(lines,format="%le%[^\n]",vals,remains) != 2*numberof(lines)) error, "impossible error during rdcols()"; remains = strpart(remains, 1:-1); if (numberof(list)) { vals(list) = missing; if (delim) remains(list) = rems; } if (type == 2) vals = long(vals); return vals; } frigaut-yorick-yutils-c173974/rgb.i000066400000000000000000000173331152651572200172240ustar00rootroot00000000000000/* * rgb.i -- * * Deal with X11 color database in Yorick. * *----------------------------------------------------------------------------- * * Copyright (c) 1995-2003 Eric THIEBAUT. * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * History: * $Id: rgb.i,v 1.1 2007-12-11 23:55:12 frigaut Exp $ * $Log: rgb.i,v $ * Revision 1.1 2007-12-11 23:55:12 frigaut * Initial revision * * Revision 1.1 2003/08/23 12:41:48 eric * Initial revision * *----------------------------------------------------------------------------- */ func rgb_load(nil) /* DOCUMENT rgb_load; -or- db = rgb_load(); Loads RGB color database (from X11 distribution). When called as a subroutine, the external symbol "rgb" get defined. The database can be used as follows: plg, y, x, color=rgb.light_goldenrod plg, y, x, color=rgb.dark_slate_grey The color names are all lower case with un underscore to separate words. If you prefer using global names for _all_ RBG colors then just include "rgb1.i" (then the color names are prefixed with "rgb_"): include, Y_USER+"rgb1.i"; plg, y, x, color=rgb_goldenrod; SEE ALSO: rgb_build_databases. */ { if (is_func(h_new) == 2) { if (!open(Y_USER+"rgb3.i","r",1)) \ error,"rgb3.i does not exist, run rgb_build_databases()"; /* use hash table */ include, Y_USER+"rgb3.i", 1; db = _rgb_hash(); } else { if (!open(Y_USER+"rgb2.i","r",1)) \ error,"rgb2.i does not exist, run rgb_build_databases()"; /* use structure */ include, Y_USER+"rgb2.i", 1; db = _rgb_struct(); } if (am_subroutine()) { extern rgb; eq_nocopy, rgb, db; } else { return db; } } func rgb_build_databases(file) /* DOCUMENT rgb_build_databases -or- rgb_build_databases, file; Builds RGB database files "rgb.txt", "rgb1.i", "rgb2.i", and "rgb3.i" in directory Y_USER from X11 RGB database FILE (default "/usr/X11R6/lib/X11/rgb.txt"). Existing files get overwritten. SEE ALSO: rgb_load, rgb_uncapitalize. */ { write, "This will overwrite files: rgb.txt, rgb1.i, rgb2.i, and rgb3.i in "+Y_USER; s = string(0); read, prompt=" Are sure you want to continue? [y/n] ", s; if (s != "y" && s != "Y") return; /* Sort and clean-up RGB database. */ if (is_void(file)) { if (open("/usr/X11R6/lib/X11/rgb.txt","r",1)) \ file = "/usr/X11R6/lib/X11/rgb.txt"; if (open("/usr/share/X11/rgb.txt","r",1)) \ file = "/usr/share/X11/rgb.txt"; if (open("/usr/lib/X11/rgb.txt","r",1)) \ file = "/usr/lib/X11/rgb.txt"; if (open("/etc/X11/rgb.txt","r",1)) \ file = "/etc/X11/rgb.txt"; } if (is_void(file)) error,"Can not find rgb.txt"; if (structof(file) == string) file = open(file); shortname = "rgb.txt"; longname = Y_USER + shortname; write, format=" Writing \"%s\"...\n", longname; if (open(longname, "r" , 1)) remove, longname; output = popen("sort -u -b -k 4 > "+Y_USER+"rgb.txt", 1); r = g = b = 0; s1 = s2 = s3 = s4 = s5 = string(0); number = 0; while ((line = rdline(file))) { n = sread(line, format="%d%d%d%s%s%s%s%s", r, g, b, s1, s2, s3, s4, s5); if (n < 4) continue; name = rgb_uncapitalize(s1); if (n >= 5) name += "_" + rgb_uncapitalize(s2); if (n >= 6) name += "_" + rgb_uncapitalize(s3); if (n >= 7) name += "_" + rgb_uncapitalize(s4); if (n >= 8) name += "_" + rgb_uncapitalize(s5); write, output, format="%3d %3d %3d %s\n", r, g, b, name; ++number; //write, output, format="_%-22s = [%3dn,%3dn,%3dn];\n", name, r, g, b; } close, output; /* other wise rgb.txt may be empty or incomplete */ /* Re-parses clean database and creates the Yorick files. */ file = open(Y_USER+"rgb.txt"); names = array(string, number); rgb = array(char, 3, number); r = g = b = 0; name = string(0); number = 0; while ((line = rdline(file))) { if (sread(line, format="%d%d%d%s", r, g, b, name) == 4) { ++number; rgb(1, number) = r; rgb(2, number) = g; rgb(3, number) = b; names(number) = name; } } close, file; write, format=" Found %d colors in new database.\n", number; /* Write the Yorick files. */ shortname = "rgb1.i"; longname = Y_USER + shortname; write, format=" Writing \"%s\"...\n", longname; file = open(longname, "w"); write, file, format="/* %s\n * %s\n */\n", "rgb1.i - Color database with global names (automatically build", " by rgb_parse in rgb.i)."; for (i=1 ; i<=number ; ++i) { write, file, format="rgb_%-22s = [%3dn,%3dn,%3dn];\n", names(i), rgb(1, i), rgb(2, i), rgb(3, i); } write, file, format="/* end of %s */", shortname; close, file; shortname = "rgb2.i"; longname = Y_USER + shortname; write, format=" Writing \"%s\"...\n", longname; file = open(longname, "w"); write, file, format="/* %s\n * %s\n */\n", "rgb2.i - Color database using Yorick structure (automatically build", " by rgb_parse in rgb.i)."; write, file, format="\n%s\n%s\n", "/* Definition of RGB structure. */", "struct _RGB_STRUCT {"; write, file, format=" char %s(3);\n", names(1:number); write, file, format="%s\n\n%s\n%s\n%s\n%s\n", "}", "func _rgb_struct(nil)", "/* DOCUMENT _rgb_struct() - Returns instanciated RGB structure. */", "{", " return _RGB_STRUCT("; for (i=1 ; i<=number ; ++i) { write, file, format=" %-22s = [%3d,%3d,%3d]%s\n", names(i), rgb(1, i), rgb(2, i), rgb(3, i), (i "dark_slate_blue" "DarkSlateBlue" -> "dark_slate_blue" SEE ALSO: rgb_build_databases. */ { (lower = char(indgen(0:255)))(1+'A':1+'Z') = lower(1+'a':1+'z'); n = numberof((r = array(string, dimsof(s)))); for (i=1; i<=n; ++i) { w1 = *pointer(s(i)); len = numberof(w1); if (len) { w2 = array(char, 2*len-1); j2 = 0; for (j1=1 ; j1= 'A' && c <= 'Z') { c = lower(1 + c); if (j1 != 1) w2(++j2) = '_'; } w2(++j2) = c; } r(i) = string(&w2); } } return r; } /*---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/tws.i000066400000000000000000000130551152651572200172640ustar00rootroot00000000000000/* * TWS.I Tiny Widget Set. * * $Id: tws.i,v 1.1 2008-01-04 15:04:37 frigaut Exp $ * * Provides simplistic routines to build simplistic, almost graphical user * interfaces. Currently supports simplisitic "buttons". * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: tws.i,v $ * Revision 1.1 2008-01-04 15:04:37 frigaut * - added tws*.i from thibaut * * */ require,"graphk.i"; require,"tws_root.i"; require,"tws_grid.i"; require,"tws_button.i"; require,"tws_field.i"; require,"tws_radio.i"; require,"tws_label.i"; extern tws; /* DOCUMENT tws_init, tws_button, tws_handler are the useful routines. Tiny Widget Set. Provides simplistic routines to build simplistic, almost graphical user interfaces. Currently supports simplisitic "buttons". See Cubeview for sample usage. You normally call tws_init once, then tws_button for each button, then tws_handler. Basic sample usage: // Define your handler: func my_handler(uname,button){ if (button==1) { // mouse button 1 performs action if (uname=="hello") write,"Hello World!"; if (uname=="quit") return 2; return 0; } else { // Any other button performs contextual help if (uname=="hello") write,"Click on this button to write \"Hello World!\""; if (uname=="quit") write,"Click on this button to quit"; return 0; } } // Create base widget: tws_init,0,1,2; // Create two buttons: tws_button,"Hello World!",uname="hello"; tws_button,"Quit",uname="quit"; // Call the handler: tws_handler,"my_handler"; // Enjoy. */ func tws_addtoparent(parent,self) { a=*(parent->children); if (is_void(a)) a=[self]; else grow,a,[self]; parent->children=&a; } func tws_isinrect(position,point) { llx=min(position(1),position(3)); urx=max(position(1),position(3)); lly=min(position(2),position(4)); ury=max(position(2),position(4)); return ((point(1) > llx) && (point(1) < urx) && (point(2) > lly) && (point(2) < ury)); } func plrect(x0,y0,x1,y1,keywords=) // need to call plgk instead of plhk for more eye candy. Move plrect into graphk.i { if (is_void(keywords)) keywords=GraphK(closed=&long(1),marks=&long(0)); else if (keywords.closed==pointer()) keywords.closed=&long(1); if (is_void(y0)) { pos=x0; x0=pos(1); y0=pos(2); x1=pos(3); y1=pos(4); } else if (is_void(x1)) { y1=y0(2); x1=y0(1); y0=x0(2); x0=x0(1); } plgk,[y0,y0,y1,y1],[x0,x1,x1,x0],keywords=keywords; } func tws_plid(widget) { widget->cur_plid++; return widget->cur_plid; } func tws_action(widget) { return symbol_def(widget->type); } func tws_handler(root,handler) /* DOCUMENT tws_handler,handler Once your control panel has been created using TWS_INIT and TWS_BUTTON, call TWS_HANDLER to start event loop. HANDLER must be a string, the name of a routine written by you that will do the real job. Sample HANDLER routine: func my_handler(uname,button) { write,"Hello world!"; return 0; } (See "help,tws" for a slightly more complete example, see Cubeview for a useful one.) Each time a button is pressed in the control panel, your home made handler is called with two arguments (which your handler must accept even if it doesn't use them): UNAME: the user name of the tws_button which has been pressed. BUTTON: the ID of the mouse button that has been used. (See MOUSE) From these to informations, your handler must do its job, for instance run contextual help if right button has been used, and run the approriate action if left button has been pressed. The tws_button which has been pressed is blue untill your handler returns a value: this is to let the user know that the corresponding action is running. Pressing another button at that time does normally nothing. Your handler must return a value. The loop lasts as long as this value is 0. Any other value makes TWS_HANDLER exit, a value of 2 makes TWS_HANDLER kill the command window and exit, which is nice. Think of it as "quit", but keep in mind that YOUR handler must do any house keeping job before returning this value. */ { res=0; window,(root->wid); while (res==0) { result=mouse(1,0,""); button=long(result(10)); if (button != 0) { event=tws_action(root)(root,action="GetEvent",mouse=result); if (!is_void(event)) { rien=tws_action(event.widget)(event.widget,action="Activate"); res=symbol_def(handler)(event); window,(root->wid); rien=tws_action(event.widget)(event.widget,action="Deactivate"); } } } if (res==2) winkill,root->wid; } func tws_realize(root,nokill=) { rien=tws_action(root)(root,action="Realize",nokill=nokill); } frigaut-yorick-yutils-c173974/tws_button.i000066400000000000000000000054361152651572200206630ustar00rootroot00000000000000/* * TWS_Button.I Tiny Widget Set Button. * Buttons for the Tiny Widget Set. See tws.i * * $Id: tws_button.i,v 1.1 2008-01-04 15:04:37 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: tws_button.i,v $ * Revision 1.1 2008-01-04 15:04:37 frigaut * - added tws*.i from thibaut * * */ struct TWS_Button /* DOCUMENT TWS_Button */ { string type,uname; pointer root,parent; // A button has no children double position(4); string label; long label_id,frame_id; } struct TWS_ButtonEvent { pointer widget; double mouse(11); long button; } func tws_button(self,parent=,label=,uname=,action=,position=,mouse=) /* DOCUMENT tws_button,label=label,parent=parent,uname=uname Creates a TWS button, labeled LABEL, with uname (=user name) UNAME. The uname should be used by your handler. See tws_handler. */ { if (is_void(self)) action="Create"; if (action=="Create") { if (is_void(position)) position=parent->position; if (is_void(uname)) uname=""; if (is_void(label)) label=""; self=&TWS_Button(); self->root=parent->root; self->parent=parent; self->type="tws_button"; self->label=label; self->uname=uname; self->frame_id=tws_plid(self->root); self->label_id=tws_plid(self->root); self->position=tws_action(self->parent)(self->parent,action="GetPosition",position=position); tws_addtoparent,parent,self; return self; } else if (action=="Realize") { plrect,self->position; plt,self->label,self->position(1)+(self->position(3)-self->position(1))/10.,self->position(2)+(self->position(4)-self->position(2))/2.,tosys=1,justify="LH"; } else if (action=="GetEvent") { Event=[]; if (tws_isinrect(self->position,mouse)) { Event=TWS_ButtonEvent(); Event.widget=self; Event.mouse=mouse; Event.button=long(mouse(10)); } return Event; } else if (action=="Activate") { pledit,self->label_id,color="blue"; redraw; } else if (action=="Deactivate") { pledit,self->label_id,color="black"; redraw; } } frigaut-yorick-yutils-c173974/tws_field.i000066400000000000000000000065711152651572200204340ustar00rootroot00000000000000/* * TWS_FIELD.I Field widgets for the Tiny Widget Set. See tws.i. * * $Id: tws_field.i,v 1.1 2008-01-04 15:04:37 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: tws_field.i,v $ * Revision 1.1 2008-01-04 15:04:37 frigaut * - added tws*.i from thibaut * * */ struct TWS_Field /* DOCUMENT TWS_Button */ { string type,uname; pointer root,parent; // A button has no children double position(4),value; string label,prompt; long label_id,frame_id,value_id,frame; } struct TWS_FieldEvent { pointer widget; double mouse(11); long button; double value; } func tws_field(self,parent=,label=,uname=,action=,position=,mouse=,value=,frame=,prompt=) /* DOCUMENT tws_button,label,uname=uname Creates a TWS button, labeled LABEL, with uname (=user name) UNAME. The uname should be used by your handler. See tws_handler. */ { if (is_void(self)) action="Create"; if (action=="Create") { if (is_void(position)) position=parent->position; if (is_void(prompt) && !is_void(label)) prompt=label; self=&TWS_Field(uname=uname,value=value,label=label,parent=parent,prompt=prompt); if (is_void(frame) || frame != 0) self->frame=1; self->root=parent->root; self->type="tws_field"; if (self->frame) self->frame_id=tws_plid(self->root); self->label_id=tws_plid(self->root); self->value_id=tws_plid(self->root); self->position=tws_action(self->parent)(self->parent,action="GetPosition",position=position); tws_addtoparent,parent,self; return self; } else if (action=="Realize") { if (self->frame) plrect,self->position; plt,self->label,self->position(1)+(self->position(3)-self->position(1))/10.,self->position(2)+(self->position(4)-self->position(2))/2.,tosys=1,justify="LH"; plt,swrite(self->value),self->position(3)-(self->position(3)-self->position(1))/10.,self->position(2)+(self->position(4)-self->position(2))/2.,tosys=1,justify="RH"; } else if (action=="GetEvent") { Event=[]; if (tws_isinrect(self->position,mouse)) { Event=TWS_FieldEvent(); Event.widget=self; Event.mouse=mouse; Event.button=long(mouse(10)); value=self->value; pledit,self->label_id,color="blue"; pledit,self->value_id,color="red"; redraw; n=read(prompt=self->prompt,format="%g",value); redraw; self->value=value; Event.value=value; tws_realize,self->root,nokill=1; // quick ugly way to update } return Event; } else if (action=="Activate") { redraw; } else if (action=="Deactivate") { pledit,self->label_id,color="black"; pledit,self->value_id,color="black"; redraw; } } frigaut-yorick-yutils-c173974/tws_grid.i000066400000000000000000000074051152651572200202730ustar00rootroot00000000000000/* * TWS_Grid.I Grid widgets for the Tiny Widget Set. See tws.i * * $Id: tws_grid.i,v 1.1 2008-01-04 15:04:37 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: tws_grid.i,v $ * Revision 1.1 2008-01-04 15:04:37 frigaut * - added tws*.i from thibaut * * */ struct TWS_Grid /* DOCUMENT TWS_Grid */ { string type,uname; pointer children,root,parent; double cur_gridx,cur_gridy,buttons_xsize, buttons_ysize; long cur_index; double position(4); long frame_id; // id of frame for pledit GraphK frame_keywords; } func tws_grid(self,parent=,cols=,lines=,uname=,position=,action=,mouse=,frame_keywords=,height=) /* DOCUMENT tws_init,wid,cols,lines [,uname=uname] Creates a TWS base widget in window WID. This widget will contain the buttons in a grid with COLS columns and LINES lines. A uname (=user name) may be given to this widget for later reference, which is currently useless since the base widget doesn't return any event to your handler. After having called TWS_INIT once, you can had buttons with TWS_BUTTON. Buttons will be drawn bottom to top and left to right in the grid. */ { if (is_void(self)) action="Create"; if (action=="Create") { self=&TWS_Grid(); self->root=parent->root; self->parent=parent; self->type="tws_grid"; if (structof(frame_keywords)==GraphK) self->frame_keywords=frame_keywords; if (!is_void(uname)) self->uname=uname; if (is_void(position)) position=parent->position; if (is_void(lines)) lines=1.; if (is_void(height)) height=lines; self->position=tws_action(self->parent)(self->parent,action="GetPosition",position=position,height=height); self->root->cur_plid++; self->frame_id=self->root->cur_plid; if (is_void(cols)) cols=1.; self->buttons_xsize=(self->position(3)-self->position(1))/cols; self->buttons_ysize=(self->position(4)-self->position(2))/lines; self->cur_index=0; tws_addtoparent,parent,self; return self; } else if (action=="Realize") { plrect,self->position,keywords=self->frame_keywords; for (i=1;i<=numberof(*self->children);i++) rien=tws_action((*self->children)(i))((*self->children)(i),action="Realize"); } else if (action=="GetPosition") { if (is_void(height)) height=1; xsize=self->position(3)-self->position(1); ysize=self->position(4)-self->position(2); X=self->position(1); Y=self->position(2); y0=self->cur_index*self->buttons_ysize; col=floor(y0/ysize); y0=y0-col*ysize; x0=col*self->buttons_xsize; x1=x0+self->buttons_xsize; y1=y0+height*self->buttons_ysize; self->cur_index=self->cur_index+height; return [X+x0,Y+y0,X+x1,Y+y1]; } else if (action=="GetEvent") { Event=[]; if (tws_isinrect(self->position,mouse)) { i=1; Event=[]; while (is_void(Event) && i<=numberof(*self->children)) { Event=tws_action((*self->children)(i))((*self->children)(i),action="GetEvent",mouse=mouse); i++; } } return Event; } } frigaut-yorick-yutils-c173974/tws_label.i000066400000000000000000000046331152651572200204250ustar00rootroot00000000000000/* * TWS_Button.I Tiny Widget Set Label. Like a button, * without a frame, that doesn't return events. * * Buttons for the Tiny Widget Set. See tws.i * * $Id: tws_label.i,v 1.1 2008-01-04 15:04:37 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: tws_label.i,v $ * Revision 1.1 2008-01-04 15:04:37 frigaut * - added tws*.i from thibaut * * */ struct TWS_Label /* DOCUMENT TWS_Button */ { string type,uname; pointer root,parent; // A button has no children double position(4); string label; long label_id; } func tws_label(self,parent=,label=,uname=,action=,position=,mouse=) /* DOCUMENT tws_button,label=label,parent=parent,uname=uname Creates a TWS Label, labeled LABEL, with uname (=user name) UNAME. */ { if (is_void(self)) action="Create"; if (action=="Create") { if (is_void(position)) position=parent->position; if (is_void(uname)) uname=""; if (is_void(label)) label=""; self=&TWS_Label(root=parent->root,parent=parent,type="tws_label",label=label,uname=uname); self->label_id=tws_plid(self->root); self->position=tws_action(self->parent)(self->parent,action="GetPosition",position=position); tws_addtoparent,parent,self; return self; } else if (action=="Realize") { plt,self->label,self->position(1)+(self->position(3)-self->position(1))/10.,self->position(2)+(self->position(4)-self->position(2))/2.,tosys=1,justify="LH"; } else if (action=="GetEvent") { Event=[]; return Event; } else if (action=="Activate") { pledit,self->label_id,color="blue"; redraw; } else if (action=="Deactivate") { pledit,self->label_id,color="black"; redraw; } } frigaut-yorick-yutils-c173974/tws_popup.i000066400000000000000000000055771152651572200205210ustar00rootroot00000000000000/* * TWS_Button.I Tiny Widget Set Button. * * Buttons for the Tiny Widget Set. See tws.i * * $Id: tws_popup.i,v 1.1 2008-01-04 15:04:37 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: tws_popup.i,v $ * Revision 1.1 2008-01-04 15:04:37 frigaut * - added tws*.i from thibaut * * */ struct TWS_Button /* DOCUMENT TWS_Popup */ { string type,uname; pointer root,parent,child; // child is the root widget of the popup window double position(4); string label,handler; long label_id,frame_id; } struct TWS_ButtonEvent { pointer widget; double mouse(11); long button; } func tws_button(self,parent=,label=,uname=,action=,position=,mouse=,cild=,handler=) /* DOCUMENT tws_button,label=label,parent=parent,uname=uname Creates a TWS popup. It's a button (so see tws_button), that creates a popup window when clicked. You must give CHILD, a Root widget, and handler, the corresponding handler */ { if (is_void(self)) action="Create"; if (action=="Create") { if (is_void(position)) position=parent->position; if (is_void(uname)) uname=""; if (is_void(label)) label=""; self=&TWS_Button(); self->root=parent->root; self->parent=parent; self->type="tws_button"; self->label=label; self->uname=uname; self->frame_id=tws_plid(self->root); self->label_id=tws_plid(self->root); self->position=tws_action(self->parent)(self->parent,action="GetPosition",position=position); tws_addtoparent,parent,self; return self; } else if (action=="Realize") { plrect,self->position; plt,self->label,self->position(1)+(self->position(3)-self->position(1))/10.,self->position(2)+(self->position(4)-self->position(2))/2.,tosys=1,justify="LH"; } else if (action=="GetEvent") { Event=[]; if (tws_isinrect(self->position,mouse)) { Event=TWS_ButtonEvent(); Event.widget=self; Event.mouse=mouse; Event.button=long(mouse(10)); } return Event; } else if (action=="Activate") { pledit,self->label_id,color="blue"; redraw; } else if (action=="Deactivate") { pledit,self->label_id,color="black"; redraw; } } frigaut-yorick-yutils-c173974/tws_radio.i000066400000000000000000000101161152651572200204350ustar00rootroot00000000000000/* * TWS_Button.I Tiny Widget Set Button. * * Buttons for the Tiny Widget Set. See tws.i * * $Id: tws_radio.i,v 1.1 2008-01-04 15:04:37 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: tws_radio.i,v $ * Revision 1.1 2008-01-04 15:04:37 frigaut * - added tws*.i from thibaut * * */ struct TWS_Radio /* DOCUMENT TWS_Button */ { string type,uname; pointer root,parent; // A button has no children double position(4); string label; int selected; long label_id,selected_id; } struct TWS_RadioEvent { pointer widget; double mouse(11); long button; long selected; } func tws_radio(self,parent=,label=,uname=,action=,position=,mouse=) /* DOCUMENT tws_button,label=label,parent=parent,uname=uname Creates a TWS button, labeled LABEL, with uname (=user name) UNAME. The uname should be used by your handler. See tws_handler. */ { if (is_void(self)) action="Create"; if (action=="Create") { if (is_void(position)) position=parent->position; if (is_void(uname)) uname=""; if (is_void(label)) label=""; self=&TWS_Radio(); self->root=parent->root; self->parent=parent; self->type="tws_radio"; self->label=label; self->uname=uname; self->selected=0; self->selected_id=tws_plid(self->root); self->label_id=tws_plid(self->root); self->position=tws_action(self->parent)(self->parent,action="GetPosition",position=position); tws_addtoparent,parent,self; return self; } else if (action=="Realize") { plt,"*",self->position(1)+(self->position(3)-self->position(1))/10.,self->position(2)+(self->position(4)-self->position(2))/2.,tosys=1,justify="CH"; plt,self->label,self->position(1)+(self->position(3)-self->position(1))/5.,self->position(2)+(self->position(4)-self->position(2))/2.,tosys=1,justify="LH"; if (self->selected) pledit,self->selected_id,color="red",font="helveticaB"; } else if (action=="GetEvent") { Event=[]; if (tws_isinrect(self->position,mouse)) { Event=TWS_RadioEvent(); Event.widget=self; Event.mouse=mouse; Event.button=long(mouse(10)); Event.selected=1; rien=tws_action(self)(self,action="Select"); for (i=1;i<=numberof(*self->parent->children);i++) { if ((*self->parent->children)(i)->type=="tws_radio" && (*self->parent->children)(i)!=self) { rien=tws_action(self)((*self->parent->children)(i),action="Deselect"); } } } return Event; } else if (action=="Activate") { pledit,self->label_id,color="blue"; redraw; } else if (action=="Deactivate") { pledit,self->label_id,color="black"; redraw; } else if (action=="Select") { pledit,self->selected_id,color="red",font="helveticaB"; self->selected=1; } else if (action=="Deselect") { pledit,self->selected_id,color="black",font="helvetica"; self->selected=0; } } func tws_radiotesthandler(event) { event; *event.widget; return 0; } func tws_radiotest { extern root,grid,choix1,choix2,choix3; root=tws_root(); grid=tws_grid(parent=root,lines=3); choix1=tws_radio(parent=grid,uname="choix1",label="Choix 1"); choix2=tws_radio(parent=grid,uname="choix2",label="Choix 2"); choix3=tws_radio(parent=grid,uname="choix3",label="Choix 3"); tws_realize,root; tws_action(choix3)(choix3,action="Select"); tws_handler,root,"tws_radiotesthandler"; } frigaut-yorick-yutils-c173974/tws_root.i000066400000000000000000000102611152651572200203230ustar00rootroot00000000000000/* * TWS_ROOT.I Root widgets for the Tiny Widget Set. See tws.i. * * $Id: tws_root.i,v 1.1 2008-01-04 15:04:37 frigaut Exp $ * * This file is part of Yutils * Copyright (C) 2007 Thibaut Paumard * * 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. * * $Log: tws_root.i,v $ * Revision 1.1 2008-01-04 15:04:37 frigaut * - added tws*.i from thibaut * * */ struct TWS_Root /* DOCUMENT TWS_Root */ { string type; // Type of widget, like "Root", "Grid" or "Button" string uname; // Application name of the widget pointer children; // Pointer to an array of pointers to widget structs. pointer root; // Pointer to root widget (self in this case) pointer parent; // Pointer to parent widget (nil in this case) double position(4); // [x0,y0,x1,y1] defining rectangle of this widget. Always [0,0,1,1] for a Root. long wid; // Only for Root widgets : Window ID. long cur_plid; // Only for Root widgets : number of objects defined up to now in the window long dpi; // Root widget should accept any keyword of WINDOW long height; long width; string style; } func tws_root(self,wid=,uname=,width=,height=,style=,action=,dpi=,position=,mouse=,nokill=) /* DOCUMENT tws_root,wid,cols,lines [,uname=uname] Creates a TWS base widget in window WID. This widget will contain the buttons in a grid with COLS columns and LINES lines. A uname (=user name) may be given to this widget for later reference, which is currently useless since the base widget doesn't return any event to your handler. After having called TWS_INIT once, you can had buttons with TWS_BUTTON. Buttons will be drawn bottom to top and left to right in the grid. */ { if (is_void(self)) action="Create"; if (action=="Create") { // Defaults if (is_void(wid)) wid=0; if (is_void(dpi)) dpi=75; if (is_void(width)) { if (dpi==75) width=450; else width=600; } if (is_void(height)) { if (dpi==75) height=450; else height=600; } if (is_void(uname)) uname="Root"; if (is_void(style)) style="nobox.gs"; // Do. self=&TWS_Root(); self->root=self; self->position=[0,0,1,1]; self->wid=wid; self->dpi=dpi; self->type="tws_root"; self->uname=uname; self->height=height; self->width=width; self->style=style; return self; } else if (action=="Realize") { if (!nokill) { winkill,self->wid; window,self->wid,height=self->height,width=self->width,style=self->style,dpi=self->dpi; } else window,self->wid; // Here I define in a general way the viewport in a full window of given // width and height. The three numeric parameters xc,yc and maybe fact // (=0.0013/2) can probably be improved. Now I would just like to now how // to remove the "system" line... require,"style.i"; get_style, land, sys, leg, cleg; xc=0.397; yc=0.639; fact=0.00065; sys(1).viewport=[xc,xc,yc,yc]+[-self->width,self->width,-self->height,self->height]*fact; set_style, land, sys, leg, cleg; fma; for (i=1;i<=numberof(*self->children);i++) rien=tws_action((*self->children)(i))((*self->children)(i),action="Realize"); } else if (action=="GetPosition") { return position; } else if (action=="GetEvent") { i=1; event=[]; while (is_void(event) && i<=numberof(*self->children)) { event=tws_action((*self->children)(i))((*self->children)(i),action="GetEvent",mouse=mouse); i++; } return event; } } frigaut-yorick-yutils-c173974/util_fr.i000066400000000000000000000423321152651572200201130ustar00rootroot00000000000000/* * util_fr.i * A collection of routines for general purpose. * * $Id: util_fr.i,v 1.4 2010-04-06 14:21:51 paumard Exp $ * * Author: Francois Rigaut. * Written 2002 * last revision/addition: 2004Oct15 * * Copyright (c) 2003, Francois RIGAUT (frigaut@gemini.edu, Gemini * Observatory, 670 N A'Ohoku Place, HILO HI-96720). * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). * * $Log: util_fr.i,v $ * Revision 1.4 2010-04-06 14:21:51 paumard * - move strlower & strupper from utils.i to emulate-yeti.i; * - move round from util_fr.i to emulate-yeti.i; * - round returns a double, like the Yeti implementation; * - review autoloads (adding emulate-yeti_start.i); * - add missing files to Makefile. * * Revision 1.3 2008/10/29 15:58:13 paumard * utils.i: reform would not work with empty dimlist. Fixed. * plot.i, util_fr.i, utils.i: rename functions now standard in Yorick (color_bar, rdfile, reform) * * Revision 1.2 2007/12/27 15:22:07 frigaut * nothing. commit before tagging. * */ require,"style.i"; /*************************/ /* CONVENIENCE functions */ /*************************/ func ls /* DOCUMENT ls: system command ls * F.Rigaut, 2001/11/10. * SEE ALSO: pwd, system, $. */ {system,"ls";} func exist(arg) /* DOCUMENT exist(arg) * Returns 0 if element is not set or is a , 1 otherwise * F.Rigaut 2002/04/03 * SEE ALSO: is_void, where */ { if (numberof(arg) == 0) {return 0;} else {return 1;} } func is_set(arg) /* DOCUMENT is_set(arg) * Returns 0 if element is void or equal to zero, 1 otherwise * F.Rigaut 2002/06/03 * SEE ALSO: is_void, where, exist */ { if (is_void(arg) | (arg == 0)) {return 0;} else {return 1;} } func tv(im,square=) /* DOCUMENT tv(im,square=) * This routines does a frame advance, display the image * and set the limits to have the image full display. * Inspired from the IDL tvscl * F.Rigaut, 2001/11/10. * SEE ALSO: fma, pli, plot */ { fma; pli,im; limits,"e","e","e","e",square=square; } func plot(vect,x,square=,histo=) /* DOCUMENT plot(vect,x,square=,histo=) * Short cut for a fma + plg * Set histo to get plh type plot * F.Rigaut 2001/10 * SEE ALSO: plg, fma, tv, plh */ { fma; if (is_set(histo)) { plh,vect,x; } else { plg,vect,x; } limits,,,,,square=square; } func nprint(var,sep=,format=) /* DOCUMENT func nprint(var,sep=,format=) Neat print of a 2d array. example: > nprint,optpos*pi/3.14e9,sep=", " +0, -5.003e-07, +0, -9.005e-08, +0, +0 +0, -4.002e-07, +0, +9.005e-08, +0, +0 +0, -3.002e-07, +0, +9.005e-08, +0, +0 +0, -2.001e-07, +0, +9.005e-08, +0, +0 +0, -1.801e-07, +0, +9.005e-08, +0, +0 +0, -1.001e-07, +0, +9.005e-08, +0, +0 +0, +1.001e-07, +0, +9.005e-08, +0, +0 sep= separator string. The default separator is two blanks (" "). format= swrite format Restricted to 2D arrays SEE ALSO: pm */ { if (!is_set(sep)) sep = " "; if (!is_set(format)) format = "%+8.4g"; dim = dimsof(var); if (dim(1) != 2) {error,"only implemented for 2D arrays";} for (i=1;i<=dim(3);i++) { for (j=1;j<=dim(2)-1;j++) { write,format=format+sep,var(j,i); } write,format=format,var(0,i); write,""; } } func typeReturn(void) /* DOCUMENT typeReturn(void) * A simple convenient function that does what is name says. * SEE ALSO: */ { rep = rdline(prompt="type return to continue..."); return rep; } hitReturn=typeReturn; /****************************/ /* ADDITIONAL MATH function */ /****************************/ func even(arg) /* DOCUMENT even(arg) * returns 1 is argument is even, zero otherwise. * The argument should be an integer. * F.Rigaut, 2001/11/10. * SEE ALSO: odd */ {return ((arg % 2) == 0);} func odd(arg) /* DOCUMENT odd(arg) * Returns 1 is argument is odd, zero otherwise. * The argument should be an integer. * F.Rigaut, 2001/11/10. * SEE ALSO: even */ {return ((arg % 2) == 1);} func minmax(arg) /* DOCUMENT minmax(arg) * Returns a vector containing the min and the max of the argument * F.Rigaut 2001/09 * SEE ALSO: */ {return [min(arg),max(arg)];} local clip; func __clip(arg,lt,ht) /* DOCUMENT func clip(arg, mini, maxi); * Returns the argument, which has been "clipped" to mini * and maxi, i.e. in which all elements lower than "mini" * have been replaced by "mini" and all elements greater * than "maxi" by "maxi". Array is converted to float. * Either "mini" and "maxi" can be ommited, in which case * the corresponding mini or maxi is not clipped. * Equivalent to the IDL ">" and "<" operators. * F.Rigaut, 2001/11/10. * SEE ALSO: */ { if (lt != []) arg = max(arg,lt); if (ht != []) arg = min(arg,ht); return arg; } if (!is_func(clip)) clip = __clip; local sinc; func __mysinc(ar) /* DOCUMENT func sinc(ar) * Return the sinus cardinal of the input array * F.Rigaut, 2002/04/03 * SEE ALSO: Eric Thiebault wrote a sinc which is probably better. */ { local ar; ar = double(ar); w = where(abs(ar) < 1e-10); if (exist(w)) {ar(w) = 1e-10;} return sin(ar)/ar; } if (!is_func(sinc)) sinc = __mysync; /************************************/ /* SYSTEM AND PERFORMANCE functions */ /************************************/ func tic(counterNumber) /* DOCUMENT tic(counter_number) * Marks the beginning of a time lapse * ex: tic ; do_something ; tac() * will print out the time ellapsed between tic and tac * a counter number can optionaly be specified if several * counters have to be used in parallel. * F.Rigaut 2001/10 * SEE ALSO: tac */ { if (counterNumber == []) counterNumber = 1; if (counterNumber > 10) error,"tic and tac are limited to 10 time counters !"; el = array(double,3); timer,el; _nowtime(counterNumber) = el(3); } if (numberof(_nowtime)!=10) _nowtime = array(double,10); func tac(counterNumber) /* DOCUMENT tac(counter_number) * Marks the end of a time lapse * ex: tic ; do_something ; tac() * will print out the time ellapsed between tic and tac * a counter number can optionaly be specified if several * counters have to be used in parallel. * F.Rigaut 2001/10 * SEE ALSO: tic */ { if (counterNumber == []) counterNumber = 1; el = array(double,3); timer,el; elapsed = el(3)-_nowtime(counterNumber); return elapsed; } func spawn_fr(command) /* DOCUMENT spawn_fr(command) * This function tries to group in one call the : * - call to system * - read the file created by the system call * - returns it * Inspired from the IDL function of the same name * F.Rigaut 2002/04/04 * SEE ALSO: system, popen, exec in Eric/system.i * * DEPRECATED: Use spawn/sys instead. */ { f = popen(command,0); ans = rdline(f); l = ans; while (l) { l = rdline(f); if (l) {ans = grow(ans,l);} } return ans; } /*******************/ /* ARRAY functions */ /*******************/ func wheremin(ar) { return where(ar == min(ar)); } func wheremax(ar) { return where(ar == max(ar)); } /* DOCUMENT func wheremin(ar) and func wheremax(ar) Short hand for where(array == min(array) or max(array) SEE ALSO: where, where2, min, max */ func indices(dim) /* DOCUMENT indices(dim) * Return a dimxdimx2 array. First plane is the X indices of the pixels * in the dimxdim array. Second plane contains the Y indices. * Inspired by the Python scipy routine of the same name. * New (June 12 2002): dim can either be : * - a single number N (e.g. 128) in which case the returned array are * square (NxN) * - a Yorick array size, e.g. [#dimension,N1,N2], in which case * the returned array are N1xN2 * - a vector [N1,N2], same result as previous case * F.Rigaut 2002/04/03 * SEE ALSO: span */ { if (numberof(dim) == 1) { x = span(1,dim,dim)(,-:1:dim); y = transpose(x); return [x,y]; } else { if (numberof(dim) == 3) {dim = dim(2:3);} x = span(1,dim(1),dim(1))(,-:1:dim(2)); y = span(1,dim(2),dim(2))(,-:1:dim(1)); y = transpose(y); return [x,y]; } } local dist; func __dist(dim,xc=,yc=) /* DOCUMENT func dist(size,xc=,yc=) * Returns an array which elements contains the distance to (xc,yc). xc * and yc can be omitted, in which case they are defaulted to size/2+1. * F.Rigaut, 2001/11/10. * SEE ALSO: indices, radial_distance */ { dim = long(dim); if (xc == []) xc = int(dim/2)+1; if (yc == []) yc = int(dim/2)+1; x = float(span(1,dim,dim)(,-:1:dim)); y = transpose(x); d = float(sqrt((x-xc)^2.+(y-yc)^2.)); d = clip(d,1e-5,); return d; } if (!is_func(dist)) {dist = __dist;} local eclat; func __eclat(image) /* DOCUMENT func eclat(image) * Equivalent, but slightly faster (?) than roll. Transpose the four main * quadrants of a 2D array. Mostly used for FFT applications. * F.Rigaut, 2001/11/10. * SEE ALSO: roll. */ { d = dimsof(image); dx = d(2); dy = d(3); x1=1; x2=dx/2 ; x3=x2+1 ; x4=dx; y1=1; y2=dy/2 ; y3=y2+1 ; y4=dy; out = image*0.; out(x1:x2,y1:y2) = image(x3:x4,y3:y4); out(x3:x4,y1:y2) = image(x1:x2,y3:y4); out(x1:x2,y3:y4) = image(x3:x4,y1:y2); out(x3:x4,y3:y4) = image(x1:x2,y1:y2); return out; } if (!is_func(eclat)) {eclat = __eclat;} func makegaussian(size,fwhm,xc=,yc=,norm=) /* DOCUMENT makegaussian(size,fwhm,xc=,yc=) * Returns a centered gaussian of specified size and fwhm. * F.Rigaut 2001/09 * norm returns normalized 2d gaussian * SEE ALSO: */ { tmp = exp(-(dist(size,xc=xc,yc=yc)/(fwhm/1.66))^2.); if (is_set(norm)) tmp = tmp/fwhm^2./1.140075; return tmp; } func bin2(image) /* DOCUMENT bin2(image) * Returns the input image, binned by a factor of 2. * That is, a 512x512 image is transformed in a 256x256 image. * one output pixel is the average of the 4 corresponding input ones, * so that it conserves the total intensity. * SEE ALSO: undersample */ { d = dimsof(image); if (d(1) != 2) { error,"Bin only accepts images"; } if (((d(2) % 2) != 0) || ((d(3) % 2) != 0)) { error,"Bin only accepts dimensions with even # of pixels"; } sim= image+roll(image,[-1,-1])+roll(image,[-1,0])+roll(image,[0,-1]); return sim(::2,::2); } /*****************************/ /* STRING AND FILE functions */ /*****************************/ func fileExist(filename) /* DOCUMENT fileExist(filename) * Returns "1" if the file(s) exist(s), "0" if it does not. * filename can be an array, in which case the results is an array * of 0s and 1s. * F.Rigaut 2002/01 * SEE ALSO: */ { exist = []; for (i=1;i<=numberof(filename);i++) { grow,exist,(open(filename(i),"r",1) ? 1:0); } if (numberof(filename) == 1) {return exist(1);} return exist; } func findfiles(files) /* DOCUMENT findfiles(filter) * This routines returns a list of files which satisfy the filter * argument. The list is a string vector. If no files were found, * the results is the empty string. * F.Rigaut, 2001/11/10. * SEE ALSO: spawn */ { // parse input parameter into path and filename: tmp = strtok(files,"/",20); tmp = tmp(where(tmp)); filereg = tmp(0); if (numberof(tmp)>1) { path = sum(tmp(1:-1)+"/"); if (strpart(files,1:1)=="/") path = "/"+path; } else path="."; l = lsdir(path); // process result list: if (noneof(l)) return; w = where(strglob(filereg,l)); if (numberof(w)==0) return; res = l(w); if (path==".") return res; return (path+res); } func __rdfile(file) /* DOCUMENT func rdfile(file) Open, read, close and return the whole content of ascii file "file". AUTHOR : F.Rigaut, Oct 2004. SEE ALSO: load_text, dump_text */ { f = open(file,"r"); fcontent = []; while (line=rdline(f)) grow,fcontent,line; return fcontent; } if (!rdfile) rdfile=__rdfile; func parsedate_fr(strdate,format,dec=) /* DOCUMENT parsedate(strdate,format,dec=) * Returns the date in integers as an array [[year],[month],[day]], * or in decimal if "dec" is set. The format has to be specified. * Does not yet accept dates in the form "2003jun05". * strdate = string array containing the date e.g. "2003/10/25" * format = format in the form "yyyy/mm/dd" * Examples: * > parsedate(["2003/05/21","2003/02/15"],"yyyy/mm/dd",dec=1) * [2003.38,2003.12] * > parsedate(["2003/05/21","2003/02/15"],"yyyy/mm/dd") * [[2003,2003],[5,2],[21,15]] * SEE ALSO: parsetime ***** NEED TO UPGRADE THIS FUNCTION FOR THE 1.6 STR FUNCTIONS **** */ { exit,"not upgraded for use with the yorick-1.6.01 str functions"; a = b = c = array(long,numberof(strdate)); strdate = strtrim(strdate); format = strtolower(format); wy = strfind(format,"y"); ys = strjoin(array("y",numberof(wy))); wm = strfind(format,"m"); ms = strjoin(array("m",numberof(wm))); wd = strfind(format,"d"); ds = strjoin(array("d",numberof(wd))); format = strreplace(format,ys,"%"+swrite(numberof(wy),format="%d")+"d"); format = strreplace(format,ms,"%"+swrite(numberof(wm),format="%d")+"d"); format = strreplace(format,ds,"%"+swrite(numberof(wd),format="%d")+"d"); sread,strdate,format=format,a,b,c; if (wy(1) < wm(1) & wm(1) < wd(1)) ymd= [a,b,c]; if (wd(1) < wm(1) & wm(1) < wy(1)) ymd= [c,b,a]; if (wm(1) < wd(1) & wd(1) < wy(1)) ymd= [c,a,b]; if (wy(1) < wd(1) & wd(1) < wm(1)) ymd= [a,c,b]; if (wd(1) < wy(1) & wy(1) < wm(1)) ymd= [b,c,a]; if (wm(1) < wy(1) & wy(1) < wd(1)) ymd= [b,a,c]; if (!dec) {return ymd;} mlength = [31.,28,31,30,31,30,31,31,30,31,30,31]; // rought cut at bisextile years: bisext = (ymd(..,1)/4. == ymd(..,1)/4); // none of the date are bisextile: if (noneof(bisext)) { return ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum); } // all of the date are bisextile: if (allof(bisext)) { mlength(2) = 29; return ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum); } // mix of bisextile and not: tnotbi = ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum); mlength(2) = 29; tbi = ymd(..,1)+(mlength(cum)(ymd(..,2))+ymd(..,3)-1.)/mlength(sum); return tnotbi*(1-bisext) + tbi*bisext; } func parsetime_fr(strtime,dec=) /* DOCUMENT parsetime(strtime,dec=) * Parse the input string array "strtime" and returns the time as a [hh,mm,ss] * vector (or array if strtime is an array of string) or returns the time * as a single decimal number (or vector if strtime is an array) if the * "dec" keyword is set. * Examples: * > parsetime(["22:30:25.792","22:20:33.852"],dec=1) * [22.5072,22.3427] * > parsetime(["22:30:25.792","22:20:33.852"]) * [[22,22],[30,20],[25.792,33.852]] ***** NEED TO UPGRADE THIS FUNCTION FOR THE 1.6 STR FUNCTIONS **** * SEE ALSO: parsedate */ { exit,"not upgraded for use with the yorick-1.6.01 str functions"; n = numberof(strtime); h = m = array(long,n); s = array(float,n); strtime = strtrim(strtime); if (allof(strmatch(strtime,":"))) {delim=":";} \ else if (allof(strmatch(strtime," "))) {delim=" ";} \ else if (allof(strmatch(strtime,";"))) {delim=";";} \ else {error,"Can't figure out the delimiter";} f = "%2d"+delim+"%2d"+delim+"%f"; sread,strtime,format=f,h,m,s; if (dec) return h+m/60.+s/3600.; return [h,m,s]; } func secToHMS(time) /* DOCUMENT secToHMS(time) * Convert from time (float in sec) to string in the form hh:mm:ss.s * AUTHOR : F.Rigaut, June 13 2002. * SEE ALSO: */ { lt = long(time); hh = lt/3600; lt = lt-hh*3600; mm = lt/60; sec = float(time)-hh*3600-mm*60; ts = swrite(hh,mm,sec,format="%02i:%02i:%04.1f"); return ts; } /*********************/ /* GRAPHIC functions */ /*********************/ func colorbar(cmin, cmax,adjust=,levs=) /* DOCUMENT colorbar colorbar, cmin, cmax draw a color bar to the right of the plot. If CMIN and CMAX are specified, label the top and bottom of the bar with those numbers. adjust: x adjust. typically +/- 0.01 levs: number of ticks in color bar (plus one) upgraded 2007june02 SEE ALSO: color_bar */ { if (adjust==[]) adjust=0.; cursys = plsys(); get_style,landscape, systems, legends, clegends; left = systems(cursys).viewport(2)+0.03+adjust; right = systems(cursys).viewport(2)+0.05+adjust; bottom = systems(cursys).viewport(3); top = systems(cursys).viewport(4); middle = (left+right)/2.; plsys, 0; pli, span(0,1,200)(-,), left, bottom, right, top, legend=""; plg, [bottom,top,top,bottom],[right,right,left,left], closed=1, marks=0,color="fg",width=1,type=1,legend=""; if (levs) { for (i=1;i<=(levs-1);i++) { y=bottom+(top-bottom)/levs*i; plg, [y,y],[left,right], marks=0,color="fg",width=1,type=1,legend=""; } } plsys, cursys; if (!is_void(cmin)) { plt, pr1(cmin), middle, bottom-0.005, justify="CT"; plt, pr1(cmax), middle, top+0.005, justify="CB"; } } // general equivalent (remove if you don't like them) man=help; frigaut-yorick-yutils-c173974/utils.i000066400000000000000000001722221152651572200176110ustar00rootroot00000000000000/* * utils.i -- * * General purpose utility routines for Yorick. * *----------------------------------------------------------------------------- * * Copyright (C) 1996-2008 Eric Thiebaut * * This file is free software; as a special exception the author gives * unlimited permission to copy and/or distribute it, with or without * modifications, as long as this notice is preserved. * * This software is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY, to the extent permitted by law; without * even the implied warranty of MERCHANTABILITY or FITNESS FOR A * PARTICULAR PURPOSE. * *----------------------------------------------------------------------------- * * Routines: * depth_of - get 3rd dimension of an array * dump_text - dump string array in a text file * eval - evaluate textual code * expand_file_name - expand leading tilde in file name(s) * filesize - get size of a file in bytes * get_file_name - get path name of file associated with a stream * glob - get list of files matching glob-style pattern * guess_compression - guess compression method of existing file * height_of - get 2nd dimension of an array * is_string_scalar - check if argument is a scalar string * load_text - load all lines of a text file * map - apply function to every elements of array or list * moments - get first moments of a sampled distribution * ncols_of - get number of columns of an array * ndims_of - get number of dimension of an array * nrows_of - get number of rows of an array * open_url - open an URL into a web browser * pdb_list - lists contents of PDB binary file * pdb_restore_all - restore all non-record variables of a PDB file * protect_file_name - protect special characters in file name * pw_get_gid - get group numerical identifier from /etc/passwd file * pw_get_home - get home directory of user from /etc/passwd file * pw_get_name - get real user name from /etc/passwd file * pw_get_shell - get path to shell of user from /etc/passwd file * pw_get_uid - get user numerical identifier from /etc/passwd file * pw_get_user - get user name from /etc/passwd file * pwd - print/get working directory * raw_read - read binary data from file * read_ascii - read ascii numeric data * smooth - smooth array along its dimensions * spline_zoom - resize an array by cubic spline interpolation * stat - display statistics/info about symbols/expressions * strcut - cut text to fit into lines of given length * strjoin - make array of strings into a single string * strip_file_extension - remove extension from file name * tempfile - get unique file name * timer_elapsed - get/print the elapsed time since timer_start * timer_start - (re)start the profiling timer * undersample - shrink array dimension(s) * width_of - get 1st dimension of an array * xopen - extended open with (de)compression, primitives, ... * * History: * $Id: utils.i,v 1.7 2010-04-07 12:59:45 paumard Exp $ * $Log: utils.i,v $ * Revision 1.7 2010-04-07 12:59:45 paumard * - utils.i loads yeti.i if present, else emulate_yeti.i * * Revision 1.6 2010/04/07 06:15:23 paumard * - remove strchr, strrchr, is_scalar and is_vector, they are in string.i (beware, no autoloads) ; * - move is_integer_scalar from utils.i to emulate_yeti.i * * Revision 1.5 2010/04/06 14:21:51 paumard * - move strlower & strupper from utils.i to emulate-yeti.i; * - move round from util_fr.i to emulate-yeti.i; * - round returns a double, like the Yeti implementation; * - review autoloads (adding emulate-yeti_start.i); * - add missing files to Makefile. * * Revision 1.4 2010/02/10 13:27:12 paumard * - Synchronize files with Eric Thiebaut's: fft_utils.i, img.i, plot.i, utils.i. * - Import emulate_yeti.i * - Remove basename() and dirname(), standard in pathfun.i. * - Remove the accents in Erics name to prevent a crash on amd64. * * Revision 1.24 2008/07/12 06:50:05 eric * - Changed final comment for setting local variables of Emacs. * * Revision 1.23 2008/07/11 20:43:50 eric * - New routine: filesize. * * Revision 1.22 2007/07/02 22:17:03 eric * - New routine: strip_file_extension. * * Revision 1.21 2007/04/24 07:10:38 eric * - New raw_read function to read binary data from a file. * - Function grow_dimlist superseded by make_dimlist (part of * Yeti) and moved to emulate_yeti.i library file. * * Revision 1.20 2007/03/21 08:39:43 eric * - Avoid blocking when function tempfile is called as a subroutine * to initialize internal random generator (_read is *not* designed * to read from devices). * * Revision 1.19 2006/06/09 15:32:48 eric * - Fixed 2 glitches in eval(). * * Revision 1.18 2006/06/09 15:15:25 eric * - Function tempfile() can now preserve the extension of the template * name. * - Private function _tempfile_init() no longer needed and deleted. * - Reworked interface for eval() function to achieve better * protection against symbol name collision. The old function * (with keywords) is available as old_eval(). * * Revision 1.17 2006/02/08 01:16:42 eric * - New function glob() to get a list of files matching glob-style * pattern. * - New function tempfile() to get a unique file name. * - New functions to query array dimensions: ndims_of, nrows_of, * ncols_of, width_of height_of and depth_of. * - Removed function reform() which is now part of "std.i". * * Revision 1.16 2005/11/23 10:10:54 eric * - In spline_zoom: changed the coordinates relationship. * - In read_ascii: new keyword MAXCOLS, the default maximum * number of columns is 10000 instead of 128, documentation * for the COMPRESS keyword. * * Revision 1.15 2005/07/14 08:38:01 eric * - Modified to work with Yorick 1.6 and Yeti package (plugin). * Some functions have been removed and are provided by * "emulate_yeti.i" which is automatically included if Yeti * plugin is not loaded: swap(), unref(), is_scalar(), is_vector(), * is_matrix(), is_real(), is_complex(), is_integer(), is_numerical(). * - New function: moments(). * * Revision 1.14 2005/04/05 13:05:17 eric * - New functions: pw_get_user, pw_get_uid, pw_get_gid, pw_get_name, * pw_get_home, and pw_get_shell to parse /etc/passwd file. * * Revision 1.13 2004/11/29 21:26:00 eric * - new functions: strchr, strrchr, basename, dirname. * * Revision 1.3 2008/10/29 15:58:13 paumard * utils.i: reform would not work with empty dimlist. Fixed. * plot.i, util_fr.i, utils.i: rename functions now standard in Yorick (color_bar, rdfile, reform) * * Revision 1.2 2008/02/15 18:55:30 frigaut * fixed UTF-8 encoding problems (crash yorick-doc on amd64) * * Revision 1.1.1.1 2007/12/11 23:55:13 frigaut * Initial Import - yorick-yutils * * Revision 1.12 2004/10/14 09:51:37 eric * - Unused (to my knowledge) function "filenameof" removed, * it is superseded by "get_file_name". * - New functions: "expand_file_name", "get_file_name", * and "protect_file_name". * * Revision 1.11 2004/08/31 07:26:17 eric * - New routines for PDB files: pdb_list, pdb_restore_all. * - New routines for profiling: timer_start, timer_elapsed. * * Revision 1.10 2003/06/03 20:37:36 eric * - Function map() now accept a list argument (as _map) and use * weird names for local variables to avoid name clash. * - New functions: xopen, guess_compression, read_ascii, * load_text, and dump_text. * * Revision 1.9 2002/11/22 08:24:27 eric * - slight changes in eval() code * - fix list of routines in leading comments of this file * * Revision 1.8 2002/11/20 09:22:15 eric * - take care of not overwriting builtin functions (unref, strlower, * strupper, ...) * - new function: grow_dimlist * * Revision 1.7 2002/07/25 10:52:32 eric * - New function: eval. * * Revision 1.6 2002/07/01 09:41:45 eric * - New function: pwd. * * Revision 1.5 2002/06/06 14:19:42 eric * - New function: undersample. * * Revision 1.4 2002/02/22 16:19:24 eric * - Change (one more time) names of str(to)upper/lower functions to * avoid clash with builtin Yeti routines. * - Add "unref" routines (after Yorick's FAQ, so the true author is * Dave, not me). * * Revision 1.3 2001/12/08 22:33:37 eric * - stat(): computation of standard deviation improved. * * Revision 1.2 2001/11/26 08:17:11 eric * - Functions strto{lower,upper} renamed as str{lower,upper}. * * Revision 1.1 2001/03/23 16:20:52 eric * Initial revision * *----------------------------------------------------------------------------- */ local old_eval; func eval(eval_code, eval_tmp, eval_debug) /* DOCUMENT eval, code [, tmp [, debug]]; -or- eval(code [, tmp [, debug]]); -or- old_eval(code, tmp=, debug=) Evaluates CODE given as a string or as an array of strings (considered as different lines in the script). Since CODE can be dynamically build, this routine allows the execution of virtually (see hints/restrictions below) any Yorick's code (e.g. dynamic definition of structures, of functions, etc.). For instance, the following statement defines a new structure: eval, "struct NewStruct {string a; long b; float c, d;}"; Since the script gets evaluated at the scope level of the "eval" routine some local variables of the "eval" routine may be used in the script: "eval_tmp" contains the name of the temporary script file and must not be changed by the script; "eval_debug" contains the value of the keyword DEBUG and must not be changed by the script; "eval_code" contains the value of the argument CODE; "eval_result" is returned by "eval", its contents may be defined into the script to provide a returned value. Note: impredictible results may occur if CODE changes the value of symbols "eval_tmp" and "eval_debug". Optional second argument TMP can be used to specify the file name of the temporary script. The default file name is: "$TMDIR/$USER_XXXXXX" if environment variable "TMDIR" is set; "_eval_XXXXXX" otherwise; where the "XXXXXX" are replaced by a random pattern to avoid collisions (see (tempfile). If optional third argument DEBUG is true (non-zero and non-nil), the name of the temporary file is printed out and the file is not removed. SEE ALSO: include, unref, tempfile. */ { /* Dump script into a temporary file. */ if (is_void(eval_tmp)) { /* Create default name for yorick temporary code. */ eval_tmp = get_env("TMPDIR"); if (eval_tmp) eval_tmp += "/" + get_env("USER") + "_XXXXXX.i"; else eval_tmp = "_eval_XXXXXX.i"; eval_tmp = tempfile(eval_tmp); } write, format="%s\n", open(eval_tmp, "w"), eval_code; /* Source script and return result. */ local eval_result; include, eval_tmp, 1; if (eval_debug) write, format="Yorick code written in \"%s\"\n", eval_tmp; else remove, eval_tmp; return eval_result; } func old_eval(code, tmp=, debug=) { /* Dump script into a temporary file. */ if (is_void(tmp)) { /* Create default name for yorick temporary code. */ tmp = get_env("YORICK_EVAL_TMP"); if (! tmp) { tmp = get_env("USER"); tmp = (tmp ? "/tmp/"+tmp+"-" : "~/.") + "eval_tmp.i"; } } write, format="%s\n", open(tmp, "w"), code; /* Use "eval_" prefix in order to somewhat protect local variables from caller's code. */ local eval_result, eval_tmp, eval_code, eval_debug; eq_nocopy, eval_tmp, tmp; eq_nocopy, eval_debug, debug; eq_nocopy, eval_code, code; /* Source script and return result. */ include, eval_tmp, 1; if (eval_debug) write, format="Yorick code written in \"%s\"\n", eval_tmp; else remove, eval_tmp; return eval_result; } func undersample(a, nsub, which=, op=) /* DOCUMENT undersample(a, nsub) Returns array A with all (some) dimensions divided by NSUB. The dimensions of interest must be a multiple of NSUB. Keyword WHICH can be used to specify the dimension(s) to shrink. Values in WHICH less or equal zero are counted from the last dimension. By default, all dimensions of A get undersampled. Keyword OP can be used to specify the range operator to apply to the sets of NSUB adjacent values along the considered dimensions: OP=sum to sum the values OP=avg to average values OP=min to keep the smallest value OP=max to keep the largest value By default, the median is taken (WARNING: with the median operator, the result depends in which order the dimensions of A are considered). SEE ALSO: median. */ { if (nsub < 1) error, "NSUB must be >= 1"; if (nsub == 1) return a; if (! is_array(a)) error, "expecting an array"; rank = dimsof(a)(1); if (is_void(which)) { which = indgen(rank); } else { which += (which <= 0)*rank; if (structof(which) != long) error, "bad data type for keyword WHICH"; if (min(which) < 1 || max(which) > rank) error, "out of range dimension in keyword WHICH"; } nw = numberof(which); noop = is_void(op); /* take median value */ if (! noop && typeof(op) != "range") error, "OP must be nil or a range operator"; dims = array(rank+1, rank+2); for (k=1 ; k<=nw ; ++k) { this = which(k); if (this != 1) a = transpose(a, [1,this]); dims(2:) = dimsof(a); dims(2) = nsub; dims(3) = dims(3)/nsub; (tmp = array(structof(a), dims))(*) = a(*); if (noop) { a = median(tmp, 1); } else { a = tmp(op,..); } tmp = []; /* free some memory */ if (this != 1) a = transpose(a, [this,1]); } return a; } /*---------------------------------------------------------------------------*/ local nrows_of, ncols_of; func ndims_of(a) { return (is_array(a) ? dimsof(a)(1) : -1); } func width_of(a) { return (is_array(a) ? ((dims = dimsof(a))(1) >= 1 ? dims(2) : 1) : 0); } func height_of(a) { return (is_array(a) ? ((dims = dimsof(a))(1) >= 2 ? dims(3) : 1) : 0); } func depth_of(a) { return (is_array(a) ? ((dims = dimsof(a))(1) >= 3 ? dims(4) : 1) : 0); } /* DOCUMENT ndims_of(a) - get number of dimensions of array A; returns -1 * for non-array argument; * nrows_of(a) - get number of rows of array A, returns 0 * for non-array or scalar argument; * ncols_of(a) - get number of columns of array A, returns 0 * for non-array or vector argument; * width_of(a) - get length of 1st dimension of A, returns 0 * if A is non-array is a scalar; * height_of(a) - get length of 2nd dimension of A, returns 0 * if A is non-array or has less than 2 dimensions; * depth_of(a) - get length of 3rd dimension of A, returns 0 * if A is non-array or has less than 3 dimensions. * * The number of rows of an array is the length of its first dimension; * the number of columns is the length of its second dimension. * * SEE ALSO: dimsof. */ nrows_of = width_of; ncols_of = height_of; /*---------------------------------------------------------------------------*/ func spline_zoom(a, factor, rgb=) /* DOCUMENT spline_zoom(a, fact) Return an array obtained by cubic spline interpolation of A with all its dimension multiplied by a factor FACT. If keyword RGB is true the first dimsion of A is left unchanged. If keyword RGB is not specified, then it is considered as true if A is a 3 dimensional array of 'char' with its first dimension equal to 3. SEE ALSO: spline, transpose. */ { if (! is_func(spline)) require, "spline.i"; dims = dimsof(a); ndims = dims(1); if (is_void(rgb)) { /* RGB image? */ rgb = (structof(a) == char && ndims == 3 && dims(2) == 3); } if (rgb) { a = transpose(a, 0); k = 1; } else { k = 0; } while (++k <= ndims) { dims = dimsof(a); n0 = dims(2); n1 = max(long(factor*n0 + 0.5), 1); if (n1 == 1) { a = a(avg,..)(..,-); } else { if (n1 != n0) { dims(2) = n1; b = array(double, dims); x0 = (indgen(n0) - (n0 + 1)/2.0)/n0; x1 = (indgen(n1) - (n1 + 1)/2.0)/n1; n = numberof(a)/n0; for (i=1 ; i<=n ; ++i) b(,i) = spline(a(,i), x0, x1); eq_nocopy, a, b; } if (ndims > 1) a = transpose(a, 0); } } if (rgb) return char(max(min(floor(a + 0.5), 255.0), 0.0)); return a; } func map(__map__f, __map__x) /* DOCUMENT map(f, input) Map scalar function F onto array/list argument INPUT to mimics element-wise unary operation. SEE ALSO: _map. */ { /* all locals here must have weird names, since the user's function may rely on external variables for arguments not varying in the source, or for accumulated outputs */ if (is_array(__map__x)) { __map__y = array(structof((__map__i = __map__f(__map__x(1)))), dimsof(__map__x)); __map__y(1) = __map__i; __map__n = numberof(__map__x); for (__map__i=2 ; __map__i<=__map__n ; ++__map__i) { __map__y(__map__i) = __map__f(__map__x(__map__i)); } } else if ((__map__n = typeof(__map__x)) == "list") { __map__y = __map__i = _lst(__map__f(_car(__map__x))); for (__map__x = _cdr(__map__x) ; ! is_void(__map__x) ; __map__x = _cdr(__map__x)) { _cat, __map__i, _lst(__map__f(_car(__map__x))); __map__i= _cdr(__map__i); } } else if (! is_void(__map__x)) { error, "unsupported data type \""+__map__n+"\""; } return __map__y; } /*---------------------------------------------------------------------------*/ /* STRING ROUTINES */ func strcut(str, len) /* DOCUMENT strcut(str, len) Cut input scalar string STR in pieces of length less or equal LEN and return an array of such pieces. SEE ALSO strjoin */ { if ((str_len= strlen(str))<=len) return str; n= (str_len+len-1)/len; result= array(string, n); for (i=1, i1=1, i2=len ; i<=n ; ++i, i1+=len, i2+=len) result(i)= strpart(str, i1:i2); return result; } func strjoin(str, glue) /* DOCUMENT strjoin(str) -or- strjoin(str, glue) Join strings from array STR into a single long string. The string GLUE (default "") is used between each pair of element from STR. SEE ALSO strcut */ { if ((n= numberof(str)) >= 1) { s= str(1); if (glue) for (i=2 ; i<=n ; ++i) s+= glue+str(i); else for (i=2 ; i<=n ; ++i) s+= str(i); return s; } } /*---------------------------------------------------------------------------*/ /* LOGICAL ROUTINES */ func is_string_scalar(x) { return (is_string(x) && is_scalar(x)); } /* DOCUMENT is_string_scalar(x) Check whether or not X is a string scalar. SEE ALSO is_scalar, is_integer_scalar. */ /*---------------------------------------------------------------------------*/ /* FILE ROUTINES */ local _TEMPFILE_ALPHABET, _TEMPFILE_SEED; func tempfile(template) /* DOCUMENT tempfile(template) Returns a file name build from TEMPLATE and which did not exists when the function checked. If the string "XXXXXX" is found in the file part of TEMPLATE (that is after the last / if any), these characters get replaced with a pseudo-random string; otherwise, the pseudo-random string is simply appended to TEMPLATE. The pseudo-random string is chosen so as to make the filename unique. There is however a very small chance that the returned filename is not unique. To limit conflicts, an empty file with the same name as the returned value is created; this file can be deleted or overwritten by the caller. The caller is responsible to delete the temporary file (with remove) when no longer needed. Note that the tempfile function uses its own internal random generator to avoid changing the sequence of random values returned by Yorick's builtin random generator. When called as a subroutine, the internal random generator is (re)initialized. SEE ALSO: open, remove. */ { extern _TEMPFILE_ALPHABET, _TEMPFILE_SEED; if (am_subroutine()) { /* Initialization: seed random generator. */ #if 0 /* _read is *not* designed to read from devices */ file = open("/dev/urandom", "rb", 1); if (file) { /* plan A: use system random generator */ t = array(char, 4); if (_read(file, 0L, t) == 4) { m = 256.0; /* multiplier */ _TEMPFILE_SEED = t(1) + m*(t(2) + m*(t(3) + m*t(4))); return; } } #endif /* plan B: use elapsed time in microseconds to seed random generator */ n = 2.0^32; /* number of values */ r = 1e6; /* microseconds */ t = array(double, 3); timer, t; _TEMPFILE_SEED = floor((sum(t) % (n/r))*r + 0.5) % n; return; } /* Locate substitution pattern in template name. */ pattern = "XXXXXX"; off = strfind("/", template, back=1)(1); sel = strfind(pattern, template, off, back=1); if (sel(2) > sel(1)) { i1 = sel(1) + 1; i2 = sel(2); buf = strchar(template); } else { buf = strchar(template + pattern); i1 = strlen(template) + 1; i2 = i1 + strlen(pattern) - 1; } /* Randomly generate a filename from the template. */ n = numberof(_TEMPFILE_ALPHABET); do { /* 32-bit pseudo-random number generator */ _TEMPFILE_SEED = (1664525.0*_TEMPFILE_SEED + 1013904223.0)%4294967296.0; x = _TEMPFILE_SEED; for (i=i1 ; i<=i2 ; ++i) { r = x % n; buf(i) = _TEMPFILE_ALPHABET(long(r + 1.5)); x = (x - r)/n; } filename = strchar(buf); } while (open(filename, "r", 1)); open, filename, "w"; /* create empty file */ return filename; } if (structof(_TEMPFILE_SEED) != double || dimsof(_TEMPFILE_SEED)(1) != 0) { tempfile; /* setup random generator */ } _TEMPFILE_ALPHABET = ['0','1','2','3','4','5','6','7','8','9', 'A','B','C','D','E','F','G','H','I','J','K','L','M', 'N','O','P','Q','R','S','T','U','V','W','X','Y','Z', 'a','b','c','d','e','f','g','h','i','j','k','l','m', 'n','o','p','q','r','s','t','u','v','w','x','y','z']; func filesize(filename, errmode) /* DOCUMENT filesize(filename) * -or- filesize(filename, errmode) * * Returns the size (in bytes) of file FILENAME which must be readable. * If ERRMODE is non-nil and non-zero, fail by returning -1L, otherwise * failure to open the file in read mode is a runtime error. * * SEE ALSO: open, _read. */ { /* Open file in binary mode and get the file size by a bisection method, attempting to read a single byte at various offsets. To avoid integer overflows, all offset computations are performed in double precision. */ stream = open(filename, "rb", 1); if (! stream) { if (errmode) return -1L; error, "cannot read file"; } byte = char(0); nbits = 8*sizeof(long) - 1; max_offset = 2.0^nbits - 1.0; min_size = 0.0; max_size = -1.0; /* negative until maximum size is detected */ offset = 16384.0; gain = 2.0; for (;;) { if (_read(stream, long(offset), byte)) { min_size = offset + 1.0; } else { max_size = offset; } if (max_size >= min_size) { /* Maximum size has been set: check for convergence, otherwise take the safeguarded bissection step. */ if (min_size == max_size) { return long(max_size); } offset = min(max_offset, floor((min_size + max_size)/2.0)); } else { /* Maximum size has not yet been set: grow the size. */ offset = min(max_offset, floor(min_size*gain)); } } } func pwd(nil) /* DOCUMENT pwd -or- pwd() Prints out (subroutine form) or returns (function form) full path of current working directory. SEE ALSO: cd, lsdir. */ { if (! is_void(nil)) error, "unexpected non-nil argument"; dir = cd("."); if (am_subroutine()) write, format="%s\n", dir; else return dir; } func glob(pat) /* DOCUMENT glob(pat) * Returns a list of files matching glob-style pattern PAT. Only the * 'file' part of PAT can have wild characters (the file part is after * the last '/' in PAT). * * SEE ALSO: lsdir, strglob. */ { i = strfind("/", pat, back=1); if ((i = i(2)) >= 1) { dir = strpart(pat, 1:i); pat = strpart(pat, i+1:0); } else { dir = "./"; } list = lsdir(dir); list = list(where(strglob(pat, list))); if (! is_void(list)) return dir + list; } func strip_file_extension(path, ext, ..) /* DOCUMENT strip_file_extension(path); * -or- strip_file_extension(path, ext, ..); * * Strip file extension from filename PATH (an array of strings). * If no other arguments are specified, the result is PATH with * trailing characters after (and including) the last dot '.' * stripped (the last dot must however occur after the last slash * '/'). Otherwise, there may be any number of extensions EXT which * are tried in turn until one matches the end of PATH, in that case * the result is PATH stripped from that particular extension (which * may or may not contain a dot). If PATH is an array, the same * processus is applied to every element of PATH (i.e. they can * match a different extension). * * * SEE ALSO: strpart, strgrep, streplace. */ { if (! is_string(path)) { error, "expecting a string"; } while (more_args()) { grow, ext, next_arg()(*); } if (is_void(ext)) { return streplace(path, strgrep("\\.[^./]*$", path), ""); } result = path; /* make a private copy */ path_len = strlen(path); n = numberof(ext); ext_len = strlen(ext); for (j = numberof(path); j >= 1; --j) { len1 = path_len(j); path1 = path(j); for (k = 1; k <= n; ++k) { if ((len2 = ext_len(k)) <= len1 && len2 > 0 && strpart(path1, 1 - len2 : 0) == ext(k)) { result(j) = strpart(path1, 1 : -len2); break; } } if (k > n) { result(j) = path1; } } return result; } func expand_file_name(_path) /* DOCUMENT expand_file_name(path) Expand leading "~" in file name PATH which must be an array of strings (or a scalar string). SEE ALSO: strpart, cd, get_cwd, get_file_name, protect_file_name. */ { result = array(string, dimsof(_path)); n = numberof(_path); cwd = get_cwd(); /* memorize current working directory */ head = string(0); local path; for (i=1 ; i<=n ; ++i) { /* Expand leading "~" in file name(s). */ eq_nocopy, path, _path(i); if (strpart(path, 1:1) == "~") { sread, path, format="%[^/]", head; home = cd(head); if (home) { cd, cwd; /* restore working directory */ tail = strpart(path, strlen(head)+1:0); if (strlen(tail)) { /* remove trailing '/' in HOME to avoid two '/' in result */ result(i) = strpart(home, 1:-1) + tail; } else if (strlen(home) > 1) { path = strpart(home, 1:-1); } else { eq_nocopy, path, home; } } } result(i) = path; } return result; #if 0 c = *pointer(path); i = numberof(c); expand = (i>1 && c(1) == '~'); slash = (i>1 && c(-1) == '/'); while (--i>0 && c(i) != '/') ; #endif } func get_file_name(obj) /* DOCUMENT get_file_name(obj) If OBJ is a stream, returns the path name of the file associated with the stream. Otherwise if OBJ is an array of strings, expand leading "~" in the elements of OBJ. SEE ALSO: open, print, expand_file_name, protect_file_name. */ { /* Expand leading "~" if string object. */ if (structof(obj) == string) { return expand_file_name(obj); } /* Check input and get description of stream by the print() command. */ if ((id = typeof(obj)) == "stream") { id = 1; s = print(obj); } else if (id == "text_stream") { id = 2; s = print(obj)(2:); } else { error, "unexpected non-string, non-stream argument"; } /* Join backslash terminated lines from print() result (another possibility would be to change the line length with `print_format' but there is no way to restore the previous line_lenght unles we building a wrapper around original `print_format' routine and make a substitution). */ join = (strpart(s, 0:0) == "\\"); if (anyof(join)) { r = array(string, (ns = numberof(s)) - sum(join) + join(0)); i = j = 0; while (i < ns) { w = s(++i); while (join(i)) { w = strpart(w, :-1); if (++i > ns) break; w += s(i); } r(++j) = w; } s = r; w = r = []; } /* Recover the full path of the stream file from the joined lines. */ if (id == 1) { /* Binary stream. */ if (numberof(s) == 2) { w1 = w2 = string(0); if (sread(s(1), format="%[^:]", w1) == 1 && sread(s(2), format="%[^/]", w2) == 1) { return strpart(s(2), strlen(w2)+1:0) + strpart(s(1), strlen(w1)+3:0); } } error, "unexpected binary stream descriptor"; } else { /* Text stream. */ if (numberof(s) == 1) { w = string(0); if (sread(s(1), format="%[^/]", w) == 1) { return strpart(s(1), strlen(w)+1:0); } } error, "unexpected text stream descriptor"; } } local _protect_file_name_table, _protect_file_name_list; func protect_file_name(path) /* DOCUMENT protect_file_name(path) Protect special characters in PATH (apostrophes, quotes, $, *, ?, [, etc) by backslashes to avoid them being interpreted by the shell, for instance when using the system() builtin function. SEE ALSO: system, get_file_name, expand_file_name. */ { c = *pointer(path); n = numberof(c) - 1; /* same as strlen(path) */ p = _protect_file_name_table(1 + c); r = array(char, 2*n + 1); i = 0; j = 0; while (++i <= n) { if (p(i)) r(++j) = '\\'; r(++j) = c(i); } return string(&r); } _protect_file_name_list = ['$','&','!','#','?','*', '[',']','{','}','<','>', '\\','"','\'', ' ','\t','\r','\n','\v','\f']; (_protect_file_name_table = array(char, 256))(1 + _protect_file_name_list) = 1; func read_ascii(file, compress=, maxcols=) /* DOCUMENT read_ascii(file_or_name) Reads ascii numeric data in columns from text file. FILE_OR_NAME is the name of the file or an already open file stream. The result is a NCOLUMNS-by-NLINES array of doubles. Data are read as double values arranged in columns separated by any number of spaces or tabs. Comments starting with a "#" or any other character which is not part of a number are ignored up to the end-of-line. Blank lines are ignored. The first non-blank/commented line gives the number of values per column, for subsequent lines. Subsequent lines must have the same number of columns -- blanks in columns are not permitted, use 0.0 instead. However, minimal error checking is performed, and if the data is not really in columns, read_ascii can silently fail to interpret your file as you would scanning it by eye. The read operation will be much faster if the number of commented lines is relatively small. Blank lines cost nothing, while a line containing just a "#" is expensive. If the file is specified by its name, it may be compressed in which case it get automatically decompressed while reading (see xopen). The value of keyword COMPRESS ("auto" by default) is passed to xopen. For very large data file, keyword MAXCOLS can be used to specify the expected maximum number of columns (10000 by default). SEE ALSO: xopen, read, raw_read. */ { /* open the file if it's not already open */ if (structof(file) == string) file = xopen(file, compress=(is_void(compress) ? "auto" : compress)); /* read lines one at a time until the "model" line which * determines the number of columns is discovered * assume the number of columns is less than MAXCOLS */ x = array(double, (is_void(maxcols) ? 10000 : maxcols)); ncols = 0; while ((line = rdline(file))) { ncols = sread(line, x); if (ncols) break; /* got a line with numbers */ } if (! ncols) return []; nrows = 1; list = _lst([x(1:ncols)]); x = array(double, ncols, 10000/ncols + 1); for(;;) { /* try to grab at least 10000 numbers from the file * blank lines will be skipped, but any comments will * interrupt the read */ if (! (n = read(file, x))) { /* if didn't get any, drop back to reading comments one * line at a time until we get some more numbers */ while ((line = rdline(file))) { if ((n = sread(line, x))) break; } if (! line) break; /* rdline detected end-of-file, n==0 too */ } if (n%ncols) error, "data is not in columns"; n /= ncols; /* grow the list the fast way, adding new values to its head * (adding to the tail would make growth an n^2 proposition, * as would using the grow function) */ list = _cat(x(,1:n), list); nrows += n; } /* pop chunks off list and reassemble result */ x = array(0.0, ncols, nrows); for (i=nrows ; list ; list=_cdr(list)) { n = numberof(_car(list))/ncols; x(,i-n+1:i) = _car(list); i -= n; } return x; } func load_text(file, compress=) /* DOCUMENT load_text(file) Returns all lines of text file as a vector of strings. Returns nil if there are no lines to read. FILE can be a file name or a text stream. In the latter case, the lines not yet read get returned. By default, if the file is specified by its name, it will be automatically decompressed if its compressed; it is possible to force another behaviour by specifying a value different from "auto" for keyword COMPRESS (see xopen). SEE ALSO: xopen, rdline, dump_text. */ { if (structof(file) == string) file = xopen(file, compress=(is_void(compress) ? "auto" : compress)); text = rdline(file, 1000); while (text(0)) grow, text, rdline(file, numberof(text)); if (is_array((j = where(text)))) return text(j); } func dump_text(file, text, compress=, level=, preserve=) /* DOCUMENT dump_text, file, text; Dump every elements of string array TEXT as individual lines into a text file. FILE can be a file name or a text stream. If the file is specified by its name, keywords COMPRESS, LEVEL can be used to specify a compression method (see xopen). The default value of COMPRESS is "auto" (i.e., method guessed on the basis of the file extension). If the file is specified by its name, keyword PRESERVE can be set to true to avoid overwriting an existing file. SEE ALSO: xopen, rdline, load_text. */ { if ((anything = ! is_void(text)) && structof(text) != string) error, "expecting array of strings or nil"; if (structof(file) == string) { file = xopen(file, "w", compress=(is_void(compress) ? "auto" : compress), level=level, preserve=preserve); } if (anything) write, file, format="%s\n", text; } func guess_compression(filename) /* DOCUMENT guess_compression, filename; -or- guess_compression(filename) Guess which compression program was used to produce file FILENAME according to first bytes of this file. When called as a subroutine, the file name is printed out with the name of the compression program if any. If called as a function, the result is an integer: 1 - if file compressed with "gzip"; 2 - if file compressed with "bzip2"; 3 - if file compressed with "compress"; 4 - if file compressed with "pack"; 0 - otherwise. SEE ALSO: xopen. */ { /* according to information in /etc/magic: * * method min. bytes * size 0 1 2 3 * --------- ---- ---- ---- ---- ---- * pack: 3 \037 \036 * compress: 3 \037 \235 * gzip: 20 \037 \213 c (1) * bzip2: 14 'B' 'Z' 'h' c (2) * * (1) if c<8, compression level, else if c==8 deflated * (2) with '0' <= c <= '9', block size = c*100kB * minimum size has been computed for an empty file: * pack -> 3 bytes * compress -> 3 bytes * bzip2 -> 14 bytes * gzip -> 20 bytes, if compression level is specified * 24 bytes, otherwise */ magic = array(char, 4); n = _read(open(filename, "rb"), 0, magic); if ((c = magic(1)) == '\037') { if ((c = magic(2)) == '\213') { if (! am_subroutine()) return 1; /* gzip */ write, format="%s: compressed with \"gzip\"\n", filename; return; } else if (c == '\235') { if (! am_subroutine()) return 3; /* compress */ write, format="%s: compressed with \"compress\"\n", filename; return; } else if (c == '\036') { if (! am_subroutine()) return 4; /* pack */ write, format="%s: compressed with \"pack\"\n", filename; return; } } else if (c == 'B' && magic(2) == 'Z' && magic(3) == 'h' && '0' <= (c = magic(4)) && c <= '9') { if (! am_subroutine()) return 2; /* bzip2 */ write, format="%s: compressed with \"bzip2\" (block size = %d kB)\n", filename, 100*(c - '0'); return; } if (! am_subroutine()) return 0; write, format="%s: uncompressed?\n", filename; } func xopen(filename, filemode, preserve=, nolog=, compress=, level=, prims=) /* DOCUMENT xopen(filename) -or- xopen(filename, filemode) Opens the file FILENAME according to FILEMODE (both are strings). The return value is an IOStream (or just stream for short). When the last reference to this return value is discarded, the file will be closed. The file can also be explicitly closed with the close function (which see). The FILEMODE (default "r" -- open an existing text file for reading) determines whether the file is to be opened in read, write, or update mode, and whether writes are restricted to the end-of-file (append mode). FILEMODE also determines whether the file is opened as a text file or as a binary file. FILEMODE can have the following values, which are the same as for the ANSI standard fopen function: "r" - read only "w" - write only, random access, existing file overwritten "a" - write only, forced to end-of-file, existing file preserved "r+" - read/write, random access, existing file preserved "w+" - read/write, random access, existing file overwritten "a+" - read/write, reads random access, writes forced to end-of-file, existing file preserved "rb" "wb" "ab" "r+b" "rb+" "w+b" "wb+" "a+b" "ab+" without b means text file, with b means binary file Keyword COMPRESS can be used to specify compression method for a text file open for reading (FILEMODE="r") or writing (FILEMODE="w") only -- (de)compression is unsupported in append mode or for binary files. The value of keyword COMPRESS can be a scalar string or an integer: "auto" - guess compression according to first bytes of file in read mode, or according to file extension in write mode: ".gz" for gzip, ".bz2" for bzip2 and ".Z" for compress. 0 "none" - no (de)compression 1 "gzip" - use gzip to (de)compress 2 "bzip2" - use bzip2 to (de)compress 3 "compress" - use compress to (de)compress 4 "pack" - use pack to (de)compress The default value for COMPRESS is "auto" in read mode and "none" in write mode. Note that "gzip", "bzip2", "pack" and "compress" commands must exists in your $PATH for compressing with the corresponding methods. Decompression of files compressed with "pack" and "compress" is done by "gzip". If keyword COMPRESS is explicitely 0, no decompression is ever applied; if keyword COMPRESS is explicitely non-zero, the file must have been compressed. The compression level for gzip and bzip2 can be specified as an integer value thanks to keyword LEVEL. Keyword PRIMS can be used to specify primitives data type different than the native ones for binary files (PRIMS is ignored for text files). PRIMS can be a scalar string (i.e., "alpha", "mac", "sun3", "cray", "macl", "sun", "dec", "pc", "vax", "vaxg", "i86", "sgi64", or "xdr") or a 32-element vector of long's as taken by set_primitives (which see). When a binary file is created, it is possible to avoid the creation of the log-file FILENAME+"L" by setting keyword NOLOG to true. Keyword PRESERVE can be set to true to avoid overwriting an existing file when FILENAME is open for writing (i.e. with a "w" in FILEMODE). BUGS: If (de)compression is used, FILENAME must not contain any double quote character ("). SEE ALSO: close, guess_compression, open, popen, set_primitives. */ { if (is_void(filemode) || filemode == "r") { /* Open file for reading in text mode. */ compress = __xopen_get_compress(compress, filename, 1); if (! compress) return open(filename, "r"); if (compress == 2) return popen("bzip2 -dc \"" + filename + "\"", 0); if (compress == -1) error, "bad value for keyword COMPRESS"; return popen("gzip -dc \"" + filename + "\"", 0); } if (preserve && strmatch(filemode, "w") && open(filename, "r", 1)) error, "file \""+filename+"\" already exists"; filemode if (filemode == "w") { /* Open file for writing in text mode. */ compress = __xopen_get_compress(compress, filename, 0); if (! compress) return open(filename, filemode); if (compress == 1) { if (is_void(level)) command = swrite(format="gzip > \"%s\"", filename); else command = swrite(format="gzip -%d > \"%s\"", level, filename); } else if (compress == 2) { if (is_void(level)) command = swrite(format="bzip2 > \"%s\"", filename); else command = swrite(format="bzip2 -%d > \"%s\"", level, filename); } else if (compress == 3) { command = swrite(format="compress > \"%s\"", filename); } else if (compress == 2) { command = swrite(format="pack > \"%s\"", filename); } else { error, "bad value for keyword COMPRESS"; } command return popen(command, 1); } /* Open file for other modes. */ if (! (is_void(compress) || compress == 0 || compress == "none")) error, "(de)compression unsupported in mode \""+filemode+"\""; if (binary && nolog) { /* will remove log-file unless it already exists */ logfile = filename + "L"; if (open(logfile, "r", 1)) logfile = []; } else { logfile = []; } file = open(filename, filemode); if (logfile) remove, logfile; /* Return open file after optionally installing primitive data types. */ if (is_void(prims) || ! strmatch(filemode, "b")) return file; if ((s = structof(prims)) == string) { if (! dimsof(prims)(1)) { if (prims != "set" && prims != "get" && is_func((sym = symbol_def(prims+"_primitives"))) == 1) { sym, file; return file; } else if (is_array((sym = symbol_def("__"+prims))) && structof(sym) == long && numberof(sym) == 32 && dimsof(sym)(1) == 1) { set_primitives, file, sym; return file; } } else if (s == long && numberof(prims) == 32 && dimsof(prims)(1) == 1) { set_primitives, file, prims; return file; } } error, "bad value for keyword PRIMS"; } func __xopen_get_compress(compress, filename, for_reading) /* DOCUMENT __xopen_get_compress(compress, filename, for_reading) Private function called by xopen. SEE ALSO xopen. */ { if (is_void(compress)) { if (for_reading) return guess_compression(filename); return 0; } else if (is_array(compress) && ! dimsof(compress)(1)) { if ((s = structof(compress)) == string) { if (compress == "auto") { if (for_reading) return guess_compression(filename); if (strpart(filename, -2:0) == ".gz" ) return 1; /* gzip */ if (strpart(filename, -3:0) == ".bz2") return 2; /* bzip2 */ if (strpart(filename, -1:0) == ".Z" ) return 3; /* compress */ return 0; } if (compress == "none" ) return 0; if (compress == "gzip" ) return 1; if (compress == "bzip2" ) return 2; if (compress == "compress") return 3; if (compress == "pack" ) return 4; } else if ((s == long || s == int || s == short || s == char) && compress >= 0 && compress <= 4) { return compress; } } return -1; } func raw_read(filename, type, .., encoding=, offset=) /* DOCUMENT raw_read(filename, type, dimlist, ...) * * Read binary array of TYPE elements with DIMLIST dimension list * into file FILENAME and return the array. * * Keyword OFFSET can be used to set the number of bytes to skip * prior to reading the data. * * Keyword ENCODING can be used to change the data encoding of the * file. The value of the keyword is a string like: * * "xdr", "sun" - eXternal Data Representation (IEEE big endian) * "native" - native data representation (i.e. no conversion) * "i86", "pc" - IEEE little endian machines * ... * * see documentation for "__sun" for a list of supported encodings; * the default is "native". * * * SEE ALSO: open, _read, __sun, make_dimlist, read_ascii. */ { /* Get dimension list. */ dims = [0]; while (more_args()) { make_dimlist, dims, next_arg(); } /* Open file. */ stream = open(filename, "rb"); if (! is_void(encoding) && encoding != "native") { symbol = encoding + "_primitives"; if (is_func(symbol_exists)) { /* Function 'symbol_exists' is provided by Yeti. */ set_encoding = (symbol_exists(symbol) ? symbol_def(symbol) : -1); } else { /* symbol_def will raise an error if symbol does not exists */ set_encoding = symbol_def(symbol); } if (is_func(set_encoding) != 1) { error, "bad encoding \""+encoding+"\""; } set_encoding, stream; } save, stream, complex; /* make stream aware of the definition of a complex */ /* Read data. */ if (is_void(offset)) { offset = 0L; } data = array(type, dims); if (type == char) { nbytes = _read(stream, offset, data); if (nbytes != numberof(data)) { error, "short file"; } } else { _read, stream, offset, data; } return data; } /*---------------------------------------------------------------------------*/ /* PARSING OF PASSWORD FILE */ local pw_get_user, pw_get_uid, pw_get_gid; local pw_get_name, pw_get_home, pw_get_shell; /* DOCUMENT pw_get_user(id) // user name * -or- pw_get_uid(id) // user numerical identifier * -or- pw_get_gid(id) // group numerical identifier * -or- pw_get_name(id) // real user name (from GECOS field) * -or- pw_get_home(id) // home directory of user * -or- pw_get_shell(id) // path to shell of user * * These functions return the value(s) of a specific field of password * entry matching user ID by parsing /etc/passwd file. If ID is * unspecified, get_env("USER") is used; otherwise, ID can be a string or * a numerical identifier. If ID is specified, it can be a scalar or an * array and the result has the same geometry as ID. For a non-existing * entry (or empty field), the returned value is -1 or the nil-string. * * Keyword PASSWD can be used to specify another location for the * password file (default: "/etc/passwd"). * * Keyword SED can be used to specify the path to the 'sed' command * (default: "sed"). * * SEE ALSO: get_env, popen. */ func pw_get_user (id,sed=,passwd=) { return _pw_get("s/^\\([^:]*\\).*$/\\1/"); } func pw_get_uid (id,sed=,passwd=) { return _pw_get("s/^\\([^:]*:\\)\\{2\\}\\([^:]*\\).*$/\\2/", 1); } func pw_get_gid (id,sed=,passwd=) { return _pw_get("s/^\\([^:]*:\\)\\{3\\}\\([^:]*\\).*$/\\2/", 1); } func pw_get_name (id,sed=,passwd=) { return _pw_get("s/^\\([^:]*:\\)\\{4\\}\\([^,:]*\\).*$/\\2/"); } func pw_get_home (id,sed=,passwd=) { return _pw_get("s/^\\([^:]*:\\)\\{5\\}\\([^:]*\\).*$/\\2/"); } func pw_get_shell(id,sed=,passwd=) { return _pw_get("s/^.*:\\([^:]*\\)$/\\1/"); } func _pw_get(script, as_integer) /* DOCUMENT _pw_get(script, as_integer) Private function used by pw_get_* functions. SEE ALSO: pw_get_real_name. */ { extern id, sed, passwd; if (is_void(passwd)) passwd = "/etc/passwd"; if (is_void(sed)) sed = "sed"; if (is_void(id)) id = get_env("USER"); if ((s = structof(id)) == string) { /* user specified by its name */ select = swrite(format="^%s:", id); result = (as_integer ? array(-1, dimsof(id)) : id); } else if (s==long || s==int || s==short || s==char) { /* user specified by its numerical ID */ select = swrite(format="^[^:]*:[^:]*:%d:", id); result = array((as_integer ? -1 : string), dimsof(id)); } else { error, "missing or bad user ID"; } if (! open(passwd, "r" , 1)) error, "cannot read password file"; format = "%s -e '/%s/!d;%s' '%s'"; n = numberof(id); for (i=1;i<=n;++i) { value = rdline(popen(swrite(format=format, sed, select(i), script, passwd), 0)); if (strlen(value)) { if (as_integer) { x = 0; if (sread(value,x) == 1) result(i) = x; } else { result(i) = value; } } } return result; } /*---------------------------------------------------------------------------*/ /* PDB FILES */ func pdb_list(file) /* DOCUMENT pdb_list, file; -or- pdb_list(file) Lists contents of PDB binary file. FILE can be either a file name or a binary stream. SEE ALSO: createb, openb, restore, pdb_restore_all. */ { if (structof(file) == string) file = openb(file); vars = get_vars(file); if (! am_subroutine()) return vars; title = ["Non-record variables", " Record variables"]; for (i=1 ; i<=2 ; ++i) { write, format="%s:", title(i); if (numberof(*vars(i))) { write, format=" %s", *vars(i); write, format="%s\n", ""; } else { write, format="%s\n", " "; } } } func pdb_restore_all(_f_i_l_e_) /* DOCUMENT pdb_restore_all, file; Restore all non-record variables of a PDB file. FILE can be either a file name or a binary stream. SEE ALSO: createb, openb, restore, pdb_list. */ { if (structof(_f_i_l_e_) == string) _f_i_l_e_ = openb(_f_i_l_e_); restore, _f_i_l_e_; } /*---------------------------------------------------------------------------*/ /* PROFILING ROUTINES */ local _timer_stamp; func timer_start { extern _timer_stamp; _timer_stamp = array(double, 3); timer, _timer_stamp; } func timer_elapsed(count) /* DOCUMENT timer_start; -or- timer_elapsed; -or- timer_elapsed, count; -or- timer_elapsed() -or- timer_elapsed(count) The subroutine timer_start (re)starts the timer and the function timer_elapsed computes the elapsed time since last call to timer_start. If COUNT is given, the elapsed time is divided by COUNT. When called as a subroutine, timer_elapsed prints out the elapsed time; when called as a function, it returns [CPU,SYSTEM,WALL], with all three times measured in seconds. The two functions make use of external variable _timer_stamp to memorize the initiale times. For instance: timer_start; ... // some code to be profiled timer_elapsed; ... // some more code to be profiled timer_elapsed; // prints out _total_ elapsed time SEE ALSO: timer. */ { extern _timer_stamp; elapsed = _timer_stamp; timer, elapsed; elapsed -= _timer_stamp; if (! is_void(count)) elapsed /= count; if (am_subroutine()) { write, format="cpu=%g, system=%g, wall=%g\n", elapsed(1), elapsed(2), elapsed(3); } else { return elapsed; } } /*---------------------------------------------------------------------------*/ func moments(x, mean, variance) /* DOCUMENT moments(x) * -or- moments(x, mean) * -or- moments(x, mean, variance) * * Returns the first moments of values in array X as: * * [MEAN, VARIANCE, SKEWNESS, KURTOSIS] * * where MEAN and VARIANCE are the mean and variance of the distribution * sampled by X. They can be specifed as the 2nd and/or 3rd arguments, * otherwise sample estimates are used: * * MEAN = avg(X) * * VARIANCE = 1/M * sum((x - MEAN)^2) * * where N = numberof(X) and where M = N, if the mean is provided; or * M = N - 1, when the sample mean avg(X) is used. The other moments * are: * * SKEWNESS = 1/N * sum(((x - MEAN)/sqrt(VARIANCE))^3) * * KURTOSIS = 1/N * sum(((x - MEAN)/sqrt(VARIANCE))^4) - 3 * * The skewness is non-dimensional and characterizes the degree of * asymmetry of a distribution around its mean. For a Gaussian * distribution, the standard deviation of the skewness is sqrt(15/N) * when the true mean is used, and sqrt(6/N) when the mean is estimated * by the sample mean. * * The kurtosis is non-dimensional and measures the peakedness or * flatness of a distribution with respect to a Normal distribution. For * a Gaussian distribution, the standard deviation of the kurtosis is * sqrt(96/N) when the true variance is known and sqrt(24/N) when it is * the sample estimate. A distribution with positive kurtosis is termed * 'leptokurtic' and is more peaked than the Normal distribution. A * distribution with negative kurtosis is termed 'platykurtic' and is * more flat than the Normal distribution. An in-between distribution is * termed 'mesokurtic'. * * SEE ALSO: avg, rms, median. */ { n = numberof(x); if (is_void(mean)) { mean = avg(x); m = n - 1; } else { mean += 0.0; /* make sure it is floating point */ m = n; } if (mean) { x -= mean; } if (is_void(variance)) { variance = (1.0/m)*sum(x*x); } if (variance != 1) { x *= (1.0/sqrt(variance)); } x3 = x*x*x; skewness = (1.0/n)*sum(x3); kurtosis = (1.0/n)*sum(x*x3) - 3.0; return [mean, variance, skewness, kurtosis]; } func _stat_worker(x) /* DOCUMENT _stat_worker(x) Private routine used by stat, returns vector of double's: [min(X), max(X), avg(X), std(X)] where std(X) is the standard deviation of X. SEE ALSO stat. */ { if (structof(x)!=double) x= double(x); avg_x= avg(x); dx = x - avg_x; return [min(x), max(x), avg_x, sqrt(avg(dx*dx))]; } func stat(..) /* DOCUMENT stat, x, ... Print out statistics and information for all the arguments. */ { ith= 0; while (more_args()) { ++ith; x= next_arg(); write, format="%2d: ", ith; if (is_array(x)) { write, format="array(%s", typeof(x); dims= dimsof(x); n= numberof(dims); for (k=2 ; k<=n ; ++k) write, format=",%d", dims(k); type= structof(x); is_numerical= (type==double || type==long || type==int || type==char || type==complex || type==float || type==short); write, format=")%s", (is_numerical ? " " : "\n"); if (is_numerical) { fmt= "min=%g max=%g avg=%g std=%g\n"; if (type==complex) { s= _stat_worker(double(x)); write, format="\n real part: "+fmt, s(1), s(2), s(3), s(4); s= _stat_worker(x.im); write, format=" imaginary part: "+fmt, s(1), s(2), s(3), s(4); s= _stat_worker(abs(x)); write, format=" modulus: "+fmt, s(1), s(2), s(3), s(4); } else { s= _stat_worker(x); write, format=fmt, s(1), s(2), s(3), s(4); } } } else { write, format="%s, %s\n", typeof(x), strjoin(print(x)); } } } /*---------------------------------------------------------------------------*/ func open_url(url, new=, browser=) /* DOCUMENT open_url, url; * Open URL into existing browser. Keyword NEW can be set to "tab" or * anything else on-false to open URL into a new tab or a new window. * Keyword BROWSER can be set to the path of the browser to use (default: * "firefox"). * * SEE ALSO: system. */ { if (is_void(browser)) browser = "firefox"; if (new) { if (new == "tab") fmt = "%s -remote 'openURL(%s,new-tab)'"; else fmt = "%s -remote 'openURL(%s,new-window)'"; } else { fmt = "%s -remote 'openURL(%s)'"; } system, swrite(format=fmt, browser, url); } /*---------------------------------------------------------------------------*/ func smooth(a, level) /* DOCUMENT smooth(a) -or- smooth(a, level) Returns array A smoothed along its dimensions. I.e. for a 1D array: smooth(A) = A(pcen)(zcen) for a 2D array: smooth(A) = A(pcen,pcen)(zcen,zcen) ... (up to 6 dimensions). For a greater number of dimensions, each direction is smoothed and transposed in turn: apart from rounding errors, the result is the same but the computation time is approximately multiplied by 3. If you oftenly smooth arrays with more than 6 dimensions you may think about modifying the source... Optional argument LEVEL (default 1) set the number of time the smoothing operation is performed. PROPERTIES OF THE SMOOTHING OPERATOR: (i) The smoothing operator is linear and symmetric. For instance, for a vector, A, smooth(A)=S(,+)*A(+) where the matrix S is tridiagonal: [3 1 ] [1 2 1 ] [ 1 2 1 ] 0.25 * [ \ \ \ ] where, to improve readability, [ \ \ \ ] missing values are all zero. [ 1 2 1 ] [ 1 2 1] [ 1 3] You can, in principle, reverse the smoothing operation with TDsolve along each dimensions of smooth(A). Note:For a vector A, the operator S-I applied to A (where I is the identity matrix) is the finite difference 2nd derivatives of A (but for the edges). (ii) The smoothing operator does not change the sum of the element values of its argument, i.e.: sum(smooth(A)) = sum(A). (iii) Only an array with all elements having the same value is invariant by the smoothing operator. In fact "slopes" along dimensions of A are almost invariant, only the values along the edges are changed. The symmetry of the smoothing operator is important for the computation of gradients. For instance, let Y = smooth(X) and DQ_DY be the gradient of a scalar function Q with respect to Y, then the gradient of Q with respect to X is simply: DQ_DX = smooth(DQ_DY) TO DO: By default A is smoothed along all its dimensions, but the list of dimensions to smooth can be specified with keyword WHICH. As usual, negative dimensions are taken as offset from the last one. If keyword WRAP is true (non-nil and non-zero) a wrapped version of the operator (with same properties but no longer tridiagonal) is applied instead. This is suitable for periodic arrays (e.g. FFT transformed arrays). SEE ALSO: TDsolve. */ { n= dimsof(a)(1); if (is_void(level) || level == 1) { if (n == 1) return a(pcen)(zcen); if (n == 2) return a(pcen,pcen)(zcen,zcen); if (n == 3) return a(pcen,pcen,pcen)(zcen,zcen,zcen); if (n == 4) return a(pcen,pcen,pcen,pcen)(zcen,zcen,zcen,zcen); if (n == 5) return a(pcen,pcen,pcen,pcen,pcen)(zcen,zcen,zcen,zcen,zcen); if (n == 6) return a(pcen,pcen,pcen,pcen,pcen,pcen)(zcen,zcen,zcen,zcen,zcen,zcen); while (n--) a= transpose(a(pcen,..)(zcen,..)); return a; } if (n == 1) { for (i=1; i<=level; i++) a= a(pcen)(zcen); } else if (n == 2) { for (i=1; i<=level; i++) a= a(pcen,pcen)(zcen,zcen); } else if (n == 3) { for (i=1; i<=level; i++) a= a(pcen,pcen,pcen)(zcen,zcen,zcen); } else if (n == 4) { for (i=1; i<=level; i++) a= a(pcen,pcen,pcen,pcen)(zcen,zcen,zcen,zcen); } else if (n == 5) { for (i=1; i<=level; i++) a= a(pcen,pcen,pcen,pcen,pcen)(zcen,zcen,zcen,zcen,zcen); } else if (n == 6) { for (i=1; i<=level; i++) a= a(pcen,pcen,pcen,pcen,pcen,pcen)(zcen,zcen,zcen,zcen,zcen,zcen); } else { while (n--) { for (i=1; i<=level; i++) a= a(pcen,..)(zcen,..); a= transpose(a); } } return a; } /*---------------------------------------------------------------------------*/ /* ALTERNATIVE TO YETI BUILTIN FUNCTIONS */ if (! is_func(yeti_init)) { // first try to load yeti include, "yeti.i", 3; if (! is_func(yeti_init)) { // fall-back to interpreted version of some functions require, "emulate_yeti.i"; } } /*---------------------------------------------------------------------------* * Local Variables: * * mode: Yorick * * tab-width: 8 * * fill-column: 75 * * c-basic-offset: 2 * * coding: latin-1 * * End: * *---------------------------------------------------------------------------*/ frigaut-yorick-yutils-c173974/yorick-yutils.spec000066400000000000000000000055411152651572200220010ustar00rootroot00000000000000%define name yorick-yutils %define version 1.5.0 %define release gemini2010apr14 Summary: Set of utility interpreted functions for yorick Name: %{name} Version: %{version} Release: %{release} Source0: %{name}-%{version}.tar.bz2 License: GPLv2 Group: Development/Languages Packager: Francois Rigaut Url: http://www.maumae.net/yorick/doc/plugins.php BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-buildroot Requires: yorick >= 2.1 BuildArch: noarch %description yutils contains a collection of utility functions, ranging from plotting, to system access, to math and coordinates transforms. More details: 1. Content: README LICENSE astro_util1.i check.i constants.i copy_plot.i detect.i fft_utils.i histo.i idl-colors.i img.i linalg.i lmfit.i plot_demo2.i plot_demo.i plot.i plvp.i poly.i pyk.i random_et.i rdcols.i rgb.i util_fr.i utils.i coords.i doppler.i graphk.i gauss.i tws*.i %prep %setup -q %build if [ -f check.i ] ; then mv check.i %{name}_check.i fi; %install rm -rf $RPM_BUILD_ROOT mkdir -p $RPM_BUILD_ROOT/usr/lib/yorick/i mkdir -p $RPM_BUILD_ROOT/usr/lib/yorick/data mkdir -p $RPM_BUILD_ROOT/usr/lib/yorick/python mkdir -p $RPM_BUILD_ROOT/usr/lib/yorick/i-start mkdir -p $RPM_BUILD_ROOT/usr/share/doc/yorick-yutils mkdir -p $RPM_BUILD_ROOT/usr/lib/yorick/packages/installed install -m 644 *.i $RPM_BUILD_ROOT/usr/lib/yorick/i install -m 644 colors1.tbl $RPM_BUILD_ROOT/usr/lib/yorick/data install -m 644 *.py $RPM_BUILD_ROOT/usr/lib/yorick/python install -m 644 *_start.i $RPM_BUILD_ROOT/usr/lib/yorick/i-start install -m 644 LICENSE $RPM_BUILD_ROOT/usr/share/doc/yorick-yutils install -m 644 README $RPM_BUILD_ROOT/usr/share/doc/yorick-yutils install -m 644 yutils.info $RPM_BUILD_ROOT/usr/lib/yorick/packages/installed rm $RPM_BUILD_ROOT/usr/lib/yorick/i/*_start.i %clean rm -rf $RPM_BUILD_ROOT %files %defattr(-,root,root) /usr/lib/yorick/i/*.i /usr/lib/yorick/data/colors1.tbl /usr/lib/yorick/python/*.py /usr/lib/yorick/i-start/*_start.i /usr/share/doc/yorick-yutils/* /usr/lib/yorick/packages/installed/* %changelog * Tue Jan 09 2008 - included the info file for compat with pkg_mngr * Fri Jan 04 2008 - added files from Thibaut Paumard (coords, graphk, doppler, gauss, tws*) - updated Makefile, README, info file - bumped to v1.3.0 * Mon Dec 31 2007 - new distro directory structure - updated cvs * Tue Dec 11 2007 - 1.2.0: various fixes (sky in astro_utils, round in util_fr) - Homogeneized/changed licences to GPLv2 - gotten rid of pdb_utils for license issues - added pyk.py - modified idl-colors.i and pyk.i to search the whole path for include files - fixed paths in rgb.i and added error checking. * Thu Dec 6 2007 - 1.1.03gemini Fixes bug in round() for negative numbers frigaut-yorick-yutils-c173974/yutils.info000066400000000000000000000066601152651572200205070ustar00rootroot00000000000000Package: yutils Kind: package Version: 1.5.0 Revision: 2 Description: Utility library of interpreted routines License: GPLv2 Author: Eric Thiebaut, Francois Rigaut, Bertrand Aracil, Thibaut Paumard Maintainer: Francois Rigaut OS: architecture independant Depends: yorick(>=1.5.10) Source: http://www.maumae.net/yorick/packages/tarballs/yutils-%v-pkg.tgz Source-MD5: Source-Directory: contrib/ DocFiles: README TODO VERSION NEWS LEGAL doc/README:README.doc doc/FILE_FORMATS doc/*.doc doc/*.pdf doc/*.ps doc/*.tex Homepage: http://www.maumae.net/yorick/yutils/doc/ DescDetail: << yutils contains a collection of utility functions, ranging from plotting, to system access, to math. More details: /* yutil Yorick package, version 1.1.1 * Authors: E.Thiebault, F.Rigaut, B.Aracil, T.Paumard * last revision/addition: 2005nov07 * * 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 (to receive a copy of the GNU * General Public License, write to the Free Software Foundation, Inc., 675 * Mass Ave, Cambridge, MA 02139, USA). */ 1. Content: ---------- README LICENSE astro_util1.i check.i constants.i copy_plot.i detect.i fft_utils.i histo.i idl-colors.i img.i linalg.i lmfit.i plot_demo2.i plot_demo.i plot.i plvp.i poly.i pyk.i random_et.i rdcols.i rgb.i util_fr.i utils.i coords.i doppler.i graphk.i gauss.i tws*.i Set of utility routines for yorick. 2. Authors: ---------- Mostly from E.Thiebaut, some from F.Rigaut, B.Aracil and T.Paumard 3. Installation: --------------- On a *nix system: [sudo] make install On windows, or if you want to do it by hand, do the following: a. Copy all files in Y_SITE/contrib/ (create the directory if needed) b. Copy yutils_start.i in Y_SITE/i-start/ You may want to run "check.i", as in : yorick -i check.i at the shell prompt, or start yorick and type #include "check.i" 4. Documentation ---------------- All function manpages are accessible through the regular help,function See http://www.maumae.net/yorick for the html help pages. 5. History ---------- $Log: yutils.info,v $ Revision 1.6 2010-04-15 16:09:18 frigaut - split emulate_yeti_start.i to condition on - yeti in path (as per thibaut's changes) - new yorick builtin functions exist (yorick post apr2010) - bumped version number to 1.5.0 Revision 1.4 2008/01/04 15:05:13 frigaut - updated Makefile README yorick-yutils.spec yutils.info to include new tws*.i files from thibaut 2007dec11: * various fixes (sky in astro_utils, round in util_fr) * Homogeneized/changed licences to GPLv2 * gotten rid of pdb_utils for license issues * added pyk.py * modified idl-colors.i and pyk.i to search the whole path for include files * fixed paths in rgb.i and added error checking. 2005nov07: * slight updates to plvp.i * moved to version 1.1 (from 0.5.3). << DescUsage: << See contrib/check-yutils.i for a test suite. Type "yorick -i check-yutils.i" (in this directory) in a terminal to run it. << DescPort: << << frigaut-yorick-yutils-c173974/yutils_start.i000066400000000000000000000124741152651572200212210ustar00rootroot00000000000000autoload, "utils.i", eval; autoload, "utils.i", undersample, ndims_of, width_of, height_of, depth_of; autoload, "utils.i", spline_zoom, map; autoload, "utils.i", strcut, strjoin; autoload, "utils.i", is_string_scalar, tempfile, filesize; autoload, "utils.i", pwd, glob, strip_file_extension; autoload, "utils.i", expand_file_name, get_file_name, protect_file_name; autoload, "utils.i", read_ascii, load_text, dump_text; autoload, "utils.i", guess_compression, xopen; autoload, "utils.i", raw_read, pw_get_user, pw_get_uid, pw_get_gid, pw_get_name; autoload, "utils.i", pw_get_home, pw_get_shell; autoload, "utils.i", pdb_list, pdb_restore_all, timer_start; autoload, "utils.i", timer_elapsed, moments, stat, open_url, smooth; autoload, "detect.i", find_1d_minmax, plot_1d_minmax, find_2d_max; autoload, "fft_utils.i", abs2, fft_best_dim, fft_indgen; autoload, "fft_utils.i", fft_dist, fft_freqlist, fft_smooth; autoload, "fft_utils.i", fft_gaussian_psf, fft_gaussian_mtf; autoload, "fft_utils.i", fft_get_ndims, fft_symmetric_index; autoload, "fft_utils.i", fft_centroid, reverse_dims, fft_recenter; autoload, "fft_utils.i", fft_recenter_at_max, fft_roll_1d, fft_roll_2d; autoload, "fft_utils.i", fft_shift_phasor, fft_unphasor, fft_fine_shift; autoload, "fft_utils.i", fft_interp_real, fft_interp_complex, fft_interp; autoload, "fft_utils.i", fft_plh, fft_plg, fft_pli; autoload, "fft_utils.i", fft_plc, fft_plfc; autoload, "fft_utils.i", fft_convolve, fft_of_two_real_arrays, fft_paste; autoload, "histo.i", histo2, histo_stat, histo_plot; autoload, "idl-colors.i", loadct; autoload, "img.i", img_dims, img_plot, img_cbar; autoload, "img.i", img_interpolate, img_extract_parallelogram_as_rectangle, img_max; autoload, "img.i", img_fft_centered_at_max, img_convolve, img_pad, img_paste; autoload, "img.i", img_flatten, img_photometry, img_flt_max, img_flt_flac; autoload, "img.i", img_get_type, img_read, img_write, img_tmpnam; autoload, "linalg.i", gram_schmidt_orthonormalization, trace, diag; autoload, "linalg.i", euclidean_norm, pm, cholesky; autoload, "linalg.i", sv_dcmp, sv_solve_trunc, sv_solve_wiener; autoload, "lmfit.i", lmfit; autoload, "plot.i", pl_fc, pl_img, pl_cbar, pla, pls_mesh, pls, plh; autoload, "plot.i", plhline, plvline, plp; autoload, "plot.i", pl_get_color, pl_get_palette, pl_get_font; autoload, "plot.i", pl_get_symbol, pl_get_axis_flags; autoload, "plot.i", pl3t, pl3dj, pl3s; autoload, "plot.i", xwindow, xbtn_plot, xbtn_which; autoload, "plot.i", xmouse_point, xmouse_point, xmouse_line, xmouse_length; autoload, "plot.i", xmouse, xmouse_demo; autoload, "plot.i", pl_box, pl_cbox, pl_circle, pl_ellipse; autoload, "plot.i", ps2png, ps2jpeg, win2png, win2jpeg, pl_map; autoload, "plot.i", win_copy_lim, pl_database_index_to_rgb; autoload, "plot.i", pl_database_index_to_packed, pl_rgb_to_packed; autoload, "plot.i", pl_packed_to_rgb; autoload, "poly.i", poly1, poly1_deriv, poly2; autoload, "poly.i", poly2_deriv, poly1_fit, poly2_fit; autoload, "poly.i", solve_lfit, plpwf, poly1_gcv_fit; autoload, "random_et.i", random_uniform, random_normal, random_poisson; autoload, "random_et.i", kolmogorov; autoload, "rdcols.i", rdcols, rdconvert; autoload, "rgb.i", rgb_load, rgb_build_databases, rgb_uncapitalize; autoload, "util_fr.i", ls, exist, is_set, tv, plot, nprint, typeReturn; autoload, "util_fr.i", even, odd, minmax; autoload, "util_fr.i", tic, tac, spawn_fr, wheremin, wheremax, indices; autoload, "util_fr.i", makegaussian, bin2, fileExist, findfiles; autoload, "util_fr.i", parsedate_fr, parsetime_fr; autoload, "util_fr.i", secToHMS, colorbar; autoload, "astro_util1.i", autocuts, sky, ct2lst, jdcnv, altaz; autoload, "astro_util1.i", airmass, sigmaFilter, deadpix, fwhmfit; autoload, "astro_util1.i", makeflat, makebias, gaussianRound, gaussian; autoload, "astro_util1.i", moffat, moffatRound, starsep; autoload, "plvp.i", plsplit, pltitle_vp, xytitles_vp; autoload, "plvp.i", pljoin, testViewports, plmargin; autoload, "gauss.i", gauss, asgauss, gauss_fit, asgauss_fit, gauss2d; autoload, "moffat.i", moffat1d, asmoffat1d, moffat1d_fit, asmoffat1d_fit; autoload, "moffat.i", moffat2d; autoload, "multiprofile.i", mp_func, mp_setx, mp_seta, mp_getx; autoload, "multiprofile.i", linear, linear2d, poly_lmfit, ol_setx, offsetlines; autoload, "coords.i", ndc2pt, pt2inch, inch2cm, pt2ndc, inch2pt, cm2inch; autoload, "coords.i", ndc2inch, inch2ndc, ndc2cm, cm2ndc, pt2cm, cm2pt; autoload, "copy_plot.i",copy_win, replot_all, replot_one_sys, save_plot; autoload, "copy_plot.i", load_plot, reshape_prop, replot, reshape_plg; autoload, "copy_plot.i", replot_plg, reshape_pldj, replot_pldj, reshape_plt; autoload, "copy_plot.i", replot_plt, reshape_plm, replot_plm, reshape_plf; autoload, "copy_plot.i", replot_plf, reshape_plv, replot_plv, reshape_plc; autoload, "copy_plot.i", replot_plc, reshape_pli, replot_pli, reshape_plfp; autoload, "copy_plot.i", replot_plfp, decomp_prop, get_nb_sys, get_color; autoload, "copy_plot.i", get_selected_system, set_selected_system; autoload, "doppler.i", voflambda, lambdaofv, vacair, airvac; autoload, "graphk.i", plhk, plgk, plmkk, pltk; autoload, "pyk.i", pyk, pyk_import, pyk_resume, pyk_set; autoload, "tws.i", tws_addtoparent, tws_isinrect, plrect, tws_plid; autoload, "tws.i", tws_action, tws_handler, tws_realize; autoload, "tws.i", tws_button, tws_field, tws_grid, tws_label, ws_radio; autoload, "tws.i", tws_radiotesthandler, tws_radiotest, tws_root;