diff options
| author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
|---|---|---|
| committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
| commit | fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch) | |
| tree | bdda434976bc09c864f2e4fa6f16ba1952b1e555 /pkg/dataio | |
| download | iraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz | |
Initial commit
Diffstat (limited to 'pkg/dataio')
149 files changed, 32492 insertions, 0 deletions
diff --git a/pkg/dataio/Revisions b/pkg/dataio/Revisions new file mode 100644 index 00000000..2c83227f --- /dev/null +++ b/pkg/dataio/Revisions @@ -0,0 +1,887 @@ +.help revisions Jun88 pkg.dataio +.nf + +dataio$lib/mkpkg + The getdatatype.x and ranges.x files were duplicates of those in the + XTOOLS library which is linked in dataio. These files should be the + versions actually linked in the binary, making XTOOLS unnecessary, but + I think the intent was to use XTOOLS. The getdatatype.x is identical + but there are slight changes in ranges.x. These files were left in + place in case there are problems found but the binary should now be + using the XTOOLS versions. (12/5/08, MJF) + +dataio$import/ipproc.gx + Fixed a type flag being used to determine byte-swapping. (12/5/08, MJF) + +dataio$import/t_import.x + Fixed a type declaration (1/21/08, MJF) + +dataio$export/exraster.gx + Fixed a bug in computing the number of output pixels (1/5/04, MJF) + +dataio$import/ipproc.gx + An operand point was possibly being freed twice, once in the ip_wrline() + procedure and again in the evvfree() call when processing completed. + This could cause a segfault on some system (9/27/02, MJF) + +dataio$export/exraster.gx +dataio$export/bltins/exppm.x + There was a bug in the generation of PPM files when using images with + and odd number of columns causing the line to be too long by one byte. + The output image will now truncate the last column to avoid this since + we cannot write byte data. (8/9/02, MJF) + +dataio$export/export.h + Changed the zscale sampling parameters to use more points spread out + over more of the image. The old values would sometimes find an + innappropriate z1/z2 range causing problems when doing many images in + batch mode. (3/20/02, MJF) + +dataio$fits/t_rfits.x +dataio$imtext/t_rtextimage.x + Changed the clgetc calls to to clgstr calls for the datatype parameter + in rfits and the otype parameter in rtextimage. This change is required + to avoid an "ERROR: Parameter not a legal character constant (parname)" + error introduced by recent changes to the CL. Basically "" is no longer + a legal argument for clgetc. (6/15/01 LED) + +dataio$fits/fits_rheader.x + Fixed a bug in the MEF file reading error recovery code that can cause + a segvio due to a too many open file descriptors condition. (5/1/01 LED) + +dataio$export/bltins/expgm.x +dataio$export/bltins/exppm.x + Fixed a bug in writing the header for these formats on PCIX. (6/23/00 MJF) + +dataio$export.par + Made the 'format' parameter automatic mode (5/16/00 MJF) + +dataio$export/expreproc.x + Modified so that the 'overlay' colors are not scaled. (5/16/00 MJF) + +dataio$reblock/t_reblock.x +dataio$reblock/reblock_file.x + Fixed a bug in the output block writing code caused by a failure to + check the status return of the awaitb call. At the same time worked + around a longstanding problem in tape to tape copies caused by + trying to open and close a magtape file for writing when there is + no data and fixed an initialization bug in the record trimming and + padding code that has been there a long time. (2/9/00 LED) + +dataio$import/ipdb.gx + Fixed a string overflow bug causing segvios on PCs (12/13/99 MJF) + +dataio$import.par +dataio$export.par + Changed query param modes to auto to avoid prompt from epar :go + command. (11/4/99 MJF) + +dataio$export/bltins/exeps.x + Fixed an array overrun when writing EPS trailer comments. (10/25/99 MJF) + +dataio$export/mkpkg +dataio$export/*/mkpkg +dataio$import/mkpkg +dataio$import/*/mkpkg + Fixed missing/extra file dependencies (9/20/99, MJF) + +dataio$export/exrgb8.x + Fixed a bug causing the cmap() function to write a garbage line at the + top or bottom of the output image. (8/20/99 MJF) + +dataio$export/exzscale.x +dataio$import/t_import.x +dataio$import/bltins/ipgif.x + Cleaned up some missing sfree() calls. (7/28/99 MJF) + +dataio$fits/wfits.h +dataio$fits/fits_cards.x +dataio$fits/fits_params.x + Modified wfits to write the DATE keyword value in the new format (including + a time field) and in units of GMT. (5/8/99 LED) + +dataio$export/bltins/exhdr.x + Changed the binary file header to use a 4-digit year (5/5/99, er..1999 MJF)) + +dataio$export/bltins/exras.x +dataio$export/bltins/exxwd.x + Fixed a bug in which rasterfiles and XWD file aren't swapped on LSB + machines when requested by the user. (12/14/98 MJF) + +dataio$import/t_import.x +dataio$import/ipproc.gx + Fixed a bug preventing 1-D data from being converted. (12/10/98 MJF)) + +dataio$import/t_import.x + Modified to initialize the 'use_cmap' flag to on by default so 8-bit + colormap images will be converted correctly. (7/14/98 MJF) + +dataio$fits/fits_cards.x + Added a check for pre-existing IRAFNAME keywords to the wfits task + (6/18/98 LED) + +dataio$export/exzscale.x +dataio$export/t_export.x +dataio$export/exobands.gx +dataio$export/bltins/exeps.x +dataio$export/bltins/exgif.x +dataio$export/bltins/exrgb.x +dataio$export/bltins/exxwd.x + Removed some unused variable and fixed type clashes (3/28/98 MJF) + +dataio$export/expreproc.x + Fixed a bug where the setcmap function was finding the colormap name + incorrectly when '@' params were used in a zscale function (2/2/98 MJF) + +dataio$import/t_import.x +dataio$import/ipobands.gx + Fixed a bug in which use of the red()/green()/blue() functions caused + the size of the output image to be computed incorrectly. (12/12/97 MJF) + +dataio$fits/fits_read.x + Fixed a bug in the header listing code which resulted in rfits reading + through the whole image after listing the data when EXTENSION = N. + (11/3/97 LED) + +dataio$fits/fits_read.x + Fixed a bug in the global header handling code that could result a + the global image header being left in the tmp$ directory. + (8/6/97 LED) + +dataio$wfits.par +dataio$fits/t_wfits.x +dataio$doc/wfits.hlp + Added a new parameter call fextn whose default value is "fits" to the + wfits task. A ".fextn" suffix is appended to the output disk file names + to ensure that they are compatable with the fits kernel. + (6/20/97 LED) + +dataio$rfits.par +dataio$wfits.par +dataio$doc/rfits.hlp +dataio$doc/wfits.hlp +dataio$fits/fits_cards.x +dataio$fits/fits_files.x +dataio$fits/fits_params.x +dataio$fits/fits_read.x +dataio$fits/fits_rheader.x +dataio$fits/fits_rimage.x +dataio$fits/fits_rpixels.x +dataio$fits/fits_wheader.x +dataio$fits/fits_wimage.x +dataio$fits/fits_wpixels.x +dataio$fits/fits_write.x +dataio$fits/mkpkg +dataio$fits/rfits.com +dataio$fits/rfits.h +dataio$fits/t_rfits.x +dataio$fits/t_wfits.x +dataio$fits/wfits.com +dataio$fits/wfits.h + Installed new versions of rfits and wfits. The new rfits and wfits + include support for: 1) reading and writing multi-extension fits files, + 2) reading and writing global header, 3) reading and writing ushort + images by default when appropriate. + (6/9/97 LED) + + +dataio$doc/export.hlp +dataio$export/excmap.x +dataio$export/cmaps.inc + Added the 'overlay' cmap as a builtin cmap. (6/6/97) + +dataio$export/expreproc.x + Removed a call to scale the colormaps when using the default values. + Cmaps are now only scaled when a brightness/contrast value is set in + the setcmap() function. (6/6/97 MJF) + +dataio$export/bltins/exgif.x + Fixed a small error in the output of GIF files causing some display + programs to complain. GIF images which would now be an odd number of + bytes have an extra trailing ';' delimiter. This should be harmless + as all processing is supposed to stop once that char is found. (6/6/97 MJF) + +dataio$mkpkg +dataio$dataio.cl +dataio$dataio.hd +dataio$dataio.men +dataio$x_dataio.x +dataio$import/ + +dataio$import.par + +dataio$export/ + +dataio$export.par + +dataio$doc/import.hlp + +dataio$doc/export.hlp + + Installed the IMPORT/EXPORT task for general use. The images database + used by the IMPORT task is currently defined to be dataio$import/images.dat. + (3/31/97 MJF) + + +dataio$fits/fits_rheader.x + Explictly set SIMPLE(fits) to YES the first time this card is encountered + so that duplicate fits SIMPLE cards are properly filtered out. Duplicate + SIMPLE cards are illegal fits so this should never happen but ... + (6/28/96 Davis). + +dataio$fits/fits_cards.x + Added some wfits code to filter any "END " keywords out of the image + header userarea. + (3/17/95 Davis) + +dataio$fits/t_wfits.x + Wfits was using the name of the @file instead of the first file as the + root output fits file name if the number of output files was 1. + (1/18/95 Davis) + +dataio$fits/fits_wheader.x + The autoscaling code was failing in the case bitpix=16 and pixtype=ushort. + Bscale and bzero values were being set to 1.0 and 0.0 respectively, + resulting in truncation of data values. The code has been modified to + set bscale and bzero to 1.0 and 32768 instead.(10/18/94 Davis) + +dataio$imtext/t_rtextimage.x +dataio$imtext/t_wtextimage.x +dataio$imtext/rt_cvtpix.x +dataio$rtextimage.par +dataio$wtextimage.par +dataio$doc/rtextimage.hlp +dataio$doc/wtextimage.hlp + A parameter "pixels" was added to select whether to read or write + the pixel values. This is complementary to rfits/wfits and allows + use of these tasks to store and restore image headers. (10/22/93, Valdes) + +dataio$reblock/t_reblock.x: Davis, Jan 20, 1993 + Added support for multiple disk file input and output to the reblock + task. + +dataio$fits/fits_read: Davis, Apr 27, 1992 + Modified rfits to use the fe parameter to skip to EOF for devices + e.g. cartridge tapes which seem to be having problems with file + skips. + +dataio$fits/t_rfits.x: Davis, Mar 25, 1992 + Rfits was using the name of the @file instead of the first file as the + root output image name if the number of output files was 1. + +dataio$fits/fits_read: Davis, Feb 27, 1992 + Changed the interpreation of the fe parameter as read from dev$tapecap + from MB to KB. + +dataio$fits/fits_write: Davis, Feb 18, 1992 + Replaced a call to imgimage with one to imgcluster to extract the root + image name minus cluster and section. + +dataio$fits/t_rfits.x: Davis, Feb 18, 1992 +dataio$fits/t_wfits.x: Davis, Feb 18, 1992 + Changed the maximum sequence number that can be appended to an output + root image of fits file name from 999 to 9999. + +dataio$fits/rfits.com: Davis, Feb 18, 1992 +dataio$fits/t_rfits.x: Davis, Feb 18, 1992 +dataio$fits/fits_read.x: Davis, Feb 18, 1992 + Implemented a scan mode in rfits so that devices which have a slow + single-file file skip function (e.g. dat drives) can be used more + efficiently with the rfits make_image=no option. + +dataio$fits/fits_params.x: Davis, Feb 17, 1992 + Modified wfits so that string parameters that are 1) written explictly + by wfits, and 2) <= 20 characters long including quotes, will have the / + in column 33 instead of 2 spaces past the end of the string. The + affected keywords are OBJECT, ORIGIN, DATE, IRAFNAME, IRAF-BPX, and + IRAFTYPE. + +dataio$fits/fits_wheader.x: Davis, Feb 17, 1992 + Modified the short_header=yes option in wfits so that the image pixel + type, fits bitpix, and the scaling parameters are printed on the + standard output. + +dataio$fits/fits_rimage.x: Davis, Feb 17, 1992 +dataio$fits/fits_wimage.x: Davis, Feb 17, 1992 + Modified rfits so that the ieee +/-NaNs, and +/-Infs are correctly + mapped to a user specified native floating point number. Underflow values + are automatically converted to 0.0. A warning message is printed on + the terminal if any bad pixels were replaced. A warning message is + also printed if valid floating point pixel values > MAX_REAL or < + -MAX_REAL were detected. Imreplace can be used to replace these + explicitly. + +dataio$fits/fits_rheader.x: Davis, Feb 14, 1992 + Modified rfits to replace control characters decimal 0 (00X) to + 31 (1FX) and decimal 127 (7FX) with the blank character. The + new fits standard now explicitly defines these illegal in fits + headers. + +dataio$wfits.par: From, Davis, Feb 13, 1992 +dataio$doc/wfits.hlp: From, Davis, Feb 13, 1992 +dataio$fits/wfits.h: From, Davis, Feb 13, 1992 +dataio$fits/t_wfits.x: From, Davis, Feb 13, 1992 +dataio$fits/fits_write.x: From, Davis, Feb 13, 1992 +dataio$fits/fits_wheader.x: From, Davis, Feb 13, 1992 +dataio$fits/fits_wimage.x: From, Davis, Feb 13, 1992 +dataio$fits/fits_wpixels.x: From, Davis, Feb 13, 1992 + 1. Modified wfits to fetch the default fits blocking factor for a device + from the dev$tapecap file. The user can still overrride this value + (which is usually set to 10) for variable blocked devices, but is no + longer required to know or set the block size for fixed block devices + like cartridge tapes. + +dataio$mtexamine/t_mtexamine.x: From, Davis, Jan 6, 1992 +dataio$cardimage/t_rcardimage.x: From, Davis, Jan 6, 1992 +dataio$cardimage/t_wcardimage.x: From, Davis, Jan 6, 1992 +dataio$reblock/t_reblock.x: From, Davis, Jan 6, 1992 +dataio$fits/t_rfits.x: From, Davis, Jan 6, 1992 +dataio$fits/t_wfits.x: From, Davis, Jan 6, 1992 + 1. Modified the mtexamine, rcardimage, wcardimage, reblock, rfits, and + wfits tasks to accept the new magtape file name syntax. + +dataio$reblock/t_reblock.x: From, Davis, Dec 11, 1991 + 1. Modified reblock so that character constants like '\n' can be + used as record padding characters. + +dataio$t2d/mkpkg: From Davis, Dec 3, 1991 + 1. Removed the printf.h file dependency from the mkpkg. + +dataio$imtext/mkpkg: From Davis, Dec 3, 1991 + 1. Added missing files dependencies for the files rt_rheader.x + (imio.h) and wti_wheader.x (imio.h). + +dataio$fits/mkpkg: From Davis, Dec 3, 1991 +dataio$fits/fits_read.x + 1. Added missing files dependencies for the files fits_rheader.x + (ctype.h) and fits_wimage.x (error.h). + 2. Removed unused "include <imset.h>" statement from fits_read.x + +dataio$cardimage/mkpkg: From Davis, Dec 3, 1991 + 1. The entries for t_rcardimage.x and t_wcardimage.x were missing + several file dependencies. + +dataio$fits/fits_cards.x: From Davis, Oct 15, 1991 + 1. Changed the name of the IRAF-B/P keyword to IRAF-BPX to conform to the + new FITS standard. + +dataio$fits/fits_rpixels.x: From Davis, Oct 9, 1991 + 1. The rfits task has been modified to permit a short last record, i.e. + a last record that has not been padded out to 2880 bytes, without + generating any warning messages. + +dataio$fits/wfits.h: From Davis, Jun 11, 1991 +dataio$fits/t_wfits.x: From Davis, Jun 11, 1991 +dataio$fits/fits_write.x: From Davis, Jun 11, 1991 +dataio$fits/fits_wheader.x: From Davis, Jun 11, 1991 + 1. The wfits task has been modified to write IEEE format FITS files + (fits bitpix = -32 and -64), instead of scaled integers if the input + image pixel type is real or double respectively and if the wfits parameter + bitpix is left at the default. If the user overrides the default and + elects to scale the data, a warning message with an estimate of the + precision loss is provided. + +dataio$fits/fits_write.x: From Davis, Jun 10, 1991 +dataio$fits/fits_read.x: From Davis, Jun 10, 1991 + 1. Modified the fits writer and reader so that the IRAFNAME parameter + can deal with image sections. The fits writer will now record image + sections in the IRAFNAME parameter instead of inserting a blank. + The directory specification is still stripped. The fits reader will + now strip off any section notation before attempting to rename + the output image. + +dataio$fits/fits_rimage.x: From Davis, Jan 17, 1991 +dataio$fits/fits_wimage.x: From Davis, Jan 17, 1991 + 1. Modified the scaling routines in rfits and wfits to minimize + the precision lost when converting from real pixels to fits integers + and vice versa. + +dataio$cardimage/t_rcardimage.x: From Davis, Jan 3, 1991 +dataio$doc/rcardimage.hlp: From Davis, Jan 3, 1991 + 1. Modified rcardimage so that the error message encountered + when an odd-blocked rcardimage tape is encountered is less obscure. + 2. Modified the rcardimage help page to include an example of how to + reformat and odd-blocked cardimage tape with reblock. + +dataio$fits/t_rfits.x: From Davis, Dec 6, 1990 + 1. Modified rfits so that it will supply a temporary root output file + name if old_irafname="yes" and quit with a clear error message if + old_irafname="no", in the case where the user sets the output file + to the null string "". + +dataio$fits/fits_rheader.x: From Davis, Sept 11, 1990 + 1. Changed rfits so that history cards know go into the user area + instead of the history area where they get truncated. + +dataio$fits/wfits.h: From Davis, August 15, 1990 +dataio$fits/t_wfits.x: From Davis, August 15, 1990 +dataio$fits/fits_write.x: From Davis, August 15, 1990 +dataio$fits/fits_wimage.x: From Davis, August 15, 1990 +dataio$fits/fits_wpixels.x: From Davis, August 15, 1990 +dataio$fits/fits_rpixels.x: From Davis, August 15, 1990 + 1. Wfits will now permit FITS blocking factors up to and including + 22 although a warning message will be issued if a blocking factor + > 10 is requested. + + 2. Wfits occasionally crashed with a segmentation violation if a + non-standard fits blocking factor was selected. This error was + triggered if the unused portion of the output block to be blank + filled was greater than 2880 bytes. This bug has been fixed in + 2.10 + + 3. Rfits was not reading FITS data with a block size < 2880 on + the 9-track drives correctly. This bug has been fixed in 2.10. + + 4. Wfits.rfits now sets the length of the user area to the maximum of + the default of 28800 chars and the value of the environment variable + "min_lenuserarea". + +dataio$fits/fits_wheader.x: From Davis, July 3, 1990 +dataio$fits/fits_cards.x: From Davis, July 3, 1990 +dataio$fits/fits_rheader.x: From Davis, July 3, 1990 + Fixed a problem in the way bscale and bzero were computed that was + causing floating point errors for some double precision images, + basically because the precision was worse than I thought. + The really problem is that the min and max of a double precision + image are stored as reals in the image header do they do not + quite correspond to what is in the image. The solution was to extend + the values of the min and max to slightly lower and higher values + respectively. These problems will go away when ieee becomes more + accepted. (See messages below for history of this problem) + + Wfits now checks for the presence of the FITS keywords SIMPLE, BITPIX, + NAXIS and NAXISn in the user area and filters them out before writing + the FITS header. + + Rfits will now ignore FITS keywords that are duplicates of SIMPLE, + BITPIX, NAXIS and NAXISn. A warning message is issued if any of + these keywords are duplicated. + +dataio$fits/fits_wheader.x: From Davis, April 21 +dataio$fits/fits_write.x: From Davis, April 21 +dataio$fits/fits_read.x: From Davis, April 21 + The original scaling algorithm was restored due to problems encountered + with the new one. This will be looked into more fully in version 2.10. + These means that a problem with double precision images may remain. + + Since I had to make the above change at the last minute I added some + code to flush the STDOUT after in input and output file names + are computed and written to STDOUT. This avoids a problem with + output not being flushed when an error condition occurs and output + is being redirected causing confusion for the user who may not be able + to tell where the error occured in that case. + +dataio$fits/fits_wheader.x: From Davis, Mar 24, 1990 + Fixed a problem with the scaling routines in wfits. Images with a + minimum which was negative and distant from the majority of the + data values could cause a problem in the scaling. + +dataio$fits/fits_rimage.x: From Davis, Mar 10, 1990 + Recoded the routine that computes the mins and maxs of an image + slightly to remove a problem with the STF kernel. The mins and maxs + of the image were being reset to 0 when the first data was written + over-riding the program initialization of MAX_REAL and -MAX_REAL + and defeating the minimum calculation for all positive data. + +dataio$fits/fits_wheader.x: From Davis, Mar 9, 1990 + Fixed a problem in the way bscale and bzero were computed that was + causing floating point errors for some double precision images, + basically because the precision was worse than I thought. + The really problem is that the min and max of a double precision + image are stored as reals in the image header do they do not + quite correspond to what is in the image. The solution was to extend + the values of the min and max to slightly lower and higher values + respectively. These problems will go away when ieee becomes more + accepted. + +dataio$fits/fits_cards: From Davis, Jan 20, 1990 + Added a filter to remove duplicate IRAF-MIN, IRAF-MAX, IRAFTYPE, + and IRAF-B/P keywords from the user area. + +dataio$fits: From Davis, Jan 19, 1990 + 1. Support was added for the IEEE floating point format to both + the rfits and wfits tasks. Rfits now recognizes -32 and -64 to + be legal values of bitpix representing respectively real and + double IEEE floating point format. Values of bscale and bzero + are applied if present in the header. By default wfits still + writes integer format FITS tapes with autoscaling. However if + the users selects a bitpix of -32 or -64 the appropriate floating + point format is written. In this case scaling is disabled. + + 2. Rfits was modified to take a list of output images names or + an output image root name. + + 3. Wfits was modified to take a list of output fits file names + or an output fits file root name. + +dataio$fits/fits_wheader.x: From Davis, Nov 20, 1989 + 1. Fixed wfits so it would write out type "ushort" images correctly + with the default parameters. The chosen bitpix is 32 instead of + 16. + +dataio$fits/t_rfits.x,t_wfits.x: From Davis, May 29, 1989 + 1. Changed both these tasks so the STDOUT is only flushed on a newline + if has not been redirected. Changed the remaining eprintf statements + to printf statements. + +dataio$fits/fits_rheader.x: From Davis, May 9, 1989 + 1. Fixed abug in the code which decodes hms format numbers. The + problem was caused by leading blanks and the fact that the ctoi + routine does not recognize the plus character. + +dataio$fits/t_wfits.x: From Davis, Mar 31, 1989 +dataio$fits/wft_wimage.x: From Davis, Mar 31, 1989 +dataio$fits/wft_wpixels.x: From Davis, Mar 31, 1989 + 1. Changed wfits so that a warning message is printed if the fits + long blocks option is used. The previous version only warned the + user if an illegal fits block size was used. + 2. Changed wfits so that the record structure written is printed + out on the standard output if short_header = yes as well as if + long_header = yes. + 3. Changed the error trapping code so that the number of records + actually written is printed out when wfits terminates prematurely + with an error condition. + + +dataio$fits/t_wfits.x: From Davis, Mar 14, 1989 +dataio$fits/fits_rpixels: From Davis, Mar 14, 1989 + 1. Changed wfits so that warning messages are printed if the user + overrides the default value of bitpix or turns of autoscaling. + These messages will be printed to the standard output along with + the output log. + 2. I have fixed a problem in the error checking code in rfits. + Too many reads were being done after an error recovery resulting + in the data in the output image being skewed. This needs to be + rechecked on DRACO where the original error recovery was done. + +dataio$reblock: From Davis, Jan 27, 1989 + 1. Fixed a problem in reblock for tape to tape copies. The copyn parameter + was being ignored if no reblocking was occurring. This problem has been + fixed. A minor problem with the record counter was also fixed. + +dataio$fits: From Davis, Apr 14, 1988 + 1. Added an option in wfits to write a non-standard physical block size + of blocking_factor > 10. This permits users with restricted block + size devices to read and write fits tapes. + + 2. Changed the cl file name template commands inside wfits to images + name template commands. + +dataio$fits: From Davis, Mar23, 1988 + 1. Fixed a bug in the fits string parameter trimming routine in which + the newline was being overwritten if the string was exactly 80 + characters long. + +dataio$rfits: From Davis, December 11, 1987 + 1. Fixed a small bug in the rfits disk handling code. If a user + successfully read a fits disk file, for example fitsdat, and then + tried to read a list of files using a template which did not match + any of the disk files, rfits would try to reread fitsdat. Rfits was + not handling the 0 length disk file list condition correctly. + +dataio$rfits: From Davis, December 3, 1987 + 1. Rfits now checks for valid bscale and bzero values. If it cannot + decode bscale or bzero it sets them to 1.0 and 0.0 respectively. + 2. Rfits and wfits no longer flushes STDOUT on a newline if the output + has been redirected to a file. This greatly improves the speed of rfits + and wfits when the long_header parameter is set to yes especially for + VMS systems. + +dataio$rfits: From Davis, September 3, 1987 + Rfits will now print out the ol irafname if short_header = yes, make_image + = no and old_name = yes. This makes it easier for users to list their + IRAF fits tapes. + +dataio$reblock/t_reblock.x: From Davis, August 12, 1987 + The offset parameter in reblock was not being queried for by + the code. + +dataio$imtext/rt_rheader.x,wti_wheader.x: From SJacoby, June 10, 1987: + Tasks RTEXTIMAGE and WTEXTIMAGE no longer limit the image user area + being written to or read from to 2880 chars. The size of the + user area to be created or accessed by these tasks is controlled + by the IRAF environment variable `min_lenuserarea', and is not + limited by the code. + +dataio$fits/fits_rheader.x: From Davis, June 4, 1987: + The code for reading fits cards into the user area has been changed. + Rfits opens a new image with the default min_lenuserarea and + reads cards into it until it is filled. If the user area is + completely filled rfits issues a warning message along with the + number of fits parameters it was not able to completely store. + +dataio$fits/fits_write.x,fits_read.x,fits_rpixels.x: From Davis, May 15, 1987: + 1. I changed the error checking code so that it would work correctly + with the fits long blocks option. Wfits now does a call to fstat + to find out the number of bytes in the last read and uses this number + to validate the buffer if a read error occurs. There is no way to + recover from a read error in the tape record containing the header info. + 2. I added a check for the maximum permitted buffer size in wfits. + The program will abort if the device cannot suuport the length of + the output record requested. + +dataio$mtexamine/t_mtexamine.x: From Davis, May 15, 1987: + Error checking code has been added to MTEXAMINE. The task will now + print out a warning message for each bad record encountered and + continue reading the file instead of skipping to the next file. + The correct record count is preserved. + +dataio$imtext/wti_wheader.x, dataio$imtext/rt_rheader.x: Hammond, Mar 24, l987. + The FITS format header written by task WTEXTIMAGE has been changed. It + no longer contains the keywords SIMPLE=T and NAXIS=0. The output of + WTEXTIMAGE is a simple text file which makes no attempt to conform to + FITS standards. Task RTEXTIMAGE was modified to read both the old and + new format headers. + +dataio$t2d/t_t2d.x: From Lytle, Mar 20, 1987: + 1. T2D now deletes the zero length file left over when the program + encounters the end-of-tape and opens and closes an empty file. + 2. I also changed the verbose output format somewhat to make it + more logical. + +dataio$t_wcardimage: From Davis, Mar 19, 1987: + 1. WCARDIMAGE now checks that the input files are not binary + files before trying to write them to tape. + +dataio$fits: From Davis, Mar 19, 1987: + 1. More extensive error checking has been added to the FITS code. + Rfits attempts to recover from a read error in the data matrix. + Instead of terminating with a partially written image RFITS will + try to skip over the bad data. The resulting output image will + have the correct number of rows and columns but may contain one + or more records of bad data. The results of the error checking + may be tape drive dependent. + 2. RFITS now prints a warning message if no pixel file is + written (NAXIS = 0). + 3. RFITS now checks the first 6 characters of the first header record + to see if they are equal to SIMPLE. + +dataio$fits_wheader.x: From Davis, Jan 28, 1987: + 1. The scaling routine for determining bscale and bzero + introduced by Skip for the MV10000 was found to have problems + with some low dynamic range data. The symptom was that + the min value of an image restored from a FITS data would + have larger than expected roundoff errors. I have changed it back + to my original scaling algorithm. + +dataio$cardimage/: From Davis, Jan 20, 1987: + 1. Rcardimage has been modified to accept a list of disk files as + input as well as a list of tape files. + +dataio$fits/: From Davis, Jan 20, 1987 + 1. The FITS longblocks option has been added to the FITS readers and + writers. RFITS will read long-blocked FITS data. The redundant + len_record parameter has been removed. IRAF mtio handles the tape + record buffering transparently. + 2. The len_record parameter has been removed from WFITS and + replaced with a blocking parameter factor, which specifies the number + of 2880 byte FITS records can be written in a single tape block. + The maximum legal FITS blocking factor is 10. + 3. RFITS has been modified to accept a list of disk files as well as + a list of tape files. This should facilitate file transfers over + the ethernet. + +dataio$reblock/reb_reblock_file.x: From Davis, Dec 12, 1986 + 1. A bug in the seek option on disk binary files has been fixed. + This bug would cause the number of bytes read to be incorrectly + computed. + +dataio$lib/addcards.x: From Hammond, Oct 27, 1986 + Header cards containing real values are now written with a %g rather + than %f format. This change affects task wtextimage. + +dataio$fits/fits_wheader.x: From Davis, Oct2 + 1. The way the scaling routine wft_set_scale computes the data range + has been changed. Instead of adjusting maxdata and mindata individually + for machine precision; the data range is first computed and then adjusted + for the machine precision. This change was made in response to precision + problems encountered on the MV10000. + +dataio$fits/wfits.h: From Davis, Sep12, 1986 + 1. The integer constants BYTE_MIN, BYTE_MAX, BYTE_BLANK etc have been + changed to type double to avoid compiler generated integer overflows. + The data type of TAPEMIN and TAPEMAX in the WFITS structure has also + been changed to double. This change was made in response to compiler + errors encountered on the MV10000 and should be transparent to the users. + +dataio$imtext/rt_cvtpix.x: From Hammond, Sep2, 1986 + A typographical error was corrected in a call to patmake. The + pattern "[DdEd]" has been replaced with the correct pattern "[DdEe]". + This means numbers written with a lower case 'e' in the exponent field + are recognized as floating point numbers when read from the text file. + This procedure is called by task RTEXTIMAGE. + +dataio$mtexamine/t_mtexamine.x: From Davis, Aug20, 1986 + 1. MTEXAMINE on the SUN was outputting an array of zeroes when asked to + dump records with output_type = c. The problem was that a long integer + was being passed to the routine ctocc instead of a char. This error + was not being detected on the VAXES. + +dataio$fits/fits_params.x: From Davis, Aug20, 1986 + 1. The boolean parameter param in routine wft_encodeb was changed to type + integer. Wft_encodeb was being called with param = YES which caused + portability problems on the MV10000. + +From Davis July 16, 1986: + +1. RFITS has been modified so that imbedded blanks in the UT, ZD, ST, RA and +DEC keywords are replaced by zeros. For example the mountain fits writers +produce hms numbers of the form 20: 6: 3. RFITS will convert this to 20:06:03. + +----------------------------------------------------------------------------- + +From Davis June 13, 1986: + +1. TXTBIN and BINTXT have been modified so that the file number is +appended to the output file name. Previous versions appended the extensions +".txt" and ".bin" to the input file name. + +------------------------------------------------------------------------------ + +From Davis June 12, 1986: + +1. WCARDIMAGE and WFITS now append a file number to the output file name +if multiple disk files are being written. In the old writers a suffix +was appended to the input file name (.fit for WFITS and .crd for +WCARDIMAGE) and the output images were being copied to the input +directory. + +------------------------------------------------------------------------------ + +From Davis June 8, 1986: + +1. WFITS has been modified to store only the root of the image name. All +pathname information has been stripped off. + +------------------------------------------------------------------------------ + +From Davis May 28, 1986: + +1. The output of WFITS has been changed to print the file number, input file +name, output file name, title and dimensions if long_header = no and +short_header = yes. + +------------------------------------------------------------------------------- + +From Davis May 22, 1986: + +1. RFITS now writes 80 character records into the user area instead of +trimming trailing whitespace from each record. This was changed to facilitate +the image database interface. This change was also made to WTEXTIMAGE. + +------------------------------------------------------------------------------- + +From Davis May 21, 1986: + +A bug in the record trimming code of REBLOCK has been fixed. REBLOCK was +computing the offset in the input block of data incorrectly. + +-------------------------------------------------------------------------------- + +From Davis May 13, 1986: + +A bug in the error checking code in MTEXAMINE has been fixed. If there is an +error on mtopen the program will abort instead of trying to open the next file. + +-------------------------------------------------------------------------------- + +From Davis May 1, 1986: + +A problem with the autoscaling option in WFITS has been fixed. In order +to avoid wrap around problems WFITS now assumes that the number of digits +of machine precision is 1 less than the number in mach.h. In the case of +the Vax the number is actually 6.? not 7 as quoted. + +----------------------------------------------------------------------------- + +From Davis Apr 17, 1986: + +Changed boolean == false constructs in files t_wcardimage.x and t_reblock.x +to ! boolean. + +---------------------------------------------------------------------------- + +From Davis Apr 4, 1986: + +The format of the RCAMERA DATE-OBS parameter has been changed form +dd-mm-yyyy to dd/mm/yyyy to bring it into conformity with FITS standard. + +--------------------------------------------------------------------------- + +From Hammond Mar 25, 1986: + +Task RTEXTIMAGE has been fixed so it properly skips over non standard fits +headers, the number of lines being specified by the parameter nskip. + +___________________________________________________________________________ + +From Davis Mar 9, 1986: + +The order of the REBLOCK parameters outfiles and file_list has been switched +in order to preserve the correct command line sequence + +---------------------------------------------------------------------------- + +From Davis Mar 3, 1986: + +The error checking in WFITS has been corrected so that WFITS terminates if +it encounters a file write error instead of continuing to the next file +as done previously. + +---------------------------------------------------------------------------- + +From Davis Feb 19, 1986: + +1. Rfits and rpds have been fixed so that attempting to delete the last +empty image does not generate a cannot delete protected file message. + +---------------------------------------------------------------------------- + +From Davis Feb 3, 1986: + +1. A mysterious bug in which the date of observation card would sometimes +not appear in the header has been fixed. A newline was missing from the +proceeding header card. + +---------------------------------------------------------------------------- + +From Davis Jan 16, 1986: + +1. Wfits no longer needs write permission to work. However as a consequence +wfits no longer updates the image min and max. + +2. The scaling routines in rfits and wfits fits have been replaced by +appropriate vector operators. + +3. The coordinate transformation parameters are now stored in the user +area and are available to hedit, imgets etc. + +4. Scaled data is now read into real images regardless of the value of +bitpix. + +----------------------------------------------------------------------------- + +From Davis Jan. 5, 1986: + +1. Rfits, rpds and rcamera now open dev$null instead of a temporary disk +file for option make_image = no. This eliminates a lot od disk access overhead +and should speed up these readers considerably. + +2. The default parameter options are now long_header=no and short_header=yes. +Setting the long_header parameter to yes will over-ride the short header +parameter. + +--------------------------------------------------------------------------- + +From Davis Dec. 3, 1985: + +1. Rcamera will now print and store the header parameters ccdpicno and airmass +if defined. + +2. A bug in the fringe scaling parameter calculation in rcamera was fixed. +Currently the mountain programs store this number in floating point format. +This will be changed in future necessitating a corresponding change in +rcamera. + +----------------------------------------------------------------------- +From Valdes Oct. 10, 1985: + +1. Defined widstape from ONEDSPEC package in the DATAIO package. The +source and executable, however, still reside in ONEDSPEC (x_onedutil.e). +Widstape and widsout should be combined and the source put in DATAIO +at some point. +.endhelp diff --git a/pkg/dataio/bintext/mkpkg b/pkg/dataio/bintext/mkpkg new file mode 100644 index 00000000..ff3db34f --- /dev/null +++ b/pkg/dataio/bintext/mkpkg @@ -0,0 +1,11 @@ +# Bintext library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_bintxt.x + t_txtbin.x + ; diff --git a/pkg/dataio/bintext/t_bintxt.x b/pkg/dataio/bintext/t_bintxt.x new file mode 100644 index 00000000..13b1e328 --- /dev/null +++ b/pkg/dataio/bintext/t_bintxt.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define MAX_RANGES 100 + +# T_BINTXT -- Procedure to convert binary files containing only text to text +# files. + +procedure t_bintxt() + +bool verbose +char outfile[SZ_FNAME] + +char infile[SZ_FNAME], out_fname[SZ_FNAME] +int list, len_list, in, out, file_number + +bool clgetb() +int strlen(), open(), clpopni(), clplen(), clgfil() + +begin + # Get input files + list = clpopni ("binary_file") + len_list = clplen (list) + + # Get output files + call clgstr ("text_file", outfile, SZ_FNAME) + + verbose = clgetb ("verbose") + + file_number = 1 + while (clgfil (list, infile, SZ_FNAME) != EOF) { + + if (len_list > 1) { + call strcpy (outfile, out_fname, SZ_FNAME) + call sprintf (out_fname[strlen(out_fname) + 1], SZ_FNAME, + "%03d") + call pargi (file_number) + } else + call strcpy (outfile, out_fname, SZ_FNAME) + + iferr { + + if (verbose) { + call printf ("File: %s -> %s\n") + call pargstr (infile) + call pargstr (out_fname) + } + + # Open input and output files, copy and close files + in = open (infile, READ_ONLY, BINARY_FILE) + out = open (out_fname, NEW_FILE, TEXT_FILE) + call fcopyo (in, out) + call close (in) + call close (out) + + } then { + if (verbose) { + call eprintf ("Cannot read file %s\n") + call pargstr (infile) + } + } else + file_number = file_number + 1 + } + + call clpcls (list) +end diff --git a/pkg/dataio/bintext/t_txtbin.x b/pkg/dataio/bintext/t_txtbin.x new file mode 100644 index 00000000..038a71ec --- /dev/null +++ b/pkg/dataio/bintext/t_txtbin.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# T_TXTBIN -- Procedure to convert text files to binary files. + +procedure t_txtbin () + +bool verbose +char outfile[SZ_FNAME] + +char infile[SZ_FNAME], out_fname[SZ_FNAME] +int list, len_list, in, out, file_number + +bool clgetb() +int clpopni(), clplen(), clgfil(), strlen(), open() + +begin + # Get list of input files + list = clpopni ("text_file") + len_list = clplen (list) + + # Get output file name + call clgstr ("binary_file", outfile, SZ_FNAME) + + verbose = clgetb ("verbose") + + # Loop over the files + file_number = 1 + while (clgfil (list, infile, SZ_FNAME) != EOF) { + + if (len_list > 1 ) { + call strcpy (outfile, out_fname, SZ_FNAME) + call sprintf (out_fname[strlen(out_fname) + 1], SZ_FNAME, + "%03d") + call pargi (file_number) + } else + call strcpy (outfile, out_fname, SZ_FNAME) + + iferr { + + if (verbose) { + call printf ("File: %s -> %s\n") + call pargstr (infile) + call pargstr (out_fname) + call flush (STDERR) + } + + # Open input and output files, copy and close input and + # output files. + in = open (infile, READ_ONLY, TEXT_FILE) + out = open (out_fname, NEW_FILE, BINARY_FILE) + call fcopyo (in, out) + call close (in) + call close (out) + + } then { + call eprintf ("Cannot read file: %s\n") + call pargstr (infile) + } else + file_number = file_number + 1 + } + call clpcls (list) +end + + + diff --git a/pkg/dataio/bintxt.par b/pkg/dataio/bintxt.par new file mode 100644 index 00000000..359f9931 --- /dev/null +++ b/pkg/dataio/bintxt.par @@ -0,0 +1,4 @@ +mode,s,h,"ql",,, +binary_file,s,a,,,,Input file name(s) +text_file,s,a,,,,Output file name +verbose,b,h,yes,,,Print messages? diff --git a/pkg/dataio/cardimage/conversion.x b/pkg/dataio/cardimage/conversion.x new file mode 100644 index 00000000..0d6f78af --- /dev/null +++ b/pkg/dataio/cardimage/conversion.x @@ -0,0 +1,221 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define MAX_CHARS 256 + + +# ASCII_TO_EBCDIC -- Vector procedure to convert ASCII characters to EBCDIC +# characters using the lookup table atoe. + +procedure ascii_to_ebcdic (inbuffer, outbuffer, nchars) + +char inbuffer[ARB] +short outbuffer[ARB], atoe[MAX_CHARS] +int l, nchars + +data (atoe[l], l = 1, 8) / 0b, 1b, 2b, 3b, '7' , '-' , '.' , '/' / +data (atoe[l], l = 9, 16) /26b, 5b, '%' , 13b, 14b, 15b, 16b, 17b / +data (atoe[l], l = 17, 24) /20b, 21b, 22b, 23b, '<' , '=' , '2' , '&' / +data (atoe[l], l = 25, 32) /30b, 31b, '?' , '\'', 34b, 35b, 36b, 37b / +data (atoe[l], l = 33, 40) /'@' , 'O' , 177b, '{' , '[' , 'l' , 'P' , '}' / +data (atoe[l], l = 41, 48) /'M' , ']' , '\\' , 'N' , 'k' , '`' , 'K' , 'a'/ +data (atoe[l], l = 49, 56) /360b, 361b, 362b, 363b, 364b, 365b, 366b, 367b/ +data (atoe[l], l = 57, 64) /370b, 371b, 'z' , '^' , 'L' , '~' , 'n' , 'o' / +data (atoe[l], l = 65, 72) /'|' , 301b, 302b, 303b, 304b, 305b, 306b, 307b/ +data (atoe[l], l = 73, 80) /310b, 311b, 321b, 322b, 323b, 324b, 325b, 326b/ +data (atoe[l], l = 81, 88) /327b, 330b, 331b, 342b, 343b, 344b, 345b, 346b/ +data (atoe[l], l = 89, 96) /347b, 350b, 351b, 'J' , 340b, 'Z' , '_' , 'm' / +data (atoe[l], l = 97, 104) /'y' , 201b, 202b, 203b, 204b, 205b, 206b, 207b/ +data (atoe[l], l = 105, 112) /210b, 211b, 221b, 222b, 223b, 224b, 225b, 226b/ +data (atoe[l], l = 113, 120) /227b, 230b, 231b, 242b, 243b, 244b, 245b, 246b/ +data (atoe[l], l = 121, 128) /247b, 250b, 251b, 300b, 'j' , 320b, 241b, 7b/ +data (atoe[l], l = 129, 136) /' ' , '!' , '"' , '#' , '$' , 25b, 6b, 27b/ +data (atoe[l], l = 137, 144) /'(' , ')' , '*' , '+' , ',' , 11b, 12b, 33b/ +data (atoe[l], l = 145, 152) /'0' , '1' , 32b, '3' , '4' , '5' , '6' , 10b/ +data (atoe[l], l = 153, 160) /'8' , '9' , ':' , ';' , 4b, 24b, '>' , 341b/ +data (atoe[l], l = 161, 168) /'A' , 'B' , 'C' , 'D' , 'E' , 'F' , 'G' , 'H' / +data (atoe[l], l = 169, 176) /'I' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' / +data (atoe[l], l = 177, 184) /'X' , 'Y' , 'b' , 'c' , 'd' , 'e' , 'f' , 'g' / +data (atoe[l], l = 185, 192) /'h' , 'i' , 'p' , 'q' , 'r' , 's' , 't' , 'u' / +data (atoe[l], l = 193, 200) /'v' , 'w' , 'x' , 200b, 212b, 213b, 214b, 215b/ +data (atoe[l], l = 201, 208) /216b, 217b, 220b, 232b, 233b, 234b, 235b, 236b/ +data (atoe[l], l = 209, 216) /237b, 240b, 252b, 253b, 254b, 255b, 256b, 257b/ +data (atoe[l], l = 217, 224) /260b, 261b, 262b, 263b, 264b, 265b, 266b, 267b/ +data (atoe[l], l = 225, 232) /270b, 271b, 272b, 273b, 274b, 275b, 276b, 277b/ +data (atoe[l], l = 233, 240) /312b, 313b, 314b, 315b, 316b, 317b, 332b, 333b/ +data (atoe[l], l = 241, 248) /334b, 335b, 336b, 337b, 352b, 353b, 354b, 355b/ +data (atoe[l], l = 249, 256) /356b, 357b, 372b, 373b, 374b, 375b, 376b, 377b/ + +begin + call alutcs (inbuffer, outbuffer, nchars, atoe) +end + + +# EBCDIC_TO_ASCII -- Vector procedure to convert EBCDIC characters to ASCII +# characters. + +procedure ebcdic_to_ascii (inbuffer, outbuffer, nchars) + +char outbuffer[ARB] +short inbuffer[ARB], etoa[MAX_CHARS] +int l, nchars + +data (etoa[l], l = 1, 8) / 0b, 1b, 2b, 3b, 234b, 11b, 206b, 177b / +data (etoa[l], l = 9, 16) /227b, 215b, 216b, 13b, 14b, 15b, 16b, 17b/ +data (etoa[l], l = 17, 24) /20b, 21b, 22b, 23b, 235b, 205b, 10b, 207b / +data (etoa[l], l = 25, 32) /30b, 31b, 222b, 217b, 34b, 35b, 36b, 37b / +data (etoa[l], l = 33, 40) /200b, 201b, 202b, 203b, 204b, 12b, 27b, 33b/ +data (etoa[l], l = 41, 48) /210b, 211b, 212b, 213b, 214b, 5b, 6b, 7b/ +data (etoa[l], l = 49, 56) /220b, 221b, 26b, 223b, 224b, 225b, 226b, 4b/ +data (etoa[l], l = 57, 64) /230b, 231b, 232b, 233b, 24b, 25b, 236b, 32b/ +data (etoa[l], l = 65, 72) /' ' , 240b, 241b, 242b, 243b, 244b, 245b, 246b/ +data (etoa[l], l = 73, 80) /247b, 250b, '[' , '.' , '<' , '(' , '+' , '!' / +data (etoa[l], l = 81, 88) /'&' , 251b, 252b, 253b, 254b, 255b, 256b, 257b/ +data (etoa[l], l = 89, 96) /260b, 261b, ']' , '$' , '*' , ')' , ';' , '^' / +data (etoa[l], l = 97, 104) /'-' , '/' , 262b, 263b, 264b, 265b, 266b, 267b/ +data (etoa[l], l = 105, 112) /270b, 271b, '|' , ',' , '%' , '_' , '>' , '?' / +data (etoa[l], l = 113, 120) /272b, 273b, 274b, 275b, 276b, 277b, 300b, 301b/ +data (etoa[l], l = 121, 128) /302b, '`' , ':' , '#' , '@' , '\'' , '=' , '"'/ +data (etoa[l], l = 129, 136) /303b, 'a' , 'b' , 'c' , 'd' , 'e' , 'f' , 'g' / +data (etoa[l], l = 137, 144) /'h' , 'i' , 304b, 305b, 306b, 307b, 310b, 311b/ +data (etoa[l], l = 145, 152) /312b, 'j' , 'k' , 'l' , 'm' , 'n' , 'o' , 'p' / +data (etoa[l], l = 153, 160) /'q' , 'r' , 313b, 314b, 315b, 316b, 317b, 320b/ +data (etoa[l], l = 161, 168) /321b, '~' , 's' , 't' , 'u' , 'v' , 'w' , 'x' / +data (etoa[l], l = 169, 176) /'y' , 'z' , 322b, 323b, 324b, 325b, 326b, 327b/ +data (etoa[l], l = 177, 184) /330b, 331b, 332b, 333b, 334b, 335b, 336b, 337b/ +data (etoa[l], l = 185, 192) /340b, 341b, 342b, 343b, 344b, 345b, 346b, 347b/ +data (etoa[l], l = 193, 200) /'{' , 'A' , 'B' , 'C' , 'D' , 'E' , 'F' , 'G' / +data (etoa[l], l = 201, 208) /'H' , 'I' , 350b, 351b, 352b, 353b, 354b, 355b/ +data (etoa[l], l = 209, 216) /'}' , 'J' , 'K' , 'L' , 'M' , 'N' , 'O' , 'P' / +data (etoa[l], l = 217, 224) /'Q' , 'R' , 356b, 357b, 360b, 361b, 362b, 363b/ +data (etoa[l], l = 225, 232) /'\\', 237b, 'S' , 'T' , 'U' , 'V' , 'W' , 'X' / +data (etoa[l], l = 233, 240) /'Y' , 'Z' , 364b, 365b, 366b, 367b, 370b, 371b/ +data (etoa[l], l = 241, 248) /'0' , '1' , '2' , '3' , '4' , '5' , '6' , '7' / +data (etoa[l], l = 249, 256) /'8' , '9' , 372b, 373b, 374b, 375b, 376b, 377b/ + +begin + call alutsc (inbuffer, outbuffer, nchars, etoa) +end + + +# IBM_TO_ASCII -- Vector procedure for converting IBM characters to ASCII +# characters. + +procedure ibm_to_ascii (inbuffer, outbuffer, nchars) + +char outbuffer[ARB] +short inbuffer[ARB], ibmtoa[MAX_CHARS] +int l, nchars + +data (ibmtoa[l], l = 1, 8) /0b, 1b, 2b, 3b, 234b, 11b, 206b, 177b / +data (ibmtoa[l], l = 9, 16) /1227b, 215b, 216b, 13b, 14b, 15b, 16b, 17b/ +data (ibmtoa[l], l = 17, 24) /20b, 21b, 22b, 23b, 235b, 205b, 10b, 207b / +data (ibmtoa[l], l = 25, 32) /30b, 31b, 222b, 217b, 34b, 35b, 36b, 37b / +data (ibmtoa[l], l = 33, 40) /200b, 201b, 202b, 203b, 204b, 12b, 27b, 33b/ +data (ibmtoa[l], l = 41, 48) /210b, 211b, 212b, 213b, 214b, 5b, 6b, 7b/ +data (ibmtoa[l], l = 49, 56) /220b, 221b, 26b, 223b, 224b, 225b, 226b, 4b/ +data (ibmtoa[l], l = 57, 64) /230b, 231b, 232b, 233b, 24b, 25b, 236b, 32b/ +data (ibmtoa[l], l = 65, 72) /' ' , 240b, 241b, 242b, 243b, 244b, 245b, 246b/ +data (ibmtoa[l], l = 73, 80) /247b, 250b, 0b, '.' , '<' , '(' , '+' , '|' / +data (ibmtoa[l], l = 81, 88) /'&' , 251b, 252b, 253b, 254b, 255b, 256b, 257b/ +data (ibmtoa[l], l = 89, 96) /260b, 261b, '!' , '$' , '*' , ')' , ';' , '^' / +data (ibmtoa[l], l = 97, 104) /'-' , '/' , 262b, 263b, 264b, 265b, 266b, 267b/ +data (ibmtoa[l], l = 105,112) /270b, 271b, 0b, ',' , '%' , '_' , '>' , '?' / +data (ibmtoa[l], l = 113, 120) /272b, 273b, 274b, 275b, 276b, 277b, 300b, 301b/ +data (ibmtoa[l], l = 121, 128) /302b, '`' , ':' , '#' , '@' , '\'' , '=' , '"'/ +data (ibmtoa[l], l = 129, 136) /303b, 'a' , 'b' , 'c' , 'd' , 'e' , 'f' , 'g' / +data (ibmtoa[l], l = 137, 144) /'h' , 'i' , 304b, 305b, 306b, 307b, 310b, 311b/ +data (ibmtoa[l], l = 145, 152) /312b, 'j' , 'k' , 'l' , 'm' , 'n' , 'o' , 'p' / +data (ibmtoa[l], l = 153, 160) /'q' , 'r' , 313b, 314b, 315b, 316b, 317b, 320b/ +data (ibmtoa[l], l = 161, 168) /321b, '~' , 's' , 't' , 'u' , 'v' , 'w' , 'x' / +data (ibmtoa[l], l = 169, 176) /'y' , 'z' , 322b, 323b, 324b, 325b, 326b, 327b/ +data (ibmtoa[l], l = 177, 184) /330b, 331b, 332b, 333b, 334b, 335b, 336b, 337b/ +data (ibmtoa[l], l = 185, 192) /340b, 341b, 342b, 343b, 344b, 345b, 346b, 347b/ +data (ibmtoa[l], l = 193, 200) /'{' , 'A' , 'B' , 'C' , 'D' , 'E' , 'F' , 'G' / +data (ibmtoa[l], l = 201, 208) /'H' , 'I' , 350b, 351b, 352b, 353b, 354b, 355b/ +data (ibmtoa[l], l = 209, 216) /'}' , 'J' , 'K' , 'L' , 'M' , 'N' , 'O' , 'P' / +data (ibmtoa[l], l = 217, 224) /'Q' , 'R' , 356b, 357b, 360b, 361b, 362b, 363b/ +data (ibmtoa[l], l = 225, 232) /'\\', 237b, 'S' , 'T' , 'U' , 'V' , 'W' , 'X' / +data (ibmtoa[l], l = 233, 240) /'Y' , 'Z' , 364b, 365b, 366b, 367b, 370b, 371b/ +data (ibmtoa[l], l = 241, 248) /'0' , '1' , '2' , '3' , '4' , '5' , '6' , '7' / +data (ibmtoa[l], l = 249, 256) /'8' , '9' , 372b, 373b, 374b, 375b, 376b, 377b / + +begin + call alutsc (inbuffer, outbuffer, nchars, ibmtoa) +end + + +# ASCII_TO_IBM -- Vector procedure to convert ASCII characters to IBM +# characters. + +procedure ascii_to_ibm (inbuffer, outbuffer, nchars) + +char inbuffer[ARB] +short outbuffer[ARB], atoibm[MAX_CHARS] +int l, nchars + +data (atoibm[l], l = 1, 8) /0b, 1b, 2b, 3b, '7' , '-' , '.' , '/' / +data (atoibm[l], l = 9, 16) /26b, 5b, '%' , 13b, 14b, 15b, 16b, 17b / +data (atoibm[l], l = 17, 24) /20b, 21b, 22b, 23b, '<' , '=' , '2' , '&' / +data (atoibm[l], l = 25, 32) /30b, 31b, '?' , '\'', 34b, 35b, 36b, 37b / +data (atoibm[l], l = 33, 40) /'@' , 'Z' , 177b, '{' , '[' , 'l' , 'P' , '}' / +data (atoibm[l], l = 41, 48) /'M' , ']' , '\\', 'N' , 'k' , '`' , 'K' , 'a' / +data (atoibm[l], l = 49, 56) /360b, 361b, 362b, 363b, 364b, 365b, 366b, 367b/ +data (atoibm[l], l = 57, 64) /370b, 371b, 'z' , '^' , 'L' , '~' , 'n' , 'o' / +data (atoibm[l], l = 65, 72) /'|' , 301b, 302b, 303b, 304b, 305b, 306b, 307b/ +data (atoibm[l], l = 73, 80) /310b, 311b, 321b, 322b, 323b, 324b, 325b, 326b/ +data (atoibm[l], l = 81, 88) /327b, 330b, 331b, 342b, 343b, 344b, 345b, 346b/ +data (atoibm[l], l = 89, 96) /347b, 350b, 351b, 255b, 340b, 275b, '_' , 'm' / +data (atoibm[l], l = 97, 104) /'y' , 201b, 202b, 203b, 204b, 205b, 206b, 207b/ +data (atoibm[l], l = 105, 112) /210b, 211b, 221b, 222b, 223b, 224b, 225b, 226b/ +data (atoibm[l], l = 113, 120) /227b, 230b, 231b, 242b, 243b, 244b, 245b, 246b/ +data (atoibm[l], l = 121, 128) /247b, 250b, 251b, 300b, 'O' , 320b, 241b, 7b/ +data (atoibm[l], l = 129, 136) /' ' , '!' , '"' , '#' , '$' , 25b, 6b, 27b/ +data (atoibm[l], l = 137, 144) /'(' , ')' , '*' , '+' , ',' , 11b, 12b, 33b/ +data (atoibm[l], l = 145, 152) /'0' , '1' , 32b, '3' , '4' , '5' , '6' , 10b/ +data (atoibm[l], l = 153, 160) /'8' , '9' , ':' , ';' , 4b, 24b, '>' , 341b/ +data (atoibm[l], l = 161, 168) /'A' , 'B' , 'C' , 'D' , 'E' , 'F' , 'G' , 'H' / +data (atoibm[l], l = 169, 176) /'I' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' / +data (atoibm[l], l = 177, 184) /'X' , 'Y' , 'b' , 'c' , 'd' , 'e' , 'f' , 'g' / +data (atoibm[l], l = 185, 192) /'h' , 'i' , 'p' , 'q' , 'r' , 's' , 't' , 'u' / +data (atoibm[l], l = 193, 200) /'v' , 'w' , 'x' , 200b, 212b, 213b, 214b, 215b/ +data (atoibm[l], l = 201, 208) /216b, 217b, 220b, 232b, 233b, 234b, 235b, 236b/ +data (atoibm[l], l = 209, 216) /237b, 240b, 252b, 253b, 254b, 255b, 256b, 257b/ +data (atoibm[l], l = 217, 224) /260b, 261b, 262b, 263b, 264b, 265b, 266b, 267b/ +data (atoibm[l], l = 225, 232) /270b, 271b, 272b, 273b, 274b, 275b, 276b, 277b/ +data (atoibm[l], l = 233, 240) /312b, 313b, 314b, 315b, 316b, 317b, 332b, 333b/ +data (atoibm[l], l = 241, 248) /334b, 335b, 336b, 337b, 352b, 353b, 354b, 355b/ +data (atoibm[l], l = 249, 256) /356b, 357b, 372b, 373b, 374b, 375b, 376b, 377b/ + +begin + call alutcs (inbuffer, outbuffer, nchars, atoibm) +end + + +# ALUTSC -- Vector operator to map one set of characters to another using a +# lookup table. + +procedure alutsc (a, b, nchars, lut) + +char b[nchars] +int nchars, i +short a[nchars], lut[ARB] + +begin + do i = 1, nchars, 1 + b[i] = lut[a[i] + 1] +end + + +# ALUTCS -- Vector operator to map one set of characters to another using +# a lookup table. + +procedure alutcs (a, b, nchars, lut) + +char a[nchars] +int nchars, i +short b[nchars], lut[ARB] + +begin + do i = nchars, 1, -1 + b[i] = lut[a[i] + 1] +end diff --git a/pkg/dataio/cardimage/mkpkg b/pkg/dataio/cardimage/mkpkg new file mode 100644 index 00000000..63e23fc4 --- /dev/null +++ b/pkg/dataio/cardimage/mkpkg @@ -0,0 +1,13 @@ +# Cardimage library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_rcardimage.x rcardimage.com <error.h> <ctype.h> <mach.h> <fset.h> + t_wcardimage.x wcardimage.com <fset.h> <error.h> <mach.h> + conversion.x + tabs.x + ; diff --git a/pkg/dataio/cardimage/rcardimage.com b/pkg/dataio/cardimage/rcardimage.com new file mode 100644 index 00000000..064f1af3 --- /dev/null +++ b/pkg/dataio/cardimage/rcardimage.com @@ -0,0 +1,10 @@ +int card_length +int max_line_length +int trim +int entab +int ebcdic +int ibm +char contn_string[SZ_LINE] + +common /rcardcom/ card_length, max_line_length, trim, entab, ebcdic, ibm, + contn_string diff --git a/pkg/dataio/cardimage/structure.hlp b/pkg/dataio/cardimage/structure.hlp new file mode 100644 index 00000000..4a8b5622 --- /dev/null +++ b/pkg/dataio/cardimage/structure.hlp @@ -0,0 +1,139 @@ +.help cardimage Jan85 dataio +.sh +RCARDIMAGE Structure Chart + +.nf +t_rcardimage() +# Returns when file list is satisfied or EOT is encountered. + + cardfile_to_textfile (in_fname, out_fname, nlines, ncards) + + fetchcard (fd, outline, ncards) + # Returns number of chars read or EOF + + card_to_text (fd, instring) + # Returns number of chars or EOF + + conversion routines +.fi + +.sh +WCARDIMAGE Structure Chart + +.nf +t_wcardimage() +# Returns when file list is satisfied. + + textfile_to_cardfile (in_file, out_fname, ncards, nlines) + + fetchline (fd, linebuf, nlines) + # Returns EOF or number of chars read + + text_to_card (line, nchars, card) + + conversion routines +.fi +.sh +RCARDIMAGE Structure Summary + +.ls t_rcardimage +The main procedure reads the control parameters. +The files to be read and converted are calculated from the specified source +and file list. A loop trough the files determines the specific input +and output filenames and calls CARDFILE_TO_TEXTFILE for each conversion. +.ls cardfile_to_textfile +The input and output files are opened. Successive card images are fetched and +converted to text lines by FETCHCARD. If the ENTAB switch is enabled +blanks are replaced by tabs and blanks. +.ls fetchcard +This procedure reads individual card images, optionally joining those +images prefixed by an indentifying continuation string with the previous +card image(s). If trim is enabled white space is removed. Newline and +EOS are added. +.ls card_to_text +Converts a packed card image to a text image. Call the CONVERSION routines +to convert from EBCDIC to ASCII if the ebcdic switch is set. +.le +.le +.le +.le +.sh +WCARDIMAGE Structure Summary + +.ls t_wcardimage +The main procedure read the control parameters. +The files to be read and converted are calculated from the specified +source and file list. A loop through the files determines the specific +input source names and output filenames and calls TEXTFILE_TO_CARDFILE +for each conversion. +.ls textfile_to_cardfile +The input and output source files are opened. Successive text lines are +read and converted to one or more lines card_length + 1 long by +calls to FETCHLINE. +.ls fetchline +FETCHLINE fetches lines of text and splits them into pieces <= +maxch characters long optionally prefixing the remainders with +an identifying continuation string. If the detab switch is set +tabs in the lines are replaced with blanks. +.ls text_to_card +Converts a text string into a packed card image removing the newline +character if necessary and padding with blanks if required. +Call the conversion routines to convert from ASCII to EBCDIC if the +ebcdic switch is set. +.le +.le +.le +.le +.sh +MTEXAMINE Structure Chart + +.nf +t_mtexamine () +# Returns when file list is satisfied + + mtexamine (tape_file, dump_range, byte_chunk, field_len, + vals_per_lines, output_format) + # Returns number of records read + + bytupkl (a, b, nbytes, byte_chunk, byteswap) + + dump (ptr, byte_chunk, nelems, field_len, vals_per_line, + output_format, max_plusint, twice_max_plusint) + + sign_convert (a, nelems, max_plusint, twice_max_plusint) +.fi +.sh +MTEXAMINE Structure Summary +.ls t_mtexamine +T_MTEXAMINE fetches the program parameters and calculates the +input file list. If dump_records is yes, T_MTEXAMINE +calculates the record list to be dumped, calculates the field length +and number of values which can be printed on a line and checks to see that the +data_type and output_format parameters are permitted types. For each +file in the input list T_MTEXAMINE calls MTEXAMINE. +.ls mtexamine +If dump_records is no, MTEXAMINE prints the record structure of the specified +files on the standard output. Otherwise MTEXAMINE loops through the tape +records until it reaches a record number in the record list +and calls dump to output the record to +the standard output. +.ls bytupkl +BYTUPKL unpacks unsigned bytes into and integer array, optionally swaps +the bytes, and assembles byte_chunk bytes into a long integer. +.le +.ls dump +DUMP prints the record on the standard output using the specified +output format and data type. If byte_chunk is 1 the output is unsigned. +If byte_chunk is equal to the size in bytes of a long integer, then +the data will be printed as signed. If byte_chunk is greater than one +and less then the length of a long the data will be signed if the +output format is decimal and unsigned otherwise. DUMP calls twos_comp +to do the sign conversion. +.ls sign_convert +SIGN_CONVERT does a twos complement sign conversion if the output format is +decimal and byte_chunk is greater than one and less than the size of a +long integer. +.le +.le +.le +.le diff --git a/pkg/dataio/cardimage/t_rcardimage.x b/pkg/dataio/cardimage/t_rcardimage.x new file mode 100644 index 00000000..a2dad404 --- /dev/null +++ b/pkg/dataio/cardimage/t_rcardimage.x @@ -0,0 +1,271 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <ctype.h> +include <mach.h> +include <fset.h> + +define MAX_RANGES 100 +define TABSIZE 8 + +# T_RCARDIMAGE -- Procedure to read cardimages tapes. Documentation in +# rcardimage.hlp. + +procedure t_rcardimage() + +char infile[SZ_FNAME] # the input file name list +char outfile[SZ_FNAME] # the output file name list +char file_list[SZ_LINE] # the file number list +int offset # the file number offset +bool join # join long lines ? +bool verbose # verbose output ? + +char in_fname[SZ_FNAME], out_fname[SZ_FNAME] +int nlines, file_number, ncards, range[MAX_RANGES*2+1], nfiles +int lenlist, junk +pointer list + +bool clgetb() +int btoi(), clgeti(), mtfile(), mtneedfileno(), strlen(), decode_ranges() +int get_next_number(), fntlenb(), fntgfnb(), fstati() +pointer fntopnb() +include "rcardimage.com" + +begin + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get parameters. + call clgstr ("cardfile", infile, SZ_FNAME) + call clgstr ("textfile", outfile, SZ_FNAME) + + # Make up a file list. + if (mtfile (infile) == YES) { + list = NULL + if (mtneedfileno (infile) == YES) + call clgstr ("file_list", file_list, SZ_LINE) + else + call strcpy ("1", file_list, SZ_LINE) + } else { + list = fntopnb (infile, YES) + lenlist = fntlenb (list) + call sprintf (file_list, SZ_LINE, "1-%d") + call pargi (lenlist) + } + + # Decode the ranges. + if (decode_ranges (file_list, range, MAX_RANGES, nfiles) == ERR) + call error (1, "Illegal file number list") + + # Set up the formatting parameters. + card_length = min (SZ_LINE, clgeti ("card_length")) + if (mod (card_length, SZB_CHAR) != 0) + call error (2, "A card must contain an even number of characters") + max_line_length = min (SZ_LINE, clgeti ("max_line_length")) + join = clgetb ("join") + if (join) + call clgstr ("contn_string", contn_string, SZ_LINE) + else + contn_string[1] = EOS + entab = btoi (clgetb ("entab")) + trim = btoi (clgetb ("trim")) + ebcdic = btoi (clgetb ("ebcdic")) + ibm = btoi (clgetb ("ibm")) + if (ibm == YES && ebcdic == YES) + call error (3, "Ibm and ebcdic cannot both be true.") + + offset = clgeti ("offset") + verbose = clgetb ("verbose") + + # Read successive cardimage files, convert and write into a numbered + # succession of output textfiles. + + file_number = 0 + while (get_next_number (range, file_number) != EOF) { + + # Get the input file name. + if (list != NULL) + junk = fntgfnb (list, in_fname, SZ_FNAME) + else { + if (mtneedfileno (infile) == YES) + call mtfname (infile, file_number, in_fname, SZ_FNAME) + else + call strcpy (infile, in_fname, SZ_FNAME) + + } + + # Get the output file name. + call strcpy (outfile, out_fname, SZ_FNAME) + if (nfiles > 1) { + call sprintf (out_fname[strlen(out_fname)+1], SZ_FNAME, "%03d") + call pargi (file_number + offset) + } + + # Copy the cardimage file to the output text file. If a read + # error occurs, try next file. If a zero length file is read, + # meaning that EOT was reached prematurely, merely exit, deleting + # the zero length output file. + + iferr { + if (verbose) { + call printf ("File: %s -> %s: ") + call pargstr (in_fname) + call pargstr (out_fname) + } + + call rc_cardfile_to_textfile (in_fname, out_fname, nlines, + ncards) + + if (verbose) { + call printf ("%d card images -> %d text lines\n") + call pargi (ncards) + call pargi (nlines) + } + + } then { + call flush (STDOUT) + call erract (EA_FATAL) + } else if (nlines == 0) { # EOT reached + if (verbose) { + call printf ("EOT encountered at file %s\n") + call pargi (file_number + offset) + } + call delete (out_fname) + break + } + } + + if (list != NULL) + call fntclsb (list) +end + + +# RC_CARDFILE_TO_TEXTFILE -- Copy a cardfile to a new textfile. +# Outputs the number of cards read and lines written. + +procedure rc_cardfile_to_textfile (in_fname, out_fname, nlines, ncards) + +char in_fname[ARB] # the input file name +char out_fname[ARB] # the output file name +int nlines # the number of lines +int ncards # the number of cards + +char lbuf[SZ_LINE], tempbuf[SZ_LINE] +int in, out, nchars +int mtopen(), open(), rc_fetchcard() +errchk mtopen, open, rc_fetchcard, putline, strentab, close +include "rcardimage.com" + +begin + in = mtopen (in_fname, READ_ONLY, 0) + out = open (out_fname, NEW_FILE, TEXT_FILE) + + ncards = 0 + iferr { + nchars = rc_fetchcard (in, lbuf, ncards) + for (nlines = 0; nchars != EOF; nlines = nlines + 1) { + if (entab == YES) { + call strentab (lbuf, tempbuf, max_line_length, TABSIZE) + call putline (out, tempbuf) + } else + call putline (out, lbuf) + nchars = rc_fetchcard (in, lbuf, ncards) + } + } then + call erract (EA_WARN) + + call close (in) + call close (out) +end + + +# RC_FETCHCARD -- Procedure to read card images and join those images prefixed +# by an identifying continuation string with the previous image(s). +# Returns number of characters in line or EOF. + +int procedure rc_fetchcard (fd, outline, cp) + +int fd # the input file descriptor +char outline[ARB] # the output line +int cp # the card counter + +bool newfile +char instring[SZ_LINE * SZ_SHORT] +int ip, op, npacked_chars, strsize +int rc_card_to_text(), strlen(), strncmp() +errchk rc_card_to_text +data newfile/true/ +include "rcardimage.com" + +begin + ip = 1 + op = 1 + strsize = strlen (contn_string) + + # Get first line of file. + if (newfile) { + npacked_chars = rc_card_to_text (fd, instring) + newfile = false + } + + while (npacked_chars != EOF) { + # Count cards and file output buffer. + while (instring[ip] != EOS && op < max_line_length) { + outline[op] = instring[ip] + ip = ip + 1 + op = op + 1 + } + cp = cp + 1 + + # Check for continuation string in next line, move pointer if yes. + npacked_chars = rc_card_to_text (fd, instring) + + if ((strsize != 0) && + (strncmp (instring, contn_string, strsize) == 0) && + (npacked_chars != EOF)) { + ip = strsize + 1 + } else { + # Output line, remove whitespace, add newline and delimit string + if (trim == YES) + while (op >= 2 && IS_WHITE (outline[op-1])) + op = op -1 + outline[op] = '\n' + outline[op+1] = EOS + return (op) + } + } + + # Initialize for new file. + newfile = true + return (EOF) +end + + +# RC_CARD_TO_TEXT -- Procedure to transform a packed card image to a text image. + +int procedure rc_card_to_text (fd, card) + +int fd # input file descriptor +char card[ARB] # the packed/unpacked cardimage image + +int npacked_chars, nchars +int read() +errchk read, ebcdic_to_ascii, ibm_to_ascii +include "rcardimage.com" + +begin + npacked_chars = read (fd, card, card_length/SZB_CHAR) + if (npacked_chars == EOF) + return (EOF) + nchars = npacked_chars * SZB_CHAR + if (ebcdic == YES) { + call achtbs (card, card, nchars) + call ebcdic_to_ascii (card, card, nchars) + } else if (ibm == YES) { + call achtbs (card, card, nchars) + call ibm_to_ascii (card, card, nchars) + } else + call chrupk (card, 1, card, 1, nchars) + card[nchars+1] = EOS + return (nchars) +end diff --git a/pkg/dataio/cardimage/t_wcardimage.x b/pkg/dataio/cardimage/t_wcardimage.x new file mode 100644 index 00000000..0a85bb55 --- /dev/null +++ b/pkg/dataio/cardimage/t_wcardimage.x @@ -0,0 +1,256 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <error.h> +include <mach.h> + +define TABSIZE 8 + +# Procedure to write cardimage files. See wcardimage.hlp for documentation. + +procedure t_wcardimage() + +char out_file[SZ_FNAME] # input file name list +char in_file[SZ_FNAME] # output file name list +bool verbose # verbose mode ? + +char out_fname[SZ_FNAME] +int ncards, file_number, nlines, list, len_list + +bool clgetb() +int fstati(), clpopni(), clplen(), mtfile(), mtneedfileno() +int clgeti(), clgfil(), strlen(), btoi() +include "wcardimage.com" + +begin + # Flush standard output on newline + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get the parameters. + list = clpopni ("textfile") + len_list = clplen (list) + + # Get name of output file. + # If no tape file number is given tape output then the program + # asks whether the tape is blank or contains data. + # If it is blank the tape begins writing at file 1 otherwise at EOT. + # Note that at some point this code needs to be modified to + # accept an output file name template. + + call clgstr ( "cardfile", out_file, SZ_FNAME) + if (mtfile (out_file) == YES) { + if (mtneedfileno (out_file) == YES) { + if (! clgetb("new_tape")) + call mtfname (out_file, EOT, out_fname, SZ_FNAME) + else + call mtfname (out_file, 1, out_fname, SZ_FNAME) + } else + call strcpy (out_file, out_fname, SZ_FNAME) + } + + # Get card_length and determine whether it fits in an integral number + # of characters. + + card_length = min (SZ_LINE, clgeti ("card_length")) + if (mod (card_length, SZB_CHAR) != 0) + call error (1, "A card must fit in an integral number of chars.") + + # Get number of cards per physical block and convert to packed chars. + cards_per_blk = clgeti ("cards_per_blk") + + # Get the formatting parameters. + call clgstr ("contn_string", contn_string, SZ_LINE) + if (strlen (contn_string) > card_length) + call error (2, + "Continuation string cannot be > card_length chars.") + detab = btoi (clgetb ("detab")) + + # Get the character type parameters. + ebcdic = btoi (clgetb ("ebcdic")) + ibm = btoi (clgetb ("ibm")) + if (ibm == YES && ebcdic == YES) + call error (3, "Ibm and ebcdic cannot both be true.") + + verbose = clgetb ("verbose") + + file_number = 1 + while (clgfil (list, in_file, SZ_FNAME) != EOF) { + if (mtfile (out_file) == NO) { + if (len_list > 1) { + call sprintf (out_fname[1], SZ_FNAME, "%s%03d") + call pargstr (out_file) + call pargi (file_number) + } else + call strcpy (out_file, out_fname, SZ_FNAME) + } else { + if (file_number == 2) + call mtfname (out_fname, EOT, out_fname, SZ_FNAME) + } + + # Copy text file to cardimage file. + + iferr { + if (verbose) { + call printf ("File: %s -> %s: ") + call pargstr (in_file) + call pargstr (out_fname) + } + + call wc_textfile_to_cardfile (in_file, out_fname, ncards, + nlines) + + if (verbose) { + call printf ("%d lines read -> %d cards written\n") + call pargi (nlines) + call pargi (ncards) + } + } then { + call flush (STDOUT) + call erract (EA_FATAL) + } else if (ncards == 0) { + if (verbose) + call printf ("\tInput file is binary or empty\n") + } + + file_number = file_number + 1 + } +end + + +# WC_TEXTFILE_TO_CARDFILE -- Reads a textfile from disk and outputs a card +# image file to tape or disk. + +procedure wc_textfile_to_cardfile (in_file, out_fname, ncards, nlines) + +char in_file[ARB] # input file name +char out_fname[ARB] # output file name +int ncards # number of card images +int nlines # number of text lines + +char linebuf[SZ_LINE] +int in, out, nchars, chars_per_blk +int mtopen(), open(), access(), wc_fetchline(), mtfile() +errchk mtopen, open, access, wc_fetchline, write, close, wc_text_to_card +include "wcardimage.com" + +begin + nlines = 0 + ncards = 0 + + if (access (in_file, READ_ONLY, TEXT_FILE) != YES) + return + + # Open the file. + in = open (in_file, READ_ONLY, TEXT_FILE) + if (mtfile (out_fname) == YES) { + chars_per_blk = cards_per_blk * card_length / SZB_CHAR + out = mtopen (out_fname, WRITE_ONLY, chars_per_blk) + } else + out = open (out_fname, NEW_FILE, BINARY_FILE) + + # Write file. + nchars = wc_fetchline (in, linebuf, nlines, card_length+1) + while (nchars != EOF) { + call wc_text_to_card (linebuf, nchars, linebuf) + call write (out, linebuf, card_length/SZB_CHAR) + ncards = ncards + 1 + nchars = wc_fetchline (in, linebuf, nlines, card_length+1) + } + + call close (in) + call close (out) +end + + +# WC_TEXT_TO_CARD -- Convert text string into a packed cardimage string +# removing the newline character if necessary, padding with blanks +# if required and optionally translating from ascii to ebcdic or ibm +# ebcdic. + +procedure wc_text_to_card (line, nchars, card) + +char line[ARB] # input text line +int nchars # number of chars in line +char card[ARB] # output packed card image + +int init, ip +errchk ascii_to_ebcdic, ascii_to_ibm, achtsb, chrpak +include "wcardimage.com" + +begin + # Pad with blanks. + init = nchars + if (line[init] != '\n') + init = init + 1 + for (ip=init; ip <= card_length; ip=ip+1) + line[ip] = ' ' + + # Pack the line. + if (ebcdic == YES) { + call ascii_to_ebcdic (line, card, card_length) + call achtsb (card, card, card_length) + } else if (ibm == YES) { + call ascii_to_ibm (line, card, card_length) + call achtsb (card, card, card_length) + } else + call chrpak (line, 1, card, 1, card_length) +end + + +# WC_FETCHLINE -- Procedure to fetch a line of text and split it into pieces +# <= maxch characters long, optionally prefixing the remainders of lines +# with a character string. + +int procedure wc_fetchline (fd, linebuf, lp, maxch) + +int fd # input file descriptor +char linebuf[ARB] # output chunk of text +int lp # number of lines read +int maxch # maximum size of chunk of text + +char line[SZ_LINE], inline[SZ_LINE] +int nchars, ip, op, offset, strsize +int getline(), gstrcpy(), strlen(), strncmp() +errchk getline(), strdetab() +include "wcardimage.com" +data ip /1/ + +begin + # Get new line and detab if requested. + if (ip == 1) { + if (detab == YES) { + nchars = getline (fd, inline) + call strdetab (inline, line, SZ_LINE, TABSIZE) + } else + nchars = getline (fd, line) + if (nchars == EOF) + return (EOF) + + lp = lp + 1 + offset = 0 + strsize = strlen (contn_string) + if (strsize != 0 && strncmp (line, contn_string, strsize) == 0) + call eprintf ("Warning: Line matches continuation string\n") + + } else { + # Otherwise determine length of continuation string. + offset = gstrcpy (contn_string, linebuf, SZ_LINE) + } + + # Copy maxch characters to the output buffer. + op = offset + 1 + while (line[ip] != EOS && op < maxch && line[ip] != '\n') { + linebuf[op] = line[ip] + ip = ip + 1 + op = op + 1 + } + + # Add newline and EOS reset pointer. + linebuf[op] = '\n' + linebuf[op+1] = EOS + if (line[ip] == EOS || line[ip] == '\n') + ip = 1 + + return (op) +end diff --git a/pkg/dataio/cardimage/tabs.x b/pkg/dataio/cardimage/tabs.x new file mode 100644 index 00000000..ccb722a2 --- /dev/null +++ b/pkg/dataio/cardimage/tabs.x @@ -0,0 +1,67 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# STRDETAB -- Procedure to remove tabs from a line of text and replace with +# blanks. + +procedure strdetab (line, outline, maxch, tabsize) + +int ip, op, maxch, tabsize +char line[ARB], outline [ARB] + +begin + op=1 + ip=1 + + while (line[ip] != EOS && op <= maxch) { + if (line[ip] == '\t') { + repeat { + outline[op] = ' ' + op = op + 1 + } until ((mod (op, tabsize) == 1) || (op > maxch)) + ip = ip + 1 + } else { + outline[op] = line[ip] + op = op + 1 + ip = ip + 1 + } + } + + outline[op] = EOS +end + + +# STRENTAB -- Procedure to replace blanks with tabs and blanks. + +procedure strentab (line, outline, maxch, tabsize) + +int maxch, tabsize +char line[ARB], outline[ARB] +int ip, op, ltab + +begin + op = 1 + ip = 1 + + repeat { + ltab = ip + while (line[ltab] == ' ' && op <= maxch) { + ltab = ltab + 1 + if (mod(ltab, tabsize) == 1) { + outline[op] = '\t' + ip = ltab + op = op + 1 + } + } + for (; ip < ltab && op <= maxch; ip = ip + 1) { + outline[op] = ' ' + op = op + 1 + } + if (line[ip] == EOS || op >= maxch+1) + break + outline[op] = line[ip] + op = op + 1 + ip = ip + 1 + } until (line[ip] == EOS || op >= maxch+1) + + outline[op] = EOS +end diff --git a/pkg/dataio/cardimage/wcardimage.com b/pkg/dataio/cardimage/wcardimage.com new file mode 100644 index 00000000..4d80adb1 --- /dev/null +++ b/pkg/dataio/cardimage/wcardimage.com @@ -0,0 +1,8 @@ +int card_length +int cards_per_blk +int detab +int ebcdic +int ibm +char contn_string[SZ_LINE] + +common /wcardcom/ card_length, cards_per_blk, detab, ebcdic, ibm, contn_string diff --git a/pkg/dataio/dataio.cl b/pkg/dataio/dataio.cl new file mode 100644 index 00000000..2120892e --- /dev/null +++ b/pkg/dataio/dataio.cl @@ -0,0 +1,19 @@ +#{ The DATAIO data input/output conversion package. + +package dataio + +task rcardimage, + wcardimage, + mtexamine, + txtbin, + bintxt, + rfits, + wfits, + reblock, + rtextimage, + t2d, + wtextimage, + import, + export = dataio$x_dataio.e + +clbye() diff --git a/pkg/dataio/dataio.hd b/pkg/dataio/dataio.hd new file mode 100644 index 00000000..93949ffd --- /dev/null +++ b/pkg/dataio/dataio.hd @@ -0,0 +1,27 @@ +# Help directory for the DATAIO package. + +$doc = "pkg$dataio/doc/" +$fits = "pkg$dataio/fits/" +$reblock = "pkg$dataio/reblock/" +$imtext = "pkg$dataio/imtext/" +$mtexamine = "pkg$dataio/mtexamine/" +$cardimage = "pkg$dataio/cardimage/" +$bintext = "pkg$dataio/bintext/" +$t2d = "pkg$dataio/t2d/" +$import = "pkg$dataio/import/" +$export = "pkg$dataio/export/" + +bintxt hlp=doc$bintxt.hlp, src=bintext$t_bintxt.x +mtexamine hlp=doc$mtexamine.hlp, src=mtexamine$t_mtexamine.x +rcardimage hlp=doc$rcardimage.hlp, src=cardimage$t_rcardimage.x +reblock hlp=doc$reblock.hlp, src=reblock$t_reblock.x +rfits hlp=doc$rfits.hlp, src=fits$t_rfits.x +rtextimage hlp=doc$rtextimage.hlp, src=imtext$t_rtextimage.x +txtbin hlp=doc$txtbin.hlp, src=bintext$t_txtbin.x +wcardimage hlp=doc$wcardimage.hlp, src=cardimage$t_wcardimage.x +wfits hlp=doc$wfits.hlp, src=fits$t_wfits.x +wtextimage hlp=doc$wtextimage.hlp, src=imtext$t_wtextimage.x +t2d hlp=doc$t2d.hlp, src=t2d$t_t2d.x +import hlp=doc$import.hlp, src=import$t_import.x +export hlp=doc$export.hlp, src=export$t_export.x +revisions sys=Revisions diff --git a/pkg/dataio/dataio.men b/pkg/dataio/dataio.men new file mode 100644 index 00000000..3d83ce6b --- /dev/null +++ b/pkg/dataio/dataio.men @@ -0,0 +1,13 @@ + bintxt - Convert a binary file to an IRAF text file + export - Convert IRAF images to some other format + import - Convert some other format to an IRAF image + mtexamine - Examine the structure of a magnetic tape + rcardimage - Convert a cardimage file into a text file + reblock - Copy a binary file, optionally reblocking + rfits - Convert FITS image data into a list of IRAF images + rtextimage - Convert text files to IRAF images + t2d - Fast tape to disk copy + txtbin - Convert an IRAF text file to a binary file + wcardimage - Convert text files to cardimage files + wfits - Convert a list of IRAF images into FITS image data + wtextimage - Convert an IRAF image to a text file diff --git a/pkg/dataio/dataio.par b/pkg/dataio/dataio.par new file mode 100644 index 00000000..ff362077 --- /dev/null +++ b/pkg/dataio/dataio.par @@ -0,0 +1,4 @@ +# Dummy package parameter file. + +version,s,h,"26Apr86" +mode,s,h,ql diff --git a/pkg/dataio/doc/Mtio_notes b/pkg/dataio/doc/Mtio_notes new file mode 100644 index 00000000..c5fb2fe5 --- /dev/null +++ b/pkg/dataio/doc/Mtio_notes @@ -0,0 +1,12 @@ + +MTIO mods: + + (1) Install error checking in MTOPEN ("errchk open"). + + (2) Attempt to position to a file beyond EOT for reading should not + cause an error, rather EOF should be returned at the first read, + indicating a zero length file (i.e., EOT). + + (3) ZARDMT should zero-fill to an integral number of chars, provided + space is available at end of buffer (see ZARDBF, which I had to + modify to provide zero-fill). diff --git a/pkg/dataio/doc/Rfits_notes b/pkg/dataio/doc/Rfits_notes new file mode 100644 index 00000000..7df78ca5 --- /dev/null +++ b/pkg/dataio/doc/Rfits_notes @@ -0,0 +1,85 @@ + +Notes on RFITS program. + +General Comments -- + The code is well structured, modular, and the identifiers are well + chosen for the most part, with some exceptions. I liked the file list + technique, and have incorporated it into the card image reader I wrote + to test MTIO. + + On the critical side, the code is not sufficiently well commented. + A few comments explaining the general approach are needed; the use + of the record buffer, the placement of unrecognized keywords in the + image header, and so on are important things that can only be derived + at present by a very detailed analysis of the code. Functionally the + program has some serious limitations as noted below. + + +Detailed Comments -- + +On functionality: + + (1) Keywords BUNIT, BLANK, DATE, DATE_OBS, ORIGIN, CRVALn, CRPIXn, + etc., etc. should all be recognized. Many of these have direct + complements in the image header and it is merely a matter of + mapping the value directly. Without doing so we cannot save + and restore IRAF images in FITS tape form without serious loss + of information. + + Our intention is eventually to map nonstandard FITS keywords + by name into the user fields. A similar table driven mapping + of the standard fields might therefore be desirable. This + would also make the reader more robust and easier to modify to + read nonstandard or future (extended) formats. + + (2) Something should be done about indefinite pixels. It is easy to + check for FITS BLANK value and map into the appropriate INDEF. + This function should be encapsulated in a separate procedure, + because it will have to be modified when we add bad pixel lists + to IMIO. + + (3) BITPIX=32 is not really implemented. Eight bits of precision lost + is too much. Also, SIMPLE='F' should not result in an irrecoverable + abort; a subsequent program may be able to recover the data if it + can at least be read into an imagefile. For similar reasons, it + would be best if it were possible to move pixels to disk without + conversion. Doing everything in real forces binary conversion of + the pixels, as well as causing the loss of precision for type long. + + +On coding: + + (1) Error checking is only partially implemented. As a rule, low level + procedures should "errchk" all subprocedures which perform i/o, so + that the higher level procedures can decide whether or not they want + to catch errors (makes code easier to modify, i.e., to add an error + handler in the future). + + (2) The stack should be unchanged upon exit from a procedure. SALLOC is + used improperly in several places (noted on listing). + + (3) The constants defining the FITS standard should be parameterized in + an include file with comments, or in an external lookup table. I do + not know what GROUPS, PCOUNT, GCOUNT are, and I had to think a bit to + figure out what the 11, 29, etc. were. The exact version of the + standard implemented by the program should be defined all in one + place, so that others can see what version of the standard is + implemented without having to read and understand the whole program, + and to make it easier to modify the program to read future and + nonstandard "FITS" files. Also numbers like "11", "29" etc. are + inherently hard to understand. Even "80" may have to be changed + to read a nonstandard or improperly written format. + + (4) Defined expressions should be enclosed in parenthesis to guarantee + that they are evaluated properly. The definitions of SZB_BIT, + SZ_UBYTE, etc. do not work if enclosed in parenthesis. This is + very tricky; if I were to inherit the program, I would have "fixed" + those definitions at first sight by adding parens, just to be safe, + and then the code would no longer work. Use of integer division + in expressions where the operands of unknown size is bad. + + (5) The "8" in the definition of SZB_BIT is machine dependent. I have + added an NBITS_BYTE definition to iraf.h. Do not let machine + dependence creep into code!! + + (6) I have added WRDSWP and ACHTB_ to the system libraries. diff --git a/pkg/dataio/doc/bintxt.hlp b/pkg/dataio/doc/bintxt.hlp new file mode 100644 index 00000000..5d758ee5 --- /dev/null +++ b/pkg/dataio/doc/bintxt.hlp @@ -0,0 +1,28 @@ +.help bintxt Jun86 dataio +.ih +NAME +bintxt -- Convert binary files containing only text to text files +.ih +USAGE +bintxt binary_file text_file +.ih +PARAMETERS +.ls binary_file +Input file name or template, e.g. "file1" or "file*". +.le +.ls text_file +The output file name. If multiple input files the filenumber will +be concatenated onto the output file name. +.le +.ls verbose = yes +Print messages of actions performed? +.le +.ih +EXAMPLES +1. Convert a binary file on disk to a text file on disk. + + cl> bintxt binary_file text_file +.ih +SEE ALSO +txtbin +.endhelp diff --git a/pkg/dataio/doc/export.hlp b/pkg/dataio/doc/export.hlp new file mode 100644 index 00000000..4ef4a492 --- /dev/null +++ b/pkg/dataio/doc/export.hlp @@ -0,0 +1,1066 @@ +.help export Oct94 dataio +.ih +NAME +export -- create a binary image file from one or more IRAF images + +.ih +USAGE +export images binfiles + +.ih +PARAMETERS + +.ls images +The list of input IRAF images to be converted. The list may contain +either 2-D images or 3-D images. +Any number of 2-D images may be combined to a single output file, only +one 3-D image (or section) at a time may be converted. See the \fIBuiltin +Formats\fR section for notes about the number of image expressions required +for each builtin format and the handling of 3-D image data. Images greater +than three dimensions should be converted using image sections. +.le +.ls binfiles +The list of output binary files to create. If any of the builtin formats +is selected for conversion the filename will have an extension added +reflecting the format (if it is not already given). +.le + +.ce +OUTPUT PARAMETERS +.ls format = "raw" +The type of binary file to write. If the value is "raw" then the input +images are converted directly to a raw binary raster using the task +parameters. If the value is "list" the pixel values will be written +to the standard output after evaluation of the \fIoutbands\fR parameter in +the same format as would appear from the \fILISTPIX\fR task. Finally, +the value may include any of the currently supported specific builtin formats: + +.nf + eps - Encapsulated PostScript + gif - Compuserve's GIF format + imh - IRAF OIF image + miff - ImageMagick MIFF format image + pgm - PBMPlus PGM format image + ppm - PBMPlus PPM format image + ras - Sun rasterfile format + rgb - SGI RGB format image + xwd - X11 Window dump file +.fi + +If any of these builtin formats is selected one or more of the following +parameters may be ignored. See the \fIBuiltin Formats\fR section for notes +about the formats supported by this task. +.le +.ls outbands = "" +Output image band expressions to write. This is a comma-delimited list of +expressions or an @-file containing the expressions. Evaluated expressions +do not all need to be the same length since the output image will be padded +to the maximum size. See below for more information. +.le +.ls verbose = no +Print verbose output to the screen during conversion? +.le + +.ce +RAW BINARY OUTPUT PARAMETERS +.ls header = yes +For raw binary file output only, prepend a header describing how the data +are stored? If set to "no" then no header will be written. If set to "yes", +a standard text header describing how the data were written will be +prepended to the output file. Setting the \fIheader\fR parameter to the +reserved string "long" will write the image headers from the IRAF images +making up the output file in the standard header. The parameter may also +be set to a filename that will be prepended to the output file. This +parameter is ignored for builtin format output. See below for a description +of the header layout. +.le +.ls outtype = "" +Output pixel type if \fIformat\fR is set to "raw" or "list". This is a +string giving the type and size of each pixel, the syntax for the outtype +entry is +.nf + + <type>[<nbytes>] +where + type = b # byte + u # unsigned (short) integer + i # signed integer + r # ieee floating point + n # native floating point + + nbytes = 1, 2, 4, or 8 + +.fi +If no value for \fInbytes\fR is given the smallest size for the given type +(i.e. 1 byte for 'b', 2 bytes for ints, 4 bytes for floating point) will +be used. If no value is entered at all the type of the input image is used, +for multiple images used to create a single binary file the type of the first +image is used. This parameter is ignored for builtin format output options. +.le +.ls interleave = 0 +Pixel interleave type. If the \fIoutbands\fR parameter is composite +(i.e. a comma-delimited list of expressions) the output file is pixel +interleaved and the \fIinterleave\fR parameter is ignored. If the +\fIoutbands\fR parameter is a single expression the file is line-interleaved +when the \fIinterleave\fR value is a positive integer. If the \fIoutbands\fR +is an empty string or a single expression the binary file is band interleaved +if this parameter is zero. This parameter is ignored for builtin formats +where the pixel storage is predefined. +.le +.ls bswap = "no" +Type of byte-swapping to perform on output. The default is bswap=no which +may be abbreviated "bswap-" (similarly a value of 'yes' can be abbreviated +"bswap+"). If disabled no byte-swapping is performed, if set all integers +are swapped on output relative to the current machine's byte ordering. +Values of 'i2' or 'i4' will swap only two or four byte integers respectively, +floating point values remain unswapped. This parameter may be used by some +builtin formats that don't have a specified byte order. +.le + +.ih +DESCRIPTION + The \fIexport\fR task will convert one or more images in an +input list to a binary raster file, a text listing of pixels values, +or one of several specific file formats. For general binary +rasters, various pixel types, data interleaving, and the byte order can be +specified. An optional header may be added to the output file. +Arbitrary arithmetic expressions, using both standard and custom +functions, may be applied to the images in the +input list before conversion allowing the user to scale intensity values, +change image orientation, compute colormaps, or compute output pixel +values. + + The \fIformat\fR parameter controls the type of output generated: +if set to \fIraw\fR a binary file described by the \fIouttype\fR, +\fIinterleave\fR, and \fIbswap\fR parameters is written with pixel values +determined from the expressions in the +\fIoutbands\fR parameter. The value of \fIouttype\fR +defines the output pixel size and type (long or short ints, native or IEEE +reals, see parameter description for details). The +\fIbswap\fR parameter can be used to set the byte order (relative to the +current machine) of integer values, this +parameter is ignored for floating point pixels or builtin +formats with a specified byte order. The \fIoutbands\fR and \fIinterleave\fR +parameters define the pixel storage in the binary file. For multiple +\fIoutbands\fR +expressions the data are assumed to be pixel interleaved (e.g. written +as { {RGB}, {RGB} ...} triplets). For single expressions, a positive value +of \fIinterleave\fR indicates that the data are written in a line-interleaved +manner (e.g. a line of R, a line of G, ...). If \fIinterleave\fR is +zero and \fIoutbands\fR is a single expression +then no interleaving is done and the image bands are written sequentially. +If \fIoutbands\fR is the null string, all pixels in a single input image +will be written to a single output file. +Error checking is done to make sure the combination of these +parameters is correct. If the \fIheader\fR parameter is "yes" a text header +describing how the data were written will be prepended to the file, setting +the \fIheader\fR parameter to the reserved string "long" +will cause the image header for each input image +to be saved in the standard header. The \fIheader\fR parameter may also +be the name of a user-defined file to prepend to the output instead of the +standard header. + + If the \fIformat\fR parameter is set to "list" the pixels values +will be written to the screen as an ascii list of pixel coordinates +followed by the pixel value. Pixel coordinates are determined using the +same interleaving scheme as above, values are determined by evaluating +each \fIoutbands\fR expression. + + Lastly, the \fIformat\fR parameter may be any of the currently +supported builtin formats. See the section on \fIBuiltin Formats\fR for +more information and the restrictions or requirements of each format. + +.ih +MORE ON OUTBANDS EXPRESSIONS + The simplest specification for \fIoutbands\fR is a null string, +in which case the image is converted directly (i.e. band storage, +pixels converted to output type). Arbitrary interpreted arithmetic +expressions using standard and custom functions and operators are also +supported. If the \fIimages\fR parameter is a list of 3-D images the +operand names are the predefined tags b1, b2, ... bN for the bands in each +image, the \fIbinfiles\fR parameter must contain an equal number of +output files. To convert multiple 3-D images they must either be sliced +to individual 2-D images (or specified as image sections) or stacked into +a single image. If the \fIimages\fR parameter is a list of 2-D images +(or sections) the operand names are the predefined tags i1, i2, ... iN for +the each image in the input list, the b1, b2, etc names are also recognized. +For more complex or +lengthy expressions the \fIoutbands\fR parameter may alternatively be an +@-file containing the expressions. Within this @-file whitespace and +newline characters are ignored to allow expressions to be indented in a +readable manner. + + The image operands determine which input images in the list are +converted to which output files. For 3-D input images one IRAF image is +converted for each output file in the list, for 2-D images multiple images +may be converted to a single output file. In the latter case the list +pointers are updated automatically to keep track of the images. For example, +to convert six images to two output files, the \fIoutbands\fR expression +should contain three images operands. The first three images in the list +will be used in evaluating the expressions for the first output file, +the last three for the second file. + + The image tags may be reordered in the expression but still refer to +e.g. band-1, band-2 and so on. For example (where rgbim is a 512x512x3 image, +and rim, gim, and bim are 512x512 images), + +.nf +cl> export rgbim file outtype="u2" header- (1) +cl> export rgbim file outtype="u2" header- outbands="b3,b2,b1" (2) +cl> export rim,gim,bim file outty="u2" outbands="i3,i2,i1" (3) +cl> export rim,gim,bim file outty="b" outbands="gray(i1,i2,i3)" (4) +.fi + +Example (1) converts the input image pixels to a raw binary file of +unsigned short integers with no header written as one image band following +another. In example (2) the order of the bands is reversed and the binary +file is stored as pixel interleaved BGR triplets of short ints. +Example (3) is the same as (2) except that the input images in the list +are reordered instead of bands within a single image. When using the image +tags the input list is updated to account for this, so it is allowed to have +more input images than output binary files. +In example (4) the three images are converted to a single grayscale image +before being written as byte data to the binary file. +More complex and detailed examples are given below. + +Individual \fIoutbands\fR expressions are composed of operators and operands +in general interpreted arithmetic expressions as follows: + +\fBOperands\fR +.nf + + iN # image list item + iN.param # image parameter + @"param" # parameter of 3-D image + bN # band within 3-D image + + func() # function + constant # numeric constant +.fi + + The 'iN.param' and '@"param"' syntax allows an image header parameter +to be accessed. For example 'i2.otime' refers to the 'otime' image +header parameter in the second image of a list and '@"otime"' refers to the +current image if the input list contains 3-D images. They may +be used in an outbands expression such as +.nf + + (i1*(i1.otime/i2.otime)),i2,(i3*(i3.otime/i2.otime)) (1) + (b1/@"otime")),(b2/@"otime"),(b3/@"otime") (2) + +.fi +to normalize the output bands by the exposure time value in the second image +in the first example, or to normalize by the 'otime' keyword of a 3-D image +in the second example. + + In cases where a constant value is used as an outbands expression an +alpha channel (an extra 8-bits of constant intensity) will be created +consisting of that value. For example, writing a 32-bit RGB image with an +alpha channel of 255 could be written using + + cl> export rgbim file outtype="b1" outbands="b1,b2,b3,255" + + +\fBOperators\fR + +The expression syntax implemented by \fIexport\fR provides the following +set of operators: + +.nf + + ( expr ) - grouping + + - * / - arithmetic + ** - exponentiation + // - concatenate + expr ? expr1 : expr2 - conditional expression + + && - logical and + || - logical or + ! - logical not + < - less than + <= - less than or equal + > - greater than + >= - greater than or equal + == - equals + != - not equals + ?= - substring equals +.fi + +The conditional expression has the value \fIexpr1\fR if \fIexpr\fR is true, +and \fIexpr2\fR otherwise. Since the expression is evaluated at every pixel +this permits pixel-dependent operations such as checking for special pixel +values, or selection of elements from either of two vectors. For example, +the command + + (i1 <= 0) ? 0 : 1 + +has the constant value zero if "i1" is less than or equal to zero, +and one otherwise, effectively creating a pixel mask of positive pixels. +Conditional expressions are general expressions and may be nested or used +anywhere an expression is permitted. + +The concatenation operator applies to all types of data, not just +strings. Concatenating two vectors results in a vector the +combined length of the two input vectors. An example use of this would +be to concatenate images side-by-side on output. + + +\fBSpecial Functions\fR + + In addition to the intrinsic functions already provided (see the help +page for the \fIimexpr\fR task for a list of standard, mathematical and type +conversion functions) there are a number of custom functions for this task: + +.ce +\fBOutput Functions:\fR + +.nf + band (args) - force band interleaved storage + line (args) - force line interleaved storage + flipx (args) - flip image in X dimension + flipy (args) - flip image in Y dimension + + block (val,width,height) - block fill area with a constant +.fi + + These functions define how the output data are written. For builtin +formats whose normal orientation and storage format is known these functions +are ignored (except where noted). These functions may not be used as arguments to other functions (except where noted) or as single operands +within expressions (e.g. "255 + flipx(i1)"), however their arguments may +be expressions or (perhaps output) functions themselves. + +.ls band (args) +Force band storage in the output file regardless of the value of the +\fIinterleave\fR parameter. This may be used to specify multiple +expressions for each band while still forcing band storage (the default +for multiple expressions is pixel-interleaved storage). This function +may be used with some builtin formats to write multiple images to the output +file as if they were a column of images in the original. This function +is ignored by builtin formats that do not support this scheme (i.e RGB +format) and may be used as an argument to the \fIsetcmap()\fR, \fIpsdpi()\fR, +and \fIpsscale()\fR functions only. +.le +.ls line (args) +Force line storage in the output file regardless of the value of the +\fIinterleave\fR parameter. This may be used to specify multiple +expressions for each band while still forcing line storage (the default +for multiple expressions is pixel-interleaved storage). This function +is ignored by builtin formats that do not support this scheme. +.le +.ls flipx (args) +Flip the image left-to-right on output. This function may be used as an +argument to the \fIband()\fR, \fIsetcmap()\fR, \fIpsdpi()\fR, or +\fIpsscale()\fR functions only. +.le +.ls flipy (args) +Flip the image top-to-bottom on output. Certain builtin formats (such as +GIF, PGM, PPM, RAS and XWD) have their normal orientation already flipped wrt +to IRAF and these will automatically be flipped on output. Using this +function with those formats cancels the flip action, writing the image in the +normal IRAF orientation and not the normal format orientation. +This function may be used as an argument to the \fIband()\fR, \fIsetcmap()\fR, +\fIpsdpi()\fR, or \fIpsscale()\fR functions only. +.le +.ls block (value, width, height) +Fill an area with a constant value. This function can be used to fill a +vertical area between images to provide padding of a constant value. It +is similar to the "repl()" intrinsic function which replicates a data element +a given number of times. +.le + + +.ce +\fBScaling Functions:\fR +.nf + + zscale (arg [,z1, z2 [, nbins]]) - scale to a fixed number of bins + zscalem (arg1, arg2) - automatic scaling with filtering + gr[ea]y (arg1,arg2,arg3) - RGB to grayscale conversion + bscale (arg, zero, scale) - linearly transform intensity scale + gamma (arg, gamma [, scale]) - apply a gamma correction +.fi + + These functions may be used to scale the intensity values of the +image before output in order to map image datatypes to a specified range. +The 'args' value may be a list of image operands or expressions. These +functions may be used as arguments to the output functions above +or as operands within more complex expressions. + +.ls zscale (arg [,z1,z2 [,nbins]]) +Scale the pixels in a given range to a specified number of bins. This +function will map the input pixels within the range z1 to z2 to one of +'nbins' values. Pixels less than z1 are mapped to the lowest output +intensity value, pixels greater than z2 are mapped to the highest value. +If no \fIz1\fR and \fIz2\fR arguments are given appropriate values will +be computed using the same algorithm and default parameters used by +the \fIDISPLAY\fR task (see the help page for more information). +If no \fInbins\fR value is given 256 bins are assumed. + +If the given value of z1 is greater than z2 the mappings will be inverted, +i.e. larger pixel values will map to the lower bin numbers, smaller pixel +values will map to larger bin numbers. For example, to map the dev$pix +test image to 200 colors such that there are "black" stars on a "white" +background one could use +.nf + + zscale (b1, @"i_maxpixval", @"i_minpixval", 200) +.fi +.le +.ls zscalem (arg1, arg2) +This is a variant of the zscale operand with automatic scale calculation; +i.e. zscale (arg). The first argument is the same as for zscale to select +the pixel values. The second argument is a boolean (true or false) +expression selecting whether a value in the first argument is to be used in +the calculation. This allows limiting the automatic scale calculation to +pixels specified in a mask or to a certain range to exclude extreme or bad +values that would otherwise perturb the result. Typical usages might be +.nf + + zscalem (i1, i2==0) + zscalem (i1, i1>0&&i1<10000) +.fi +where i1 are the image pixels and i2 would be pixels from the second +input argument which defines a mask. Note that you can't just say i2 +for a mask but must use it in an expression resulting in a true or false +value. Also note that the result is always in the range 0 to 255. +.le +.ls grey (arg1,arg2,arg3) or gray (arg1,arg2,arg3) +Convert three image operands or expressions to a single grayscale image +using the standard NTSC equation: +.nf + + Gray = 0.3 * arg1 + 0.59 * arg2 + 0.11 * arg3 +.fi +.le +.ls bscale (arg, zero, scale) +Linearly transform the intensity scale of the image using the equation +.nf + + new[i] = (arg[i] - zero) / scale + +.fi +Pixels are scaled in their input datatype prior to converting to the output +datatype. +.le +.ls gamma (arg, gamma [, scale]) +Apply a gamma correction to the pixels. Pixel values are scaled according to +the equation +.nf + + new = scale * [ (old/scale) ** (1.0/gamma) ] + +.fi +If no scale argument is given a value of 255 will be assumed. +.le + + + \fIAdditional functions\fR are supported for specific formats: + +.nf + Function Description Formats + -------- ----------- ------- + cmap (r,g,b [,ncols]) create 8-bit colormap GIF,RAS,XWD,EPS + setcmap (args, [opts]) define a colormap GIF,RAS,XWD,EPS + psdpi (args, dpi) set dpi for output EPS + psscale (args, scale) set scale of output EPS +.fi + + These functions may take as arguments some of the output functions +named above. For example, one can specify the dpi resolution of EPS output +and band storage of images using something like +.nf + + psdpi(band(args), dpi) + +.fi + +.ls cmap (arg1,arg2,arg3 [, ncolors]) +Compute an 8-bit colormap from three image operands or expressions using a +Median-Cut Algorithm and Floyd-Steinberg dithering. The computed colormap +is written to the header of the output file. The resultant image +is an 8-bit color index into the computed colormap. The \fIncolors\fR argument +specifies the number of desired colors, a default value of 256 will be used +if not provided. This function is only +allowed for builtin formats supporting color lookup tables and may not be +used within another expression or function. +.le +.ls setcmap (args, cmap [, brightness, contrast]) +Define the colormap to be used on output. This function is only supported +for formats that support colormaps, the \fIargs\fR expressions are used to +compute the color index values. The \fIcmap\fR argument may either be the +filename of a normalized colormap table (such as is used by \fIXImtool\fR) +or one of the builtin values: +.nf + aips0 - and RGB false color mapping + blue - various shades of blue + color - standard B/W and RGB colormap + grayscale - standard grayscale + greyscale - (alias for above) + green - various shades of green + halley - standard halley mission colormap + heat - temperatures as colors + rainbow - rainbow colors + red - various shades of red + staircase - RGB staircase + standard - RGB ramps + overlay - grayscale with IMDKERN overlay colors +.fi + +Colormap names must be quoted with either single or double quote characters. +The optional \fIbrightness\fR and \fIcontrast\fR arguments have default +values of 0.5 and 1.0 respectively corresponding to the default +brightness/contrast scaling of the \fIXImtool\fR display server. +If the cmap argument is an empty string the default Grayscale LUT will +be used, IRAF logical paths may be used in the filename specification. +.le +.ls psdpi (args, dpi) +Specify the dots-per-inch resolution of the output image. The default +resolution is 300dpi, this may need to be reset for some printers or if +the raster rendering produces "bands" in the output. This function may +only be used as an argument to the \fIpsscale()\fR function. +.le +.ls psscale (args, scale) +Specify the scale of the output image. The default value is 1.0 which +means that image printed on a 300dpi device is roughly the same size +as displayed on a typical 72dpi screen. Scale values less than one reduce +the image size on the page, values greater than one increase the size. The +scale value will automatically be adjusted if it creates an image that will +not fit on a 8.5 inch by 11 inch page. A scale value of 0.25 prints one +image pixel per 300dpi printer pixel. This function may +only be used as an argument to the \fIpsdpi()\fR function. +.le + +.ih +EXPORT HEADER FORMAT + The header prepended to the binary data is ascii text consisting of +keyword-value pairs, one per line, terminated with a newline after the +value, beginning with the magic string +"format = EXPORT". Using an ascii header allows the file format to be +easily determined by the user with a file pager or any program reading +the file. + +Defined keywords are: + +.nf + date - date file was written (dd/mm/yy) + hdrsize - size of header (bytes) + ncols - no. of image columns + nrows - no. of image rows + nbands - no. of image bands + datatype - pixel type (as <type><nbytes>) + outbands - outband expression list + interleave - interleave value (same as above) + bswap - are ints swapped relative to MII format? + image1 - image names used in creating file + : + imageN + header1 '{' <header> '}' - image headers of above + : + headerN '{' <header> '}' + end - terminate header +.fi + +If the \fIheader\fR parameter is set to "long" the image headers for +each image used in creating the file is included in the output header, +otherwise only the image names are included. + +A sample (verbose) header might look like: + +.nf + format = EXPORT + date = '19/06/94' + hdrsize = 2084 + nrows = 512 + ncols = 512 + nbands = 1 + datatype = 'i2' + outbands = '' + interleave = 0 + bswap = no + image1 = "dev$pix" + header1 = { + IRAF-BPX= 16 / DATA BITS/PIXEL + IRAFTYPE= 'SHORT ' / PIXEL TYPE + CCDPICNO= 53 / ORIGINAL CCD PICTURE NUM + ITIME = 600 / INTEGRATION TIME (SECS) + : : : : + } + end +.fi + +.ih +BUILTIN FORMATS + While the task provides a way of writing general binary raster +files there is still a need for converting to specific formats. +Implementing most formats is trivial since they usually follow the +data model and the only "builtin" knowledge of the format is the minimal +header required. More complex formats such as GIF and EPS are implemented +as special cases. Note that all of the builtin formats require 8-bit color +index or 8-bits per color in RGB or RGBA files, users should be careful +in how the datatype conversion from IRAF image types is handled. In most +cases this can be handled with the \fIzscale()\fR or \fIzscalem\fR functions. + + For each of the formats listed below the table shows the number +of \fIoutbands\fR expressions required and the type of output file that +can be written. Complete examples for the most common cases are shown in +the \fIExamples\fR section below. The columns in the table are defined as +.nf + + #expr - number of required \fIoutbands\fR expressions + Type - RGB or 8-bit colormap (index) file + bitpix - number of bits-per-pixel + CLT? - does the file have a colormap? + Alpha? - does the file have an alpha channel? + Interleaving - type of pixel interleaving + Notes - see explanation below each table + +.fi +A general description and specific restrictions or requirements are given for +each format. An error is generated of the input parameters do not meet the +requirements of the requested format. Unless otherwise noted the values of +the \fIheader\fR, \fIbswap\fR and \fIinterleave\fR parameters will be ignored. +The value of \fIouttype\fR will be set internally and is also ignored. + + If the input image is 3-D and no \fIoutbands\fR expressions are +given, then where supported each band will be written to the output file as +a complete image or RGB color component. For example, a 512x512x3 image +will be written as a 512x1536 image with each band comprising one third +the height of the output image. If the output format requires 24-bit pixels +then each band of the image will be written as a color component. + + The currently supported builtin formats include: + +.ls EPS - Encapsulated PostScript +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + +.fi + The output 8-bit Encapsulated PostScript image +centered on the page at a default scale of 1.0 at 300dpi (i.e. the image will +appear on a 300dpi printer about the same size as displayed on a 72dpi +screen). The output scale may be adjusted using +the \fIpsscale()\fR function, e.g. to set the output for one image pixel +per 300 dpi printer pixel use "psscale(b1,0.25)" (one quarter the normal size +on the page). The output dpi resolution may be set explicitly with +the \fIpsdpi()\fR function, this is sometimes necessary if "bands" appear +in the final output image. Color EPS files may be written as either RGB +postscript or with a colormap applied to the data (using either the +\fIcmap()\fR or \fIsetcmap()\fR functions). +.le +.ls GIF - Compuserve's GIF format +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 yes no none 1 + 3 index 8 yes no none 2 + + Notes: + 1) Colormap generation enabled using \fIsetcmap()\fR or else + default grayscale colormap will be used + 2) use of \fIcmap()\fR required to generate colormap + +.fi + The output file is a GIF '87 image. A linear colormap of 256 entries +will automatically be generated if only one image or expression is given for +conversion and no colormap is specified. +If three images or expressions are specified a 24-to-8 bit +conversion can be done using a Median Cut Algorithm and Floyd-Steinberg +dithering with the required \fIcmap()\fR function. Since the colormap +sizes are limited to 256 entries the maximum pixel value is assumed to +be 255, i.e. the output pixel size will be forced to 8-bits or less. +.le +.ls IMH - IRAF image file + The output file is an IRAF OIF format image of the specified datatype. +Writing the image out as another IRAF image may be used to scale or composite +several images into a new image that can be annotated with the \fITVMARK\fR +task before writing out the final format. +.le +.ls MIFF - ImageMagick MIFF format image +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + 1 index 8 yes no none 1,2 + 3 rgb 24 no no pixel + + Notes: + 1) Colormap generation enabled using \fIsetcmap()\fR + 2) Colormap generation enabled using \fIcmap()\fR + +.fi + The output file is a Machine Independent File Format image, with or +without a colormap or as a 24-bit RGB image. Although MIFF permits 64K +colors in a colormap the task only supports 256 colors, no compression is +used in the image. The maximum pixel value per color is assumed to be 255. +.le +.ls PGM - PBMPlus PGM format image +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + 3 index 8 no no none 1 + + Notes: + 1) Grayscale may be produce with \fIgray()\fR function + +.fi + The output file is an 8-bit raw (i.e. binary pixels) PGM image. +The maximum pixel value is assumed to be 255. +.le +.ls PPM - PBMPlus PPM format image +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 3 rgb 24 no no pixel + +.fi + The output file is an 24-bit raw (i.e. binary pixels) PPM image. +The maximum pixel value per color is assumed to be 255. +.le +.ls RAS - Sun rasterfile format +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + 1 index 8 yes no none 1,2 + 3 rgb 24 no no pixel + 4 rgb 32 no yes pixel + + Notes: + 1) Colormap generation enabled using \fIsetcmap()\fR + 2) Colormap generation enabled using \fIcmap()\fR + +.fi + The output file will be a Sun rasterfile. The header values +(long integers) may be byte swapped by setting the \fIbswap\fR parameter +to "yes" or "i4". For 32-bit true-color rasterfiles the +alpha channel should be specified as the first expression. The maximum +pixel value is assumed to be 255. +.le +.ls RGB - SGI RGB format image +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 no no none + 3 rgb 24 no no scanline + +.fi + The output file will be an SGI RGB (IRIS) format image. Although +this format supports colormaps they are not supported by this task. +The maximum pixel value is assumed to be 255. +.le +.ls XWD - X11 Window dump file +.nf + + #expr Type bitpix CLT? Alpha? Interleaving Notes + ----- ----- ------ ---- ------ ------------ ----- + 1 index 8 yes no none 1,2,3 + 3 rgb 24 no no none + + Notes: + 1) Linear grayscale colormap automatically generated + 2) Colormap generation enabled using \fIsetcmap()\fR + 3) Colormap generation enabled using \fIcmap()\fR + +.fi + The output file will be an X11 window dump file. +A linear colormap of 256 entries will automatically be generated if only +one image or expression is given for conversion, the \fIsetcmap()\fR function +may be used to create an alternate colormap. If three images or expressions +are specified a 24-to-8 bit conversion can be done using a Median Cut +Algorithm and Floyd-Steinberg dithering if the \fIcmap()\fR function is +specified. Header values (long integers) may be byte swapped by setting the +task \fIbswap\fR parameter to "yes" or "i4". The maximum pixel value is +assumed to be 255. +.le + +.ih +COLOR OUTPUT IMAGES + In theory the colormaps generated by the \fIcmap()\fR and +\fIsetcmap()\fR functions could be written in the header for raw binary +output and the pixel written out as color indices, but since we also +support color index formats which are recognized widely by other packages +there is no need to do this. Therefore we limit the use of colormaps to +the builtin formats which already support it. + + The simplest type of "color" image is the familiar grayscale image. +Pixel values represent the display gray level, although for some formats a CLT +(color lookup table) is required (e.g. GIF) and these pixel values are +actually indices into a grayscale colormap. Most of the conversion done +with this task will produce a grayscale image of some sort. For "color +index" images the pixel values are indices into a colormap containing the +RGB components of the color for a pixel with that value. Colormaps +usually permit at most 256 possible colors implying 8-bit pixels. +In this task the colormap may be computed either with the \fIcmap()\fR (which +does a 24-to-8 bit mapping of the colors) or the \fIsetcmap()\fR function +(which computes the colormap from a display lookup table of colors). +"True color" images are those which have 24-bits of color (8-bit for each +component) for each pixel, some true color images also contain an alpha +channel (an extra 8-bits of constant intensity) which may or may not be +used by the software displaying the image. + + The \fIcmap()\fR function takes three images and computes a colormap +using Paul Heckbert's Median Cut Algorithm ("Color Image Quantization for +Frame Buffer Display", SIGGRAPH '82 Proceedings, pg 297) and Floyd-Steinberg +dithering technique. The computed colormap is written to the file header +and pixel values are converted to color indices. By default 256 colors are +computed but fewer colors may be requested. This function is most useful +for generating pseudo-color images from three input images taken in different +filter bands (which is required for some formats like GIF that do not +support 24-bit RGB). + + The \fIsetcmap()\fR function, on the other hand, can be used to +generate a color image from a single input image and a lookup table such as +the ones used by displays servers like XImtool. In this case the pixel +values are indices into a pre-defined colormap which is normalized between +zero and one (so that it may be scaled to the desired number of colors). +The \fIbrightness\fR argument defines the center of the transfer function, the +default is 0.5 because it in the middle of the normalized range. The +\fIcontrast\fR arguments sets the contrast of the transfer function. For +example, the normalized pixel values and default brightness/contrast settings +will map the pixel values to the corresponding color in the LUT. Changing +the brightness to a lower value means that pixel intensities will map to lower +values in the LUT, doubling the contrast for instance means that the LUT +will increment two colors for every unit pixel change. This is what happens +when changing a displayed image in IRAF with the mouse by moving the cursor +left-right (changing the brightness) or up-down (changing the contrast). + + An example use of this function would be if one wanted to convert an +IRAF image to a color rasterfile with the same colormap and intensity +scaling as was displayed in XImtool. After adjusting the display the +brightness/contrast values could be read from the control panel and the +rasterfile generated using +.nf + + setcmap (b1, "aips0", 0.36, 1.2) + +.fi +where the "aips0" is one of the builtin colormaps and the brightness and +contrast arguments are those from the ximtool display. Similarly, the +expression +.nf + + setcmap (zscale(i1),"idl15.lut") + +.fi +will save the image with the same intensity scaling and color as would be see +by displaying it to ximtool using the default DISPLAY task settings, +normalized XImtool brightness/contrast values and the "idl15.lut" LUT in the +current directory. + + +.ih +EXAMPLES + The examples below are divided into several categories showing +typical usage when creating various raw and builtin output files. Note +that the output file will have a filename extension added indicating the +format when converting to a builtin format. + +\fICreating Raw Binary Files\fR +.nf + +List the pixels being one the standard output, apply a linear scale +function first: + + cl> export dev$pix "" list outbands="bscale(b1,1.0,3.2)" + +Convert the dev$pix test image to an 8-bit binary file with a gamma +correction, write the standard header: + + cl> export dev$pix bfil raw header+ outty="u1" outbands="gamma(b1,1.8)" + +Write the three bands of an IRAF image to a pixel interleaved binary +file of short integers, prepend a user-defined header: + + cl> export rgbim bfil raw header="hdr.txt" outty="i2" outban="b1,b2,b3" + +Convert three images representing RGB to a 4-color line-interleaved +file, the IRAF images don't require scaling, create alpha channel: + + cl> export rim,gim,bim bfil raw outty="u1" outban="line(i1,i2,i3,0)" + +Write the three bands of an IRAF image to a line-interleaved binary +file of short integers: + + cl> export rgbim binfil raw outtype="i2" outbands="line(b1,b2,b3)" + cl> export rgbim binfil raw outtype="i2" outbands="" interleave=3 + +Write the three bands of an IRAF image to a grayscale binary file using +a custom conversion formula. Pixel values are truncated to 8-bits: + + cl> export rgbim grey raw outty="u1" outban="(.2*b1)+(.5*b2)+(.3*b3)" + +.fi + +\fICreating Specific Formats\fR +.nf + +Convert dev$pix to an 8-bit Sun rasterfile with no colormap, scale the +image to 8-bits using the default \fIzscale()\fR intensity mapping: + + cl> export dev$pix dpix ras outbands="zscale(i1)" + +Apply various functions to the data before doing the same conversion: + + cl> export dev$pix dpix ras outbands="zscale(log(i1))" + cl> export dev$pix dpix ras outbands="zscale(sqrt(i1))" + +Convert dev$pix to an 8-bit Sun rasterfile with no colormap, image pixel +values are truncated to 8-bits: + + cl> export dev$pix dpix ras + +Convert three images representing RGB to a 24-bit Sun rasterfile, assume +the IRAF images don't require intensity scaling: + + cl> export rim,gim,bim rgb ras outbands="i1,i2,i3" + +Create a Silicon Graphics RGB format image from a 3-D image: + + cl> export rgbim bdata rgb outbands="b1,b2,b3" + +Convert dev$pix to an 8-bit GIF grayscale image, scale the image to map +only pixel values between 0 and 320: + + cl> export dev$pix dpix gif outbands="zscale(i1,0.0,320.0)" + +Combine three images representing RGB into an 8-bit X11 window dump +grayscale image: + + cl> export rim,gim,bim gray xwd outbands="gray(i1,i2,i3)" + +Convert dev$pix to an Encapsulated PostScript file at half the normal scale +and apply a linear transformation to scale the pixel values: + + cl> export dev$pix dpix eps \ + >>> outbands="psscale(bscale(i1,0.,0.32), 0.5)" + +Convert three images representing RGB to an 8-bit GIF color image with +a computed colormap: + + cl> export rim,gim,bim rgb gif outbands="cmap(i1,i2,i3)" + +Convert dev$pix to a color rasterfile using the builtin "heat" colormap +and default intensity mapping: + + cl> export dev$pix dpix ras outban='setcmap(zscale(i1),"heat")' + +Convert dev$pix to a color rasterfile using the XImtool "idl15.lut" +LUT file in the current directory and default intensity mapping: + + cl> copy /usr/local/lib/imtoolcmap/idl15.lut . + cl> export dev$pix dpix ras outbands="setcmap(zscale(i1),'idl15.lut')" + + +\fIAdvanced Usage\fR + +Given a set of DISPLAY task z1/z2 values of 10 and 320 respectively, and +brightness/contrast values from XImtool of 0.6 and 1.2 respectively, +convert an image to an EPS file with the same appearance: + + im> type expr + setcmap ( zscale (i1, 10.0, 320.0), "greyscale", 0.6, 1.2 ) + im> export dev$pix dpix eps outbands="@expr" + +Concatenate two images side-by-side to a PGM file, normalize each image +by it's exposure time and apply a default intensity mapping: + + cl> export im1,im2 two pgm \ + >>> outbands='(zscale(i1/i1.otime)) // (zscale(i2/i2.otime))' + +Convert dev$pix to a color GIF using the XImtool "idl15" LUT with a spec- +ified brightness/contrast scale. Map only pixel values between 5 and 300 +to 201 output intensity values. This should produce and image identical +to what one would get by displaying dev$pix to imtool, setting the same +brightness/contrast scale, and selecting the idl15 LUT: + + cl> copy /usr/local/lib/imtoolcmap/idl15.lut . + cl> type expr.dat + setcmap ( + zscale(i1, 5.0, 320.0, 201), + "idl15.lut", + 0.41, + 1.35) + cl> export dev$pix dpix gif outbands="@expr.dat" + +Combine three images representing RGB to an 8-bit Sun rasterfile with a +computed colormap. Scale the intensity value of each image differently. + + cl> type expr.dat + cmap ( + zscale (i1), + zscale (i2, 0.0, 1200.0), + zscale (i3, -1.0, 320.0) ) + cl> export im1,im2,im3 rgb ras outbands="@expr.dat" + +Do the same example but apply a gamma correction to the images: + + cl> type expr.dat + cmap ( + gamma (zscale(i1), 2.2), + gamma (zscale(i2,0,1200), 2.2), + gamma (zscale(i3,-1,320), 2.2) ) + +Write four images to a grayscale GIF file such that they are tiled in a +2x2 grid: + + cl> export im1,im2,im3,im4 quad gif \ + >>> outbands="band( (i1//i2), (i3//i4) )" + +Do the same example but create a border of 2 gray pixels around each +of the images and apply the AIPS0 LUT with brightness/contrast values +to create a color image: + + cl> copy /usr/local/lib/imtoolcmap/aips0.lut . + cl> type expr.dat + setcmap ( + band( + 128, 128, + (repl (128,2) // i1// repl (128,2) // i2 // repl (128,2)), + 128, 128, + (repl (128,2) // i3// repl (128,2) // i4 // repl (128,2)), + 128, 128 ), + "aips0.lut", + 0.54, + 1.03) + cl> export im1,im2,im3,im4 cquad gif outbands="@expr.dat" + +.fi + +Automatically scale an image ignoring data in a bad pixel mask (bpm), map the +result to the greyscale part of the "overlay" color map, and apply a +overlay pattern given by another mask (pattern). + + cl> export dev$pix,bpm,pattern foo gif \ + >>> outbands = "setcmap(i3==0?(zscalem(i1,i2==0)*200/255.):i3+203,'overlay')" + + +The pattern has values of 1 and 203 is added to get it into the color map +values of the overlay colors. The factor of 200/255 is to scale the result +of zscalem from the range 0-255 to the range 0-200. + +.ih +NOTES + This task is new with V2.11. + + (long int headers in RAS and XWD may cause problems on 64-bit +machines like the Alpha where host software expects 64-bit values. Need to +see if IRAF on the alpha produces 32 or 64-bit longs, either way exchanging +images may be a problem) + +.ih +BUGS + Output of bitmap images is currently not supported. +.ih +SEE ALSO +import, tvmark, imexpr +.endhelp diff --git a/pkg/dataio/doc/import.hlp b/pkg/dataio/doc/import.hlp new file mode 100644 index 00000000..da8047b7 --- /dev/null +++ b/pkg/dataio/doc/import.hlp @@ -0,0 +1,631 @@ +.help import Oct94 dataio +.ih +NAME +import -- create an IRAF image from an arbitrary binary file +.ih +USAGE +import binfiles images +.ih +PARAMETERS +.ls binfiles +The list of input binary files to be read. +.le +.ls images +The list of output IRAF images to be written. This parameter only needs to +be specified when generating an output image (see the \fIoutput\fR parameter +description). +.le +.ls format = "sense" +The type of format to be processed. In default mode, i.e. \fIsense\fR, +the format database is searched for a format identifier that evaluates +truly for the current binary file, the input file parameters are then +derived from the database entry. A specific format name in the database may +alternatively be given in which case the input params are derived from that +entry in the database. If \fIformat\fR=\fInone\fR the task parameters +are used to describe the input file. +.le + +.ce +INPUT PARAMETERS +.ls dims = "" +The input file dimension string. This is a space or comma delimited string +containing the length of the file in each dimension, e.g. "512,512,3". +.le +.ls pixtype = "" +Input pixel type. This is a comma delimited string giving the type and size +of each pixel, and an optional tag name to be used in the \fIoutbands\fR +expressions. The syntax for the pixtype entry is +.ls <type><nbytes>[:tag],<type><nbytes>[:tag],[....] + +where +.nf + type = b # byte (no conversions) + u # unsigned integer + i # signed integer + r # ieee floating point + n # native floating point + x # ignore (skip) + + nbytes = 1, 2, 4, or 8 + + tag is something like 'r','g','b' (color triplets), 'r', + 'i' (complex data), etc. If no tags are given one will + automatically be assigned of the form 'b1', 'b2', etc. + +.fi +.le +.le +.ls interleave = 0 +Pixel interleave type. If the \fIpixtype\fR parameter is a composite then +the input pixel are pixel-interleaved (i.e. each pixel in a band is stored +together, as with RGB triplets) and this parameter is ignored. If +the \fIpixtype\fR is an atomic value and \fIinterleave\fR is a positive +number the image is line interleaved (e.g. a line of 'R', followed by a +line of 'G', and so on). If the \fIpixtype\fR is atomic and \fIinterleave\fR +is zero, the no data interleaving is assumed and each band in the file +is stored sequentially. +.le +.ls bswap = "no" +Type of byte-swapping to perform. By default no byte swapping is done, +if \fIbswap\fR is "yes" then all input values are byte swapped, if \fIbswap\fR +is "i2" then only short integers are byte swapped, if \fIbswap\fR is "i4" then +only long integers are swapped. A combination of "i2,i4" can be used to +swap only integer values, floating point numbers will not be swapped. +.le +.ls hskip = 0 +Number of bytes preceding pixel data to skip. +.le +.ls tskip = 0 +Number of bytes to skip at end of file. +.le +.ls bskip = 0 +Number of bytes between image bands to skip. +.le +.ls lskip = 0 +Number of bytes to skip at font of each line. +.le +.ls lpad = 0 +Number of bytes to skip at end of each line. +.le + +.ce +OUTPUT PARAMETERS +.ls output = "image" +Type of output to generate. Possible values include "none" process the files +but not generate an output image (e.g. to check the parameter values for +correctness), "image" to generate an output image, "list" to generate a +pixel listing of the file as would be produced by the \fILISTPIX\fR task +on the image if were converted (no image is created with this option), +or "info" to print information about the file. The \fIimages\fR parameter +is only used for \fIoutput\fR=image. +.le +.ls outtype = "" +The data type of the output image. May be one of 's' for a short image, 'i' +for an integer image, 'l' for a long image, 'r' for a real image, and 'd' +for a double precision image. If no \fIouttype\fR is specified then the +datatype of the \fIoutbands\fR expression is used. This parameter is only +used when \fIoutput\fR is set to "image". +.le +.ls outbands = "" +Output image band expressions. If no expressions are given then all of the +input pixels will be converted. The number of output bands may be more or +less than the number of input bands. See the \fIOUTBANDS EXPRESSIONS\fR +section for a more complete description of this parameter. +.le +.ls imheader = "" +Image or header keyword data file. If an image is given then the image header +is copied. If a file is given then the FITS format cards are copied. +This only applies to new images. The data file consists of lines +in FITS format with leading whitespace ignored. A FITS card must begin +with an uppercase/numeric keyword. Lines not beginning with a FITS +keyword such as comments or lower case are ignored. The user keyword +output of \fBimheader\fR is an acceptable data file. See \fBmkheader\fR +for further information. +.le + +.ls database = "imcnv$lib/images.dat" +The format database. This may also be a list of files to be searched (e.g. +so that user-defined databases may be included), which will be treated as +a single database. +.le +.ls verbose = yes +Print verbose output during the conversion? +.le +.ls buffer_size = 64 +Number of image lines \fIper band\fR to buffer in memory before writing to +disk. Image buffering can increase task performance by as much as a factor +of 30 for some formats but requires more memory. +.le + +.ih +DESCRIPTION + + The \fIimport\fR task is used to convert arbitrary raster binary +files to IRAF format images. The input format may be specified either +through the task parameters (\fIformat\fR set to 'none'), or as an entry +in a database of known formats (\fIformat\fR set to the name of the entry). +If the format of the image is not known a priori, the database can be +searched and each record will be evaluated for an expression which +identifies the format (\fIformat\fR set to "sense"). The task will +output either an IRAF image, a list of pixel values +in a manner similar to the \fILISTPIX\fR task, or information about the +file format if it is supported in the database. + +.ih +Input File Specification + The input raster is assumed to be at most three dimensional, with +pixels of various sizes that can be interleaved in a variety of ways. +No compression schemes are yet supported, except in the case of builtin +formats where special code has been written to handle to format. +Byte-swapping and floating point conversion of pixels (from IEEE to +native) is also supported. + + The \fIpixtype\fR and \fIinterleave\fR parameters define the pixel +storage in the binary file. \fIPixtype\fR is a comma delimited string, +the elements of which define the type and size of each pixel. An optional +'tag' name may be given to each pixel for use in the \fIoutbands\fR +expressions. If no tag is given one will automatically be assigned. +For composite pixtypes (i.e. when more than one element is listed), the +data are assumed to be pixel interleaved (e.g. stored as { {RGB}, {RGB} ...} +triplets). For atomic (i.e. single) pixtypes, a positive value of +\fIinterleave\fR indicates that the data are stored in a line-interleaved +manner (e.g. a line of R, a line of G, ...). If \fIinterleave\fR is +zero and \fIpixtype\fR is atomic, then no interleaving is done and the +image bands are thought to be stored sequentially. Minimal error +checking is done to make sure the +combination of these parameters is correct. + + The file may contain arbitrary padding around the pixels as +defined by the \fItskip\fR, \fIbskip\fR, \fIlskip\fR, and \fIlpad\fR +parameters, header information may be skipped by setting the \fIhskip\fR +parameter. Additionally, pixels may be ignored on input while still +specifying the full format. +.ih +Output Parameters + Once a format has been found, the task may output an IRAF image +by setting \fIoutput\fR to "image", a list of the pixels in the file +can be written to STDOUT by setting \fIoutput\fR to "list", or information +about the input file can be printed by setting \fIoutput\fR to "info". +If \fIoutput\fR is set to "none" then no output will be generated, this +can be used to check for read errors on the input file to verify task +parameters. The datatype of the output image can be set by specifying +the \fIouttype\fR parameter. + + The \fIoutbands\fR parameter is a list of expressions which are +evaluated to compute the pixels in each band of the output image. Operands +in these expressions consist of numeric constants and the pixtype tags +(either user-supplied tags or the automatic tags), general arithmetic +expressions are supported, which can include any of the special functions +listed below. The simplest expression is the name of a tag itself. +Regardless of the storage of pixels in the input file, each image band is +separated on output unless an expression is given which combines them. +See below for more details on \fIoutbands\fR. + + Header information may be added to an output image by naming +either a keyword file or an existing image header listing in the +\fIimheader\fR parameter. A header keyword data file consists of lines +of FITS format cards. Leading whitespace is ignored. Lines not recognized +as FITS cards are ignored. A valid FITS card is defined as beginning with +a keyword of up to 8 uppercase, digit, hyphen, or underscore characters. If +less than 8 characters the remaining characters are blanks. The +ninth character may be an equal sign but must be immediately followed +by a blank. Such value cards should be in FITS format though no +attempt is made to enforce this. Any other ninth character is also +acceptable and the line will be treated as a comment. Note that this +way of recognizing FITS parameters excludes the case of comments +in which the first 8 characters are blank. The reason for allowing +leading whitespace and eliminating the blank keyword case is so that +the long output of \fBimheader\fR may be used directly as input. + +.ih +OUTBANDS EXPRESSIONS + + The outbands parameter is a comma delimited list of expressions, the +simplest of which is the name of a tag itself (or the default names of the +tags if none are provided in the \fIpixtype\fR param). +The input pixels, regardless of how they are stored in the binary file, +are always stored as separate bands in the output IRAF image. +The outbands expressions will be evaluated to compute the pixels in each +band of the output image. This means that e.g. RGB triplets in an input +file will be separated into different bands in the output image, unless a +single expression is given that combines them. The components named +in \fIpixtype\fR may be eliminated or re-ordered in \fIoutbands\fR to +exclude certain input bands, or to change the channel order. For example +the commands: + +.nf +cl> import file img pixtype="u1:a,u1:r,u1:g,u1:b" outbands="g,r,a" +cl> import file img pixtype="u1,u1,u1,u1" outbands="b3,b2,b1" +.fi + +both convert an input 32-bit image with ARGB components. In the first case +the output image is an IRAF image where the B component has been eliminated +and the channel order reversed. The second case is the same as the first but +uses the automatic tag names. A combination of user-supplied tags and +defaults could also be used. + + General interpreted arithmetic expressions are supported and can +contain any of the standard expression evaluator functions (see +the \fIimexpr\fR help page for more details). Special functions in +expressions also include: +.nf + + flipx (arg) - flip image in X + flipy (arg) - flip image in Y + gr[ea]y (r,g,b) - RGB to grayscale using the NTSC Y formula + red (arg) - get the red component of a colormap image + green (arg) - get the green component of a colormap image + blue (arg) - get the blue component of a colormap image + gamma (arg, gamma) - apply a gamma correction to the image + +.fi +The two flip functions can change the image orientation by reversing the order +of pixels within a line (a flipx() call), or it can flip an image from top- +to-bottom (a flipy() call). The flipping will apply to all bands of the out- +put image even if it was only used in one expression. To reverse the channel +order simply change the order of the tags in the outbands parameter. RGB +images may be converted to a single grayscale image using the NTSC formula: +.nf + + gray = (0.289 * r) + (0.587 * G) + (0.114 * B) + +.fi +Note that a similar grayscale conversion can be done by explicitly defining +a similar equation in \fIoutbands\fR and supplying different coefficients. + + The \fIred()\fR, \fIgreen()\fR, or \fIblue()\fR functions can be used +to get a single color component from a colormap image rather than the +grayscale equivalent of the colormap. For example, to separate an 8-bit +GIF color image into it's RGB components one could specify an outbands +parameter such as +.nf + +cl> import foo.gif bar format=gif outbands="red(b1),green(b1),blue(b1)" + +.fi + + Functions may also be nested in complex expressions such as: + +.nf + flipy (gray(r,g,b)) - convert to grayscale, flip in Y + flipx (flipy (gray (r,g,b))) - convert to grayscale, flip in X & Y + gray (r,g,255) - use constant 255 as the B band + gray (r,g+100,-b) - add constant to G, negate B +.fi + +.ih +FORMAT DATABASE + + The format database is a text file named as a task parameter. +Each record of a database entry is of the form: + +.nf + <format_name>: + <alias>: + keyword = <expr> + keyword = <expr> + ...and so on +.fi + +A database record begins with the format name at the beginning of a line. +Whitespace at the beginning of a line is considered the continuation of a +previous line. Comments may be inserted in the database using the normal '#' +character, the remainder of the line is considered a comment. Blank lines +and comments are ignored, a record ends at the next line with a format name +at the beginning of the line. The task \fIdatabase\fR parameter +defines the text files to be +scanned as the database. If the parameter is a list of files then each file +in the list will be concatenated to a single database file used by the task. + + The format_name field is a string identifying each entry in the +database, any number of aliases may also be given to identify the same +format possibly known by another name. Supported keywords include: + +.nf + image_id - A boolean expression identifying the image type + id_string - Verbose name of file format + bswap - is file byte-swapped? (See Below) + dims - a whitespace/comma delimited string of dimensions + pixtype - pixel type, size [and tag], may be a composite + interleave - describes how pixels are stored + hskip - # of bytes of header info to skip + tskip - # of bytes of trailing info to skip at end of file + bskip - # of bytes of info to skip between image bands + lskip - # of bytes of info to skip at front of each line + lpad - # of bytes of info to skip at end of each line + error - A condition that would cause a file read error, + returns a string with the error message, otherwise + returns the string "okay" +.fi + +The 'image_id' string is an expression to be evaluated which, if true, +uniquely identifies the file format (such as a comparison to a "magic number"). +The 'id_string' is a verbose name of the format. +The 'error' keywords use the "? :" conditional syntax to +define a boolean expression which, when true, returns an error message and is +used to indicate a condition in a format which isn't supported. The remaining +keywords have the same meaning as the task parameters. Keywords not present +in the database record will take the default parameter value. + + Expressions consist of any valid string that may be evaluated with the +standard system expression evaluator evvexpr(). (See the documentation for this +procedure or the \fIIMEXPR\fR task help page for details of builtin functions +and operators.) Operators within expressions may be boolean, arithmetic, +or the string operators '?=' (substring equality) and '//' (concatenation). +Operands may be the special functions named below, previously defined +keywords, constants (numeric or strings), and the special operands + +.ls $FSIZE +The size of the binary file in bytes. In expressions this operand has an +integer datatype. For formats with variable header sizes this can be used +to determine the size of the header, since the size of the data can be +derived from the image dimensions and subtracted from the total size of the +file. +.le +.ls $FNAME +The name of the binary file. In expressions this operand has a character +datatype. As a last resort for images without any identifying features the +file name may possibly be used to determine the format from a file name +extension. +.le + + +.ih +Special Functions: + + In addition to the intrinsic functions already provided there are a +number of input and utility functions for the database. These are: +.nf + + \fIINPUT FUNCTIONS\fR + + ctocc ([offset]) - convert byte to printable char constant + ctod ([offset]) - convert string to double precision real + ctoi ([offset]) - convert string to integer + ctol ([offset]) - convert string to long + ctor ([offset]) - convert string to single precision real + ctowrd ([offset]) - get 1st white-space delimited word from str + + getstr ([offset,] len) - get a string at offset + getb ([offset]) - get a byte at offset + getu ([offset]) - get an unsigned short int at offset +geti[24] ([offset]) - get a signed int at offset +getr[48] ([offset]) - get an IEEE fp number at offset +getn[48] ([offset]) - get a native fp number at offset + + locate ([offset,] pat) - find an offset to a pattern + line (n) - offset of line N + + \fIUTILITY FUNCTIONS\fR + + skip (nbytes) - move offset by N-bytes + bswap (arg) - byte swap the argument + substr (str, c1, c2) - extract a substring from argument + stridx (test, str) - get 1st occurrence of 'test' w/in 'str' + +parameter (param) - return the current task parameter + default (param) - return the default task parameter + lsb_host () - returns true if host is little-endian + msb_host () - returns true if host is big-endian +.fi + +.ls ctocc ([offset]) [string] +Convert byte at the given offset to printable char constant. +If no offset argument is given the current offset is used. +.le +.ls ctod ([offset]) [double] +Convert string to double precision real. +The function reads a string from +the file and converts it up to the first unrecognized character. +If no offset argument is given the current offset is used. +.le +.ls ctoi ([offset]) [int] +Convert string to integer. +The function reads a string from +the file and converts it up to the first unrecognized character. +If no offset argument is given the current offset is used. +.le +.ls ctol ([offset]) [long] +Convert string to long. +The function reads a string from +the file and converts it up to the first unrecognized character. +If no offset argument is given the current offset is used. +.le +.ls ctor ([offset]) [real] +Convert string to single precision real. +The function reads a string from +the file and converts it up to the first unrecognized character. +If no offset argument is given the current offset is used. +.le +.ls ctowrd ([offset]) [string] +Get 1st white-space delimited word from str, leading whitespace is skipped. +If no offset argument is given the current offset is used. +.le +.ls getstr ([offset,] len) [string] +Get a string at offset. +If no offset argument is given the current offset is used, the length of +the string must be specified. +.le +.ls getb ([offset]) [int] +Get a byte at offset. +If no offset argument is given the current offset is used. +.le +.ls getu ([offset]) [int] +Get an unsigned short integer at offset. +If no offset argument is given the current offset is used. +.le +.ls geti[24] ([offset]) [int] +Get a signed int at offset. +If no offset argument is given the current offset is used. +Long integers values can be read by specifying the function as geti4(), +the names geti() and geti2() return short integers. +.le +.ls getr[48] ([offset]) [real/double] +Get an IEEE floating point number at an optional offset. +If no offset argument is given the current offset is used. +Double precision values can be read by specifying the function as getr8(), +the names getr() and getr4() return single precision real. +.le +.ls getn[48] ([offset]) [real/double] +Get a native floating point number at an optional offset. +If no offset argument is given the current offset is used. +Double precision values can be read by specifying the function as getn8(), +the names getn() and getn4() return single precision real. +.le +.ls locate ([offset,] pat) [int] +Compute an offset. +If no offset argument is given the current offset is used. +.le +.ls line (N) [int] +Offset of line N in bytes. The database is rewound and the offset of the +requested line number is returned, line are delimited by the '\n' character. +.le +.ls skip (nbytes) [int] +Move current offset by N-bytes. The number of bytes skipped is returned as +the function value. +.le +.ls bswap (arg) [type of arg] +Byte swap the argument. +.le +.ls substr (str, first, last) [string] +Extracts a substring from string \fIstr\fR. The first character in +the string is at index 1. +.le +.ls stridx (test, str) [int] +Finds the position of the first occurrence of any character found +in \fItest\fR in the string \fIstr\fR, returning 0 if the match fails. +.le +.ls parameter (param) [param type] +Return the current task parameter. The parameter is specified as a string +containing the name of a task parameter, the type of the returned value is +the parameter type +.le +.ls default (param) [param type] +Return the default task parameter. The parameter is specified as a string +containing the name of a task parameter, the type of the returned value is +the parameter type +.le +.ls lsb_host () [bool] +Returns true if host is little-endian. +This function can be used as the \fIbswap\fR keyword expression for formats +with a specified byte order. +.le +.ls msb_host () [bool] +Returns true if host is big-endian. +This function can be used as the \fIbswap\fR keyword expression for formats +with a specified byte order. +.le + +.ih +BYTE SWAPPING + + The 'bswap' database entry is similar to the task parameter, it may +be used to set byte swapping for the whole file, or for only certain data +types. The value is a string parameter that may be "yes" to byteswap the +whole file, "no" to not swap anything, or a comma delimited string of types +described below to enable swapping for only those values. +.nf + + bswap = { no | yes | i2 i4 } + + no # no swapping (default) + yes # byte swap whole file + i2 # byte swap short ints only + i4 # byte swap long ints only +.fi + + The \fIbswap\fR task parameter applies only to the pixel data, +but the bswap keyword in a database record sets byte-swapping +for the header information: arguments to the input and conversion functions +will be byteswapped prior to being evaluated by the function. The bswap() +special function can be used to negate byteswapping for a particular +argument if it is or is not set by the keyword (the default is no byte +swapping). + +.ih +EXAMPLES +.nf + +Get a list of known input formats: + + cl> import "" "" output=info + +Get a list of known input formats, including those defined by the user: + + cl> import "" "" output=info database="dev$images.dat,mydb.dat" + +Get a list of the file formats of each image in the directory: + + cl> import file* "" format="sense" output=info verbose- + file1.ras Sun rasterfile + file1.eps unknown format + file1.pgm 8-bit PGM file + : : + +Get a list of the file formats of each image in the directory and +print out some information about each file: + + cl> import file* "" format="sense" output=info verbose+ + file1.ras: Sun Rasterfile + Resolution: 320 x 200 + Pixel type: 8-bit unsigned integer + Pixel storage: non-interleaved + Header length: 137 bytes + Byte swapped: no + ... : + +Read a raw 8-bit file of pixels into an unsigned short IRAF image: + + cl> import file img format="none" dims="512,512" pixtype="b1" \ + >>> outtype="u" outbands="b1" + +Read a JPL VICAR image or 8-bit Sun rasterfile: + + cl> import file img format="vicar" + cl> import file img format="sunras" + +Concatenate three separate red, blue, and green images and convert + to a single grayscale image: + + cl> concat pic.[rgb] > rgb + cl> import rgb img format=none dims="640,480,3" \ + >>> pixtype="u1" interleave=0 outbands="gray(b1,b2,b3)" + +Read an 8-bit colormap GIF image and separate the RGB colors into + separate bands in the output image: + + cl> import file.gif img outbands="red(b1),green(b1),blue(b1)" + +Read three 8-bit rasterfiles with 200 byte-headers as if they were + a single image, and combine the images to a single output band: + + cl> concat pix.* > rfiles + cl> import rfiles img dims="512,512,3" pixtype="b1" \ + >>> hskip=200 bskip=200 interleave=0 outbands="gray(b1,b2,b3)" + +Read a FITS image with one header record in which the data bytes + are incorrectly swapped, but the header info is in the right order: + + cl> rfits nite1.fits "" nite1 + File: nite1 1866-A Size = 640x480 + cl> imheader nite1 l+ > imheader.dat # Save the header info + cl> imdel nite1.imh + cl> import nite1.fits nite1 format="none" dims="640,480" \ + >>> bswap+ hskip=2880 pixtype="i2" outtype="s" imheader="imheader.dat" + +.fi + +.ih +BUGS +Bitmap images are not yet supported. Their most logical use would be as +pixel masks but there hasn't been much call for these formats so they may +be implemented at a later time. +.ih +REVISIONS +.ls IMPORT V2.11 +This is a new task in this version. +.le +.ih +SEE ALSO +export. imexpr, hedit, default image database imcnv$lib/images.dat +.endhelp diff --git a/pkg/dataio/doc/mtexamine.hlp b/pkg/dataio/doc/mtexamine.hlp new file mode 100644 index 00000000..15504254 --- /dev/null +++ b/pkg/dataio/doc/mtexamine.hlp @@ -0,0 +1,84 @@ +.help mtexamine Apr84 dataio +.ih +NAME +mtexamine -- examine the structure of magtape or a single disk file +.ih +USAGE +mtexamine tape_file +.ih +PARAMETERS +.ls tape_file +Tape or disk file, e.g. "mta1600[2]", "mta1600" or "data". +.le +.ls file_list = "1-999" +List of tape file numbers or ranges delimited by commas, e.g. "1-3,5-8". +File_list is used only if no file number is given in tape_file. +Files will be read in ascending order, regardless of the order of the list. +Reading will terminate if EOT is reached, thus a list such as "1-999" +may be used to read all the files on the tape. File_list is ignored is input +is a single disk file. +.le +.ls dump_records = no +Dump selected records? +.le +.ls rec_list = "1-999" +List of tape record numbers or ranges to be dumped delimited by whitespace +or commas e.g "1-3,4". +.le +.ls swapbytes = no +Swap bytes? +.le +.ls byte_chunk = 1 +The number of bytes which are considered as one output element. +The maximum number of bytes permitted in byte_chunk is the number of +bytes in a long integer on the host machine. +.le +.ls output_format = "o" +Permitted types are character(c), octal(o), hexadecimal (x), decimal (d) +or unsigned decimal (u). Character dumps are only permitted for byte_chunk = 1. +Unless decimal format is specified, the data are dumped as +unsigned integers. +.le +.ih +DESCRIPTION +By default mtexamine determines the record structure of all files +on a magnetic tape or a single disk file. +Selected files can be dumped by setting the file_list parameter. +Selected records can be dumped by setting the dump_record switch +and entering a record list. The user can select the byte chunk +and the output format for the dump. + +Mtexamine can also be used to dump a single disk file. However the concept +of a block is not well defined for disk files. Mtexamine defines a block +to be one IRAF file io block which is usually some multiple of the machine +block size. +.ih +EXAMPLES +1. Determine the record structure of a magnetic tape and send the result to +the file tapedump. + +.nf + cl> mtexamine mtb1600 > tapedump +.fi + +2. Dump the third tape file in octal bytes on the standard output. + +.nf + cl> mtexamine mtb1600[3] du+ +.fi + +3. Dump the contents of the fifth record of the third tape file in ASCII +characters on the standard output. + +.nf + cl> mtexamine mtb1600[3] du+ re=5 ou=c +.fi +.ih +BUGS +The IRAF magtape i/o routines do not permit data beyond a double EOF +to be accessed. Therefore mtexamine cannot be used to examine tapes with +embedded double EOFs. +.ih +SEE ALSO +rewind, allocate +.endhelp diff --git a/pkg/dataio/doc/rcardimage.hlp b/pkg/dataio/doc/rcardimage.hlp new file mode 100644 index 00000000..910cfc72 --- /dev/null +++ b/pkg/dataio/doc/rcardimage.hlp @@ -0,0 +1,120 @@ +.help rcardimage Jan87 dataio +.ih +NAME +rcardimage -- Convert a card image file into an IRAF text file +.ih +USAGE +rcardimage cardfile file_list textfile +.ih +PARAMETERS +.ls cardfile +The cardimage source file. Cardfile may be either a template specifying a +list of disk files, e.g. card* or a mag tape file specification of the +form mtl*[n], where mt stands for mag tape, l stands for a specific drive, +* stands for the density and [n] is the tape file number. If no tape file +number is specified then the tape file numbers are taken from the +file_list parameter. +.le +.ls file_list +A list of tape file +numbers or ranges delimited by commas, for example +"1,3,5-8", which is used only if the magtape device is specified. +Files will be read in ascending order, regardless of +the ordering of the list. Reading will terminate silently if EOT +is reached, thus a list such as "1-999" may be used to read all +files on a tape. +.le +.ls textfile +Name of the output file. If multiple input files, multiple output +files will be generated by concatenating the tape file number or +disk sequence number onto the textfile string. +.le +.ls card_length = 80 +The number of columns per card in the input card image file. +Must be divisible by the number of bytes per "IRAF character" (2 on most +machines). The task reblock can be used to pad files with odd-sized +cards. +.le +.ls max_line_length = 161 +The maximum line length to be generated. Default is maximum size +of a line permitted by IRAF. +Useful for stripping columns 73-80 from Fortran card image files. +.le +.ls entab = yes +Replace blanks with tabs and blanks. Tabsize is 8. +.le +.ls join = no +Rejoin oversize lines. +.le +.ls contn_string = ">>" +Marker to enable program to recognize oversize lines. +.le +.ls trim = yes +Trim trailing whitespace from each line. +.le +.ls verbose = yes +Output messages listing files created, number of cards +processed, etc. +.le +.ls ebcdic = no +Translate from ebcdic to ascii. +.le +.ls ibm = no +Translate from ibm ebcdic to ascii. +.le +.ls offset = 0 +Integer parameter specifying the tape file number offset. For example if +offset = 100, card_file = "card" and file_list = "1-3", the output file +names will be "card101", "card102" and "card103" respectively, instead of +"card001", "card002" and "card003". +.le + +.ih +DESCRIPTION +Multiple cardimage files are read from disk or tape. +If only the magtape device is specified, +a list of file numbers is requested. In the latter case, output files +have the form root_filename // tape(disk)_file_number. By default, trailing +whitespace is trimmed from each line. + +.ih +EXAMPLES +1. Convert a set of ASCII cardimage files on magnetic tape to IRAF text files, +replacing blanks with tabs and blanks, and trimming whitespace from +the ends of lines. + + cl> rcardimage mtb1600 1-999 textfiles + +2. Convert a set of ASCII cardimage files on disk to IRAF test files. + + cl> rcard card* 1 textfiles + +3. Convert a set of EBCDIC cardimage files on magnetic tape to IRAF text files, +trimming whitespace from the ends of lines but leaving embedded blanks +unchanged. + + cl> rcardimage mtb1600 1-999 textfile en- ebc+ + +4. Convert an odd-blocked (81 bytes per card) rcardimage file on tape to an +IRAF text file by using reblock to write the file to disk and pad the cards +with blanks, followed by rcardimage to convert the file to an IRAF textfile. + + cl> reblock mta[1] cardimage inrecord=81 outrecord=82 \ + padchar=" " + + cl> rcardimage cardimage 1 textfile card_length=82 + +.ih +BUGS +Due to portability considerations The card length in bytes must fill an +integral number of IRAF characters. On most machines this means that the +length of the card must be an even number of bytes . The task should be +generalized to require only that the tape record length be specified +to read odd blocked card image files. + +The size of the output text file lines is currently restricted to 161 +or fewer characters. +.ih +SEE ALSO +wcardimage +.endhelp diff --git a/pkg/dataio/doc/reblock.hlp b/pkg/dataio/doc/reblock.hlp new file mode 100644 index 00000000..dd3a506a --- /dev/null +++ b/pkg/dataio/doc/reblock.hlp @@ -0,0 +1,177 @@ +.help reblock Jan93 dataio +.ih +NAME +reblock -- copy a file to tape or disk with optional reblocking +.ih +USAGE +reblock infiles outfiles file_list +.ih +PARAMETERS +.ls infiles +The input file list or device name, e.g. "mta1600[2]" or "mta800", "file1", +"file1,file2", or "@infiles". +.le +.ls outfiles +The list of output files or device name, e.g. "gemini!mtb", "out1", +"out1,out2", or "@outfiles". +If multiple file output to disk is requested, and the specified number +of output files is 1, the output file names will be generated +by concatenating the tape file number (the input files are on tape) or +a sequence number (the input files are on disk) onto the output file +name. +.le +.ls file_list +List of tape file numbers or ranges delimited by commas, +e.g. "1-3,5_8". +File_list is requested only if the magtape input device is specified. +Files will be read in ascending order regardless of the ordering of the list. +Reading will terminate silently if EOT is reached, thus a list such as +"1-999" may be used to read all files on the tape. +.le +.ls newtape +If the output device is magtape, newtape specifies whether the tape is +blank or contains data. +Newtape is requested only if no tape file number is specified, e.g. "mta1600". +.le +.ls outblock = INDEF +Size of the output block bytes. +In the default case and for disk output, the output block size is set to the +file i/o disk default buffer size. +.le +.ls inrecord = INDEF, outrecord = INDEF +The sizes of the input and output logical records in bytes. +The default input and output record sizes are set equal to +the input and output block sizes respectively. If inrecord > outrecord, +records are trimmed; if inrecord < outrecord, records are padded; if +inrecord = outrecord, records are simply counted. If only one of inrecord or +outrecord is set, the undefined parameter defaults to the value of the +other. +.le +.ls skipn = 0 +The number of input blocks (tape input) or records (disk input, size inrecord) +to be skipped. +.le +.ls copyn = INDEF +The number of input blocks (tape input) or records +(disk input, size inrecord) to be copied. Copyn defaults to a very large number. +.le +.ls byteswap = no +Swap every other byte. For example if byteswap is enabled, bytes 1 2 3 4 5 6 +would become bytes 2 1 4 3 6 5 on output. +.le +.ls wordswap = no +Swap every 4 bytes. For example if byteswap is enabled, bytes 1 2 3 4 5 6 7 8 +would become 4 3 2 1 8 7 6 5 on output. +.le +.ls pad_block = no +If pad_block is set, reblock pads trailing blocks until they are outblock +bytes long, otherwise trailing blocks may be short. +.le +.ls padchar = 0 +Single character used to pad blocks or records. +Padchar is only requested if pad_record or pad_block +is set. If padchar equals one of the digits 0 through nine, records and +blocks are padded with the face value of the character, otherwise the +ASCII value is used. +.le +.ls offset = 0 +The number which added to the tape file number is appended to \fIoutfiles\fR +to produce the output file name. For example if file_list = "1-3", outfiles = +"out" and offset = 100, the three files out101, out102, out103 would +be produced rather than out001, out002 and out003. +.le +.ls verbose = yes +Print messages about files, blocks copied etc. +.le +.ih +DESCRIPTION +REBLOCK is a procedure to copy disk or tape resident files to +disk or tape. Multiple input tape or disk files may be specified. +If multiple files are output to disk, and only one output file name is +specified, the output file names will be +generated by concatenating the tape file number (the input files are on tape) +or a sequence number (the input files are on disk) onto the output file name. +The user may request magnetic tape output to begin at a specific file on +tape, e.g. mta1600[5] in which case file five will be overwritten if it +exists, or at BOT or EOT. If no file number is specified REBLOCK asks +whether the tape is new or old and begin writing at BOT or EOT as +appropriate. + +Before beginning the copy, the user may request reblock to skip +n (default 0) blocks (tape input) or logical records (disk input). +The user can also specify that +only n (default all) blocks (tape input) or records (disk input) +are to be copied. Before the copy the data may be optionally word-swapped +(default no) and/or byte-swapped (default no). If verbose is specified +(default yes) reblock prints the input and output file names, +the number of blocks read and written and the number of records read and +written. + +Reblock +uses the default buffer sizes supplied by mtio and file i/o to determine the +maximum number of bytes which can be read in a single read call. For tapes +this corresponds to the maximum number of bytes per block permitted by the +device. Mtio will not read more than one block per read call. Therefore the +actual number of bytes read will be less than or equal to the mtio buffer size. +For disk files the default buffer size set by IRAF is a multiple of the +disk block size. If the disk file is smaller than one block +or the last block is partially full, the number of bytes read +will be less than the default buffer size. All magtape and disk reads are +done with the file i/o read procedure and a call to fstati determines the number +of bytes actually read. + +If all the defaults are set, a binary copy is performed. +In tape to tape copies the block and record sizes are preserved, +but the density may +be changed by specifying the appropriate output file name e.g. mta800 or +mta1600. +Reblocking occurs in tape to disk transfers, if records, are trimmed, +padded or counted, or if blocks are padded. +If a disk to tape transfer is requested +the output block size will be the default file i/o buffer size. +The last block in a file may be short. If uniform sized blocks are +desired, pad_block must be set, in which case trailing partially filled +blocks will be padded with padchar. + +Logical records are distinguished from blocks (physical records). +The input and output record sizes default to +the size of the input and output blocks respectively. +Logical records may be shorter or longer than the block sizes. + +.ih +EXAMPLES +1. Copy a magnetic tape preserving the record sizes but changing +the density from 800 bpi to 1600 bpi. + +.nf + cl> reblock mtb800 mta1600[1] 1-999 +.fi + +2. Reblock a magnetic tape changing the block size from 4000 bytes to 8000 +bytes and padding the last block. + +.nf + cl> reblock mtb1600 mta1600[1] 1-999 outb=8000 padb+ +.fi + +3. Copy a series of disk fits files to tape + +.nf + cl> reblock @fitsfiles mta[1] outb=28800 +.fi + +4. Trim the records of a disk file. + +.nf + cl> reblock infile outfile inrec=80 outrec=72 +.fi + +5. Pad the records of a disk file with blanks. + +.nf + cl> reblock input output inrec=81 outrec=82 padchar=" " +.fi +.ih +SEE ALSO +t2d +.endhelp diff --git a/pkg/dataio/doc/rfits.hlp b/pkg/dataio/doc/rfits.hlp new file mode 100644 index 00000000..d28690c1 --- /dev/null +++ b/pkg/dataio/doc/rfits.hlp @@ -0,0 +1,228 @@ +.help rfits May97 dataio +.ih +NAME +rfits -- convert image data in FITS files to individual IRAF images +.ih +USAGE +rfits fits_file file_list iraf_file +.ih +PARAMETERS +.ls fits_file +The FITS data source. Fits_file is either a list of disk files or a tape +device specification of the form mt[*][n], where mt is the mag tape +device (e.g. mta), * is an optional density (e.g. 1600), and [n] is an +optional tape file number. If n is specified then only image data in the +nth tape file is read. +.le +.ls file_list +The list of FITS extensions to be read from each disk file or from a single +tape file, or the list of tape files AND FITS extensions to be read from +an entire tape. FITS extensions are numbered from 0 to n, tape files are +numbered from 1 to n. If file_list is "", only the 0th extension is read +from each disk file or from a single tape file, but all the files and +extensions are read from an entire tape. Legal file lists are composed +of a series of file numbers and / or file ranges separated by commas +or whitespace. For example the string + + "1-3,4-8" + +will convert ALL the FITS extensions in files 1 through 8 on tape, +but only FITS extensions 1 through 8 from a disk file or a single tape file. +For the case of disk input, the same FITS extensions must be read from +each input file. For the case of tape input the FITS extensions to be +read from each file must be specified separately. For example the following +string + + "1-10[2-4],15-21[1-10]" + +tells rfits to convert extensions 2 through 4 in tape files 1 through 10 +and extensions 1 through 10 in tape files 15 through 21. Rfits will only +convert extensions which contain image data. Other types of fits data +such as tables will not be converted. +.le +.ls iraf_file +The IRAF file which will receive the FITS image data if the make_image parameter +switch is set. Iraf_file may be a template of output image names or +a single root output image name. In the former case one output image name +must be specified for every input file. In the latter case iraf_file is +a root output image name to which the input file sequence number or tape +file number is appended if the number of input files > 1. For example +reading files 1 and 3 from a FITS tape with a value of iraf_file of "data" +will produce the files data0001 and data0003, whereas reading the same +two files with a value of iraf_file of "data1,data2" will produce the files +data1 and data2. Extension numbers will be appended to the root output +names if appropriate. +.le +.ls make_image = yes +If make_images is "yes" convert the FITS image data to IRAF image data, +otherwise simply print the header information using the long_header or +short_header switches. +.le +.ls long_header = no +If long_header is "yes" the full FITS header is printed on the standard output. +.le +.ls short_header = yes +If short_header is "yes" and long_header is "no", only the output filename, +the title string, and the image dimensions are printed on the standard output. +.le +.ls datatype +The output image data type. Datatype may be s (short integer), i (integer), +u (unsigned integer), l (long integer), r (real), or d (double). Data +truncation may occur if an inappropriate data type is specified. If an +unsupported data type or a null string is supplied then a default data +type is selected based on the value of the fits bitpix, bscale, and bzero +parameters. If the bscale and bzero parameters in the FITS header are +undefined or equal to 1.0 and 0.0 respectively, rfits selects datatype +s or l depending on bitpix. If bscale and bzero are set to 1.0 and 32768.0, +rfits selects datatype, otherwise rfits selects datatype r. +.le +.ls blank = 0. +The IRAF image value assigned to a FITS blank pixel. +.le +.ls scale = yes +If scale is "no" then the data values are read directly from the FITS image +without conversion. Otherwise rfits scales the data before output using +the values of bscale and bzero. +.le +.ls oldirafname = no +If the oldirafname switch is set rfits will attempt to restore the image to +disk with the filename defined by the IRAFNAME parameter in the FITS header. +.le +.ls offset = 0 +An integer parameter specifying the offset to the current tape file +number. For example if offset = 100, iraf_file = "fits" and file_list = "1-3" +then the output file names will be "fits0101", "fits0102" and "fits0103" +respectively rather than "fits0001", "fits0002" and "fits0003". +.le +.ih +DESCRIPTION +FITS data is read from the specified source; either disk or +magnetic tape. The FITS header may optionally be printed on the standard +output as either a full listing or a short description. +The FITS long blocks option is supported. + +At present non-standard FITS files (SIMPLE = F) and files containing +group data are skipped and a warning message is issued. +Image stored in the FITS standard extension IMAGE can be read. +Other standard extensions such as TABLE and BINTABLE are currently ignored. + +A warning message will be issued if the default user area allocated in +memory is too small +to hold all the FITS parameter cards being read in by RFITS. +Since the default user area is 64000 +characters and a single card image is 81 characters long, the normal +user area will hold ~800 complete card images. RFITS will not permit +partial cards to be written. The user can override the default user area +length by setting the environment variable min_lenuserarea (see example +below). +.ih +EXAMPLES +1. Convert all the image data on a mag tape to individual IRAF +images. Allow rfits to select the output datatype and set blanks +to zero. + +.nf + cl> rfits mtb1600 "" images + + or alternatively + + cl> rfits mtb1600 * images +.fi + +2. Convert FITS files on disk to IRAF images. In the first example case the +files specified by fits* are written to images images0001, images0002, etc. +In the second example the fits disk files listed one per line in the text +file fitslist are written to the output images listed one per line in +the file imlist. Note that by using 0 or "" for the file_list parameter +the user has told rfits to read only the primary fits data unit. + +.nf + cl> rfits fits* "" images + + or alternatively + + cl> rfits fits* 0 images + + + cl> rfits @fitslist "" @imlist + + or alternatively + + cl> rfits @fitslist 0 @imlist +.fi + +3. List the contents of a FITS tape on the standard output without creating +any image files. + +.nf + cl> rfits mtb1600 "" images ma- +.fi + +4. Convert FITS files on tape directly to IRAF images without scaling. + +.nf + cl> rfits mtb1600 "" images scal- +.fi + +5. Convert the first three FITS files on tape to IRAF image converting FITS +blank values to -1 in the process. Note that the user will not get what +he or she expects if the output data type is ushort. + +.nf + cl> rfits mta 1-3 images blank=-1 +.fi + +6. Read in a disk FITS file with a header roughly twice the usual IRAF length +of 64000 characters. + +.nf + cl> set min_lenuserarea = 128000 + cl> rfits fitsimage "" image +.fi + +7. Read a FITS tape which has 5 normal fits records (2880 bytes) to a tape +record. Notice that no hidden rfits parameters are required to do this. + +.nf + cl> rfits mta * images +.fi + +8. Convert only the zeroth FITS extension in each of the first 100 files on a +magnetic tape and try to restore the original IRAF image name in the process. + +.nf + cl> rfits mta 1-100[0] images old+ +.fi + +9. Convert the second, third, and fourth FITS extensions in the first 100 +files of a FITS tape and try to restore the original IRAF name in the process. + +.nf + cl> rfits mta "1-100[2-4]" images old+ +.fi + +10. Convert the second, third, and fourth FITS extensions in each of a list of +disk files and restore the original IRAF name in the process. + +.nf + cl> rfits @fitslist "2-4" images old+ +.fi + +11. Convert the second, third, and fourth FITS extensions in the fifth +mag tape file and try to restore the original IRAF name in the process. + +.nf + cl> rfits mta[5] "2-4" images old+ +.fi + +.ih +BUGS +Blank pixels are counted and set to a user determined value, but they are not +records in the output image header. + +Rfits can read image data only. Other FITS data types such as ASCII and +binary tables are skipped. +.ih +SEE ALSO +wfits, reblock, t2d, fits kernel +.endhelp diff --git a/pkg/dataio/doc/rtextimage.hlp b/pkg/dataio/doc/rtextimage.hlp new file mode 100644 index 00000000..f6b8f037 --- /dev/null +++ b/pkg/dataio/doc/rtextimage.hlp @@ -0,0 +1,84 @@ +.help rtextimage Oct93 dataio +.ih +NAME +rtextimage -- convert a text file to an IRAF image +.ih +USAGE +rtextimage input output +.ih +PARAMETERS +.ls input +A list of text files containing image pixels and optional header. Most likely +the output from \fIrcardimage\fR, see examples below. +.le +.ls output +The output IRAF image name. If more than one text file is being +read, the ordinal of the text file in \fBinput\fR +is appended to \fIoutput\fR to generate a unique image name. +.le +.ls otype = "" +The data type of the output IRAF image pixels. If left unset and the IRAFTYPE +keyword is found in the FITS header, output pixels will be of type IRAFTYPE. +If IRAFTYPE appears more than once in the FITS header, the last value of +IRAFTYPE is used. If left unset and the IRAFTYPE keyword is not provided in +the FITS header, the output data type is determined from the pixels themselves. +.le +.ls header = yes +If \fBheader\fR = yes, \fIrtextimage\fR will attempt to read a FITS +header at the beginning of each text file. +.le +.ls pixels = yes +Read the pixel values from the input text file. If no then the +output image is initialized to zero pixel values. +.le +.ls nskip = 0 +The number of lines to skip before reading pixels. This is used to +skip over a non-standard header and is important only when \fBheader\fR = no. +.le +.ls dim = "" +A string listing the dimension of each axis. The number of dimensions listed +equals the number of image dimensions. This information must be entered unless +it can be read from a FITS header. +.le +.ih +DESCRIPTION +Text files are converted to IRAF images files with procedure +\fBrtextimage\fR. The text file consists of an optional header optionally +followed by the pixel values. If no pixel values are read the image is +initialized to all zero pixel values. If pixel values a given they are +read in FITS order, that is, the leftmost subscript varies most rapidly. +The number of image dimensions and the length of each dimension must either +be read from a FITS header or supplied by the user. Internally, +\fBrtextimage\fR determines the format (integer or floating point) of the +pixels in the text file by reading the first one and assuming all others +are the same. +.ih +EXAMPLES +1. Read a file written by \fIwtextimage\fR from the magtape file "mta[1]" into +the IRAF image "picture". + + cl> rcard mta[1] | rtext out=picture + +2. Read a series of text files with no headers preceding the pixels. The +text files were previously read from tape with task \fBrcardimage\fR. +The two dimensional images are 512 by 320 pixels, and will be named +crab001, crab002, crab003, etc. + + cl> rtext text.* crab header- dim=512,320 + + +3. Read a file with a non-standard header. The header is 5 cardimages long. + + cl> rcard mta[5] | rtext out=spect.1 head- nskip=5 dim=1024 +.ih +TIME REQUIREMENTS +Task \fIrtextimage\fR requires about 145 cpu seconds to write a 512 square +image (integer or real) from a text file. +.ih +BUGS +The text file being read cannot have lines longer than SZ_LINE characters +(see hlib$iraf.h). +.ih +SEE ALSO +rcardimage, wtextimage +.endhelp diff --git a/pkg/dataio/doc/t2d.hlp b/pkg/dataio/doc/t2d.hlp new file mode 100644 index 00000000..5d36334c --- /dev/null +++ b/pkg/dataio/doc/t2d.hlp @@ -0,0 +1,70 @@ +.help t2d May89 dataio +.ih +NAME +t2d -- copy files from tape to disk quickly +.ih +USAGE +t2d input ofroot +.ih +PARAMETERS +.ls input +Tape file or device name, e.g. "mta1600[1]" or "mta" +.le +.ls files +List of tape file numbers or ranges delimited by commas, e.g. "1-3,5-8". +`Files' is requested only if no file number is given in `input'. +Files will be read in ascending order, regardless of the order of the list. +Reading will terminate if EOT is reached, thus a list such as "1-999" +may be used to read all the files on the tape. +.le +.ls ofroot +Root name to give output files. A three digit sequence number will be appended +to this root name for each file written if a file list is used. If the file +number is specifically given in the 'input' parameter, the output file will +be named this root without an appended sequence number. +.le +.ls verbose = yes +Flag to signal program that it should produce verbose output. This means +progress reports. +.le +.ls errignore = yes +Flag to signal program that tape records that give read errors should be +considered to have zero length. If set to 'no', error records are considered +to be the same length as all the other records on the tape. +.le +.ih +DESCRIPTION +T2d reads files from tape and puts them into disk files. No formatting is +performed so the bits and bytes are in the same order on disk as they were +on tape. The program uses double buffering and asynchronous i/o to speed +things up as much as possible. + +When read errors are encountered one of two things can happen. Depending +on the value of the parameter 'errignore', the error record is either +thrown out or considered valid data. If 'errignore' is 'no' when an error +is found, the input buffer is validated to the most recent 'good record' +length and written to disk. If 'errignore' is 'yes' when an error is +found, the input buffer is disposed of for that record. +.ih +EXAMPLES +1. To read the second image from mta at 1600 bpi, store the image into +"image" and see verbose output the command would be: + +.nf + cl> t2d mta1600[2] image +.fi + +2. To read all the files on mtb at the default speed of 1600 bpi and put +the disk files in root001, root002, root003, etc. and turn off verbose +output, the command would be: + +.nf + cl> t2d mtb root v- +.fi + +The program will prompt the user and ask for the list of files to be read +to which the response would be "1-999". +.ih +SEE ALSO +reblock +.endhelp diff --git a/pkg/dataio/doc/txtbin.hlp b/pkg/dataio/doc/txtbin.hlp new file mode 100644 index 00000000..c519125f --- /dev/null +++ b/pkg/dataio/doc/txtbin.hlp @@ -0,0 +1,28 @@ +.help txtbin Jun86 dataio +.ih +NAME +txtbin -- convert text files to binary files +.ih +USAGE +txtbin text_file binary_file +.ih +PARAMETERS +.ls text_file +Input file name or template, e.g. "abc" or "abc.*". +.le +.ls binary_file +Output file name. If multiple input files the file_number will be +added to the output file name. +.le +.ls verbose = "yes" +Print messages about files processed? +.le +.ih +EXAMPLES +1. Convert a text file on disk to a binary file on disk. + + cl> txtbin text_file binary_file +.ih +SEE ALSO +bintxt +.endhelp diff --git a/pkg/dataio/doc/wcardimage.hlp b/pkg/dataio/doc/wcardimage.hlp new file mode 100644 index 00000000..650f78ed --- /dev/null +++ b/pkg/dataio/doc/wcardimage.hlp @@ -0,0 +1,74 @@ +.help wcardimage Jun86 dataio +.ih +NAME +wcardimage -- convert IRAF text files to card image files +.ih +USAGE +wcardimage infiles outfiles +.ih +PARAMETERS +.ls textfile +A character string identifying the file (s) on disk to be processed. +The string acts as a "template" so that multiple files can be pro- +cessed. +.le +.ls cardfile +Name of the output tape device of the form "mta800" or "mta800[#]" +or name of disk file (s). EOT and BOT are acceptable tape file numbers. +The file number will be appended to +the output file name in the case of multiple file disk output. +.le +.ls new_tape +Specifies whether the output tape is blank or contains data. +.le +.ls contn_string = ">>" +Character string which will be inserted at the beginning of +card image lines which have been split from a single text line. +.le +.ls verbose = yes +Print messages of actions performed? +.le +.ls detab = yes +Remove tabs? +.le +.ls card_length = 80 +Number of columns per card. +.le +.ls cards_per_blk = 50 +Number of card images per physical record. +.le +.ls ebcdic = no +Translate ascii characters to ebcdic? +.le +.ls ibm = no +Translate ascii characters to ibm ebcdic? +.le +.ih +DESCRIPTION +If multiple file disk output is requested, ".crd" is appended to the input +file name. Oversize lines are split and prefixed by the string ">>". +.ih +EXAMPLES +1. Convert a set of IRAF text files to a set of blocked ASCII cardimage files +on tape, replacing tabs with blanks and prefixing the leftover portions +of oversize lines with ">>". + +.nf + + cl> wcardimage files* mtb1600[1] +.fi + +2. Convert a set of IRAF text files to a set of blocked EBCDIC cardimage files +on tape, replacing tabs with blanks and prefixing the leftover portions +of oversize lines with ">>". + + cl> wcardimage files* mtb1600[1] eb+ +.ih +BUGS +The card_length in bytes must be an integral number of chars. +At present WCARDIMAGE can only handle lines with less than or equal to +161 characters. +.ih +SEE ALSO +rcardimage +.endhelp diff --git a/pkg/dataio/doc/wfits.hlp b/pkg/dataio/doc/wfits.hlp new file mode 100644 index 00000000..67d6f3c3 --- /dev/null +++ b/pkg/dataio/doc/wfits.hlp @@ -0,0 +1,237 @@ +.help wfits May97 dataio +.ih +NAME +wfits -- convert individual IRAF image files to FITS image data +.ih +USAGE +wfits iraf_files fits_files +.ih +PARAMETERS +.ls iraf_files +The input IRAF image file(s), e.g. "image.imh" or "*.imh". +.le +.ls fits_files +The output FITS files. +Magnetic tape output is assumed if the first two characters of fits_files +are "mt", otherwise the disk output is assumed. Tape output will begin +at the file number specified in fits_files, e.g. file 5 if fits_files = +"mtb1600[5]", and the data in file 5 and succeeding files will be overwritten. +If no tape file number is specified in fits_files, the newtape parameter +is queried, and tape output will begin at BOT (beginning of tape) if +newtape = yes, otherwise at EOT (end of tape, after the double EOF). +Requesting a tape write at EOT on a blank tape may cause tape runaway. +In the case of disk output, fits_files may be either a file name template +or a root filename. In the former case there must be one output FITS file +name for every input image. In the latter case fits_files is a root name +and a sequence number will be appended to fits_files if the number of +input images > 1. +.le +.ls newtape +Boolean parameter specifying whether an output tape is blank or already +contains data. Newtape is requested only if no tape file number is specified in +fits_files, e.g. fits_files = "mtb1600". +.le +.ls bscale +The FITS bscale parameter, defined as p = i * bscale + bzero, where +p and i are the physical and tape data values respectively. +The bscale parameter is only requested if the scale switch is on +and the autoscale switch is off. +.le +.ls bzero +The FITS bzero parameter (see bscale for a definition). +Bzero is only requested if the scale switch is on and the autoscale +switch is off. +.le +.ls fextn = "fits" +The output fits file extension. If fextn is defined, an extension of +the form ".fextn", e.g. ".fits" is added to the output fits file name. +Fextn should be chosen to be compatible with one of the permitted fits +kernel extensions. +.le +.ls extensions = no +By default wfits writes each input image to a separate disk or tape FITS +file. If \fIextensions\fR is "yes", then wfits will write all the images in +the input image list to a single disk or tape FITS file using the FITS +standard IMAGE extension to write images other than the first. Extension +numbering is 0 indexed. The first image will be written to extension 1 if +\fIglobal_header\fR is "yes", or to extension 0 if \fIglobal_hdr\fR is "no". +.le +.ls global_hdr = yes +Write a short global header to the 0th extension of the output FITS file +if \fIextensions\fR is "yes". +.le +.ls make_image = yes +By default wfits writes the FITS image(s) to the output destination. +If the make_image switch is turned off, wfits prints the FITS headers +on the standard output and no output file is created. In this way the +output FITS headers can be examined before actually writing a FITS tape. +.le +.ls long_header = no +If this switch is set the full FITS header will be printed on the standard +output for each IRAF image converted. +.le +.ls short_header = yes +If this switch is set only a short header, listing the files processed and +their dimensions will be printed on the standard output. +The long_header switch must be turned off. +.le +.ls bitpix = 0 +A bitpix of 8, 16, or 32 will produce either an unsigned byte, +twos-complement 16 bit integer, or twos-complement 32 bit integer FITS +image. If bitpix is -32 or +-64 IEEE real or double precision floating point FITS images are produced. +If bitpix is set to 0 (the default), wfits will choose one of 8, +16, 32, -32 or -64 based on the data type of the IRAF image. +For example a short integer and real image will default to bitpix 16 and +-32 respectively. +Users should be wary or overriding the default value of bitpix as loss +of precision in their data may result. In this case wfits will issue a +warning message and an estimate of the maximum loss of precision to be +expected. +.le +.ls blocking_factor = 0 +The tape blocking factor for FITS. +Wfits normally writes \fIblocking_factor\fR * 2880 byte records, +where \fIblocking_factor\fR is an integer from 1 to 10. +If \fIblocking_factor\fR = 0, wfits uses the default FITS blocking +factor specified for the device by the "fb" parameter in the +file dev$tapecap, or 1 if the "fb" parameter is not present. For +devices which support variable block sizes, e.g. 9-track tapes, exabytes +and dats, "fb" is normally set to 10. +The user may override this value by setting \fIblocking_factor\fR +>= 1 or <= 10. If the device does not support variable block sizes, e.g. +various types of cartridge drives, blocks of the size defined for the +device by the "bs" parameter in the dev$tapecap file are written +and \fIblocking_factor\fR is ignored. +.le +.ls scale = yes +If the scale switch is set, the IRAF image will be scaled before output. +Two types of scaling are available. The scaling parameters bscale and +bzero may be entered by the user (autoscale = no), or the program can +calculate the appropriate bscale and bzero factors (autoscale = yes). +If the scale switch is turned off, the IRAF image data is converted +directly to integers of the specified bitpix with possible loss of +precision. +.le +.ls autoscale = yes +If the autoscale switch is set, wfits calculates the appropriate bscale and +bzero factors based on the IRAF image data type, and the maximum and minimum +values of the data. +.le +.ih +DESCRIPTION +IRAF data is read from disk and written to the specified destination, +either disk or magnetic tape. The FITS header may optionally be printed +on the standard output as either a full listing or a short description, +with or without creating an output image file. If a the default value +of bitpix (default = 0) is entered, wfits will select the appropriate +bitpix value based on the precision of the IRAF data. Otherwise the +user value is used and loss of precision is possible. Two data scaling +options are available. In autoscale mode wfits calculates the appropriate +scaling factors based on the maximum and minimum data values in the +IRAF image and the FITS bits per pixel. Alternatively the scaling factors +can be entered directly. If no scaling is requested the IRAF data values +will be converted directly to FITS integers or floating point values +with possible loss of precision. +.ih +EXAMPLES +1. Convert a list of IRAF image files to a list of FITS image files on a blank +magnetic tape, allowing wfits to select the appropriate bitpix +and scaling parameters. + +.nf + cl> wfits iraf_file* mtb1600[1] +.fi + +2. Convert a list of IRAF image files to FITS image files on disk, +allowing wfits to select the appropriate bitpix and scaling parameters. +In the first example below the images specified by the template are written +to files fits001, fits002, etc. In the second the list of input images +specified one per line in the text file imlist are written to the +files specified one per line in the text file fitslist. + +.nf + cl> wfits iraf_file* fits + + cl> wfits @imlist @fitslist +.fi + +3. Convert an IRAF image file to a 32 bits per pixel FITS file with no +scaling and append to a tape already containing data. + +.nf + cl> wfits iraf_file mtb1600[EOT] bi=32 sc- +.fi + +4. Convert an IRAF image to a 16 bit FITS image on disk, and specify +bscale and bzero explicitly in the process. + +.nf + cl> wfits iraf_file fits_file bi=16 au- bs=4.0 bz=0.0 +.fi + +5. Print the FITS headers on the standard output. + +.nf + cl> wfits iraf_file* ma- +.fi + +6. Create a disk file called headers containing the FITS headers for a list +of IRAF image files. + +.nf + cl> wfits iraf_file* ma- > headers +.fi + +7. Write a FITS tape with 14400 bytes per record (5 2880 FITS records per +tape block) on a 9-track tape. + +.nf + cl> wfits images* mtb[1] block=5 +.fi + +8. Write a FITS Exabyte tape with a blocking factor of 1 (1 2880 FITS record +per block). Note that wfits will normally by default write a 28000 ( +10 2880 FITS logical records per block) byte record. + +.nf + cl> wfits images* mtb[1] block=1 +.fi + +9. Write a list of images to a single tape file using the FITS standard +extension IMAGE. Users who are planning on reading their data with +local FITS readers should check that those local readers support the +FITS IMAGE extension before selecting this option. + +.nf + cl> wfits *.imh mtb[1] block=1 extensions+ +.fi + +10. Repeat the previous example but do not write a global header. + +.nf + cl> wfits *.imh mtb[1] block=1 extensions+ global- +.fi + +.ih +BUGS +WFITS does not attempt to recover from write errors. When an error is +detected, WFITS issues an error message and attempts to write a double +EOF at the end of the last good record. In this case the last file on +the tape will be a partial file. IF WFITS is not successful in writing +the double EOF, the message "Cannot close magtape file (name)" will be +issued. Problems occur as some drives permit the double EOF to be +written after the physical end of tape and some do not. Similarly +some drives can read a double EOF after end of tape and some cannot. Depending +on operating system and device driver, an attempt to read or write past +end of tape may or may not be distinguishable from a normal write error. + +Blank pixel values are not correctly handled. + +Attempting to write at EOT on a blank tape will at best result in numerous +error messages being issued and at worst result in tape runaway depending +on the driver. +.ih +SEE ALSO +rfits, reblock, fits kernel +.endhelp diff --git a/pkg/dataio/doc/wtextimage.hlp b/pkg/dataio/doc/wtextimage.hlp new file mode 100644 index 00000000..6dd67ff8 --- /dev/null +++ b/pkg/dataio/doc/wtextimage.hlp @@ -0,0 +1,100 @@ +.help wtextimage Oct93 dataio +.ih +NAME +wtextimage -- convert an IRAF image to a text file +.ih +USAGE +wtextimage input output +.ih +PARAMETERS +.ls input +An IRAF image file name or template of file names to be converted. +.le +.ls output +Name or root_name of output text file. If more than one IRAF image +is being converted, the ordinal of the file in the input file list +is appended to \fIoutput\fR to generate a unique output file name. +.le +.ls header = yes +This parameter determines whether or not a descriptive header precedes +the pixels written to the text file. When \fIheader = no\fR, only +pixels values are converted; no header information is included in the +output. +.le +.ls pixels = yes +This parameter determines whether or not to write the pixels to the +text file. This can be set to no to only write out the header. +.le +.ls format = "" +Output format for each pixel. If not set by the user, the appropriate output +pixel format is determined by the image data type. +Acceptable formats are chosen from "W.D[defgz]" where w is the field width and +d specifies the precision. Fortran formats of the form [iefgz]W.D are also +acceptable. If a field width of 0 is specified, (e.g., 0.6g), +output will be free format with each output line containing as many pixels as +will fit on the line. This is the most space efficient format but requires +that the reader program be able to handle free format (list directed) input. +.le +.ls maxlinelen = 80 +The maximum number of characters output per line of text; \fBmaxlinelen\fR +must not exceed 322 characters. (Note that tasks \fIrtextimage\fR and +\fIwcardimage\fR cannot read lines of text greater than 161 characters.) +.le +.ih +DESCRIPTION +IRAF images are converted to text files with procedure \fBwtextimage\fR. +The text file written consists of an optional header optionally followed by +the pixel values. The pixels are output in FITS order, that is, the +leftmost subscript varies most rapidly. The image header is written in the +"keyword = value / comment" format of FITS. +.ih +EXAMPLES +1. Write a text file from an image section of dev$pix. The default maximum +linelength of 80 is used; an output format is specified. The header portion +of the output text is as follows: +.ls +.nf +BITPIX = 8 / 8-bit ASCII characters +NAXIS = 2 / Number of Image Dimensions +NAXIS1 = 10 / Length of axis +NAXIS2 = 10 / Length of axis +ORIGIN = 'NOAO-IRAF: WTEXTIMAGE' / +IRAF-MAX= 31431. / Max image pixel (out of date) +IRAF-MIN= 33. / Min image pixel (out of date) +IRAF-B/P= 16 / Image bits per pixel +IRAFTYPE= 'SHORT INTEGER ' / Image datatype +OBJECT = 'NGC 4147 B 1800 ' / +FILENAME= 'DEV$PIX[1:10,1:10]' / IRAF filename +FORMAT = '11I7 ' / Text line format +DATA-TYP= ' object ( 0 )' / object,dark,comp,etc. +ITIME = 1800 / integration time secs +UT = '11:23:13' / universal time +ZD = '24: 5: 0' / zenith distance +DATE-OBS= '15/02/1985' / dd/mm/yy observation +ST = '13:38:31' / sidereal time +RA = '12: 9:20' / right ascension +DEC = '18:35:35' / declination +EPOCH = .0 / epoch of RA and DEC +CAM-TEMP= -104.95 / camera temperature, deg C +DEW-TEMP= -192.96 / dewar temp, deg C +HISTORY1= 'bt= 590 bp= 0 cr= 0 dk= 0 ' +HISTORY2= 'ff= 55 fg= 0 sc= .000 bi= 51 ' +COMMENT = 'ngc 4147 b 1800' +F1POS = 2 / filter bolt I position +F2POS = 0 / filter bolt II position +END +.fi +.le + +2. Write a series of text files from the IRAF images having root name +"reduced". One text file is written for each image. + + cl> wtext reduced.* txt +.ih +TIME REQUIREMENTS +It takes almost 10 cpu minutes to convert a 512 square image of real pixels. +A 512 square image of integer pixels takes about 3 cpu minutes. +.ih +SEE ALSO +wcardimage, rtextimage, noao.onedspec.wspectext +.endhelp diff --git a/pkg/dataio/export.par b/pkg/dataio/export.par new file mode 100644 index 00000000..d39690f2 --- /dev/null +++ b/pkg/dataio/export.par @@ -0,0 +1,13 @@ +# EXPORT Task Parameter File +images,s,a,"",,,"The list of input iraf images" +binfiles,s,a,"",,,"The list of output binary files" +format,s,a,"raw",,,"The type of binary file to write { raw|list|<format> }" +header,s,h,"yes",,,"Prepend a header describing how the data are stored?" +outtype,s,h,"",,,"Output pixel type" +outbands,s,h,"",,,"Output expressions" +interleave,i,h,0,,,"Pixel interleave type" +bswap,s,h,"no",,,"Type of byte-swapping to perform on output" +verbose,b,h,no,,,"Verbose output during conversion?" + +# Mode parameter +mode,s,h,"ql",,,"mode parameter" diff --git a/pkg/dataio/export/Notes b/pkg/dataio/export/Notes new file mode 100644 index 00000000..5e60b65a --- /dev/null +++ b/pkg/dataio/export/Notes @@ -0,0 +1,37 @@ +Things to Do: +------------- + + Help Page: +done - examples showing image operand usage +done - examples of zscale/grey/bscale/gamma funcs in complex exprs + +done - clean up output header description +done - verbose is used as terminal output and raw header flag - change +done - define 'composite' in interleave description + - format=raw for >3-D images, more detail +done? - clean up description of image list handling for large groups of + images - perhaps multiple params for operands +done - format should be a query param +??? - should 'outbands' be 'outexpr' +??? - should there be an 'append' param to append existing files +done - what happens if 3-D image passes in for builtin conversion +done - Dave's typos/comments + - note that grouping exprs in function may affect the number of + perceived expressions, e.g. "psdpi ( (b1, b2, b3), 150.0)" +done - add block() function to help page +done - add setcmap() function - this is what's currently defined as the + setlut() function. +??? - Clear up confusion about LUT and colormaps in the help page + + Source: +done - block() function fills full height of expression, not just that + height specified +done - remove constraint on image sizes all being equal +done - @param and tag.param operators need to be implemented +done - text output still needs work +done - remove xvv_initop() calls - interface violation +done - finish header output +done - is zscale() mapping the pixels NOT in the range 0-255 for gif??? +done - need to implement XWD + - need to patch xwd expr for RGB to add alpha channel + - optimize image reads from 3D images diff --git a/pkg/dataio/export/bltins/exeps.x b/pkg/dataio/export/bltins/exeps.x new file mode 100644 index 00000000..b7189896 --- /dev/null +++ b/pkg/dataio/export/bltins/exeps.x @@ -0,0 +1,537 @@ +include <evvexpr.h> +include <imhdr.h> +include <mach.h> +include <fset.h> +include "../export.h" +include "../exbltins.h" + + +define SZ_EPSSTRUCT 5 +define EPS_ITEMSPERLINE Memi[$1] # no. of items per line +define EPS_HPTR Memi[$1+1] # ptr to hex digit string +define EPS_BPTR Memi[$1+2] # ptr to output buffer +define EPS_BCNT Memi[$1+3] # index into output buffer +define HEXSTR Memc[EPS_HPTR($1)+$2] +define BUF Memc[EPS_BPTR($1)+$2-1] + +define LINEWID 36 # hexstr pixels per line +define HEXITS "0123456789abcdef" # hex digits +define MARGIN 0.95 # defaults for 300 dpi +define PAGEWID 612 +define PAGEHGT 762 +define SZ_EPSBUF 8192 +define SZ_TRAILER 31 + + +# EX_EPS - Write the output image to an Encasulated PostScript file. + +procedure ex_eps (ex) + +pointer ex #i task struct pointer + +pointer eps +pointer bptr +int fd, len, flags + +int strlen() +bool streq() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if ((EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) && EX_NEXPR(ex) != 3) + call error (7, "Invalid number of expressions for EPS file.") + + # Set some of the output parameters. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Allocate the EPS structure. + iferr (call calloc (eps, SZ_EPSSTRUCT, TY_STRUCT)) + call error (0, "Error allocating eps structure.") + call calloc (EPS_HPTR(eps), 17, TY_CHAR) + call calloc (EPS_BPTR(eps), SZ_EPSBUF+SZ_TRAILER, TY_CHAR) + call strcpy (HEXITS, Memc[EPS_HPTR(eps)], 17) + EPS_BCNT(eps) = 1 + + # Now write out the header and image data. + fd = EX_FD(ex) + call fseti (fd, F_ADVICE, SEQUENTIAL) + if (bitset (flags, OF_CMAP)) { + if (streq (CMAPFILE(ex),"grayscale") || + streq (CMAPFILE(ex),"greyscale")) { + call eps_header (ex, eps, NO) + call eps_gray (ex, eps, fd, false, true) + } else { + call eps_header (ex, eps, YES) + call eps_gray (ex, eps, fd, true, false) + } + + } else if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) { + call eps_header (ex, eps, NO) + call eps_gray (ex, eps, fd, false, false) + + } else if (EX_NEXPR(ex) == 3) { + call eps_header (ex, eps, YES) + call eps_rgb (ex, eps, fd) + } + + # Flush the remaining pixels in the buffer. + call calloc (bptr, SZ_EPSBUF, TY_CHAR) + + if (mod (EPS_BCNT(eps),2) == 0) { + call amovc ("\ngrestore showpage\n%%Trailer\n\0", + BUF(eps,EPS_BCNT(eps)), SZ_TRAILER) + } else { + call amovc ("\ngrestore showpage\n%%Trailer\n", + BUF(eps,EPS_BCNT(eps)), SZ_TRAILER) + } + len = strlen (BUF(eps,1)) + call strpak (BUF(eps,1), Memc[bptr], len) + call write (fd, Memc[bptr], len / SZB_CHAR) + call flush (fd) + + # Write the EPS trailer and clean up the pointers. + call mfree (EPS_HPTR(eps), TY_CHAR) + call mfree (EPS_BPTR(eps), TY_CHAR) + call mfree (eps, TY_STRUCT) + call mfree (bptr, TY_CHAR) +end + + +# EPS_GRAY - Write a grayscale EPS file. + +procedure eps_gray (ex, eps, fd, use_cmap, is_gray) + +pointer ex #i task struct pointer +pointer eps #i postscript struct pointer +int fd #i output file descriptor +bool use_cmap #i write a false color image? +bool is_gray #i is this a grayscale cmap? + +pointer op, bop, out, cm +int i, j, k, line, percent +int len, orow, type + +pointer ex_evaluate(), ex_chtype() + +begin + # Now process the expressions and write the image. + type = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + cm = EX_CMAP(ex) + call malloc (out, EX_OCOLS(ex)+2, TY_SHORT) + do i = 1, EX_NEXPR(ex) { + + # Process each line in the image. + do j = 1, O_HEIGHT(ex,i) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + bop = ex_chtype (ex, op, type) + + # Write evaluated pixels. + call achtbs (Memc[bop], Mems[out], O_LEN(op)) + len = O_LEN(op) - 1 + if (is_gray) { + # Write a single color index as the grayscale value. + do k = 0, len + call eps_putval (eps, fd, CMAP(cm,EX_RED,Mems[out+k]+1)) + } else if (use_cmap) { + # Write index values as RGB triplets. + do k = 0, len { + call eps_putval (eps, fd, + CMAP(cm,EX_RED, Mems[out+k]+1)) + call eps_putval (eps, fd, + CMAP(cm,EX_GREEN,Mems[out+k]+1)) + call eps_putval (eps, fd, + CMAP(cm,EX_BLUE, Mems[out+k]+1)) + } + } else { + do k = 0, len + call eps_putval (eps, fd, Mems[out+k]) + } + + # Clean up the pointers. + call mfree (bop, TY_CHAR) + call evvfree (op) + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + } + call mfree (out, TY_SHORT) +end + + +# EPS_RGB - Write a RGB true color EPS file. + +procedure eps_rgb (ex, eps, fd) + +pointer ex #i task struct pointer +pointer eps #i postscript struct pointer +int fd #i output file descriptor + +pointer op, bop, out +int i, j, k, line, percent, orow, type + +pointer ex_evaluate(), ex_chtype() + +begin + # Now process the expressions and write the image. + type = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + call malloc (out, EX_OCOLS(ex)+2, TY_SHORT) + do j = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Process each line in the image. + do i = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + bop = ex_chtype (ex, op, type) + + # Write evaluated pixels. + call achtbs (Memc[bop], Mems[out], O_LEN(op)) + do k = 1, O_LEN(op) + call eps_putval (eps, fd, Mems[out+k-1]) + + # Clean up the pointers. + call mfree (bop, TY_CHAR) + call evvfree (op) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + call mfree (out, TY_SHORT) +end + + +# EPS_HEADER - Write the EPS header block. + +procedure eps_header (ex, eps, color) + +pointer ex #i task struct pointer +pointer eps #i EPS struct pointer +int color #i is this a color image? + +int bp, fd, cols, rows, dpi, len +int icols, irows, devpix, turnflag +real scale, pixfac, scols, srows, llx, lly + +int strlen(), stropen() + +begin + fd = EX_FD(ex) + turnflag = NO + dpi = EX_PSDPI(ex) + scale = EX_PSSCALE(ex) + cols = EX_OCOLS(ex) + rows = EX_OROWS(ex) + + # Open the buffer as a string file and print to it. + bp = stropen (BUF(eps,1), SZ_EPSBUF, TEXT_FILE) + + # See if we need to rotate the image to fit on the page. + icols = cols + irows = rows + if (cols > rows && (scale * cols) > int (PAGEWID * MARGIN)) { + turnflag = YES + cols = irows + rows = icols + } + + # Figure out size. + devpix = dpi / 72.0 + 0.5 # device pixels per unit, approx + pixfac = 72.0 / dpi * devpix # 1, approx. + scols = scale * cols * pixfac + srows = scale * rows * pixfac + + if ( scols > PAGEWID * MARGIN || srows > PAGEHGT * MARGIN ) { + if ( scols > PAGEWID * MARGIN ) { + scale = scale * PAGEWID / scols * MARGIN + scols = scale * cols * pixfac + srows = scale * rows * pixfac + } + if ( srows > PAGEHGT * MARGIN ) { + scale = scale * PAGEHGT / srows * MARGIN + scols = scale * cols * pixfac + srows = scale * rows * pixfac + } + if (EX_VERBOSE(ex) == YES) { + call printf ("\tImage too large for page, rescaled to %g\n") + call pargr (scale) + call flush (STDOUT) + } + } + + # Center it on the page. + llx = (PAGEWID - scols) / 2 + lly = (PAGEHGT - srows) / 2 + + call fprintf (bp, "%%!PS-Adobe-2.0 EPSF-2.0\n") + call fprintf (bp, "%%%%Creator: IRAF EXPORT task\n") + call fprintf (bp, "%%%%Title: %s\n") + call pargstr (BFNAME(ex)) + call fprintf (bp, "%%%%Pages: 1\n") + call fprintf (bp, "%%%%BoundingBox: %d %d %d %d\n") + call pargi (int (llx + 0.5)) + call pargi (int (lly + 0.5)) + call pargi (int (llx + scols)) + call pargi (int (lly + srows)) + call fprintf (bp, "%%%%EndComments\n") + + call fprintf (bp, "/readstring {\n") # s -- s + call fprintf (bp, " currentfile exch readhexstring pop\n") + call fprintf (bp, "} bind def\n") + + if (color == YES && !bitset (EX_OUTFLAGS(ex),OF_CMAP)) { + call eps_defcol (bp, icols) + + call fprintf (bp, "/rpicstr %d string def\n") + call pargi (icols) + call fprintf (bp, "/gpicstr %d string def\n") + call pargi (icols) + call fprintf (bp, "/bpicstr %d string def\n") + call pargi (icols) + + } else if (color == YES && bitset (EX_OUTFLAGS(ex),OF_CMAP)) { + call eps_defcol (bp, icols) + + } else { + call fprintf (bp, "/picstr %d string def\n") + call pargi (icols) + } + + call fprintf (bp, "%%%%EndProlog\n") + call fprintf (bp, "%%%%Page: 1 1\n") + call fprintf (bp, "gsave\n") + call fprintf (bp, "%g %g translate\n") + call pargr (llx) + call pargr (lly) + call fprintf (bp, "%g %g scale\n") + call pargr (scols) + call pargr (srows) + + if (turnflag == YES) { + call fprintf (bp, + "0.5 0.5 translate 90 rotate -0.5 -0.5 translate\n") + } + + call fprintf (bp, "%d %d 8\n") + call pargi (icols) + call pargi (irows) + call fprintf (bp, "[ %d 0 0 -%d 0 %d ]\n") + call pargi (icols) + call pargi (irows) + call pargi (irows) + if (color == YES) { + if (bitset (EX_OUTFLAGS(ex), OF_CMAP)) { + call fprintf (bp, "{currentfile pix readhexstring pop}\n") + call fprintf (bp, "false 3 colorimage") + } else { + call fprintf (bp, "{ rpicstr readstring }\n") + call fprintf (bp, "{ gpicstr readstring }\n") + call fprintf (bp, "{ bpicstr readstring }\n") + call fprintf (bp, "true 3 colorimage") + } + } else { + call fprintf (bp, "{ picstr readstring }\n") + call fprintf (bp, "image") + } + call flush (bp) + call strclose (bp) + + # See if we need to pad the string to write it out correctly. + len = strlen(BUF(eps,1)) + if (mod(len,2) == 1) { + BUF(eps,len+1) = '\n' + } else { + BUF(eps,len+1) = ' ' + BUF(eps,len+2) = '\n' + } + + # Now write the contents of the string buffer to the output file. + len = strlen(BUF(eps,1)) + call strpak (BUF(eps,1), BUF(eps,1), len) + call write (fd, BUF(eps,1), len / SZB_CHAR) + call aclrc (BUF(eps,1), SZ_EPSBUF) + EPS_ITEMSPERLINE(eps) = 0 +end + + +# EPS_DEFCOL - Write out code that checks if the PostScript device in question +# knows about the 'colorimage' operator. If it doesn't, it defines +# 'colorimage' in terms of image (ie, generates a greyscale image from +# RGB data). + +procedure eps_defcol (fd, len) + +int fd #i output file descriptor +int len #i length of a scanline + +begin + call fprintf (fd, "%% build a temporary dictionary\n") + call fprintf (fd, "20 dict begin\n\n") + call fprintf (fd, + "%% define string to hold a scanline's worth of data\n") + call fprintf (fd, "/pix %d string def\n\n") + call pargi (len) + + call fprintf (fd, "\n") + call fprintf (fd, "%% define 'colorimage' if it isn't defined\n") + call fprintf (fd, + "/colorimage where %% do we know about 'colorimage'?\n") + call fprintf (fd, + " { pop } %% yes: pop off the 'dict' returned\n") + call fprintf (fd, " { %% no: define one\n") + call fprintf (fd, " /colortogray { %% define an RGB->I function\n") + call fprintf (fd, + " /rgbdata exch store %% call input 'rgbdata'\n") + call fprintf (fd, " rgbdata length 3 idiv\n") + call fprintf (fd, " /npixls exch store\n") + call fprintf (fd, " /rgbindx 0 store\n") + call fprintf (fd, + " /grays npixls string store %% str to hold the result\n") + call fprintf (fd, " 0 1 npixls 1 sub {\n") + call fprintf (fd, " grays exch\n") + call fprintf (fd, + " rgbdata rgbindx get 20 mul %% Red\n") + call fprintf (fd, + " rgbdata rgbindx 1 add get 32 mul %% Green\n") + call fprintf (fd, + " rgbdata rgbindx 2 add get 12 mul %% Blue\n") + call fprintf (fd, + " add add 64 idiv %% I = .5G + .31R + .18B\n") + call fprintf (fd, " put\n") + call fprintf (fd, " /rgbindx rgbindx 3 add store\n") + call fprintf (fd, " } for\n") + call fprintf (fd, " grays\n") + call fprintf (fd, " } bind def\n\n") + + call fprintf (fd, " %% Utility procedure for colorimage operator.\n") + call fprintf (fd, + " %% This procedure takes two procedures off the\n") + call fprintf (fd, + " %% stack and merges them into a single procedure.\n\n") + + call fprintf (fd, " /mergeprocs { %% def\n") + call fprintf (fd, " dup length\n") + call fprintf (fd, " 3 -1 roll\n") + call fprintf (fd, " dup\n") + call fprintf (fd, " length\n") + call fprintf (fd, " dup\n") + call fprintf (fd, " 5 1 roll\n") + call fprintf (fd, " 3 -1 roll\n") + call fprintf (fd, " add\n") + call fprintf (fd, " array cvx\n") + call fprintf (fd, " dup\n") + call fprintf (fd, " 3 -1 roll\n") + call fprintf (fd, " 0 exch\n") + call fprintf (fd, " putinterval\n") + call fprintf (fd, " dup\n") + call fprintf (fd, " 4 2 roll\n") + call fprintf (fd, " putinterval\n") + call fprintf (fd, " } bind def\n\n") + + call fprintf (fd, " /colorimage { %% def\n") + call fprintf (fd, " pop pop %% remove 'false 3' operands\n") + call fprintf (fd, " {colortogray} mergeprocs\n") + call fprintf (fd, " image\n") + call fprintf (fd, " } bind def\n") + call fprintf (fd, " } ifelse %% end of 'false' case\n") + call fprintf (fd, "\n\n") + call flush (fd) +end + + +# EPS_PUTVAL - Put a pixel value to the output file. + +procedure eps_putval (eps, fd, sval) + +pointer eps #i EPS struct pointer +int fd #i output file descriptor +short sval #i value to write + +int val, index +char ch, nl, sp +int shifti() + +begin + # Force value to 8-bit range. + #val = max (0, min (255, sval)) + val = sval + + if (EPS_ITEMSPERLINE(eps) >= LINEWID) { + sp = ' ' + call eps_putc (eps, fd, sp) + nl = '\n' + call eps_putc (eps, fd, nl) + EPS_ITEMSPERLINE(eps) = 0 + } + + # Get the hex string equivalent of the byte. + index = shifti (val, -4) # get left 4 bits + ch = HEXSTR(eps,index) + call eps_putc (eps, fd, ch) + + index = and (val, 0FX) # get right 4 bits + ch = HEXSTR(eps,index) + call eps_putc (eps, fd, ch) + + EPS_ITEMSPERLINE(eps) = EPS_ITEMSPERLINE(eps) + 1 +end + + +# EPS_PUTC - Put a character to the buffer. This routine also flushes the +# accumulated buffer to disk once it fills. + +procedure eps_putc (eps, fd, ch) + +pointer eps #i EPS struct pointer +int fd #i file descriptor +char ch #i character to 'write' + +begin + BUF(eps,EPS_BCNT(eps)) = ch + EPS_BCNT(eps) = EPS_BCNT(eps) + 1 + + # If we're getting close to a full buffer, write it out. + # Leave some space at the end for the epilogue. + if (EPS_BCNT(eps) > SZ_EPSBUF-64) { + call strpak (BUF(eps,1), BUF(eps,1), EPS_BCNT(eps)) + call write (fd, BUF(eps,1), EPS_BCNT(eps) / SZB_CHAR) + #call aclrc (BUF(eps,1), SZ_EPSBUF) + EPS_BCNT(eps) = 1 + } +end diff --git a/pkg/dataio/export/bltins/exgif.x b/pkg/dataio/export/bltins/exgif.x new file mode 100644 index 00000000..462b70e4 --- /dev/null +++ b/pkg/dataio/export/bltins/exgif.x @@ -0,0 +1,557 @@ +include <mach.h> +include <fset.h> +include <evvexpr.h> +include "../export.h" +include "../exbltins.h" + + +define SZ_GIFSTRUCT 30 + +define GIF_INIT_BITS Memi[$1] # initial number of bits +define GIF_MAXCODE Memi[$1+1] # max output code +define GIF_FREE_ENT Memi[$1+2] # first unused entry +define GIF_OFFSET Memi[$1+3] # offset into output buffer +define GIF_IN_COUNT Memi[$1+4] # length of input +define GIF_CUR_BITS Memi[$1+5] # current no. bits in code +define GIF_N_BITS Memi[$1+6] # no. of max bits +define GIF_CUR_ACCUM Memi[$1+7] # current accumulator +define GIF_A_COUNT Memi[$1+8] # no. of chars in 'packet' +define GIF_CLEAR_CODE Memi[$1+9] # clear hash table code +define GIF_EOF_CODE Memi[$1+10] # EOF code +define GIF_CLEAR_FLAG Memi[$1+11] # hash table has been cleared? +define GIF_CURX Memi[$1+12] # current 'x' position in image +define GIF_CURY Memi[$1+13] # current 'y' position in image +define GIF_PASS Memi[$1+14] # interlacing pass number +define GIF_WIDTH Memi[$1+15] # width of output image +define GIF_HEIGHT Memi[$1+16] # height of output image +define GIF_EXPNUM Memi[$1+17] # expression we're evaluating +define GIF_LNUM Memi[$1+18] # line w/in that expression +define GIF_NPIX Memi[$1+19] # no. of pixels to process +define GIF_PERCENT Memi[$1+20] # percent of file completed + +define GIF_CDPTR Memi[$1+25] # compressed data (ptr) +define GIF_HPTR Memi[$1+26] # hash table (ptr) +define GIF_APTR Memi[$1+27] # packet accumulator (ptr) +define GIF_DPTR Memi[$1+28] # expression data (ptr) +define GIF_CPTR Memi[$1+29] # code table (ptr) + +define ACCUM Mems[GIF_APTR($1)+$2] +define HTAB Memi[GIF_HPTR($1)+$2] +define CODETAB Memi[GIF_CPTR($1)+$2] +define DATA Mems[GIF_DPTR($1)+$2-1] +define CDATA Mems[GIF_CDPTR($1)+$2] + +define HSIZE 5003 # 80% occupancy +define USE_INTERLACE true # Write interlaced GIF files? + +#---------------------------------------------------------------------------- +define INTERLACE 040X # Image descriptor flags +define GLOBAL_COLORMAP 080X +define LOCAL_COLORMAP 080X # (currently unused) + +# Define the flags for the GIF89a extension blocks (currently unused). +define GE_PLAINTEXT 001X # Plain Text Extension +define GE_APPLICATION 0FFX # Application Extension +define GE_COMMENT 0FEX # Comment Extension +define GE_GCONTROL 0F9X # Graphics Control Extension + + +# EX_GIF - Write the output image to a GIF 87a file. + +procedure ex_gif (ex) + +pointer ex #i task struct pointer + +pointer gif +int nbytes, flags + +char ch[2] +int or() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for GIF file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for GIF file.") + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Allocate the gif structure. + iferr { + call calloc (gif, SZ_GIFSTRUCT, TY_STRUCT) + call calloc (GIF_APTR(gif), 257, TY_SHORT) + call calloc (GIF_HPTR(gif), HSIZE, TY_INT) + call calloc (GIF_CPTR(gif), HSIZE, TY_INT) + call calloc (GIF_DPTR(gif), max(256,EX_OCOLS(ex)), TY_SHORT) + call calloc (GIF_CDPTR(gif), (2*EX_OROWS(ex)*EX_OCOLS(ex)),TY_SHORT) + } then + call error (0, "Error allocating gif structure.") + + GIF_WIDTH(gif) = EX_OCOLS(ex) + GIF_HEIGHT(gif) = EX_OROWS(ex) + GIF_NPIX(gif) = EX_OROWS(ex) * EX_OCOLS(ex) + GIF_CURX(gif) = 1 + GIF_CURY(gif) = 0 + GIF_PASS(gif) = 1 + GIF_EXPNUM(gif) = EX_NEXPR(ex) + GIF_LNUM(gif) = GIF_HEIGHT(gif) + + # Write the header information. + call gif_wheader (ex, EX_FD(ex)) + + # Start processing the expressions and write compressed image data. + call gif_compress (ex, gif, EX_FD(ex)) + + # Write the GIF file terminator and dump the whole thing to disk. + if (mod(GIF_OFFSET(gif),2) == 1) { + CDATA(gif,GIF_OFFSET(gif)) = '\0' + GIF_OFFSET(gif) = GIF_OFFSET(gif) + 1 + ch[1] = ';' + ch[2] = ';' + nbytes = (GIF_OFFSET(gif) + 1) / SZB_CHAR + } else { + ch[1] = '\0' + ch[2] = ';' + nbytes = GIF_OFFSET(gif) / SZB_CHAR + } + call achtsb (CDATA(gif,0), CDATA(gif,0), GIF_OFFSET(gif)) + call write (EX_FD(ex), CDATA(gif,0), nbytes) + call achtsb (ch, ch, 2) + call write (EX_FD(ex), ch, 1) + + # Clean up the pointers. + call mfree (GIF_APTR(gif), TY_SHORT) + call mfree (GIF_DPTR(gif), TY_SHORT) + call mfree (GIF_CDPTR(gif), TY_SHORT) + call mfree (GIF_HPTR(gif), TY_INT) + call mfree (GIF_CPTR(gif), TY_INT) + call mfree (gif, TY_STRUCT) +end + + +# GIF_WHEADER - Write the GIF header information. This covers not only the +# global file header but all the preliminary stuff up until the actual image +# data + +procedure gif_wheader (ex, fd) + +pointer ex #i tast struct pointer +int fd #i output file descriptor + +char sig[7] # GIF signature +char lsd[772] # Screen and Color Map information +short SWidth, SHeight # Screen width and height + +short stmp +int i, j + +int shifti(), ori() + +define GIF_SIGNATURE "GIF87a" + +begin + fd = EX_FD(ex) + + # Write the GIF signature. This is technically the "header", following + # this are the scene/color/image descriptors. + call strcpy (GIF_SIGNATURE, sig, 7) + call strpak (sig, sig, 7) + call write (fd, sig, 7/SZB_CHAR) + + # Logical Screen Descriptor. + SWidth = EX_OCOLS(ex) + SHeight = EX_OROWS(ex) + call gif_putword (fd, SWidth) + call gif_putword (fd, SHeight) + + # Set the 'packed' flags and write it out + i = 0 + i = ori (i, GLOBAL_COLORMAP) # indicate a colormap + i = ori (i, (shifti(7, 4))) # color resolution + i = ori (i, (8-1)) # bits per pixel + lsd[1] = i # packed flags + lsd[2] = 0 # background color + lsd[3] = 0 # aspect ratio + lsd[4] = 0 # filler expansion byte + + # Write out the colormap. + if (EX_CMAP(ex) != NULL) { + j = 1 + for (i=4 ; i <= 772; i=i+3) { + lsd[i ] = CMAP(EX_CMAP(ex), EX_RED, j) + lsd[i+1] = CMAP(EX_CMAP(ex), EX_GREEN, j) + lsd[i+2] = CMAP(EX_CMAP(ex), EX_BLUE, j) + j = j + 1 + } + } else { + j = 0 + for (i=4 ; i <= 772; i=i+3) { + lsd[i ] = j + lsd[i+1] = j + lsd[i+2] = j + j = j + 1 + } + } + lsd[772] = ',' + call achtcb (lsd, lsd, 772) + call write (fd, lsd, 772/SZB_CHAR) + + # Write the image header. + stmp = 0 + call gif_putword (fd, stmp) + call gif_putword (fd, stmp) + call gif_putword (fd, SWidth) + call gif_putword (fd, SHeight) + + # Next set the interlace flag and the initial code size in the next + # two bytes. + if (USE_INTERLACE) + stmp = ori (shifti(INTERLACE,8), 8) + else + stmp = 8 + if (BYTE_SWAP2 == YES) + call bswap2 (stmp, 1, stmp, 1, 2) + call write (fd, stmp, 1) +end + + +# GIF_COMPRESS - Compress the image data using a modified LZW. + +procedure gif_compress (ex, gif, fd) + +pointer ex #i tast struct pointer +pointer gif #i gif struct pointer +int fd #i output file descriptor + +long fcode +int i, c, ent, disp +int hsize_reg, hshift + +short gif_next_pixel() +int xori(), shifti() + +define probe_ 99 +define nomatch_ 98 + +begin + GIF_INIT_BITS(gif) = 9 # initialize + GIF_N_BITS(gif) = 9 + GIF_OFFSET(gif) = 0 + GIF_CLEAR_FLAG(gif) = NO + GIF_IN_COUNT(gif) = 1 + GIF_MAXCODE(gif) = 511 + GIF_CLEAR_CODE(gif) = 256 + GIF_EOF_CODE(gif) = GIF_CLEAR_CODE(gif) + 1 + GIF_FREE_ENT(gif) = GIF_CLEAR_CODE(gif) + 2 + GIF_A_COUNT(gif) = 0 + + ent = gif_next_pixel (ex, gif) + hshift = 0 + for (fcode = HSIZE; fcode < 65536 ; fcode = fcode * 2) + hshift = hshift + 1 + hshift = 8-hshift # set hash code range bound + + hsize_reg = HSIZE # clear the hash table + call amovki (-1, HTAB(gif,0), HSIZE) + + call gif_output (fd, gif, GIF_CLEAR_CODE(gif)) + + # Now loop over the pixels. + repeat { + c = gif_next_pixel (ex, gif) + if (c == EOF) + break + GIF_IN_COUNT(gif) = GIF_IN_COUNT(gif) + 1 + + fcode = shifti (c, 12) + ent + i = xori (shifti (c, hshift), ent) + + if (HTAB(gif,i) == fcode) { + ent = CODETAB(gif,i) + next + } else if (HTAB(gif,i) < 0) # empty slot + goto nomatch_ + disp = hsize_reg - i # secondary hash (after G. Knott) + if (i == 0) + disp = 1 + +probe_ i = i - disp + if (i < 0) + i = i + hsize_reg + + if (HTAB(gif,i) == fcode) { + ent = CODETAB(gif,i) + next + } + if (HTAB(gif,i) >= 0) + goto probe_ + +nomatch_ call gif_output (fd, gif, ent) + ent = c + if (GIF_FREE_ENT(gif) < 4096) { + CODETAB(gif,i) = GIF_FREE_ENT(gif) + GIF_FREE_ENT(gif) = GIF_FREE_ENT(gif) + 1 + HTAB(gif,i) = fcode + } else { + # Clear out the hash table. + call amovki (-1, HTAB(gif,0), HSIZE) + GIF_FREE_ENT(gif) = GIF_CLEAR_CODE(gif) + 2 + GIF_CLEAR_FLAG(gif) = YES + call gif_output (fd, gif, GIF_CLEAR_CODE(gif)) + } + } + + # Write out the final code. + call gif_output (fd, gif, ent) + call gif_output (fd, gif, GIF_EOF_CODE(gif)) +end + + +# GIF_NEXT_PIXEL - Writes a 16-bit integer in GIF order (LSB first). + +short procedure gif_next_pixel (ex, gif) + +pointer ex #i tast struct pointer +pointer gif #i gif struct pointer + +short pix +pointer op, out +pointer ex_chtype(), ex_evaluate() + +begin + if (GIF_NPIX(gif) == 0) + return (EOF) + + # If the current X position is at the start of a line get the new + # data, otherwise just return what we already know. + pix = 1 + if (GIF_CURX(gif) == 1) { + call ex_getpix (ex, GIF_LNUM(gif)) + op = ex_evaluate (ex, O_EXPR(ex,GIF_EXPNUM(gif))) + out = ex_chtype (ex, op, TY_UBYTE) + call aclrs (DATA(gif,1), O_LEN(op)) + call achtbu (Memc[out], DATA(gif,1), O_LEN(op)) + call mfree (out, TY_CHAR) + call evvfree (op) + } + pix = DATA(gif,GIF_CURX(gif)) + + # Increment the position. + if (GIF_CURY(gif) == EX_OROWS(ex)) { + GIF_CURX(gif) = min (EX_OCOLS(ex), GIF_CURX(gif) + 1) + } else + call gif_bump_pixel (ex, gif) + + GIF_NPIX(gif) = GIF_NPIX(gif) - 1 + return (pix) +end + + +# GIF_BUMP_PIXEL - Update the current x and y values for interlacing. + +procedure gif_bump_pixel (ex, gif) + +pointer ex #i tast struct pointer +pointer gif #i gif struct pointer + +int i, row, sum + +begin + GIF_CURX(gif) = GIF_CURX(gif) + 1 + + # If we are at the end of a scan line, set curx back to the beginning + # Since we are interlaced, bump the cury to the appropriate spot. + + if (GIF_CURX(gif) > GIF_WIDTH(gif)) { + GIF_CURX(gif) = 1 + + if (USE_INTERLACE) { + switch (GIF_PASS(gif)) { + case 1: + GIF_CURY(gif) = GIF_CURY(gif) + 8 + if (GIF_CURY(gif) >= GIF_HEIGHT(gif)) { + GIF_PASS(gif) = GIF_PASS(gif) + 1 + GIF_CURY(gif) = 4 + } + case 2: + GIF_CURY(gif) = GIF_CURY(gif) + 8 + if (GIF_CURY(gif) >= GIF_HEIGHT(gif)) { + GIF_PASS(gif) = GIF_PASS(gif) + 1 + GIF_CURY(gif) = 2 + } + case 3: + GIF_CURY(gif) = GIF_CURY(gif) + 4 + if (GIF_CURY(gif) >= GIF_HEIGHT(gif)) { + GIF_PASS(gif) = GIF_PASS(gif) + 1 + GIF_CURY(gif) = 1 + } + case 4: + GIF_CURY(gif) = GIF_CURY(gif) + 2 + if (GIF_CURY(gif) >= GIF_HEIGHT(gif)) { + GIF_EXPNUM(gif) = EX_NEXPR(ex) + GIF_LNUM(gif) = EX_OROWS(ex) + GIF_CURY(gif) = GIF_HEIGHT(gif) + return + } + } + + # Now figure out where we are in the expressions. + i = EX_NEXPR(ex) + sum = GIF_HEIGHT(gif) + while (sum >= GIF_CURY(gif)) { + sum = sum - O_HEIGHT(ex,i) + i = i - 1 + } + GIF_EXPNUM(gif) = i + 1 + GIF_LNUM(gif) = (sum + O_HEIGHT(ex,i+1)) - GIF_CURY(gif) + 1 + + row = ((EX_OROWS(ex) * EX_OCOLS(ex)) - GIF_NPIX(gif)) / + EX_OCOLS(ex) + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, row, GIF_PERCENT(gif)) + + } else { + GIF_CURY(gif) = GIF_CURY(gif) + 1 + + # Now figure out where we are in the expressions. + i = EX_NEXPR(ex) + sum = GIF_HEIGHT(gif) + while (sum >= GIF_CURY(gif)) { + sum = sum - O_HEIGHT(ex,i) + i = i - 1 + } + + if ((i+1) == GIF_EXPNUM(gif)) { + GIF_LNUM(gif) = GIF_LNUM(gif) - 1 + } else { + GIF_EXPNUM(gif) = i + 1 + GIF_LNUM(gif) = O_HEIGHT(ex,i+1) + } + + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, GIF_CURY(gif), GIF_PERCENT(gif)) + } + } +end + + +# GIF_OUTPUT - Output the given code. + +procedure gif_output (fd, gif, code) + +int fd #i output file descriptor +pointer gif #i gif struct pointer +int code #i code to output + +long masks[17] +int i + +int ori(), andi(), shifti() + +data (masks(i), i=1,5) /00000X, 00001X, 00003X, 00007X, 0000FX/ +data (masks(i), i=6,9) /0001FX, 0003FX, 0007FX, 000FFX/ +data (masks(i), i=10,13) /001FFX, 003FFX, 007FFX, 00FFFX/ +data (masks(i), i=14,17) /01FFFX, 03FFFX, 07FFFX, 0FFFFX/ + +begin + GIF_CUR_ACCUM(gif) = andi(GIF_CUR_ACCUM(gif),masks[GIF_CUR_BITS(gif)+1]) + + if (GIF_CUR_BITS(gif) > 0) + GIF_CUR_ACCUM(gif) = ori (GIF_CUR_ACCUM(gif), + shifti (code, GIF_CUR_BITS(gif))) + else + GIF_CUR_ACCUM(gif) = code + GIF_CUR_BITS(gif) = GIF_CUR_BITS(gif) + GIF_N_BITS(gif) + + while (GIF_CUR_BITS(gif) >= 8) { + call char_out (fd, gif, andi (GIF_CUR_ACCUM(gif), 0FFX)) + GIF_CUR_ACCUM(gif) = shifti (GIF_CUR_ACCUM(gif), -8) + GIF_CUR_BITS(gif) = GIF_CUR_BITS(gif) - 8 + } + + # If the next entry is going to be too big for the code size then + # increase it if possible. + if (GIF_FREE_ENT(gif) > GIF_MAXCODE(gif) || GIF_CLEAR_FLAG(gif)==YES) { + if (GIF_CLEAR_FLAG(gif) == YES) { + GIF_MAXCODE(gif) = 511 + GIF_N_BITS(gif) = 9 + GIF_CLEAR_FLAG(gif) = NO + } else { + GIF_N_BITS(gif) = GIF_N_BITS(gif) + 1 + if (GIF_N_BITS(gif) == 12) + GIF_MAXCODE(gif) = 4096 + else + GIF_MAXCODE(gif) = shifti (1, GIF_N_BITS(gif)) - 1 + } + } + + if (code == GIF_EOF_CODE(gif)) { + # At EOF, write the rest of the buffer. + while (GIF_CUR_BITS(gif) >= 8) { + call char_out (fd, gif, andi (GIF_CUR_ACCUM(gif), 0FFX)) + GIF_CUR_ACCUM(gif) = shifti (GIF_CUR_ACCUM(gif), -8) + GIF_CUR_BITS(gif) = GIF_CUR_BITS(gif) - 8 + } + + call flush_char (gif) + call flush (fd) + } +end + + +# GIF_PUTWORD - Writes a 16-bit integer in GIF order (LSB first). + +procedure gif_putword (fd, w) + +int fd +short w + +short val +int tmp, shifti() + +begin + # If this is a MSB-first machine swap the bytes before output. + if (BYTE_SWAP2 == NO) { + call bitpak (int(w), tmp, 9, 8) + call bitpak (shifti(int(w),-8), tmp, 1, 8) + val = tmp + } else + val = w + + call write (fd, val, SZ_SHORT/SZ_CHAR) +end + + +procedure char_out (fd, gif, c) + +int fd #i output file descriptor +pointer gif #i gif struct pointer +int c #i char to output + +begin + ACCUM(gif,GIF_A_COUNT(gif)) = c + GIF_A_COUNT(gif) = GIF_A_COUNT(gif) + 1 + if (GIF_A_COUNT(gif) >= 254) + call flush_char (gif) +end + + +procedure flush_char (gif) + +pointer gif #i gif struct pointer + +begin + if (GIF_A_COUNT(gif) > 0) { + CDATA(gif,GIF_OFFSET(gif)) = GIF_A_COUNT(gif) + GIF_OFFSET(gif) = GIF_OFFSET(gif) + 1 + call amovs (ACCUM(gif,0), CDATA(gif,GIF_OFFSET(gif)), + GIF_A_COUNT(gif)) + GIF_OFFSET(gif) = GIF_OFFSET(gif) + GIF_A_COUNT(gif) + GIF_A_COUNT(gif) = 0 + } +end diff --git a/pkg/dataio/export/bltins/exiraf.x b/pkg/dataio/export/bltins/exiraf.x new file mode 100644 index 00000000..282cf383 --- /dev/null +++ b/pkg/dataio/export/bltins/exiraf.x @@ -0,0 +1,110 @@ +include <imhdr.h> +include <mach.h> +include <evvexpr.h> +include "../export.h" + + +# EX_IRAF - Write the evaluated expressions back out as an IRAF image. + +procedure ex_iraf (ex) + +pointer ex #i task struct pointer + +pointer sp, imname +pointer im, op, out +int i, j, flags +int line, percent, orow, type + +pointer ex_evaluate(), ex_chtype() +pointer immap() +pointer impl2s(), impl2i(), impl2l(), impl2r(), impl2d() +int fnroot() + +errchk immap + +begin + # Check to see that we have the correct number of expressions. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for IRAF image.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for IRAF image.") + if (EX_OUTTYPE(ex) == TY_UBYTE) + call ex_do_outtype (ex, "u2") + + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call aclrc (Memc[imname], SZ_FNAME) + + # Since we're writing an image, close the output file descriptor + # and instead use an image pointer. + call close (EX_FD(ex)) + call delete (BFNAME(ex)) + EX_FD(ex) = NULL + + # Generate the image name and map it for processing. + if (fnroot (BFNAME(ex), Memc[imname], SZ_FNAME) == 0) + call error (0, "Error making image name.") + iferr (im = immap (Memc[imname], NEW_IMAGE, 0)) + call error (0, "Error mapping output image.") + + # Set the minimal header values. + IM_LEN(im,1) = EX_OCOLS(ex) + IM_LEN(im,2) = EX_OROWS(ex) + IM_NDIM(im) = 2 + IM_PIXTYPE(im) = EX_OUTTYPE(ex) + + # Finally, evaluate the expressions and write the image. + type = EX_OUTTYPE(ex) + percent = 0 + orow = 1 + do i = 1, EX_NEXPR(ex) { + + # Process each line in the image. + do j = 1, O_HEIGHT(ex,i) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, type) + + # Write evaluated pixels. + switch (type) { + case TY_USHORT, TY_SHORT: + call amovs (Mems[out], Mems[impl2s(im,orow)], O_LEN(op)) + case TY_INT: + call amovi (Memi[out], Memi[impl2i(im,orow)], O_LEN(op)) + case TY_LONG: + call amovl (Meml[out], Meml[impl2l(im,orow)], O_LEN(op)) + case TY_REAL: + call amovr (Memr[out], Memr[impl2r(im,orow)], O_LEN(op)) + case TY_DOUBLE: + call amovd (Memd[out], Memd[impl2d(im,orow)], O_LEN(op)) + default: + call error (0, "Illegal output image type.") + } + + # Clean up the pointers. + call mfree (out, type) + call evvfree (op) + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + } + + call imunmap (im) + call sfree (sp) +end diff --git a/pkg/dataio/export/bltins/exmiff.x b/pkg/dataio/export/bltins/exmiff.x new file mode 100644 index 00000000..9e5756e5 --- /dev/null +++ b/pkg/dataio/export/bltins/exmiff.x @@ -0,0 +1,81 @@ +include <mach.h> +include "../export.h" + + +# EX_MIFF - Write the evaluated expressions as an ImageMagick MIFF format file. + +procedure ex_miff (ex) + +pointer ex #i task struct pointer + +pointer sp, hdr, cmap +int i, j, flags +char ncols[6] + +int strlen() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 3 && EX_NEXPR(ex) != 1) + call error (7, "Invalid number of expressions for MIFF file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for MIFF file.") + + # Write the header to the file. + call smark (sp) + call salloc (hdr, SZ_COMMAND, TY_CHAR) + call aclrc (Memc[hdr], SZ_COMMAND) + + call sprintf (ncols, 6, "%d") + call pargi (EX_NCOLORS(ex)) + call sprintf (Memc[hdr], SZ_COMMAND, + "{\nCreated by IRAF EXPORT Task\n}\nid=ImageMagick\nclass=%s %s%s\ncolumns=%-5d rows=%-5d\n\f\n:\n") + + if (EX_NEXPR(ex) == 3) { + call pargstr ("DirectClass") + call pargstr ("") + call pargstr ("") + } else { + call pargstr ("PseudoClass") + if (bitset (flags,OF_CMAP)) { + call pargstr ("colors=") + call pargstr (ncols) + } else { + call pargstr ("") + call pargstr ("") + } + } + call pargi (EX_OCOLS(ex)) + call pargi (EX_OROWS(ex)) + + if (mod(strlen(Memc[hdr]),2) == 1) + call strcat ("\n", Memc[hdr], SZ_COMMAND) + call strpak (Memc[hdr], Memc[hdr], SZ_COMMAND) + call write (EX_FD(ex), Memc[hdr], strlen(Memc[hdr])/SZB_CHAR) + + # Finally, evaluate the expressions and write the image. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + if (bitset (flags,OF_CMAP)) { + # Write out the colormap. + call salloc (cmap, 3*CMAP_SIZE, TY_CHAR) + j = 1 + do i = 0, (3*CMAP_SIZE-1), 3 { + Memc[cmap+i+0] = CMAP(EX_CMAP(ex), EX_RED, j) + Memc[cmap+i+1] = CMAP(EX_CMAP(ex), EX_GREEN, j) + Memc[cmap+i+2] = CMAP(EX_CMAP(ex), EX_BLUE, j) + j = j + 1 + } + call achtcb (Memc[cmap], Memc[cmap], (3 * CMAP_SIZE)) + call write (EX_FD(ex), Memc[cmap], ((3 * CMAP_SIZE) / SZB_CHAR)) + + call ex_no_interleave (ex) # write the pixels + + } else + call ex_px_interleave (ex) + + call sfree (sp) +end diff --git a/pkg/dataio/export/bltins/expgm.x b/pkg/dataio/export/bltins/expgm.x new file mode 100644 index 00000000..c8a7a1d7 --- /dev/null +++ b/pkg/dataio/export/bltins/expgm.x @@ -0,0 +1,47 @@ +include <mach.h> +include "../export.h" + + +# EX_PGM - Write the evaluated expressions as a PGM format file. + +procedure ex_pgm (ex) + +pointer ex #i task struct pointer + +pointer sp, hdr +int len, flags + +int strlen() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for PGM file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for PGM file.") + + # Write the header to the file. + call smark (sp) + call salloc (hdr, SZ_LINE, TY_CHAR) + call aclrc (Memc[hdr], SZ_LINE) + + call sprintf (Memc[hdr], SZ_LINE, "P5\n%-6d %-6d\n255\n") + call pargi (EX_OCOLS(ex) - mod (EX_OCOLS(ex),2)) + call pargi (EX_OROWS(ex)) + len = strlen (Memc[hdr]) + call strpak (Memc[hdr], Memc[hdr], SZ_LINE) + call write (EX_FD(ex), Memc[hdr], len/SZB_CHAR) + call sfree (sp) + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Finally, evaluate the expressions and write the image. + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) + call ex_no_interleave (ex) + else + call error (7, "Shouldn't be here.") +end diff --git a/pkg/dataio/export/bltins/exppm.x b/pkg/dataio/export/bltins/exppm.x new file mode 100644 index 00000000..4dab4727 --- /dev/null +++ b/pkg/dataio/export/bltins/exppm.x @@ -0,0 +1,49 @@ +include <mach.h> +include "../export.h" + + +# EX_PPM - Write the evaluated expressions as a PPM format file. + +procedure ex_ppm (ex) + +pointer ex #i task struct pointer + +pointer sp, hdr +int len, flags + +int strlen() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 3) + call error (7, "Invalid number of expressions for PPM file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for PPM file.") + + # Write the header to the file. + call smark (sp) + call salloc (hdr, SZ_LINE, TY_CHAR) + call aclrc (Memc[hdr], SZ_LINE) + + # If we have an odd number of pixels we can't correctly write the + # last column to the file, so truncate the column in the output image. + if (mod (EX_NCOLS(ex),2) == 1) + EX_OCOLS(ex) = EX_OCOLS(ex) - 1 + + call sprintf (Memc[hdr], SZ_LINE, "P6\n%-6d %-6d\n255\n") + call pargi (EX_OCOLS(ex)) + call pargi (EX_OROWS(ex)) + len = strlen (Memc[hdr]) + call strpak (Memc[hdr], Memc[hdr], SZ_LINE) + call write (EX_FD(ex), Memc[hdr], len/SZB_CHAR) + call sfree (sp) + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Finally, evaluate the expressions and write the image. + call ex_px_interleave (ex) +end diff --git a/pkg/dataio/export/bltins/exras.x b/pkg/dataio/export/bltins/exras.x new file mode 100644 index 00000000..f24209c6 --- /dev/null +++ b/pkg/dataio/export/bltins/exras.x @@ -0,0 +1,117 @@ +include <mach.h> +include "../export.h" + + +# EXRAS.X - Source file for the EXPORT task rasterfile builtin format. + +define SZ_RASHDR 8 +define RAS_MAGIC 1 # Magic number +define RAS_WIDTH 2 # Image width (pixels per line) +define RAS_HEIGHT 3 # Image height (number of lines) +define RAS_DEPTH 4 # Image depth (bits per pixel) +define RAS_LENGTH 5 # Image length (bytes) +define RAS_TYPE 6 # File type +define RAS_MAPTYPE 7 # Colormap type +define RAS_MAPLENGTH 8 # Colormap length (bytes) + +# Rasterfile magic number +define RAS_MAGIC_NUM 59A66A95X +define RAS_RLE 80X + +# Sun supported ras_types +define RT_OLD 0 # Raw pixrect image in 68000 byte order +define RT_STANDARD 1 # Raw pixrect image in 68000 byte order +define RT_BYTE_ENCODED 2 # Run-length compression of bytes +define RT_FORMAT_RGB 3 # XRGB or RGB instead of XBGR or BGR +define RT_FORMAT_TIFF 4 # tiff <-> standard rasterfile +define RT_FORMAT_IFF 5 # iff (TAAC format) <-> standard rasterfile +define RT_EXPERIMENTAL 65535 # Reserved for testing + +# Sun supported ras_maptypes +define RMT_NONE 0 # ras_maplength is expected to be 0 +define RMT_EQUAL_RGB 1 # red[ras_maplength/3],green[],blue[] +define RMT_RAW 2 + + + +# EX_RAS - Write the evaluated expressions as a Sun Rasterfile. + +procedure ex_ras (ex) + +pointer ex #i task struct pointer + +pointer sp, cmap +long header[SZ_RASHDR] +int i, flags + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && EX_NEXPR(ex) != 3 && EX_NEXPR(ex) != 4) { + if (!bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for rasterfile.") + } + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for rasterfile.") + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Make sure the output is padded to the nearest 16-bits. + if (mod (O_WIDTH(ex,1),2) != 0) { + do i = 1, EX_NEXPR(ex) { + call strcat ("//repl(0,1)", O_EXPR(ex,i), SZ_EXPSTR) + O_WIDTH(ex,i) = O_WIDTH(ex,i) + 1 + } + EX_OCOLS(ex) = EX_OCOLS(ex) + 1 + } + + # Set the header values. + header[RAS_MAGIC] = RAS_MAGIC_NUM + header[RAS_WIDTH] = EX_OCOLS(ex) + header[RAS_HEIGHT] = EX_OROWS(ex) + header[RAS_TYPE] = RT_STANDARD + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) { + header[RAS_LENGTH] = header[RAS_WIDTH] * header[RAS_HEIGHT] + header[RAS_DEPTH] = long (8) + } else { + header[RAS_LENGTH] = header[RAS_WIDTH] * header[RAS_HEIGHT] * 3 + header[RAS_DEPTH] = long (24) + header[RAS_TYPE] = RT_FORMAT_RGB + } + if (bitset(flags, OF_CMAP)) { + header[RAS_MAPTYPE] = RMT_EQUAL_RGB + header[RAS_MAPLENGTH] = long (3*CMAP_SIZE) + } else { + header[RAS_MAPTYPE] = RMT_NONE + header[RAS_MAPLENGTH] = long (0) + } + + # Write the header to the file. First swap it to Sun byte order if + # needed (although the format doesn't require this), then swap it + # if requested by the user. + if (BYTE_SWAP4 == YES) + call bswap4 (header, 1, header, 1, (SZ_RASHDR * SZ_LONG * SZB_CHAR)) + if (EX_BSWAP(ex) == S_I4) + call bswap4 (header, 1, header, 1, (SZ_RASHDR * SZ_LONG * SZB_CHAR)) + call write (EX_FD(ex), header, (SZ_RASHDR * SZ_LONG)) + + # If we have a colormap write that out now. + if (bitset(flags, OF_CMAP)) { + call smark (sp) + call salloc (cmap, 3*CMAP_SIZE, TY_CHAR) + + call achtcb (Memc[EX_CMAP(ex)], Memc[cmap], (3 * CMAP_SIZE)) + call write (EX_FD(ex), Memc[cmap], ((3 * CMAP_SIZE) / SZB_CHAR)) + + call sfree (sp) + } + + # Finally, evaluate the expressions and write the image. + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) + call ex_no_interleave (ex) + else if (EX_NEXPR(ex) == 3 || EX_NEXPR(ex) == 4) + call ex_px_interleave (ex) +end diff --git a/pkg/dataio/export/bltins/exrgb.x b/pkg/dataio/export/bltins/exrgb.x new file mode 100644 index 00000000..119168e6 --- /dev/null +++ b/pkg/dataio/export/bltins/exrgb.x @@ -0,0 +1,74 @@ +include <mach.h> +include "../export.h" +include "../exbltins.h" + + +define IMAGIC 0732B # SGI magic number +define BPPMASK 00FFX +define ITYPE_VERBATIM 0001X +define ITYPE_RLE 0100X + + +# EX_RGB - Write the output image to an SGI RGB format file. + +procedure ex_rgb (ex) + +pointer ex #i task struct pointer + +int i, fd +short imagic, type, dim # stuff saved on disk +short xsize, ysize, zsize, pad +long min, max +char name[80] + +begin + # Check to see that we have the correct number of expressions to + # write this format. + if (EX_NEXPR(ex) != 3) + call error (7, "Invalid number of expressions for SGI RGB.") + + # Fix up the number of output rows. + EX_OROWS(ex) = EX_NLINES(ex) * EX_NEXPR(ex) + + # Load the image header values + imagic = IMAGIC + type = ITYPE_VERBATIM + if (EX_NEXPR(ex) >= 3 && !bitset (EX_OUTFLAGS(ex),OF_BAND)) { + dim = 3 + zsize = 3 + } else { + dim = 2 + zsize = 1 + } + xsize = EX_OCOLS(ex) + ysize = EX_NLINES(ex) + min = 0 + max = 255 + call aclrc (name, 80) + call strcpy ("no name", name, 80) + call achtcb (name, name, 80) + + # Write the header values to the output file. + fd = EX_FD(ex) + call write (fd, imagic, SZ_SHORT / SZ_CHAR) + call write (fd, type, SZ_SHORT / SZ_CHAR) + call write (fd, dim, SZ_SHORT / SZ_CHAR) + call write (fd, xsize, SZ_SHORT / SZ_CHAR) + call write (fd, ysize, SZ_SHORT / SZ_CHAR) + call write (fd, zsize, SZ_SHORT / SZ_CHAR) + call write (fd, min, SZ_LONG / SZ_CHAR) + call write (fd, max, SZ_LONG / SZ_CHAR) + call write (fd, 0, SZ_LONG / SZ_CHAR) + call write (fd, name, 8 / SZB_CHAR) + + # Pad to a 512 byte header. + pad = 0 + do i = 1, 240 + call write (fd, pad, SZ_SHORT / SZ_CHAR) + + # Fix the output parameters. + call ex_do_outtype (ex, "b1") + + # Write it out. + call ex_no_interleave (ex) +end diff --git a/pkg/dataio/export/bltins/exvicar.x b/pkg/dataio/export/bltins/exvicar.x new file mode 100644 index 00000000..31c8360f --- /dev/null +++ b/pkg/dataio/export/bltins/exvicar.x @@ -0,0 +1,111 @@ +include <mach.h> +include "../export.h" + + +define SZ_VICHDR 1024 + + +# EX_VICAR - Write the evaluated expressions as a VICAR2 format file. + +procedure ex_vicar (ex) + +pointer ex #i task struct pointer + +pointer sp, hdr, user, date, arch +int i, flags +char space + +int envfind(), strncmp(), strlen() +long clktime() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + if (EX_NEXPR(ex) != 1 && !bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for VICAR file.") + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for VICAR file.") + + # Write the header to the file. + call smark (sp) + call salloc (hdr, SZ_VICHDR, TY_CHAR) + call salloc (user, SZ_FNAME, TY_CHAR) + call salloc (date, SZ_FNAME, TY_CHAR) + call salloc (arch, SZ_FNAME, TY_CHAR) + + space = ' ' + call amovkc (space, Memc[hdr], SZ_VICHDR) + call aclrc (Memc[user], SZ_FNAME) + call aclrc (Memc[date], SZ_FNAME) + call aclrc (Memc[arch], SZ_FNAME) + + # Header keywords: + call getuid (Memc[user], SZ_FNAME) + call cnvtime (clktime(long(0)), Memc[date], SZ_FNAME) + call sprintf (Memc[hdr], SZ_VICHDR, + "LBLSIZE=%d FORMAT='%s' TYPE='IMAGE' BUFSIZ=20480 DIM=3 EOL=0 RECSIZE=%d ORG='%s' NL=%d NS=%d NB=%d N1=%d N2=%d N3=%d N4=0 NBB=0 NLB=0 INTFMT='%s' REALFMT='%s' TASK='EXPORT' USER='%s' DAT_TIM='%s' ") + + call pargi (SZ_VICHDR) # LBLSIZE + switch (EX_OUTTYPE(ex)) { # FORMAT + case TY_UBYTE: call pargstr ("BYTE") + case TY_SHORT: call pargstr ("HALF") + case TY_INT: call pargstr ("FULL") + case TY_LONG: call pargstr ("FULL") + case TY_REAL: call pargstr ("REAL") + case TY_DOUBLE: call pargstr ("DOUB") + } + call pargi (EX_OCOLS(ex)) # RECSIZE + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call pargstr ("BIL") # ORG + else + call pargstr ("BSQ") + call pargi (EX_OROWS(ex)) # NL + call pargi (EX_OCOLS(ex)) # NS + call pargi (EX_NEXPR(ex)) # NB + call pargi (EX_OCOLS(ex)) # N1 + call pargi (EX_OROWS(ex)) # N2 + call pargi (EX_NEXPR(ex)) # N3 + if (BYTE_SWAP2 == NO) + call pargstr ("HIGH") # INTFMT + else + call pargstr ("LOW") + if (IEEE_USED == YES) { # REALFMT + if (envfind ("arch", Memc[arch], SZ_FNAME) != ERR) { + # If this is a DECstation we have a different IEEE. + if (strncmp(Memc[arch], ".d", 2) == 0) + call pargstr ("RIEEE") + else + call pargstr ("IEEE") + } + } else { + # Assume it's a VAX. + call pargstr ("VAX") + } + call pargstr (Memc[user]) # USER + call pargstr (Memc[date]) # DAT_TIM + + i = SZ_VICHDR + while (Memc[hdr+i-1] != EOS && i > 0) + i = i - 1 + Memc[hdr+i-1] = ' ' + + call strpak (Memc[hdr], Memc[hdr], SZ_VICHDR) + call write (EX_FD(ex), Memc[hdr], strlen(Memc[hdr])/SZB_CHAR) + call sfree (sp) + + # Fix the output pixel type to single bytes. + switch (EX_OUTTYPE(ex)) { + case TY_UBYTE: call ex_do_outtype (ex, "b1") + case TY_SHORT: call ex_do_outtype (ex, "i2") + case TY_INT: call ex_do_outtype (ex, "i4") + case TY_LONG: call ex_do_outtype (ex, "i4") + case TY_REAL: call ex_do_outtype (ex, "n4") + case TY_DOUBLE: call ex_do_outtype (ex, "n8") + } + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Finally, evaluate the expressions and write the image. + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) + call ex_no_interleave (ex) +end diff --git a/pkg/dataio/export/bltins/exxwd.x b/pkg/dataio/export/bltins/exxwd.x new file mode 100644 index 00000000..08c4609a --- /dev/null +++ b/pkg/dataio/export/bltins/exxwd.x @@ -0,0 +1,253 @@ +include <mach.h> +include "../export.h" +include "../exbltins.h" + + +define X11WD_FILE_VERSION 7 # XWD version +define SZ_XWD 25 # number of header elements +define SZ_XWDHEADER 100 # size of header record (bytes) + +# Define the header structure. +define X_HEADER_SIZE Meml[$1] # Size of the header (bytes) +define X_FILE_VERSION Meml[$1+1] # XWD_FILE_VERSION +define X_PIXMAP_FORMAT Meml[$1+2] # Pixmap format +define X_PIXMAP_DEPTH Meml[$1+3] # Pixmap depth +define X_PIXMAP_WIDTH Meml[$1+4] # Pixmap width +define X_PIXMAP_HEIGHT Meml[$1+5] # Pixmap height +define X_XOFFSET Meml[$1+6] # Bitmap x offset +define X_BYTE_ORDER Meml[$1+7] # MSBFirst, LSBFirst +define X_BITMAP_UNIT Meml[$1+8] # Bitmap unit +define X_BITMAP_BIT_ORDER Meml[$1+9] # MSBFirst, LSBFirst +define X_BITMAP_PAD Meml[$1+10] # Bitmap scanline pad +define X_BITS_PER_PIXEL Meml[$1+11] # Bits per pixel +define X_BYTES_PER_LINE Meml[$1+12] # Bytes per scanline +define X_VISUAL_CLASS Meml[$1+13] # Class of colormap +define X_RED_MASK Meml[$1+14] # Z red mask +define X_GREEN_MASK Meml[$1+15] # Z green mask +define X_BLUE_MASK Meml[$1+16] # Z blue mask +define X_BITS_PER_RGB Meml[$1+17] # Log2 of distinct color values +define X_COLORMAP_ENTRIES Meml[$1+18] # Number of entries in colormap +define X_NCOLORS Meml[$1+19] # Number of Color structures +define X_WINDOW_WIDTH Meml[$1+20] # Window width +define X_WINDOW_HEIGHT Meml[$1+21] # Window height +define X_WINDOW_X Meml[$1+22] # Window upper left X coordinate +define X_WINDOW_Y Meml[$1+23] # Window upper left Y coordinate +define X_WINDOW_BDRWIDTH Meml[$1+24] # Window border width + +define LSBFirst 0 # Byte order flags +define MSBFirst 1 + +define XYBitmap 0 # Pixmap types +define XYPixmap 1 +define ZPixmap 2 + +define StaticGray 0 # Recognized visuals +define GrayScale 1 +define StaticColor 2 +define PseudoColor 3 +define TrueColor 4 +define DirectColor 5 + +define DEBUG false + + +# EX_XWD - Write the output image to an X11 Window Dump file. + +procedure ex_xwd (ex) + +pointer ex #i task struct pointer + +pointer xwd, cmap +char cflags, fname[SZ_FNAME] +int i, fd, flags +long pixel +short r, g, b, val + +int strlen() + +begin + # Check to see that we have the correct number of expressions to + # write this format. + flags = EX_OUTFLAGS(ex) + fd = EX_FD(ex) + if (EX_NEXPR(ex) != 1 && EX_NEXPR(ex) != 3 && EX_NEXPR(ex) != 4) { + if (!bitset(flags, OF_BAND)) + call error (7, "Invalid number of expressions for XWD.") + } + if (bitset(flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call error (7, "Line storage illegal for XWD.") + + # Fix the output pixel type to single bytes. + call ex_do_outtype (ex, "b1") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + # Allocate space for the header. + iferr (call calloc (xwd, SZ_XWD, TY_STRUCT)) + call error (0, "Error allocate XWD structure.") + + # Set up the header values. + flags = EX_OUTFLAGS(ex) + X_HEADER_SIZE(xwd) = SZ_XWDHEADER + strlen ("xwddump") + 1 + X_FILE_VERSION(xwd) = X11WD_FILE_VERSION + X_PIXMAP_FORMAT(xwd) = ZPixmap + X_PIXMAP_WIDTH(xwd) = EX_OCOLS(ex) + X_PIXMAP_HEIGHT(xwd) = EX_OROWS(ex) + X_XOFFSET(xwd) = 0 + X_BYTE_ORDER(xwd) = MSBFirst + X_BITMAP_BIT_ORDER(xwd) = MSBFirst + X_WINDOW_WIDTH(xwd) = EX_OCOLS(ex) + X_WINDOW_HEIGHT(xwd) = EX_OROWS(ex) + X_WINDOW_X(xwd) = 0 + X_WINDOW_Y(xwd) = 0 + X_WINDOW_BDRWIDTH(xwd) = 0 + + if (EX_NEXPR(ex) >= 3) { + if (DEBUG) call eprintf ("We think this is a DirectColor image.\n") + X_PIXMAP_DEPTH(xwd) = 24 + X_BITMAP_UNIT(xwd) = 32 + X_BITMAP_PAD(xwd) = 32 + X_BITS_PER_PIXEL(xwd) = 32 + X_VISUAL_CLASS(xwd) = DirectColor + X_COLORMAP_ENTRIES(xwd) = 256 + X_NCOLORS(xwd) = 0 + X_RED_MASK(xwd) = 0FF0000X + X_GREEN_MASK(xwd) = 0FF00X + X_BLUE_MASK(xwd) = 0FFX + X_BYTES_PER_LINE(xwd) = EX_OCOLS(ex) * 4 + } else if (bitset (flags, OF_CMAP)) { + if (DEBUG) call eprintf ("We think this has a colormap.\n") + X_PIXMAP_DEPTH(xwd) = 8 + X_BITS_PER_PIXEL(xwd) = 8 + X_COLORMAP_ENTRIES(xwd) = EX_NCOLORS(ex) + X_NCOLORS(xwd) = EX_NCOLORS(ex) + X_BYTES_PER_LINE(xwd) = EX_OCOLS(ex) + + X_BITMAP_UNIT(xwd) = 8 + X_BITMAP_PAD(xwd) = 8 + X_VISUAL_CLASS(xwd) = StaticGray + X_RED_MASK(xwd) = 0 + X_GREEN_MASK(xwd) = 0 + X_BLUE_MASK(xwd) = 0 + } else { + if (DEBUG) call eprintf ("Pseudocolor.\n") + X_PIXMAP_DEPTH(xwd) = 8 + X_BITS_PER_PIXEL(xwd) = 8 + X_VISUAL_CLASS(xwd) = PseudoColor + X_COLORMAP_ENTRIES(xwd) = 255 + 1 + X_NCOLORS(xwd) = EX_NCOLORS(ex) + X_RED_MASK(xwd) = 0 + X_GREEN_MASK(xwd) = 0 + X_BLUE_MASK(xwd) = 0 + X_BYTES_PER_LINE(xwd) = EX_OCOLS(ex) + X_BITMAP_UNIT(xwd) = 8 + X_BITMAP_PAD(xwd) = 8 + } + X_BITS_PER_RGB(xwd) = X_PIXMAP_DEPTH(xwd) + + # See if we need to byte swap in order to get MSB byte ordering. + if (BYTE_SWAP4 == YES) + call bswap4 (Meml[xwd], 1, Meml[xwd], 1, SZ_XWDHEADER) + if (EX_BSWAP(ex) == S_I4) + call bswap4 (Meml[xwd], 1, Meml[xwd], 1, SZ_XWDHEADER) + call write (fd, Meml[xwd], SZ_XWDHEADER/SZB_CHAR) + call strpak ("xwddump\0", fname, 8) + call write (fd, fname, 4) + + # If we have a colormap set up the structure and write it out. + if (bitset (flags, OF_CMAP)) { + cmap = EX_CMAP(ex) + cflags = 0 + do i = 1, EX_NCOLORS(ex) { + pixel = i - 1 + r = CMAP(cmap,EX_RED,i) * 65535 / 256 + g = CMAP(cmap,EX_GREEN,i) * 65535 / 256 + b = CMAP(cmap,EX_BLUE,i) * 65535 / 256 + + call xwd_putlong (ex, fd, pixel) + call xwd_putword (ex, fd, r) + call xwd_putword (ex, fd, g) + call xwd_putword (ex, fd, b) + call xwd_putword (ex, fd, cflags) + } + } else if (EX_NEXPR(ex) < 3) { + do i = 0, 255 { + val = i * 65535 / 256 + call xwd_putlong (ex, fd, long(i)) + call xwd_putword (ex, fd, val) + call xwd_putword (ex, fd, val) + call xwd_putword (ex, fd, val) + val = 0 #shifti (7, 8) + call xwd_putword (ex, fd, val) + } + } + + # Finally, evaluate the expressions and write the image. + if (EX_NEXPR(ex) == 1 || bitset (flags, OF_BAND)) + call ex_no_interleave (ex) + else if (EX_NEXPR(ex) == 3) { + # If all they gave were the RGB values we need to patch the + # outbands expressions to stick in an alpha channel. Patch it + # up here. + + call ex_alloc_outbands (OBANDS(ex,4)) + do i = 4, 2, -1 { + call strcpy (O_EXPR(ex,i-1), O_EXPR(ex,i), SZ_EXPSTR) + O_WIDTH(ex,i) = O_WIDTH(ex,i-1) + O_HEIGHT(ex,i) = O_HEIGHT(ex,i-1) + } + call strcpy ("0", O_EXPR(ex,1), SZ_EXPSTR) + EX_NEXPR(ex) = 4 + call ex_px_interleave (ex) + + } else if (EX_NEXPR(ex) >= 3) + call ex_px_interleave (ex) + + # Clean up. + call mfree (xwd, TY_STRUCT) +end + + +# XWD_PUTWORD - Writes a 16-bit integer in XWD order (MSB first). + +procedure xwd_putword (ex, fd, w) + +pointer ex #i task struct pointer +int fd +short w + +short val + +begin + # If this is a MSB-first machine swap the bytes before output. + if (BYTE_SWAP2 == YES) + call bswap2 (w, 1, val, 1, (SZ_SHORT * SZB_CHAR)) + else + val = w + if (EX_BSWAP(ex) == S_I2) + call bswap2 (val, 1, val, 1, (SZ_SHORT * SZB_CHAR)) + + call write (fd, val, SZ_SHORT/SZ_CHAR) +end + + +# XWD_PUTLONG - Writes a 32-bit integer in XWD order (MSB first). + +procedure xwd_putlong (ex, fd, w) + +pointer ex #i task struct pointer +int fd +long w + +long val + +begin + # If this is a MSB-first machine swap the bytes before output. + if (BYTE_SWAP4 == YES) + call bswap4 (w, 1, val, 1, (SZ_LONG * SZB_CHAR)) + else + val = w + if (EX_BSWAP(ex) == S_I4) + call bswap4 (val, 1, val, 1, (SZ_LONG * SZB_CHAR)) + + call write (fd, val, SZ_LONG/SZ_CHAR) +end diff --git a/pkg/dataio/export/bltins/mkpkg b/pkg/dataio/export/bltins/mkpkg new file mode 100644 index 00000000..14e6b8d4 --- /dev/null +++ b/pkg/dataio/export/bltins/mkpkg @@ -0,0 +1,20 @@ +# Mkpkg file for building the EXPORT task builtin formats. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + exeps.x ../exbltins.h ../export.h \ + <evvexpr.h> <fset.h> <imhdr.h> <mach.h> + exgif.x ../exbltins.h ../export.h <evvexpr.h> <fset.h> <mach.h> + exiraf.x ../export.h <evvexpr.h> <imhdr.h> <mach.h> + exmiff.x ../export.h <mach.h> + expgm.x ../export.h <mach.h> + exppm.x ../export.h <mach.h> + exras.x ../export.h <mach.h> + exrgb.x ../exbltins.h ../export.h <mach.h> + exvicar.x ../export.h <mach.h> + exxwd.x ../exbltins.h ../export.h <mach.h> + ; diff --git a/pkg/dataio/export/cmaps.inc b/pkg/dataio/export/cmaps.inc new file mode 100644 index 00000000..91707e68 --- /dev/null +++ b/pkg/dataio/export/cmaps.inc @@ -0,0 +1,534 @@ +short aips0[768] +data (aips0(i),i= 1, 12) / 0, 0, 0, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 13, 24) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 25, 36) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 37, 48) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 49, 60) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 61, 72) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 73, 84) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 85, 96) / 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50, 50/ +data (aips0(i),i= 97,108) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=109,120) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=121,132) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=133,144) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=145,156) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=157,168) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=169,180) /121, 0,154,121, 0,154,121, 0,154,121, 0,154/ +data (aips0(i),i=181,192) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=193,204) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=205,216) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=217,228) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=229,240) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=241,252) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=253,264) / 0, 0,199, 0, 0,199, 0, 0,199, 0, 0,199/ +data (aips0(i),i=265,276) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=277,288) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=289,300) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=301,312) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=313,324) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=325,336) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=337,348) / 95,166,235, 95,166,235, 95,166,235, 95,166,235/ +data (aips0(i),i=349,360) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=361,372) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=373,384) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=385,396) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=397,408) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=409,420) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=421,432) / 0,145, 0, 0,145, 0, 0,145, 0, 0,145, 0/ +data (aips0(i),i=433,444) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=445,456) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=457,468) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=469,480) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=481,492) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=493,504) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=505,516) / 0,246, 0, 0,246, 0, 0,246, 0, 0,246, 0/ +data (aips0(i),i=517,528) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=529,540) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=541,552) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=553,564) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=565,576) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=577,588) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=589,600) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (aips0(i),i=601,612) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=613,624) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=625,636) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=637,648) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=649,660) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=661,672) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=673,684) /255,177, 0,255,177, 0,255,177, 0,255,177, 0/ +data (aips0(i),i=685,696) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=697,708) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=709,720) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=721,732) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=733,744) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=745,756) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (aips0(i),i=757,768) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ + + +short color[768] +data (color(i),i= 1, 12) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (color(i),i= 13, 24) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (color(i),i= 25, 36) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (color(i),i= 37, 48) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (color(i),i= 49, 60) / 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46/ +data (color(i),i= 61, 72) / 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46/ +data (color(i),i= 73, 84) / 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46/ +data (color(i),i= 85, 96) / 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46, 46/ +data (color(i),i= 97,108) / 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95/ +data (color(i),i=109,120) / 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95/ +data (color(i),i=121,132) / 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95/ +data (color(i),i=133,144) / 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95, 95/ +data (color(i),i=145,156) /142,142,142,142,142,142,142,142,142,142,142,142/ +data (color(i),i=157,168) /142,142,142,142,142,142,142,142,142,142,142,142/ +data (color(i),i=169,180) /142,142,142,142,142,142,142,142,142,142,142,142/ +data (color(i),i=181,192) /142,142,142,142,142,142,142,142,142,142,142,142/ +data (color(i),i=193,204) /191,191,191,191,191,191,191,191,191,191,191,191/ +data (color(i),i=205,216) /191,191,191,191,191,191,191,191,191,191,191,191/ +data (color(i),i=217,228) /191,191,191,191,191,191,191,191,191,191,191,191/ +data (color(i),i=229,240) /191,191,191,191,191,191,191,191,191,191,191,191/ +data (color(i),i=241,252) /238,238,238,238,238,238,238,238,238,238,238,238/ +data (color(i),i=253,264) /238,238,238,238,238,238,238,238,238,238,238,238/ +data (color(i),i=265,276) /238,238,238,238,238,238,238,238,238,238,238,238/ +data (color(i),i=277,288) /238,238,238,238,238,238,238,238,238,238,238,238/ +data (color(i),i=289,300) / 0, 46,238, 0, 46,238, 0, 46,238, 0, 46,238/ +data (color(i),i=301,312) / 0, 46,238, 0, 46,238, 0, 46,238, 0, 46,238/ +data (color(i),i=313,324) / 0, 46,238, 0, 46,238, 0, 46,238, 0, 46,238/ +data (color(i),i=325,336) / 0, 46,238, 0, 46,238, 0, 46,238, 0, 46,238/ +data (color(i),i=337,348) / 0, 95,191, 0, 95,191, 0, 95,191, 0, 95,191/ +data (color(i),i=349,360) / 0, 95,191, 0, 95,191, 0, 95,191, 0, 95,191/ +data (color(i),i=361,372) / 0, 95,191, 0, 95,191, 0, 95,191, 0, 95,191/ +data (color(i),i=373,384) / 0, 95,191, 0, 95,191, 0, 95,191, 0, 95,191/ +data (color(i),i=385,396) / 0,127,127, 0,127,127, 0,127,127, 0,127,127/ +data (color(i),i=397,408) / 0,127,127, 0,127,127, 0,127,127, 0,127,127/ +data (color(i),i=409,420) / 0,127,127, 0,127,127, 0,127,127, 0,127,127/ +data (color(i),i=421,432) / 0,127,127, 0,127,127, 0,127,127, 0,127,127/ +data (color(i),i=433,444) / 0,191, 78, 0,191, 78, 0,191, 78, 0,191, 78/ +data (color(i),i=445,456) / 0,191, 78, 0,191, 78, 0,191, 78, 0,191, 78/ +data (color(i),i=457,468) / 0,191, 78, 0,191, 78, 0,191, 78, 0,191, 78/ +data (color(i),i=469,480) / 0,191, 78, 0,191, 78, 0,191, 78, 0,191, 78/ +data (color(i),i=481,492) / 0,238, 0, 0,238, 0, 0,238, 0, 0,238, 0/ +data (color(i),i=493,504) / 0,238, 0, 0,238, 0, 0,238, 0, 0,238, 0/ +data (color(i),i=505,516) / 0,238, 0, 0,238, 0, 0,238, 0, 0,238, 0/ +data (color(i),i=517,528) / 0,238, 0, 0,238, 0, 0,238, 0, 0,238, 0/ +data (color(i),i=529,540) / 78,159, 0, 78,159, 0, 78,159, 0, 78,159, 0/ +data (color(i),i=541,552) / 78,159, 0, 78,159, 0, 78,159, 0, 78,159, 0/ +data (color(i),i=553,564) / 78,159, 0, 78,159, 0, 78,159, 0, 78,159, 0/ +data (color(i),i=565,576) / 78,159, 0, 78,159, 0, 78,159, 0, 78,159, 0/ +data (color(i),i=577,588) /127,127, 0,127,127, 0,127,127, 0,127,127, 0/ +data (color(i),i=589,600) /127,127, 0,127,127, 0,127,127, 0,127,127, 0/ +data (color(i),i=601,612) /127,127, 0,127,127, 0,127,127, 0,127,127, 0/ +data (color(i),i=613,624) /127,127, 0,127,127, 0,127,127, 0,127,127, 0/ +data (color(i),i=625,636) /159, 78, 0,159, 78, 0,159, 78, 0,159, 78, 0/ +data (color(i),i=637,648) /159, 78, 0,159, 78, 0,159, 78, 0,159, 78, 0/ +data (color(i),i=649,660) /159, 78, 0,159, 78, 0,159, 78, 0,159, 78, 0/ +data (color(i),i=661,672) /159, 78, 0,159, 78, 0,159, 78, 0,159, 78, 0/ +data (color(i),i=673,684) /238, 0, 0,238, 0, 0,238, 0, 0,238, 0, 0/ +data (color(i),i=685,696) /238, 0, 0,238, 0, 0,238, 0, 0,238, 0, 0/ +data (color(i),i=697,708) /238, 0, 0,238, 0, 0,238, 0, 0,238, 0, 0/ +data (color(i),i=709,720) /238, 0, 0,238, 0, 0,238, 0, 0,238, 0, 0/ +data (color(i),i=721,732) /191, 0, 78,191, 0, 78,191, 0, 78,191, 0, 78/ +data (color(i),i=733,744) /191, 0, 78,191, 0, 78,191, 0, 78,191, 0, 78/ +data (color(i),i=745,756) /191, 0, 78,191, 0, 78,191, 0, 78,191, 0, 78/ +data (color(i),i=757,768) /191, 0, 78,191, 0, 78,191, 0, 78,191, 0, 78/ + + +short halley[768] +data (halley(i),i= 1, 12) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,179/ +data (halley(i),i= 13, 24) / 0, 0,179, 0, 0,220, 0, 0,220,120, 0,220/ +data (halley(i),i= 25, 36) /120, 0,220,120, 0,220,179, 0,229,179, 0,229/ +data (halley(i),i= 37, 48) /255, 0,255,255, 0,255,255, 0,179,255, 0,179/ +data (halley(i),i= 49, 60) /255, 0,132,255, 0, 0,255, 0, 0,255,120, 0/ +data (halley(i),i= 61, 72) /255,120, 0,252,184, 0,252,184, 0,250,206, 0/ +data (halley(i),i= 73, 84) /250,216, 0,250,216, 0,255,255, 0,255,255, 0/ +data (halley(i),i= 85, 96) /179,255, 0,179,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i= 97,108) / 0,255, 0, 0,255,179, 0,255,179, 0,255,255/ +data (halley(i),i=109,120) / 0,255,255,120,199,255,120,199,255,120,199,255/ +data (halley(i),i=121,132) /159,159,255,159,159,255,199,120,255,199,120,255/ +data (halley(i),i=133,144) /255,179,255,255,179,255,255,196,255,255,220,255/ +data (halley(i),i=145,156) /255,220,255,255,255,255,255,255,255,255,255,255/ +data (halley(i),i=157,168) /255,255,255,255,229,255,255,220,255,255,220,255/ +data (halley(i),i=169,180) /255,220,255, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=181,192) / 0,255, 0, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=193,204) / 0,255, 0, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=205,216) / 0,255, 0, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=217,228) /235,158,255,199,120,255,199,120,255,199,120,255/ +data (halley(i),i=229,240) /199,120,255,199,120,255,199,120,255,199,120,255/ +data (halley(i),i=241,252) /199,120,255,199,120,255,167,152,255,159,159,255/ +data (halley(i),i=253,264) /159,159,255, 0, 0,255, 0, 0,255, 0, 0,255/ +data (halley(i),i=265,276) / 0, 0,255, 0, 0,255, 0, 0,255, 0, 0,255/ +data (halley(i),i=277,288) / 0, 0,255, 0, 0,255,255, 0, 0,255, 0, 0/ +data (halley(i),i=289,300) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=301,312) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=313,324) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=325,336) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=337,348) /255, 0, 0,255, 0, 0, 0,255,179, 0,255,179/ +data (halley(i),i=349,360) / 0,255,179, 0,255,179, 0,255,179, 0,255,179/ +data (halley(i),i=361,372) / 0,255,166, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=373,384) / 0,255, 0, 0,255, 0, 0,255, 0, 0,255, 0/ +data (halley(i),i=385,396) / 0,255, 0, 0,255, 0, 91,255, 0,179,255, 0/ +data (halley(i),i=397,408) /179,255, 0,179,255, 0,179,255, 0,179,255, 0/ +data (halley(i),i=409,420) /179,255, 0,179,255, 0,179,255, 0,179,255, 0/ +data (halley(i),i=421,432) /250,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (halley(i),i=433,444) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (halley(i),i=445,456) /255,255, 0,254,248, 0,250,216, 0,250,216, 0/ +data (halley(i),i=457,468) /250,216, 0,250,216, 0,250,216, 0,250,216, 0/ +data (halley(i),i=469,480) /250,216, 0,250,216, 0,250,216, 0,252,197, 0/ +data (halley(i),i=481,492) /252,184, 0,252,184, 0,252,184, 0,252,184, 0/ +data (halley(i),i=493,504) /252,184, 0,252,184, 0,252,184, 0,252,184, 0/ +data (halley(i),i=505,516) /252,184, 0,255,120, 0,255,120, 0,255,120, 0/ +data (halley(i),i=517,528) /255,120, 0,255,120, 0,255,120, 0,255,120, 0/ +data (halley(i),i=529,540) /255,120, 0,255,120, 0,255, 94, 0,255, 0, 0/ +data (halley(i),i=541,552) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=553,564) /255, 0, 0,255, 0, 0,255, 0, 0,255, 0, 0/ +data (halley(i),i=565,576) /255, 0,119,255, 0,179,255, 0,179,255, 0,179/ +data (halley(i),i=577,588) /255, 0,179,255, 0,179,255, 0,179,255, 0,179/ +data (halley(i),i=589,600) /255, 0,179,255, 0,179,255, 0,255,255, 0,255/ +data (halley(i),i=601,612) /255, 0,255,255, 0,255,255, 0,255,255, 0,255/ +data (halley(i),i=613,624) /255, 0,255,255, 0,255,255, 0,255,233, 0,248/ +data (halley(i),i=625,636) /179, 0,229,179, 0,229,179, 0,229,179, 0,229/ +data (halley(i),i=637,648) /179, 0,229,179, 0,229,179, 0,229,179, 0,229/ +data (halley(i),i=649,660) /179, 0,229,135, 0,223,120, 0,220,120, 0,220/ +data (halley(i),i=661,672) /120, 0,220,120, 0,220,120, 0,220,120, 0,220/ +data (halley(i),i=673,684) /120, 0,220,120, 0,220,120, 0,220,255,255,255/ +data (halley(i),i=685,696) /255,255,255,255,255,255,255,255,255,255,255,255/ +data (halley(i),i=697,708) / 0, 0,220, 0, 0,220, 0, 0,220, 0, 0,220/ +data (halley(i),i=709,720) / 0, 0,204, 0, 0,179, 0, 0,179, 0, 0,179/ +data (halley(i),i=721,732) / 0, 0,179, 0, 0,179, 0, 0,179, 0, 0,179/ +data (halley(i),i=733,744) / 0, 0,179, 0, 0,179, 0, 0, 34, 0, 0, 0/ +data (halley(i),i=745,756) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (halley(i),i=757,768) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ + + +short heat[768] +data (heat(i),i= 1, 12) / 0, 0, 0, 2, 0, 0, 6, 1, 0, 8, 2, 0/ +data (heat(i),i= 13, 24) / 12, 4, 0, 14, 5, 0, 18, 6, 0, 20, 6, 0/ +data (heat(i),i= 25, 36) / 24, 7, 0, 26, 8, 0, 30, 10, 0, 32, 11, 0/ +data (heat(i),i= 37, 48) / 36, 12, 0, 38, 12, 0, 42, 13, 0, 44, 14, 0/ +data (heat(i),i= 49, 60) / 48, 16, 0, 51, 17, 0, 53, 18, 0, 57, 19, 0/ +data (heat(i),i= 61, 72) / 59, 19, 0, 63, 20, 0, 65, 21, 0, 69, 23, 0/ +data (heat(i),i= 73, 84) / 71, 24, 0, 75, 25, 0, 77, 25, 0, 81, 26, 0/ +data (heat(i),i= 85, 96) / 83, 27, 0, 87, 29, 0, 89, 30, 0, 93, 31, 0/ +data (heat(i),i= 97,108) / 95, 31, 0, 99, 32, 0,102, 33, 0,104, 34, 0/ +data (heat(i),i=109,120) /108, 36, 0,110, 37, 0,114, 38, 0,116, 38, 0/ +data (heat(i),i=121,132) /120, 39, 0,122, 40, 0,126, 42, 0,128, 43, 0/ +data (heat(i),i=133,144) /132, 44, 0,134, 44, 0,138, 45, 0,140, 46, 0/ +data (heat(i),i=145,156) /144, 48, 0,146, 49, 0,150, 50, 0,153, 51, 0/ +data (heat(i),i=157,168) /155, 51, 0,159, 52, 0,161, 53, 0,165, 55, 0/ +data (heat(i),i=169,180) /167, 56, 0,171, 57, 0,173, 57, 0,177, 58, 0/ +data (heat(i),i=181,192) /179, 59, 0,183, 61, 0,185, 62, 0,189, 63, 0/ +data (heat(i),i=193,204) /191, 63, 0,195, 64, 0,197, 65, 0,201, 67, 0/ +data (heat(i),i=205,216) /204, 68, 0,206, 69, 0,210, 70, 0,212, 70, 0/ +data (heat(i),i=217,228) /216, 71, 0,218, 72, 0,222, 74, 0,224, 75, 0/ +data (heat(i),i=229,240) /228, 76, 0,230, 76, 0,234, 77, 0,236, 78, 0/ +data (heat(i),i=241,252) /240, 80, 0,242, 81, 0,246, 82, 0,248, 82, 0/ +data (heat(i),i=253,264) /252, 83, 0,255, 84, 0,255, 85, 0,255, 87, 0/ +data (heat(i),i=265,276) /255, 88, 0,255, 89, 0,255, 89, 0,255, 90, 0/ +data (heat(i),i=277,288) /255, 91, 0,255, 93, 0,255, 94, 0,255, 95, 0/ +data (heat(i),i=289,300) /255, 95, 0,255, 96, 0,255, 97, 0,255, 99, 0/ +data (heat(i),i=301,312) /255,100, 0,255,101, 0,255,102, 0,255,102, 0/ +data (heat(i),i=313,324) /255,103, 0,255,104, 0,255,106, 0,255,107, 0/ +data (heat(i),i=325,336) /255,108, 0,255,108, 0,255,109, 0,255,110, 0/ +data (heat(i),i=337,348) /255,112, 0,255,113, 0,255,114, 0,255,114, 0/ +data (heat(i),i=349,360) /255,115, 0,255,116, 0,255,118, 0,255,119, 0/ +data (heat(i),i=361,372) /255,120, 0,255,121, 0,255,121, 0,255,122, 0/ +data (heat(i),i=373,384) /255,123, 0,255,125, 0,255,126, 0,255,127, 0/ +data (heat(i),i=385,396) /255,127, 0,255,128, 0,255,129, 0,255,131, 0/ +data (heat(i),i=397,408) /255,132, 0,255,133, 0,255,133, 0,255,134, 0/ +data (heat(i),i=409,420) /255,135, 0,255,136, 0,255,138, 0,255,139, 0/ +data (heat(i),i=421,432) /255,140, 0,255,140, 0,255,141, 0,255,142, 0/ +data (heat(i),i=433,444) /255,144, 0,255,145, 0,255,146, 0,255,146, 0/ +data (heat(i),i=445,456) /255,147, 0,255,148, 0,255,150, 0,255,151, 0/ +data (heat(i),i=457,468) /255,152, 0,255,153, 0,255,153, 0,255,154, 0/ +data (heat(i),i=469,480) /255,155, 0,255,157, 0,255,158, 0,255,159, 0/ +data (heat(i),i=481,492) /255,159, 0,255,160, 0,255,161, 0,255,163, 0/ +data (heat(i),i=493,504) /255,164, 0,255,165, 0,255,165, 2,255,166, 6/ +data (heat(i),i=505,516) /255,167, 8,255,169, 12,255,170, 14,255,171, 18/ +data (heat(i),i=517,528) /255,172, 20,255,172, 24,255,173, 26,255,174, 30/ +data (heat(i),i=529,540) /255,176, 32,255,177, 36,255,178, 38,255,178, 42/ +data (heat(i),i=541,552) /255,179, 44,255,180, 48,255,182, 51,255,183, 53/ +data (heat(i),i=553,564) /255,184, 57,255,184, 59,255,185, 63,255,186, 65/ +data (heat(i),i=565,576) /255,187, 69,255,189, 71,255,190, 75,255,191, 77/ +data (heat(i),i=577,588) /255,191, 81,255,192, 83,255,193, 87,255,195, 89/ +data (heat(i),i=589,600) /255,196, 93,255,197, 95,255,197, 99,255,198,102/ +data (heat(i),i=601,612) /255,199,104,255,201,108,255,202,110,255,203,114/ +data (heat(i),i=613,624) /255,204,116,255,204,120,255,205,122,255,206,126/ +data (heat(i),i=625,636) /255,208,128,255,209,132,255,210,134,255,210,138/ +data (heat(i),i=637,648) /255,211,140,255,212,144,255,214,146,255,215,150/ +data (heat(i),i=649,660) /255,216,153,255,216,155,255,217,159,255,218,161/ +data (heat(i),i=661,672) /255,220,165,255,221,167,255,222,171,255,223,173/ +data (heat(i),i=673,684) /255,223,177,255,224,179,255,225,183,255,227,185/ +data (heat(i),i=685,696) /255,228,189,255,229,191,255,229,195,255,230,197/ +data (heat(i),i=697,708) /255,231,201,255,233,204,255,234,206,255,235,210/ +data (heat(i),i=709,720) /255,235,212,255,236,216,255,237,218,255,238,222/ +data (heat(i),i=721,732) /255,240,224,255,241,228,255,242,230,255,242,234/ +data (heat(i),i=733,744) /255,243,236,255,244,240,255,246,242,255,247,246/ +data (heat(i),i=745,756) /255,248,248,255,248,252,255,249,255,255,250,255/ +data (heat(i),i=757,768) /255,252,255,255,253,255,255,254,255,255,255,255/ + + +short rainbow[768] +data (rainbow(i),i= 1, 12) / 0, 0, 42, 6, 0, 46, 14, 0, 51, 21, 0, 56/ +data (rainbow(i),i= 13, 24) / 29, 0, 61, 37, 0, 65, 44, 0, 70, 51, 0, 76/ +data (rainbow(i),i= 25, 36) / 58, 0, 81, 67, 0, 85, 75, 0, 90, 82, 0, 95/ +data (rainbow(i),i= 37, 48) / 89, 0,101, 96, 0,106,104, 0,110,112, 0,115/ +data (rainbow(i),i= 49, 60) /120, 0,121,127, 0,126,134, 0,131,141, 0,136/ +data (rainbow(i),i= 61, 72) /150, 0,141,141, 0,146,134, 0,152,127, 0,157/ +data (rainbow(i),i= 73, 84) /120, 0,163,112, 0,167,104, 0,172, 96, 0,178/ +data (rainbow(i),i= 85, 96) / 89, 0,184, 82, 0,189, 75, 0,195, 67, 0,199/ +data (rainbow(i),i= 97,108) / 58, 0,204, 51, 0,210, 44, 0,216, 37, 0,222/ +data (rainbow(i),i=109,120) / 29, 0,227, 21, 0,233, 14, 0,237, 6, 0,243/ +data (rainbow(i),i=121,132) / 0, 0,248, 0, 0,255, 0, 6,248, 0, 12,243/ +data (rainbow(i),i=133,144) / 0, 16,237, 0, 20,233, 0, 25,227, 0, 29,222/ +data (rainbow(i),i=145,156) / 0, 32,216, 0, 36,210, 0, 39,204, 0, 43,199/ +data (rainbow(i),i=157,168) / 0, 46,195, 0, 50,189, 0, 53,184, 0, 57,178/ +data (rainbow(i),i=169,180) / 0, 59,172, 0, 63,167, 0, 67,163, 0, 70,157/ +data (rainbow(i),i=181,192) / 0, 72,152, 0, 76,146, 0, 78,141, 0, 82,136/ +data (rainbow(i),i=193,204) / 0, 84,131, 0, 88,126, 0, 90,121, 0, 94,115/ +data (rainbow(i),i=205,216) / 0, 96,110, 0,100,106, 0,102,101, 0,104, 95/ +data (rainbow(i),i=217,228) / 0,108, 90, 0,110, 85, 0,114, 81, 0,116, 76/ +data (rainbow(i),i=229,240) / 0,119, 70, 0,121, 65, 0,125, 61, 0,127, 56/ +data (rainbow(i),i=241,252) / 0,129, 51, 0,133, 46, 0,134, 42, 0,138, 37/ +data (rainbow(i),i=253,264) / 0,140, 32, 0,142, 27, 0,146, 24, 0,148, 19/ +data (rainbow(i),i=265,276) / 0,151, 14, 0,153, 11, 0,155, 6, 0,159, 2/ +data (rainbow(i),i=277,288) / 0,160, 0, 0,164, 0, 0,165, 0, 0,169, 0/ +data (rainbow(i),i=289,300) / 0,171, 0, 0,173, 0, 0,176, 0, 0,178, 0/ +data (rainbow(i),i=301,312) / 0,180, 0, 0,184, 0, 0,185, 0, 0,189, 0/ +data (rainbow(i),i=313,324) / 0,191, 0, 0,193, 0, 0,196, 0, 0,197, 0/ +data (rainbow(i),i=325,336) / 0,201, 0, 0,203, 0, 0,205, 0, 0,208, 0/ +data (rainbow(i),i=337,348) / 0,210, 0, 0,212, 0, 0,215, 0, 0,217, 0/ +data (rainbow(i),i=349,360) / 0,220, 0, 0,222, 0, 0,224, 0, 0,227, 0/ +data (rainbow(i),i=361,372) / 0,229, 0, 0,231, 0, 0,234, 0, 0,235, 0/ +data (rainbow(i),i=373,384) / 0,238, 0, 0,241, 0, 0,242, 0, 0,244, 0/ +data (rainbow(i),i=385,396) / 0,248, 0, 0,249, 0, 0,252, 0, 0,255, 0/ +data (rainbow(i),i=397,408) / 0,252, 0, 0,249, 0, 0,248, 0, 0,244, 0/ +data (rainbow(i),i=409,420) / 0,242, 0, 0,241, 0, 0,238, 0, 0,235, 0/ +data (rainbow(i),i=421,432) / 0,234, 0, 0,231, 0, 0,229, 0, 0,227, 0/ +data (rainbow(i),i=433,444) / 0,224, 0, 0,222, 0, 0,220, 0, 0,217, 0/ +data (rainbow(i),i=445,456) / 0,215, 0, 0,212, 0, 0,210, 0, 0,208, 0/ +data (rainbow(i),i=457,468) / 0,205, 0, 0,203, 0, 0,201, 0, 0,197, 0/ +data (rainbow(i),i=469,480) / 1,196, 0, 8,197, 0, 17,201, 0, 25,204, 0/ +data (rainbow(i),i=481,492) / 32,206, 0, 42,210, 0, 51,215, 0, 59,218, 0/ +data (rainbow(i),i=493,504) / 68,222, 0, 77,227, 0, 87,229, 0, 95,235, 0/ +data (rainbow(i),i=505,516) /104,237, 0,114,242, 0,123,247, 0,133,252, 0/ +data (rainbow(i),i=517,528) /142,255, 0,152,255, 0,161,255, 0,171,255, 0/ +data (rainbow(i),i=529,540) /180,255, 0,191,255, 0,199,255, 0,210,255, 0/ +data (rainbow(i),i=541,552) /218,255, 0,229,255, 0,237,255, 0,248,255, 0/ +data (rainbow(i),i=553,564) /255,255, 0,255,255, 0,255,255, 0,255,255, 0/ +data (rainbow(i),i=565,576) /255,255, 0,255,255, 0,255,255, 0,254,255, 0/ +data (rainbow(i),i=577,588) /249,255, 0,244,248, 0,241,238, 0,235,229, 0/ +data (rainbow(i),i=589,600) /231,218, 0,228,209, 0,223,198, 0,218,189, 0/ +data (rainbow(i),i=601,612) /214,178, 0,210,169, 0,204,159, 0,201,148, 0/ +data (rainbow(i),i=613,624) /196,139, 0,192,129, 0,189,119, 0,184,109, 0/ +data (rainbow(i),i=625,636) /180,100, 0,177, 89, 0,173, 81, 0,169, 70, 0/ +data (rainbow(i),i=637,648) /165, 61, 0,161, 51, 0,159, 43, 0,157, 32, 0/ +data (rainbow(i),i=649,660) /154, 25, 0,158, 20, 0,159, 16, 0,163, 12, 0/ +data (rainbow(i),i=661,672) /165, 6, 0,167, 0, 0,170, 0, 0,172, 0, 0/ +data (rainbow(i),i=673,684) /174, 0, 0,178, 0, 0,180, 0, 0,183, 0, 0/ +data (rainbow(i),i=685,696) /185, 0, 0,187, 0, 0,191, 0, 0,192, 0, 0/ +data (rainbow(i),i=697,708) /196, 0, 0,197, 0, 0,201, 0, 0,204, 1, 1/ +data (rainbow(i),i=709,720) /205, 6, 6,209, 12, 12,210, 20, 20,214, 29, 29/ +data (rainbow(i),i=721,732) /216, 38, 38,218, 49, 49,221, 58, 58,223, 70, 70/ +data (rainbow(i),i=733,744) /225, 82, 82,229, 95, 95,231,109,109,234,123,123/ +data (rainbow(i),i=745,756) /236,138,138,238,153,153,242,169,169,243,184,184/ +data (rainbow(i),i=757,768) /247,202,202,248,218,218,252,236,236,255,255,255/ + + +short staircase[768] +data (staircase(i),i= 1, 12) / 0, 0, 80, 1, 1, 80, 2, 2, 80, 4, 4, 80/ +data (staircase(i),i= 13, 24) / 5, 5, 80, 6, 6, 80, 6, 6, 80, 7, 7, 80/ +data (staircase(i),i= 25, 36) / 8, 8, 80, 10, 10, 80, 11, 11, 80, 12, 12, 80/ +data (staircase(i),i= 37, 48) / 12, 12, 80, 13, 13, 80, 14, 14, 80, 16, 16, 80/ +data (staircase(i),i= 49, 60) / 17, 17,120, 18, 18,120, 19, 19,120, 19, 19,120/ +data (staircase(i),i= 61, 72) / 20, 20,120, 21, 21,120, 23, 23,120, 24, 24,120/ +data (staircase(i),i= 73, 84) / 25, 25,120, 25, 25,120, 26, 26,120, 27, 27,120/ +data (staircase(i),i= 85, 96) / 29, 29,120, 30, 30,120, 31, 31,120, 31, 31,120/ +data (staircase(i),i= 97,108) / 32, 32,159, 33, 33,159, 34, 34,159, 36, 36,159/ +data (staircase(i),i=109,120) / 37, 37,159, 38, 38,159, 38, 38,159, 39, 39,159/ +data (staircase(i),i=121,132) / 40, 40,159, 42, 42,159, 43, 43,159, 44, 44,159/ +data (staircase(i),i=133,144) / 44, 44,159, 45, 45,159, 46, 46,159, 48, 48,159/ +data (staircase(i),i=145,156) / 49, 49,199, 50, 50,199, 51, 51,199, 51, 51,199/ +data (staircase(i),i=157,168) / 52, 52,199, 53, 53,199, 55, 55,199, 56, 56,199/ +data (staircase(i),i=169,180) / 57, 57,199, 57, 57,199, 58, 58,199, 59, 59,199/ +data (staircase(i),i=181,192) / 61, 61,199, 62, 62,199, 63, 63,199, 63, 63,199/ +data (staircase(i),i=193,204) / 64, 64,240, 65, 65,240, 67, 67,240, 68, 68,240/ +data (staircase(i),i=205,216) / 69, 69,240, 70, 70,240, 70, 70,240, 71, 71,240/ +data (staircase(i),i=217,228) / 72, 72,240, 74, 74,240, 75, 75,240, 76, 76,240/ +data (staircase(i),i=229,240) / 76, 76,240, 77, 77,240, 78, 78,240, 80, 80,240/ +data (staircase(i),i=241,252) / 81, 81,242, 82, 82,246, 82, 82,248, 83, 83,252/ +data (staircase(i),i=253,264) / 84, 84,255, 0, 80, 0, 1, 80, 1, 2, 80, 2/ +data (staircase(i),i=265,276) / 4, 80, 4, 5, 80, 5, 6, 80, 6, 6, 80, 6/ +data (staircase(i),i=277,288) / 7, 80, 7, 8, 80, 8, 10, 80, 10, 11, 80, 11/ +data (staircase(i),i=289,300) / 12, 80, 12, 12, 80, 12, 13, 80, 13, 14, 80, 14/ +data (staircase(i),i=301,312) / 16, 80, 16, 17,120, 17, 18,120, 18, 19,120, 19/ +data (staircase(i),i=313,324) / 19,120, 19, 20,120, 20, 21,120, 21, 23,120, 23/ +data (staircase(i),i=325,336) / 24,120, 24, 25,120, 25, 25,120, 25, 26,120, 26/ +data (staircase(i),i=337,348) / 27,120, 27, 29,120, 29, 30,120, 30, 31,120, 31/ +data (staircase(i),i=349,360) / 31,120, 31, 32,159, 32, 33,159, 33, 34,159, 34/ +data (staircase(i),i=361,372) / 36,159, 36, 37,159, 37, 38,159, 38, 38,159, 38/ +data (staircase(i),i=373,384) / 39,159, 39, 40,159, 40, 42,159, 42, 43,159, 43/ +data (staircase(i),i=385,396) / 44,159, 44, 44,159, 44, 45,159, 45, 46,159, 46/ +data (staircase(i),i=397,408) / 48,159, 48, 49,199, 49, 50,199, 50, 51,199, 51/ +data (staircase(i),i=409,420) / 51,199, 51, 52,199, 52, 53,199, 53, 55,199, 55/ +data (staircase(i),i=421,432) / 56,199, 56, 57,199, 57, 57,199, 57, 58,199, 58/ +data (staircase(i),i=433,444) / 59,199, 59, 61,199, 61, 62,199, 62, 63,199, 63/ +data (staircase(i),i=445,456) / 63,199, 63, 64,240, 64, 65,240, 65, 67,240, 67/ +data (staircase(i),i=457,468) / 68,240, 68, 69,240, 69, 70,240, 70, 70,240, 70/ +data (staircase(i),i=469,480) / 71,240, 71, 72,240, 72, 74,240, 74, 75,240, 75/ +data (staircase(i),i=481,492) / 76,240, 76, 76,240, 76, 77,240, 77, 78,240, 78/ +data (staircase(i),i=493,504) / 80,240, 80, 81,242, 81, 82,246, 82, 82,248, 82/ +data (staircase(i),i=505,516) / 83,252, 83, 84,255, 84, 80, 0, 0, 80, 1, 1/ +data (staircase(i),i=517,528) / 80, 2, 2, 80, 4, 4, 80, 5, 5, 80, 6, 6/ +data (staircase(i),i=529,540) / 80, 6, 6, 80, 7, 7, 80, 8, 8, 80, 10, 10/ +data (staircase(i),i=541,552) / 80, 11, 11, 80, 12, 12, 80, 12, 12, 80, 13, 13/ +data (staircase(i),i=553,564) / 80, 14, 14, 80, 16, 16,120, 17, 17,120, 18, 18/ +data (staircase(i),i=565,576) /120, 19, 19,120, 19, 19,120, 20, 20,120, 21, 21/ +data (staircase(i),i=577,588) /120, 23, 23,120, 24, 24,120, 25, 25,120, 25, 25/ +data (staircase(i),i=589,600) /120, 26, 26,120, 27, 27,120, 29, 29,120, 30, 30/ +data (staircase(i),i=601,612) /120, 31, 31,120, 31, 31,159, 32, 32,159, 33, 33/ +data (staircase(i),i=613,624) /159, 34, 34,159, 36, 36,159, 37, 37,159, 38, 38/ +data (staircase(i),i=625,636) /159, 38, 38,159, 39, 39,159, 40, 40,159, 42, 42/ +data (staircase(i),i=637,648) /159, 43, 43,159, 44, 44,159, 44, 44,159, 45, 45/ +data (staircase(i),i=649,660) /159, 46, 46,159, 48, 48,199, 49, 49,199, 50, 50/ +data (staircase(i),i=661,672) /199, 51, 51,199, 51, 51,199, 52, 52,199, 53, 53/ +data (staircase(i),i=673,684) /199, 55, 55,199, 56, 56,199, 57, 57,199, 57, 57/ +data (staircase(i),i=685,696) /199, 58, 58,199, 59, 59,199, 61, 61,199, 62, 62/ +data (staircase(i),i=697,708) /199, 63, 63,199, 63, 63,240, 64, 64,240, 65, 65/ +data (staircase(i),i=709,720) /240, 67, 67,240, 68, 68,240, 69, 69,240, 70, 70/ +data (staircase(i),i=721,732) /240, 70, 70,240, 71, 71,240, 72, 72,240, 74, 74/ +data (staircase(i),i=733,744) /240, 75, 75,240, 76, 76,240, 76, 76,240, 77, 77/ +data (staircase(i),i=745,756) /240, 78, 78,240, 80, 80,242,100,100,244,134,134/ +data (staircase(i),i=757,768) /248,170,170,250,204,204,253,204,204,255,255,255/ + + +short standard[768] +data (standard(i),i= 1, 12) / 0, 0, 84, 1, 1, 87, 2, 2, 89, 4, 4, 90/ +data (standard(i),i= 13, 24) / 5, 5, 93, 6, 6, 95, 6, 6, 96, 7, 7, 99/ +data (standard(i),i= 25, 36) / 8, 8,101, 10, 10,102, 11, 11,104, 12, 12,107/ +data (standard(i),i= 37, 48) / 12, 12,108, 13, 13,110, 14, 14,113, 16, 16,114/ +data (standard(i),i= 49, 60) / 17, 17,116, 18, 18,119, 19, 19,121, 19, 19,122/ +data (standard(i),i= 61, 72) / 20, 20,125, 21, 21,127, 23, 23,128, 24, 24,131/ +data (standard(i),i= 73, 84) / 25, 25,133, 25, 25,134, 26, 26,136, 27, 27,139/ +data (standard(i),i= 85, 96) / 29, 29,140, 30, 30,142, 31, 31,145, 31, 31,146/ +data (standard(i),i= 97,108) / 32, 32,148, 33, 33,150, 34, 34,153, 36, 36,154/ +data (standard(i),i=109,120) / 37, 37,157, 38, 38,159, 38, 38,160, 39, 39,163/ +data (standard(i),i=121,132) / 40, 40,165, 42, 42,166, 43, 43,169, 44, 44,171/ +data (standard(i),i=133,144) / 44, 44,172, 45, 45,174, 46, 46,177, 48, 48,178/ +data (standard(i),i=145,156) / 49, 49,180, 50, 50,183, 51, 51,184, 51, 51,186/ +data (standard(i),i=157,168) / 52, 52,189, 53, 53,191, 55, 55,192, 56, 56,195/ +data (standard(i),i=169,180) / 57, 57,197, 57, 57,198, 58, 58,201, 59, 59,203/ +data (standard(i),i=181,192) / 61, 61,204, 62, 62,206, 63, 63,209, 63, 63,210/ +data (standard(i),i=193,204) / 64, 64,212, 65, 65,215, 67, 67,216, 68, 68,218/ +data (standard(i),i=205,216) / 69, 69,221, 70, 70,223, 70, 70,224, 71, 71,227/ +data (standard(i),i=217,228) / 72, 72,229, 74, 74,230, 75, 75,233, 76, 76,235/ +data (standard(i),i=229,240) / 76, 76,236, 77, 77,238, 78, 78,241, 80, 80,242/ +data (standard(i),i=241,252) / 81, 81,244, 82, 82,247, 82, 82,248, 83, 83,250/ +data (standard(i),i=253,264) / 84, 84,253, 0, 84, 0, 1, 87, 1, 2, 89, 2/ +data (standard(i),i=265,276) / 4, 90, 4, 5, 93, 5, 6, 95, 6, 6, 96, 6/ +data (standard(i),i=277,288) / 7, 99, 7, 8,101, 8, 10,102, 10, 11,104, 11/ +data (standard(i),i=289,300) / 12,107, 12, 12,108, 12, 13,110, 13, 14,113, 14/ +data (standard(i),i=301,312) / 16,114, 16, 17,116, 17, 18,119, 18, 19,121, 19/ +data (standard(i),i=313,324) / 19,122, 19, 20,125, 20, 21,127, 21, 23,128, 23/ +data (standard(i),i=325,336) / 24,131, 24, 25,133, 25, 25,134, 25, 26,136, 26/ +data (standard(i),i=337,348) / 27,139, 27, 29,140, 29, 30,142, 30, 31,145, 31/ +data (standard(i),i=349,360) / 31,146, 31, 32,148, 32, 33,150, 33, 34,153, 34/ +data (standard(i),i=361,372) / 36,154, 36, 37,157, 37, 38,159, 38, 38,160, 38/ +data (standard(i),i=373,384) / 39,163, 39, 40,165, 40, 42,166, 42, 43,169, 43/ +data (standard(i),i=385,396) / 44,171, 44, 44,172, 44, 45,174, 45, 46,177, 46/ +data (standard(i),i=397,408) / 48,178, 48, 49,180, 49, 50,183, 50, 51,184, 51/ +data (standard(i),i=409,420) / 51,186, 51, 52,189, 52, 53,191, 53, 55,192, 55/ +data (standard(i),i=421,432) / 56,195, 56, 57,197, 57, 57,198, 57, 58,201, 58/ +data (standard(i),i=433,444) / 59,203, 59, 61,204, 61, 62,206, 62, 63,209, 63/ +data (standard(i),i=445,456) / 63,210, 63, 64,212, 64, 65,215, 65, 67,216, 67/ +data (standard(i),i=457,468) / 68,218, 68, 69,221, 69, 70,223, 70, 70,224, 70/ +data (standard(i),i=469,480) / 71,227, 71, 72,229, 72, 74,230, 74, 75,233, 75/ +data (standard(i),i=481,492) / 76,235, 76, 76,236, 76, 77,238, 77, 78,241, 78/ +data (standard(i),i=493,504) / 80,242, 80, 81,244, 81, 82,247, 82, 82,248, 82/ +data (standard(i),i=505,516) / 83,250, 83, 84,253, 84, 84, 0, 0, 87, 1, 1/ +data (standard(i),i=517,528) / 89, 2, 2, 90, 4, 4, 93, 5, 5, 95, 6, 6/ +data (standard(i),i=529,540) / 96, 6, 6, 99, 7, 7,101, 8, 8,102, 10, 10/ +data (standard(i),i=541,552) /104, 11, 11,107, 12, 12,108, 12, 12,110, 13, 13/ +data (standard(i),i=553,564) /113, 14, 14,114, 16, 16,116, 17, 17,119, 18, 18/ +data (standard(i),i=565,576) /121, 19, 19,122, 19, 19,125, 20, 20,127, 21, 21/ +data (standard(i),i=577,588) /128, 23, 23,131, 24, 24,133, 25, 25,134, 25, 25/ +data (standard(i),i=589,600) /136, 26, 26,139, 27, 27,140, 29, 29,142, 30, 30/ +data (standard(i),i=601,612) /145, 31, 31,146, 31, 31,148, 32, 32,150, 33, 33/ +data (standard(i),i=613,624) /153, 34, 34,154, 36, 36,157, 37, 37,159, 38, 38/ +data (standard(i),i=625,636) /160, 38, 38,163, 39, 39,165, 40, 40,166, 42, 42/ +data (standard(i),i=637,648) /169, 43, 43,171, 44, 44,172, 44, 44,174, 45, 45/ +data (standard(i),i=649,660) /177, 46, 46,178, 48, 48,180, 49, 49,183, 50, 50/ +data (standard(i),i=661,672) /184, 51, 51,186, 51, 51,189, 52, 52,191, 53, 53/ +data (standard(i),i=673,684) /192, 55, 55,195, 56, 56,197, 57, 57,198, 57, 57/ +data (standard(i),i=685,696) /201, 58, 58,203, 59, 59,204, 61, 61,206, 62, 62/ +data (standard(i),i=697,708) /209, 63, 63,210, 63, 63,212, 64, 64,215, 65, 65/ +data (standard(i),i=709,720) /216, 67, 67,218, 68, 68,221, 69, 69,223, 70, 70/ +data (standard(i),i=721,732) /224, 70, 70,227, 71, 71,229, 72, 72,230, 74, 74/ +data (standard(i),i=733,744) /233, 75, 75,235, 76, 76,236, 76, 76,238, 77, 77/ +data (standard(i),i=745,756) /241, 78, 78,242, 80, 80,244, 81, 81,247, 82, 82/ +data (standard(i),i=757,768) /248, 82, 82,250, 83, 83,253, 84, 84,255, 85, 85/ + + +short overlay[768] +data (overlay(i),i= 1, 12) / 0, 0, 0, 1, 1, 1, 3, 3, 3, 4, 4, 4/ +data (overlay(i),i= 13, 24) / 5, 5, 5, 6, 6, 6, 8, 8, 8, 9, 9, 9/ +data (overlay(i),i= 25, 36) / 10, 10, 10, 11, 11, 11, 13, 13, 13, 14, 14, 14/ +data (overlay(i),i= 37, 48) / 15, 15, 15, 17, 17, 17, 18, 18, 18, 19, 19, 19/ +data (overlay(i),i= 49, 60) / 20, 20, 20, 22, 22, 22, 23, 23, 23, 24, 24, 24/ +data (overlay(i),i= 61, 72) / 26, 26, 26, 27, 27, 27, 28, 28, 28, 29, 29, 29/ +data (overlay(i),i= 73, 84) / 31, 31, 31, 32, 32, 32, 33, 33, 33, 34, 34, 34/ +data (overlay(i),i= 85, 96) / 36, 36, 36, 37, 37, 37, 38, 38, 38, 40, 40, 40/ +data (overlay(i),i= 97,108) / 41, 41, 41, 42, 42, 42, 43, 43, 43, 45, 45, 45/ +data (overlay(i),i=109,120) / 46, 46, 46, 47, 47, 47, 48, 48, 48, 50, 50, 50/ +data (overlay(i),i=121,132) / 51, 51, 51, 52, 52, 52, 54, 54, 54, 55, 55, 55/ +data (overlay(i),i=133,144) / 56, 56, 56, 57, 57, 57, 59, 59, 59, 60, 60, 60/ +data (overlay(i),i=145,156) / 61, 61, 61, 62, 62, 62, 64, 64, 64, 65, 65, 65/ +data (overlay(i),i=157,168) / 66, 66, 66, 68, 68, 68, 69, 69, 69, 70, 70, 70/ +data (overlay(i),i=169,180) / 71, 71, 71, 73, 73, 73, 74, 74, 74, 75, 75, 75/ +data (overlay(i),i=181,192) / 77, 77, 77, 78, 78, 78, 79, 79, 79, 80, 80, 80/ +data (overlay(i),i=193,204) / 82, 82, 82, 83, 83, 83, 84, 84, 84, 85, 85, 85/ +data (overlay(i),i=205,216) / 87, 87, 87, 88, 88, 88, 89, 89, 89, 91, 91, 91/ +data (overlay(i),i=217,228) / 92, 92, 92, 93, 93, 93, 94, 94, 94, 96, 96, 96/ +data (overlay(i),i=229,240) / 97, 97, 97, 98, 98, 98, 99, 99, 99,101,101,101/ +data (overlay(i),i=241,252) /102,102,102,103,103,103,105,105,105,106,106,106/ +data (overlay(i),i=253,264) /107,107,107,108,108,108,110,110,110,111,111,111/ +data (overlay(i),i=265,276) /112,112,112,113,113,113,115,115,115,116,116,116/ +data (overlay(i),i=277,288) /117,117,117,119,119,119,120,120,120,121,121,121/ +data (overlay(i),i=289,300) /122,122,122,124,124,124,125,125,125,126,126,126/ +data (overlay(i),i=301,312) /128,128,128,129,129,129,130,130,130,131,131,131/ +data (overlay(i),i=313,324) /133,133,133,134,134,134,135,135,135,136,136,136/ +data (overlay(i),i=325,336) /138,138,138,139,139,139,140,140,140,142,142,142/ +data (overlay(i),i=337,348) /143,143,143,144,144,144,145,145,145,147,147,147/ +data (overlay(i),i=349,360) /148,148,148,149,149,149,150,150,150,152,152,152/ +data (overlay(i),i=361,372) /153,153,153,154,154,154,156,156,156,157,157,157/ +data (overlay(i),i=373,384) /158,158,158,159,159,159,161,161,161,162,162,162/ +data (overlay(i),i=385,396) /163,163,163,164,164,164,166,166,166,167,167,167/ +data (overlay(i),i=397,408) /168,168,168,170,170,170,171,171,171,172,172,172/ +data (overlay(i),i=409,420) /173,173,173,175,175,175,176,176,176,177,177,177/ +data (overlay(i),i=421,432) /179,179,179,180,180,180,181,181,181,182,182,182/ +data (overlay(i),i=433,444) /184,184,184,185,185,185,186,186,186,187,187,187/ +data (overlay(i),i=445,456) /189,189,189,190,190,190,191,191,191,193,193,193/ +data (overlay(i),i=457,468) /194,194,194,195,195,195,196,196,196,198,198,198/ +data (overlay(i),i=469,480) /199,199,199,200,200,200,201,201,201,203,203,203/ +data (overlay(i),i=481,492) /204,204,204,205,205,205,207,207,207,208,208,208/ +data (overlay(i),i=493,504) /209,209,209,210,210,210,212,212,212,213,213,213/ +data (overlay(i),i=505,516) /214,214,214,215,215,215,217,217,217,218,218,218/ +data (overlay(i),i=517,528) /219,219,219,221,221,221,222,222,222,223,223,223/ +data (overlay(i),i=529,540) /224,224,224,226,226,226,227,227,227,228,228,228/ +data (overlay(i),i=541,552) /230,230,230,231,231,231,232,232,232,233,233,233/ +data (overlay(i),i=553,564) /235,235,235,236,236,236,237,237,237,238,238,238/ +data (overlay(i),i=565,576) /240,240,240,241,241,241,242,242,242,244,244,244/ +data (overlay(i),i=577,588) /245,245,245,246,246,246,247,247,247,249,249,249/ +data (overlay(i),i=589,600) /250,250,250,251,251,251,252,252,252,254,254,254/ +data (overlay(i),i=601,612) /255,255,255, 0, 0, 0,255,255,255,255, 0, 0/ +data (overlay(i),i=613,624) / 0,255, 0, 0, 0,255,255,255, 0, 0,255,255/ +data (overlay(i),i=625,636) /255, 0,255,255,127, 80,176, 48, 96,255,165, 0/ +data (overlay(i),i=637,648) /255,246,143,218,112,214, 0,245,255,238,130,238/ +data (overlay(i),i=649,660) /255,231,186, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=661,672) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=673,684) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=685,696) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=697,708) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=709,720) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=721,732) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=733,744) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=745,756) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ +data (overlay(i),i=757,768) / 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0/ diff --git a/pkg/dataio/export/exbltins.h b/pkg/dataio/export/exbltins.h new file mode 100644 index 00000000..0723cdb2 --- /dev/null +++ b/pkg/dataio/export/exbltins.h @@ -0,0 +1,28 @@ +# EXBLTINS.H -- Macro definitions for builtin formats. + +define EX_FORMATS "|eps|epsi|epi|epsf|gif|giff|iraf|imh|miff|pgm|ppm|\ + |ps|ras|sun|sunras|rgb|sgi|irix|xwd|x11|vicar2|" + +define EPS 1 # Encapsulated PostScript +define EPSI 2 # Encapsulated PostScript (alias) +define EPI 3 # Encapsulated PostScript (alias) +define EPSF 4 # Encapsulated PostScript (alias) +define GIF 5 # Compuserve GIF format +define GIFF 6 # Compuserve GIF format (alias) +define IRAF 7 # IRAF OIF format (hidden) +define IMH 8 # IRAF OIF format (alias) +define MIFF 9 # ImageMagick MIFF format +define PGM 10 # PBMplus PGM grayscale format +define PPM 11 # PBMplus PPM color format +#newline +define PS 13 # Sun rasterfile format +define RAS 14 # Sun rasterfile format +define SUN 15 # Sun rasterfile format (alias) +define SUNRAS 16 # Sun rasterfile format (alias) +define RGB 17 # Silicon Graphics RGB format +define SGI 18 # Silicon Graphics RGB format (alias) +define IRIS 19 # Silicon Graphics RGB format (alias) +define XWD 20 # X11 Window dump +define X11 21 # X11 Window dump (alias) +define VICAR 22 # VICAR2 format + diff --git a/pkg/dataio/export/exbltins.x b/pkg/dataio/export/exbltins.x new file mode 100644 index 00000000..bb0152dd --- /dev/null +++ b/pkg/dataio/export/exbltins.x @@ -0,0 +1,243 @@ +include <mach.h> +include "export.h" +include "exbltins.h" + + +# EXb_BUILTIN - Process a builtin format. + +procedure exb_process_image (ex) + +pointer ex #i task struct pointer + +begin + # Branch to the appropriate procedure for processing. + switch (EX_BLTIN(ex)) { + case EPS: # Encapsulated PostScript + call ex_eps (ex) + case GIF: # GIF + call ex_gif (ex) + case IMH: # IRAF OIF + call ex_iraf (ex) + case MIFF: # ImageMagick MIFF file + call ex_miff (ex) + case PGM: # PBMplus PGM (grayscale) file + call ex_pgm (ex) + case PPM: # PBMplus PPM (RGB) file + call ex_ppm (ex) + case RAS: # Sun rasterfile + call ex_ras (ex) + case RGB: # SGI RGB format file + call ex_rgb (ex) + case XWD: # X11 Window Dump + call ex_xwd (ex) + case VICAR: # JPL VICAR2 format image + call ex_vicar (ex) + default: + call error (0, "Unrecognized format") + } +end + + +# EXB_CHKPARS - Check the parameters for the builtin parameters. + +int procedure exb_chkpars (ex) + +pointer ex #i task struct pointer + +int legal, fmt + +begin + # Do a quick check that the number of expressions is valid for + # the requested format. + legal = NO + fmt = EX_BLTIN(ex) + switch (EX_NEXPR(ex)) { + case 1: + # PPM is the only format required to have 3 expressions. + if (fmt != PPM) + legal = YES + case 3: + if (fmt == PPM || fmt == RAS || fmt == RGB || + fmt == XWD || fmt == EPS || fmt == MIFF) + legal = YES + case 4: + if (fmt == RAS || fmt == XWD) + legal = YES + case EX_UNDEFINED: # let it slide for now.... + legal = YES + default: + if (bitset (EX_OUTFLAGS(ex), OF_BAND)) + legal = YES + } + if (legal == NO) { + call error (1, "Wrong no. of expressions for requested format") + return (ERR) + } + + # Check the bswap param. If it's set but ignored by a given format + # warn the user. + if (EX_BSWAP(ex) != S_NONE && (fmt != RAS && fmt != XWD)) { + call eprintf ("Warning: `bswap' parameter will be ignored") + return (ERR) + } + + return (OK) +end + + +# EXB_DO_FORMAT - Process a builtin task format parameter and set appropriate +# flags. + +procedure exb_do_format (ex, format) + +pointer ex #i task struct pointer +char format[ARB] #i format parameter value + +char fmt[SZ_FNAME] +int strdic() + +begin + switch (strdic (format, fmt, SZ_FNAME, EX_FORMATS)) { + case EPS, EPSI, EPI, EPSF, PS: + EX_BLTIN(ex) = EPS + EX_COLOR(ex) = YES + case GIF, GIFF: + EX_BLTIN(ex) = GIF + EX_COLOR(ex) = YES + case IMH, IRAF: + EX_BLTIN(ex) = IMH + EX_COLOR(ex) = NO + case MIFF: + EX_BLTIN(ex) = MIFF + EX_COLOR(ex) = YES + case PGM: + EX_BLTIN(ex) = PGM + EX_COLOR(ex) = NO + case PPM: + EX_BLTIN(ex) = PPM + EX_COLOR(ex) = NO + case RAS, SUN, SUNRAS: + EX_BLTIN(ex) = RAS + EX_COLOR(ex) = YES + case RGB, SGI, IRIS: + EX_BLTIN(ex) = RGB + EX_COLOR(ex) = NO + case XWD, X11: + EX_BLTIN(ex) = XWD + EX_COLOR(ex) = YES + case VICAR: + EX_BLTIN(ex) = VICAR + EX_COLOR(ex) = NO + default: + call error (2, "Unknown format.") + } +end + + +# EXB_PNAME - Print verbose name of the format. + +procedure exb_pname (ex) + +pointer ex #i task struct pointer + +begin + switch (EX_BLTIN(ex)) { + case EPS: + call pargstr ("Encapsulated PostScript") + case GIF: + call pargstr ("GIF") + case MIFF: + call pargstr ("ImageMagick MIFF") + case PGM: + call pargstr ("PGM") + case PPM: + call pargstr ("PPM") + case RAS: + call pargstr ("Sun Rasterfile") + case RGB: + call pargstr ("SGI RGB") + case XWD: + call pargstr ("X11 Window Dump") + case VICAR: + call pargstr ("JPL VICAR2 Image") + default: + call pargstr ("") + } +end + + +# EXB_PENDIAN - Print byte order of the format. + +procedure exb_pendian (ex) + +pointer ex #i task struct pointer + +begin + switch (EX_BLTIN(ex)) { + case GIF: + call pargstr ("Least Significant Byte First") + default: + if (EX_BSWAP(ex) == 0 && (BYTE_SWAP2==NO || BYTE_SWAP4==NO)) + call pargstr ("Most Significant Byte First") + else + call pargstr ("Least Significant Byte First") + } +end + + +# EXB_PSTORAGE - Print pixel storage type of the format. + +procedure exb_pstorage (ex) + +pointer ex #i task struct pointer + +int flags + +begin + switch (EX_BLTIN(ex)) { + case GIF: + call pargstr ("LZW compressed bytes") + case RGB: + call pargstr ("Band interleaved") + default: + flags = EX_OUTFLAGS(ex) + if (bitset(flags, OF_BAND) || bitset(flags,BAND_STORAGE)) + call pargstr ("Band Interleaved") + else if (bitset(flags, OF_LINE) || bitset(flags,LINE_STORAGE)) + call pargstr ("Line Interleaved") + else if (bitset(flags,PIXEL_STORAGE)) + call pargstr ("Pixel Interleaved") + else + call pargstr ("Unknown") + } +end + + +# EXB_FMT_EXT - Print the name of the builtin format. The returned pointer +# must be freed by the calling procedure. + +pointer procedure exb_fmt_ext (ex) + +pointer ex #i task struct pointer + +pointer suf + +begin + call malloc (suf, SZ_FNAME, TY_CHAR) + + switch (EX_BLTIN(ex)) { + case EPS: call strcpy (".eps", Memc[suf], SZ_FNAME) + case GIF: call strcpy (".gif", Memc[suf], SZ_FNAME) + case IMH: call strcpy (".imh", Memc[suf], SZ_FNAME) + case MIFF: call strcpy (".miff", Memc[suf], SZ_FNAME) + case PGM: call strcpy (".pgm", Memc[suf], SZ_FNAME) + case PPM: call strcpy (".ppm", Memc[suf], SZ_FNAME) + case RAS: call strcpy (".ras", Memc[suf], SZ_FNAME) + case RGB: call strcpy (".rgb", Memc[suf], SZ_FNAME) + case XWD: call strcpy (".xwd", Memc[suf], SZ_FNAME) + case VICAR: call strcpy (".vic", Memc[suf], SZ_FNAME) + default: Memc[suf] = EOS + } + + return (suf) +end diff --git a/pkg/dataio/export/excmap.x b/pkg/dataio/export/excmap.x new file mode 100644 index 00000000..486813ef --- /dev/null +++ b/pkg/dataio/export/excmap.x @@ -0,0 +1,258 @@ +include <lexnum.h> +include "export.h" + + +define EX_COLORMAPS "|aips0|blue|color|grayscale|greyscale|green|halley\ + |heat|rainbow|red|staircase|standard|overlay|" + +define AIPS0 1 # builtin colormaps +define BLUE 2 +define COLOR 3 +define GRAYSCALE 4 +define GREYSCALE 5 +define GREEN 6 +define HALLEY 7 +define HEAT 8 +define RAINBOW 9 +define RED 10 +define STAIRCASE 11 +define STANDARD 12 +define OVERLAY 13 + + +# EX_READ_CMAP - Read a colormap into the colormap structure. We assume the +# colormap is either a normalized CLT of RGB values between zero and one, or +# RGB integer values between 0 and 255. The format of the file is three +# values per line given as a red, green, and blue color. If the first line +# contains a single number assume it's the number of colors. A maximum of +# 256 colors will be read, if fewer values are read the remaining colors will +# be filled with zeros. + +procedure ex_read_cmap (ex, cmname) + +pointer ex #i colormap pointer +char cmname[ARB] #i colormap file name + +pointer cmap +pointer sp, line +real r, g, b, scale +int i, stat, fd, type, ncolors + +int open(), fscan(), nscan() +int getline(), lexnum(), strdic() +errchk open + +define rdmap_ 99 + +begin + # See if this is a builtin colormap request. + if (strdic(cmname,cmname,SZ_LINE,EX_COLORMAPS) > 0) { + call ex_bltin_cmap (ex, cmname) + return + } + + # Open the colormap filename. + iferr (fd = open (cmname, READ_ONLY, TEXT_FILE)) + call error (0, "Cannot open requested colormap file.") + + # Check the first line to see if it's the number of colors or a + # CLT entry. + stat = fscan (fd) + call gargr (r) + call gargr (g) + call gargr (b) + if (nscan() == 1) { + ncolors = r + goto rdmap_ + } else if (nscan() == 3) { + call seek (fd, BOF) +rdmap_ call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + stat = getline (fd, Memc[line]) + i = 1 + ncolors = 256 + type = lexnum (Memc[line], i, stat) + + if (type == LEX_REAL) + scale = 255.0 + else if (type == LEX_DECIMAL) + scale = 1.0 + else + call error (0, "Colormap file has an unknown format.") + + call sfree (sp) + } else + call error (1, "Colormap file has an unknown format.") + + # Read in a normalize colormap file. + cmap = EX_CMAP(ex) + for (i=1; fscan(fd) != EOF && i <= ncolors; i=i+1) { + call gargr (r) + call gargr (g) + call gargr (b) + + CMAP(cmap,EX_RED,i) = max (0, min (255, int (r * scale + 0.5))) + CMAP(cmap,EX_GREEN,i) = max (0, min (255, int (g * scale + 0.5))) + CMAP(cmap,EX_BLUE,i) = max (0, min (255, int (b * scale + 0.5))) + } + ncolors = i + EX_NCOLORS(ex) = ncolors + + # Close the file. + call close (fd) +end + + +# EX_SCALE_CMAP - Scale the colormap with the requested brightness and +# contrast values. + +procedure ex_scale_cmap (cmap, ncolors, brightness, contrast) + +pointer cmap #i colormap pointer +int ncolors #i number of colors in map +real brightness #i brightness offset +real contrast #i contrast scale + +pointer sp, ctmp +int i, c1, c2 +short r, g, b +real x, y, z, frac, slope, offset + +begin + call smark (sp) + call salloc (ctmp, 3*CMAP_SIZE, TY_CHAR) + call aclrc (Memc[ctmp], 3*CMAP_SIZE) + + slope = max (-7.0, min (7.0, contrast)) + offset = max (0.0, min (1.0, brightness)) + + # Compute the scaled colormap. + do i = 1, ncolors { + x = real (i) / real (ncolors) + y = (x - offset) * slope + 0.5 + + if (y <= 0.0) { + r = CMAP(cmap,EX_RED, 1) + g = CMAP(cmap,EX_GREEN,1) + b = CMAP(cmap,EX_BLUE, 1) + } else if (y >= 1.0) { + r = CMAP(cmap,EX_RED, ncolors) + g = CMAP(cmap,EX_GREEN,ncolors) + b = CMAP(cmap,EX_BLUE, ncolors) + } else { + z = y * (ncolors - 1) + c1 = max (1, int (z)) + c2 = min (ncolors-1, c1 + 1) + frac = z - c1 + r = CMAP(cmap,EX_RED,c1) * (1.0 - frac) + + CMAP(cmap,EX_RED,c2) * frac + g = CMAP(cmap,EX_GREEN,c1) * (1.0 - frac) + + CMAP(cmap,EX_GREEN,c2) * frac + b = CMAP(cmap,EX_BLUE,c1) * (1.0 - frac) + + CMAP(cmap,EX_BLUE,c2) * frac + } + + CMAP(ctmp,EX_RED, i) = r + CMAP(ctmp,EX_GREEN,i) = g + CMAP(ctmp,EX_BLUE, i) = b + } + call amovc (Memc[ctmp], Memc[cmap], 3*CMAP_SIZE) + + call sfree (sp) +end + + +# EX_BLTIN_CMAP - Load a predefined colormap. + +procedure ex_bltin_cmap (ex, cmname) + +pointer ex #i task struct pointer +char cmname[ARB] #i colormap name + +pointer cmap +int i, j, strdic() + +include "cmaps.inc" + +begin + j = 1 + cmap = EX_CMAP(ex) + EX_NCOLORS(ex) = CMAP_SIZE + + switch (strdic (cmname, cmname, SZ_LINE, EX_COLORMAPS)) { + case AIPS0: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = aips0[j] + CMAP(cmap,EX_GREEN,i) = aips0[j+1] + CMAP(cmap,EX_BLUE,i) = aips0[j+2] + j = j + 3 + } + case BLUE: + call aclrs (Mems[cmap], 3*CMAP_SIZE) + do i = 1, 256 + CMAP(cmap,EX_BLUE,i) = i - 1 + case COLOR: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = color[j] + CMAP(cmap,EX_GREEN,i) = color[j+1] + CMAP(cmap,EX_BLUE,i) = color[j+2] + j = j + 3 + } + case GRAYSCALE, GREYSCALE: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = i - 1 + CMAP(cmap,EX_GREEN,i) = i - 1 + CMAP(cmap,EX_BLUE,i) = i - 1 + } + case GREEN: + call aclrs (Mems[cmap], 3*CMAP_SIZE) + do i = 1, 256 + CMAP(cmap,EX_GREEN,i) = i - 1 + case HALLEY: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = halley[j] + CMAP(cmap,EX_GREEN,i) = halley[j+1] + CMAP(cmap,EX_BLUE,i) = halley[j+2] + j = j + 3 + } + case HEAT: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = heat[j] + CMAP(cmap,EX_GREEN,i) = heat[j+1] + CMAP(cmap,EX_BLUE,i) = heat[j+2] + j = j + 3 + } + case RAINBOW: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = rainbow[j] + CMAP(cmap,EX_GREEN,i) = rainbow[j+1] + CMAP(cmap,EX_BLUE,i) = rainbow[j+2] + j = j + 3 + } + case RED: + call aclrs (Mems[cmap], 3*CMAP_SIZE) + do i = 1, 256 + CMAP(cmap,EX_RED,i) = i - 1 + case STAIRCASE: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = staircase[j] + CMAP(cmap,EX_GREEN,i) = staircase[j+1] + CMAP(cmap,EX_BLUE,i) = staircase[j+2] + j = j + 3 + } + case STANDARD: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = standard[j] + CMAP(cmap,EX_GREEN,i) = standard[j+1] + CMAP(cmap,EX_BLUE,i) = standard[j+2] + j = j + 3 + } + case OVERLAY: + do i = 1, 256 { + CMAP(cmap,EX_RED,i) = overlay[j] + CMAP(cmap,EX_GREEN,i) = overlay[j+1] + CMAP(cmap,EX_BLUE,i) = overlay[j+2] + j = j + 3 + } + } +end diff --git a/pkg/dataio/export/exfcn.h b/pkg/dataio/export/exfcn.h new file mode 100644 index 00000000..7a9c61b3 --- /dev/null +++ b/pkg/dataio/export/exfcn.h @@ -0,0 +1,25 @@ +# EXFCN.H - Include file for the special functions supported by the EXPORT task. + +# Outbands expressions functions. +define OB_FUNCTIONS "|band|line|flipx|flipy|\ + |cmap|setcmap|psdpi|psscale|\ + |zscale|grey|gray|bscale|gamma|\ + |block|" + +define BAND 1 # force band-interleaved storage +define LINE 2 # force line-interleaved storage +define FLIPX 3 # flip image left-to-right +define FLIPY 4 # flip image top-to-bottom +#newline +define CMAP 6 # create 8-bit colormap +define SETCMAP 7 # apply a colormap +define PSDPI 8 # set dpi for output +define PSSCALE 9 # set scale of PS output +#newline +define ZSCALE 11 # scale to a fixed number of bins +define GREY 12 # RGB to greyscale conversion +define GRAY 13 # " " " " +define BSCALE 14 # linearly transform intensity scale +define GAMMA 15 # apply a gamma correction +#newline +define BLOCK 17 # floodfill a block w/ a constant diff --git a/pkg/dataio/export/exhdr.x b/pkg/dataio/export/exhdr.x new file mode 100644 index 00000000..9ba56a99 --- /dev/null +++ b/pkg/dataio/export/exhdr.x @@ -0,0 +1,207 @@ +include <error.h> +include <fset.h> +include <imhdr.h> +include <imio.h> +include <time.h> +include <mach.h> +include "export.h" + + +# EX_WHEADER - Write the output file header information. + +procedure ex_wheader (ex, outfile) + +pointer ex #i task struct pointer +char outfile[ARB] #i output file name + +pointer sp, tfile, buf, cbuf +int file_type, nchars + +int fd, open(), access(), strlen() +long fsize, fstatl() + +errchk open, access + +begin + if (EX_HEADER(ex) == HDR_SHORT || EX_HEADER(ex) == HDR_LONG) { + + call smark (sp) + call salloc (tfile, SZ_PATHNAME, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (cbuf, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[cbuf], SZ_LINE) + + # Write the generic header. + call mktemp ("tmp$ex", Memc[tfile], SZ_PATHNAME) + fd = open (Memc[tfile], NEW_FILE, TEXT_FILE) + call ex_mkheader (ex, fd) + call close (fd) + + if (EX_FORMAT(ex) != FMT_LIST) + fd = open (Memc[tfile], READ_ONLY, BINARY_FILE) + else + fd = open (Memc[tfile], READ_ONLY, TEXT_FILE) + fsize = fstatl (fd, F_FILESIZE) * SZB_CHAR + nchars = fsize + 27 #+ fsize/10 + call sprintf (Memc[buf], SZ_LINE, "format = EXPORT\nhdrsize = %d\n") + call pargi (nchars) + nchars = strlen (Memc[buf]) + if (EX_FD(ex) != STDOUT && EX_FORMAT(ex) != FMT_LIST) { + call strpak (Memc[buf], Memc[cbuf], nchars) + call write (EX_FD(ex), Memc[cbuf], nchars/SZB_CHAR) + call fcopyo (fd, EX_FD(ex)) + call close (fd) + } else { + call fprintf (EX_FD(ex), "%s") + call pargstr (Memc[buf]) + if (EX_FORMAT(ex) == FMT_LIST) + call fcopyo (fd, EX_FD(ex)) + else + call fcopy (Memc[tfile], "STDOUT") + + call close (fd) + } + + call delete (Memc[tfile]) + call sfree (sp) + + } else if (EX_HEADER(ex) == HDR_USER) { + # Copy user file to output. + iferr { + # If the user header is a text file we need to reopen the + # output file so the copy is done correctly. Afterwards + # we'll reopen it as a binary file. + if (access (HDRFILE(ex), 0, TEXT_FILE) == YES) { + file_type = TEXT_FILE + call close (EX_FD(ex)) + EX_FD(ex) = open (outfile, APPEND, file_type) + } else + file_type = BINARY_FILE + + fd = open (HDRFILE(ex), READ_ONLY, file_type) + call fcopyo (fd, EX_FD(ex)) + if (EX_FD(ex) != STDOUT) + call close (fd) + + if (file_type == TEXT_FILE) { + if (EX_FD(ex) != STDOUT) + call close (EX_FD(ex)) + if (EX_FORMAT(ex) != FMT_LIST) + EX_FD(ex) = open (outfile, APPEND, BINARY_FILE) + } + } then + call error (2, "Error writing user header.") + } +end + + +# EX_MKHEADER - Write the generic binary file header. Since we need to +# output the size we'll write out just the trailer part to the temp file +# and copy it to the real output file later. + +procedure ex_mkheader (ex, fd) + +pointer ex #i task struct pointer +int fd #i temp file descriptor + +long clktime() # seconds since 00:00:00 10-Jan-80 +int tm[LEN_TMSTRUCT] # broken down time structure + +begin + # Write the time stamp string. + call brktime (clktime(0), tm) + call fprintf (fd, "date = '%d/%d/%d'\n") + call pargi (TM_MDAY(tm)) + call pargi (TM_MONTH(tm)) + call pargi (TM_YEAR(tm)) + + # ... and the rest of the header + call fprintf (fd, "ncols = %d\n") # image dimensions + call pargi (EX_OCOLS(ex)) + call fprintf (fd, "nrows = %d\n") + call pargi (EX_OROWS(ex)) + call fprintf (fd, "nbands = %d\n") + call pargi (EX_NEXPR(ex)) + + call fprintf (fd, "datatype = '%s'\n") # pixel type + call pargstr (Memc[EX_OTPTR(ex)]) + + call fprintf (fd, "outbands = '%s'\n") # outbands expressions + call pargstr (Memc[EX_OBPTR(ex)]) + + call fprintf (fd, "interleave = %d\n") # pixel interleave type + call pargi (EX_INTERLEAVE(ex)) + + call fprintf (fd, "bswap = %s\n") # byte swapping flag + switch (EX_BSWAP(ex)) { + case S_NONE: call pargstr ("none") + case S_ALL: call pargstr ("all") + case S_I2: call pargstr ("i2") + case S_I4: call pargstr ("i4") + } + + if (EX_HEADER(ex) == HDR_LONG) + call ex_wimhdr (ex, fd) # write image headers + + # Terminate header. + call fprintf (fd, "end\n") +end + + +# EX_WIMHDR - Write the image header information. Include the headers if this +# is a verbose output. + +procedure ex_wimhdr (ex, fd) + +pointer ex #i task struct pointer +int fd #i temp file descriptor + +pointer sp, lbuf, ip, im +int i, in, ncols, min_lenuserarea +int stropen(), getline(), envgeti() + +define USER_AREA Memc[($1+IMU-1)*SZ_STRUCT + 1] +define LMARGIN 4 + +begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + do i = 1, EX_NIMAGES(ex) { + + im = IO_IMPTR(IMOP(ex,i)) + call fprintf (fd, "image%d = '%s'\n") + call pargi (i) + call pargstr (IM_HDRFILE(im)) + call fprintf (fd, "header%d {\n") + call pargi (i) + + # Open user area in header. + min_lenuserarea = (LEN_IMDES+IM_LENHDRMEM(im)-IMU) * SZ_STRUCT - 1 + in = stropen (USER_AREA(im), min_lenuserarea, READ_ONLY) + ncols = envgeti ("ttyncols") - LMARGIN + + # Copy header records to the output, stripping any trailing + # whitespace and clipping at the right margin. + + while (getline (in, Memc[lbuf]) != EOF) { + for (ip=lbuf; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + while (ip > lbuf && Memc[ip-1] == ' ') + ip = ip - 1 + if (ip - lbuf > ncols) + ip = lbuf + ncols + Memc[ip] = '\n' + Memc[ip+1] = EOS + + call putline (fd, " ") + call putline (fd, Memc[lbuf]) + } + + call fprintf (fd, "}\n") + } + + call close (in) + call sfree (sp) +end diff --git a/pkg/dataio/export/exobands.gx b/pkg/dataio/export/exobands.gx new file mode 100644 index 00000000..cd7313a3 --- /dev/null +++ b/pkg/dataio/export/exobands.gx @@ -0,0 +1,390 @@ +include <error.h> +include <mach.h> +include <evvexpr.h> +include <fset.h> +include <ctype.h> +include "../export.h" +include "../exfcn.h" + +define DEBUG false +define VDEBUG false + + +# EX_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ex_evaluate (ex, expr) + +pointer ex #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ex_getop(), ex_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ex_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ex_getop), ex, locpr(ex_obfcn), ex, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# EX_GETOP -- Called by evvexpr to get an operand. + +procedure ex_getop (ex, opname, o) + +pointer ex #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype, imnum +pointer sp, buf +pointer op, param, emsg +pointer im + +#int ex_ptype() +int imgeti(), imgftype(), btoi(), ctoi() +bool streq(), imgetb() +double imgetd() + +define getpar_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (emsg, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[param], SZ_FNAME) + call aclrc (Memc[emsg], SZ_LINE) + + if (VDEBUG) { call eprintf ("getop: opname=%s ");call pargstr(opname)} + + # First see if it's one of the special image operands that was + # referenced in an "@param" call. + + if (((opname[1] != 'i' && opname[1] != 'b') && !IS_DIGIT(opname[2])) || + (opname[1] == 'i' && opname[2] == '_')) { + call strcpy (opname, Memc[param], SZ_FNAME) + im = IO_IMPTR(IMOP(ex,1)) +getpar_ O_LEN(o) = 0 + switch (imgftype (im, Memc[param])) { + case TY_BOOL: + O_TYPE(o) = TY_BOOL + O_VALI(o) = btoi (imgetb (im, Memc[param])) + case TY_CHAR: + O_TYPE(o) = TY_CHAR + O_LEN(o) = SZ_LINE + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + case TY_INT: + O_TYPE(o) = TY_INT + O_VALI(o) = imgeti (im, Memc[param]) + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + O_VALD(o) = imgetd (im, Memc[param]) + default: + call sprintf (Memc[emsg], SZ_LINE, "param %s not found\n") + call pargstr (Memc[param]) + call error (6, Memc[emsg]) + } + + call sfree (sp) + return + + } else if (IS_LOWER(opname[1]) && opname[3] == '.') { + # This is a tag.param operand. Break out the image tag name and + # get the image pointer for it, then get the parameter + if (opname[1] == 'b') { # band of 3-D image, only 1 ptr + imnum = 1 + } else if (opname[1] == 'i') { # image descriptor + i = 2 + if (ctoi (opname, i, imnum) == 0) + call error (6, "can't parse operand") + } else { + call sprintf (Memc[buf], SZ_LINE, + "Unknown outbands operand `%s'\n") + call pargstr(opname) + call error (1, Memc[buf]) + } + + # Get the parameter value. + im = IO_IMPTR(IMOP(ex,imnum)) + call strcpy (opname[4], Memc[param], SZ_FNAME) + goto getpar_ + } + + nops = EX_NIMOPS(ex) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = IMOP(ex,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG && found == YES) { + call eprintf (" tag=%s found=%d ") + call pargstr(Memc[IO_TAG(op)]) ; call pargi(found) + call zze_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + #optype = ex_ptype (IO_TYPE(op), IO_NBYTES(op)) + optype = IO_TYPE(op) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + $for (ilrd) + case TY_PIXEL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_PIXEL + call malloc (O_VALP(o), IO_NPIX(op), TY_PIXEL) + call amov$t (Mem$t[IO_DATA(op)], Mem$t[O_VALP(o)], IO_NPIX(op)) + $endfor + } + + } else { + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call error (1, Memc[buf]) + } + + call sfree (sp) +end + + +# EX_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ex_obfcn (ex, fcn, args, nargs, o) + +pointer ex #i package pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray +pointer scaled, data +int i, len, v_nargs, func, nbins +short sz1, sz2, sb1, sb2, zero +real gamma, bscale, bzero, scale, pix +real z1, z2 + +int strdic() +bool fp_equalr(), strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case ZSCALE: + v_nargs = -1 + case BSCALE: + v_nargs = 3 + case GAMMA: + v_nargs = -1 + case BLOCK: + v_nargs = 3 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zze_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + zero = 0 + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + $for (ilrd) + case TY_PIXEL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mem$t[r+i] + + G_COEFF * Mem$t[g+i] + + B_COEFF * Mem$t[b+i] + } + $endfor + } + + case ZSCALE: + data = O_VALP(args[1]) + switch (O_TYPE(args[2])) { + case TY_SHORT: z1 = O_VALS(args[2]) + case TY_INT: z1 = O_VALI(args[2]) + case TY_LONG: z1 = O_VALL(args[2]) + case TY_REAL: z1 = O_VALR(args[2]) + case TY_DOUBLE: z1 = O_VALD(args[2]) + } + switch (O_TYPE(args[3])) { + case TY_SHORT: z2 = O_VALS(args[3]) + case TY_INT: z2 = O_VALI(args[3]) + case TY_LONG: z2 = O_VALL(args[3]) + case TY_REAL: z2 = O_VALR(args[3]) + case TY_DOUBLE: z2 = O_VALD(args[3]) + } + if (nargs < 4) + nbins = 256 + else + nbins = O_VALI(args[4]) + len = O_LEN(args[1]) + O_LEN(o) = len + O_TYPE(o) = O_TYPE(args[1]) + call malloc (O_VALP(o), len, O_TYPE(args[1])) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + sz1 = z1 + sz2 = z2 + sb1 = 0 + sb2 = nbins - 1 + if (abs(sz2-sz1) > 1.0e-5) + call amaps (Mems[data], Mems[scaled], len, sz1, sz2, + sb1, sb2) + else + call amovks (0, Mems[scaled], len) + $for (ilrd) + case TY_PIXEL: + if (abs(z2-z1) > 1.0e-5) + call amap$t (Mem$t[data], Mem$t[scaled], len, PIXEL (z1), + PIXEL(z2), PIXEL (0), PIXEL (nbins-1)) + else + call amovk$t (PIXEL (0), Mem$t[scaled], len) + $endfor + } + + case BSCALE: + data = O_VALP(args[1]) + bzero = O_VALR(args[2]) + bscale = O_VALR(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Mems[data+i] - bzero) / bscale + } else + call amovks (zero, Mems[scaled], len) + $for (ilrd) + case TY_PIXEL: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Mem$t[data+i] - bzero) / bscale + } else + call amovk$t (PIXEL(0), Mem$t[scaled], len) + $endfor + } + + case GAMMA: + data = O_VALP(args[1]) + gamma = 1.0 / O_VALR(args[2]) + if (nargs == 3) + scale = max (1.0, O_VALR(args[3])) + else + scale = 255.0 + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + pix = max (zero, Mems[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + $for (ilrd) + case TY_PIXEL: + do i = 0, len { + pix = max (PIXEL(0), Mem$t[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + $endfor + } + + case BLOCK: + len = O_VALI(args[2]) + O_LEN(o) = len + O_TYPE(o) = O_TYPE(args[1]) + call malloc (O_VALP(o), len, O_TYPE(args[1])) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovks (O_VALS(args[1]), Mems[scaled], len) + case TY_INT: + call amovki (O_VALI(args[1]), Memi[scaled], len) + case TY_LONG: + call amovkl (O_VALL(args[1]), Meml[scaled], len) + case TY_REAL: + call amovkr (O_VALR(args[1]), Memr[scaled], len) + case TY_DOUBLE: + call amovkd (O_VALD(args[1]), Memd[scaled], len) + } + + + } + + if (DEBUG) { call zze_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/export/export.h b/pkg/dataio/export/export.h new file mode 100644 index 00000000..279e4378 --- /dev/null +++ b/pkg/dataio/export/export.h @@ -0,0 +1,155 @@ +# EXPORT.H -- Main include file for the task structure. + +# Main task structure. +define SZ_EXPSTRUCT 40 +define SZ_EXPSTR (20*SZ_LINE) +define EX_UNDEFINED -999 +define MAX_OBEXPR 250 +define MAX_OPERANDS 50 + + +define EX_FD Memi[$1] # output binary file descriptor +define EX_HEADER Memi[$1+1] # write an output header? +define EX_OUTTYPE Memi[$1+2] # outtype parameter value +define EX_INTERLEAVE Memi[$1+3] # interleave parameter value +define EX_BSWAP Memi[$1+4] # bswap parameter value +define EX_VERBOSE Memi[$1+5] # verbose parameter value + +define EX_FORMAT Memi[$1+6] # format parameter code +define EX_BLTIN Memi[$1+7] # buitlin format code +define EX_COLOR Memi[$1+8] # does format support color? +define EX_OROWS Memi[$1+9] # no. rows in output image +define EX_OCOLS Memi[$1+10] # no. cols in output image + +define EX_IMDIM Memi[$1+11] # input image list dimensionality +define EX_IMTYPE Memi[$1+12] # input image list type +define EX_NIMAGES Memi[$1+13] # number of images to convert +define EX_NCOLS Memi[$1+14] # number of columns in image +define EX_NLINES Memi[$1+15] # number of lines in image +define EX_NEXPR Memi[$1+16] # number of outbands expressions +define EX_NIMOPS Memi[$1+17] # image operand array (ptr) +define EX_IMOPS Memi[$1+18] # image operand array (ptr) + +define EX_OUTFLAGS Memi[$1+20] # output format flags +define EX_BFNPTR Memi[$1+21] # binary file name (ptr) +define EX_HDRPTR Memi[$1+22] # user-defined head file (ptr) +define EX_OTPTR Memi[$1+23] # output type string (ptr) +define EX_OBPTR Memi[$1+24] # outbands expression string (ptr) +define EX_CMPTR Memi[$1+25] # colormap filename (ptr) +define EX_LUTPTR Memi[$1+26] # LUT filename (ptr) +define EX_TIMPTR Memi[$1+27] # temp image name (ptr) +define EX_PSDPI Memr[P2R($1+28)] # EPS dpi resolution +define EX_PSSCALE Memr[P2R($1+29)] # EPS scale +define EX_BRIGHTNESS Memr[P2R($1+30)] # display brightness value +define EX_CONTRAST Memr[P2R($1+31)] # display contrast value + +define EX_CMAP Memi[$1+32] # colormap struct (ptr) +define EX_NCOLORS Memi[$1+33] # no. of colors in colormap +define EX_LUT Memi[$1+34] # LUT struct (ptr) +define EX_NLUTEL Memi[$1+35] # no. of indices in lut +define EX_OBANDS Memi[$1+36] # outbands array (ptr) + + +# Handy macros. +define HDRFILE Memc[EX_HDRPTR($1)] +define LUTFILE Memc[EX_LUTPTR($1)] +define CMAPFILE Memc[EX_CMPTR($1)] +define BFNAME Memc[EX_BFNPTR($1)] +define TIMNAME Memc[EX_TIMPTR($1)] +define OBANDS Memi[EX_OBANDS($1)+$2-1] +define IMOP Memi[EX_IMOPS($1)+$2-1] + + +# Define the outbands struct. +define LEN_OUTBANDS 5 +define OB_EXPSTR Memi[$1] # expression string (ptr) +define OB_WIDTH Memi[$1+1] # expression width +define OB_HEIGHT Memi[$1+2] # expression height + +define O_EXPR Memc[OB_EXPSTR(OBANDS($1,$2))] +define O_WIDTH OB_WIDTH(OBANDS($1,$2)) +define O_HEIGHT OB_HEIGHT(OBANDS($1,$2)) + + +# Operand structure. +define LEN_OPERAND 10 +define IO_IMPTR Memi[$1] # image descriptor +define IO_BAND Memi[$1+1] # image band +define IO_LINE Memi[$1+2] # image line + +define IO_TAG Memi[$1+3] # operand tag name +define IO_TYPE Memi[$1+4] # operand type +define IO_NBYTES Memi[$1+5] # number of bytes +define IO_NPIX Memi[$1+6] # number of pixels +define IO_DATA Memi[$1+7] # pixel ptr +define IO_ISIM Memi[$1+8] # is data an image ptr? + +define OP_TAG Memc[IO_TAG($1)] + +#----------------------------------------------------------------------------- +# Useful Macro Definitions. + +define bitset (and($1,$2)==($2)) + +# Format flags. +define FMT_RAW 1 # write a generic binary raster +define FMT_LIST 2 # list pixels values to the screen +define FMT_BUILTIN 3 # write a builtin format + +# OUTPUT FLAGS: +# Byte swapping flags. +define S_NONE 0000B # swap nothing +define S_ALL 0001B # swap everything +define S_I2 0002B # swap short ints +define S_I4 0004B # swap long ints +define SWAP_STR "|no|none|yes|i2|i4|" + +# Pixel storage flags. +define PIXEL_STORAGE 0001B # { {RGB} {RGB} ... {RGB} ... } +define LINE_STORAGE 0002B # { {RRRR} {GGG} {BBB} .... {RRR} ... } +define BAND_STORAGE 0004B # { {RR..RRR} {GG...GGG} {BB..BBB} } + +# Output flags. +define OF_CMAP 00010B # a colormap was defined +define OF_MKCMAP 00020B # compute a colormap +define OF_BAND 00040B # force band storage +define OF_LINE 00100B # force line storage +define OF_FLIPX 00200B # flip image in X +define OF_FLIPY 00400B # flip image in Y +define OF_IEEE 01000B # write IEEE floating point + +# Header flags. +define HDR_NONE 1 # no output header +define HDR_SHORT 2 # write a short header +define HDR_LONG 3 # write a verbose header +define HDR_USER 4 # user defined a file + +# Pixtype pixel types. +define PT_BYTE 1 # byte data (no conversion) +define PT_UINT 2 # unsigned integer +define PT_INT 3 # signed integer +define PT_IEEE 4 # ieee floating point +define PT_NATIVE 5 # native floating point +define PT_SKIP 6 # skip + +# EPS output params. +define EPS_DPI 72 # dpi resolution +define EPS_SCALE 1.0 # output scale + +# Define colormap/grayscale macros and parameters. +define CMAP_SIZE 256 # Output colormap length +define CMAP_MAX 255 # Maximum map value +define CMAP Memc[$1+($2*CMAP_SIZE)+$3-1] + +define R_COEFF 0.299 # NTSC grayscale coefficients +define G_COEFF 0.587 +define B_COEFF 0.114 + +define EX_RED 0 # color flags +define EX_GREEN 1 +define EX_BLUE 2 + +define SAMPLE_SIZE 10000 # default zscale() sample size +define CONTRAST 0.25 # default zscale() contrast +define SAMP_LEN 40 # default zscale() sample length + diff --git a/pkg/dataio/export/expreproc.x b/pkg/dataio/export/expreproc.x new file mode 100644 index 00000000..579f1fde --- /dev/null +++ b/pkg/dataio/export/expreproc.x @@ -0,0 +1,352 @@ +include <error.h> +include <ctype.h> +include "export.h" +include "exfcn.h" + +define DEBUG false + + +# EX_PREPROCESS - Some of the output functions aren't really applied to +# each line in the image (which is how the expressions are evaluated) but +# just define some feature of the whole output image. We'll strip out +# those functions here and set a flag so that the expression evaluation +# code doesn't have to see them. + +procedure ex_preprocess (ex, expr) + +pointer ex #i task struct pointer +char expr[ARB] #i input expression strings + +char expstr[SZ_EXPSTR] +int ip, pp, last_ip, explen +char func[SZ_FNAME] +bool saw_output_func + +int strlen(), strdic(), nowhite() + +errchk ex_pp_setcmap, ex_pp_psdpi +errchk ex_cnt_parens, ex_pp_psscale + +begin + # Strip out any whitespace chars. + call aclrc (expstr, SZ_EXPSTR) + ip = nowhite (expr, expstr, SZ_EXPSTR) + + # Do a quick syntax check. + iferr (call ex_cnt_parens (expstr)) + call erract (EA_FATAL) + + # Only some functions may be nested, loop until we're forced to break. + # The functions have a precedence such that "special functions" + # may have as arguments "output functions". Below that are "scaling + # functions" and "builtin functions" that are evaluated for each image + # line. Functions w/in the same class may/may not call each other + # where it makes sense, we check for that here. + # + # The precedence order is: + # + # CMAP, SETCMAP, PSDPI, PSSCALE + # BAND, LINE, FLIPX, FLIPY + # ZSCALE, GRAY, BSCALE, GAMMA + # builtin functions + + if (DEBUG) { call eprintf("preproc: str=`%s'\n");call pargstr(expstr) } + + saw_output_func = false + for (ip = 1 ; expstr[ip] == '(' ; ip = ip + 1) + ; + + last_ip = 1 + explen = strlen (expstr) + repeat { + # Get the function name. + pp = 1 + call aclrc (func, SZ_FNAME) + while (expstr[ip] != '(' && expstr[ip] != EOS) { + func[pp] = expstr[ip] + ip = ip + 1 + pp = pp + 1 + } + func[pp+1] = EOS + if (expstr[ip] == EOS) { + call strcpy (expstr[last_ip], expr, SZ_EXPSTR) + return + } + if (DEBUG) { call eprintf("\tfunc=`%s'\n");call pargstr(func) } + + # Update pointer into string past '('. + ip = ip + 1 + + switch (strdic (func, func, SZ_FNAME, OB_FUNCTIONS)) { + + case CMAP: + if (EX_NEXPR(ex) > 1) + call error (4, + "cmap() func allowed only in single expression") + if (saw_output_func) + call error (5, + "Function cmap() may not be nested in output func.") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_MKCMAP) + + case SETCMAP: + if (EX_NEXPR(ex) > 1) + call error (4, + "setcmap() func allowed only in single expression") + if (saw_output_func) + call error (5, + "Function setcmap(0 may not be nested in output func.") + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_CMAP) + iferr (call ex_pp_setcmap (ex, expstr[ip])) + call erract (EA_FATAL) + last_ip = ip + explen = strlen (expstr) + next + + case PSDPI: + if (EX_NEXPR(ex) > 1) + call error (4, + "psdpi() func allowed only in single expression") + if (saw_output_func) + call error (5, + "Function psdpi() may not be nested in output func.") + iferr (call ex_pp_psdpi (ex, expstr[ip])) + call erract (EA_FATAL) + last_ip = ip + explen = strlen (expstr) + next + + case PSSCALE: + if (EX_NEXPR(ex) > 1) + call error (4, + "psscale() func allowed only in single expression") + if (saw_output_func) + call error (5, + "Function psscale() may not be nested in output func.") + iferr (call ex_pp_psscale (ex, expstr[ip])) + call erract (EA_FATAL) + last_ip = ip + explen = strlen (expstr) + next + + + case BAND: + saw_output_func = true + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_BAND) + case LINE: + saw_output_func = true + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_LINE) + case FLIPX: + saw_output_func = true + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPX) + case FLIPY: + saw_output_func = true + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_FLIPY) + + default: + # No special function seen so just punt. + break + } + + last_ip = ip # update string ptr + if (expstr[explen] != ')') + call error (5, + "Malformed expression, expecting ')' as last char") + expstr[explen] = EOS # remove trailing right paren + } + + # Copy expression from current ip to begining of buffer. + call strcpy (expstr[last_ip], expr, SZ_EXPSTR) + + if (DEBUG) { call eprintf("\tfixed exp =`%s'\n");call pargstr(expr) } +end + + +# EX_PP_SETCMAP - Process the SETCMAP special function. + +procedure ex_pp_setcmap (ex, expstr) + +pointer ex #i task struct pointer +char expstr[ARB] #i expression string + +pointer sp, cm, cmap +int ip, lp # string pointers +int tp, i # where to trim the string + +int ctor() +bool streq() +include "cmaps.inc" + +begin + call smark (sp) + call salloc (cm, SZ_FNAME, TY_CHAR) + call aclrc (Memc[cm], SZ_FNAME) + + if (DEBUG) { call eprintf("\t\texp=`%s'\n");call pargstr(expstr)} + + # Skip ahead to a quote char single or double) indicating colormap + # name, we also stop at another non-blank char incase they didn't + # use quotes. If we find a comma, back up one so it's handled below. + ip = 1 + while (expstr[ip] != EOS && + expstr[ip] != '"' && + expstr[ip] != '\'') { + if (expstr[ip] == '@') + for (ip=ip+2; expstr[ip] != '"'; ip=ip+1) + ; + ip = ip + 1 + } + tp = ip - 1 + + if (expstr[ip+1] == '"' || (expstr[ip+1]==' ' && expstr[ip+2]=='"') || + expstr[ip+1] == '\'' || (expstr[ip+1]==' ' && expstr[ip+2]=='\'')) { + # No colormap file specified, assume it's a greyscale. + call strcpy ("greyscale", CMAPFILE(ex), SZ_FNAME) + ip = ip + 1 + + } else { + # Get colormap name and put it in the task struct. + ip = ip + 1 + lp = 0 + repeat { + Memc[cm+lp] = expstr[ip] + lp = lp + 1 + ip = ip + 1 + } until (expstr[ip] == EOS || expstr[ip] == '"' || + expstr[ip] == '\'') + call strcpy (Memc[cm], CMAPFILE(ex), SZ_FNAME) + } + + # Allocate the colormap pointer and read the colormap. + iferr (call calloc (EX_CMAP(ex), 3*CMAP_SIZE, TY_CHAR)) + call error (0, "Error allocating colormap pointer.") + call ex_read_cmap (ex, CMAPFILE(ex)) + + # Get optional brightness and contrast values. + ip = ip + 1 + if (expstr[ip] == ',') { + ip = ip + 1 + if (ctor (expstr, ip, EX_BRIGHTNESS(ex)) == 0) + call error (5, "cannot interpret brightness value") + ip = ip + 1 + if (ctor (expstr, ip, EX_CONTRAST(ex)) == 0) + call error (5, "cannot interpret contrast value") + + # Don't scale the overlay colors in colormap. + if (streq(CMAPFILE(ex), "overlay")) { + cmap = EX_CMAP(ex) + call ex_scale_cmap (cmap, 200, + EX_BRIGHTNESS(ex), EX_CONTRAST(ex)) + + # Patch up the static overlay colors. + do i = 201, 255 { + Memc[cmap+(EX_RED*CMAP_SIZE)+i] = overlay[i*3+1] + Memc[cmap+(EX_GREEN*CMAP_SIZE)+i] = overlay[i*3+2] + Memc[cmap+(EX_BLUE*CMAP_SIZE)+i] = overlay[i*3+3] + } + } else { + call ex_scale_cmap (EX_CMAP(ex), EX_NCOLORS(ex), + EX_BRIGHTNESS(ex), EX_CONTRAST(ex)) + } + } + + # We should be at the end of the string now. + if (expstr[ip] != ')') + call error (5, "Malformed expression, expecting ')' as last char") + + if (DEBUG) { + call eprintf("\t\tcmfile=`%s' brightness=%g contrast=%g\n") + call pargstr(CMAPFILE(ex));call pargr(EX_BRIGHTNESS(ex)) + call pargr(EX_CONTRAST(ex)) + } + + # Now trim the expression string. + expstr[tp] = EOS + call sfree (sp) +end + + +# EX_PP_PSDPI - Process the PSDPI special function. + +procedure ex_pp_psdpi (ex, expstr) + +pointer ex #i task struct pointer +char expstr[ARB] #i expression string + +int ip, tp +int ctor(), strlen() + +begin + if (DEBUG) { call eprintf("\t\texp=`%s'\n");call pargstr(expstr)} + + # The last argument is required to be the dpi resolution so pull + # it out. + ip = strlen (expstr) + while (expstr[ip] != ',') { + ip = ip - 1 + if (expstr[ip] == ')' || IS_ALPHA(expstr[ip])) + call error (6, "syntax error") + } + + tp = ip + ip = ip + 1 + if (ctor(expstr,ip,EX_PSDPI(ex)) == 0) + call error (5, "cannot interpret EPS dpi value") + + # Now trim the expression string. + expstr[tp] = EOS +end + + +# EX_PP_PSSCALE - Process the PSSCALE special function. + +procedure ex_pp_psscale (ex, expstr) + +pointer ex #i task struct pointer +char expstr[ARB] #i expression string + +int ip, tp +int ctor(), strlen() + +begin + if (DEBUG) { call eprintf("\t\texp=`%s'\n");call pargstr(expstr)} + + # The last argument is required to be the dpi resolution so pull + # it out. + ip = strlen (expstr) + while (expstr[ip] != ',') { + ip = ip - 1 + if (expstr[ip] == ')' || IS_ALPHA(expstr[ip])) + call error (6, "syntax error") + } + + tp = ip + ip = ip + 1 + if (ctor(expstr,ip,EX_PSSCALE(ex)) == 0) + call error (5, "cannot interpret EPS scale value") + + # Now trim the expression string. + expstr[tp] = EOS +end + + +# EX_CNT_PARENS - Count the number of parentheses in the expression string. + +procedure ex_cnt_parens (expr) + +char expr[ARB] #i outbands expression strinf + +int ip, plev + +begin + ip = 1 + plev = 0 + while (expr[ip] != EOS) { + if (expr[ip] == '(') plev = plev + 1 + if (expr[ip] == ')') plev = plev - 1 + ip = ip + 1 + } + if (plev > 0) + call error (5, "Missing right paren in `outbands' expression.") + if (plev < 0) + call error (5, "Missing left paren in `outbands' expression.") +end diff --git a/pkg/dataio/export/exraster.gx b/pkg/dataio/export/exraster.gx new file mode 100644 index 00000000..a4c08710 --- /dev/null +++ b/pkg/dataio/export/exraster.gx @@ -0,0 +1,621 @@ +include <imhdr.h> +include <mach.h> +include <evvexpr.h> +include "../export.h" + +define DEBUG false + + +# EX_NO_INTERLEAVE - Write out the image with no interleaving. + +procedure ex_no_interleave (ex) + +pointer ex #i task struct pointer + +pointer op, out +int i, j, k, line, percent, orow +int fd, outtype + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_no_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + # Loop over the number of image expressions. + fd = EX_FD(ex) + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NEXPR(ex) { + + # Process each line in the image. + do j = 1, O_HEIGHT(ex,i) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + #line = EX_NLINES(ex) - j + 1 + line = O_HEIGHT(ex,i) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, outtype) + + # Write evaluated pixels. + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, out, O_LEN(op)) + else { + call ex_listpix (fd, outtype, out, O_LEN(op), j, i, + EX_NEXPR(ex), NO) + } + + # Clean up the pointers. + if (outtype == TY_UBYTE || outtype == TY_CHAR) + call mfree (out, TY_CHAR) + else + call mfree (out, outtype) + call evvfree (op) + do k = 1, EX_NIMOPS(ex) { + op = IMOP(ex,k) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + } + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_LN_INTERLEAVE - Write out the image with line interleaving. + +procedure ex_ln_interleave (ex) + +pointer ex #i task struct pointer + +pointer op, out +int i, j, line, percent, orow +int fd, outtype + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_ln_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + # Process each line in the image. + fd = EX_FD(ex) + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - i + 1 + else + line = i + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Loop over the number of image expressions. + do j = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,j)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, outtype) + + # Write evaluated pixels. + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, out, O_LEN(op)) + else { + call ex_listpix (fd, outtype, out, O_LEN(op), i, j, + EX_NEXPR(ex), NO) + } + + # Clean up the pointers. + if (outtype == TY_UBYTE || outtype == TY_CHAR) + call mfree (out, TY_CHAR) + else + call mfree (out, outtype) + call evvfree (op) + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + + do j = 1, EX_NIMOPS(ex) { + op = IMOP(ex,j) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + } + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_PX_INTERLEAVE - Write out the image with pixel interleaving. + +procedure ex_px_interleave (ex) + +pointer ex #i task struct pointer + +pointer sp, pp, op +pointer o, outptr +int i, j, line, npix, outtype +long totpix +int fd, percent, orow + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_px_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + call smark (sp) + call salloc (pp, EX_NEXPR(ex), TY_POINTER) + + # Process each line in the image. + fd = EX_FD(ex) + outptr = NULL + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - i + 1 + else + line = i + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Loop over the number of image expressions. + totpix = 0 + do j = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,j)) + + # Convert to the output pixel type. + o = ex_chtype (ex, op, outtype) + Memi[pp+j-1] = o + + npix = O_LEN(op) + #npix = EX_OCOLS(op) + call evvfree (op) + } + + # Merge pixels into a single vector. + call ex_merge_pixels (Memi[pp], EX_NEXPR(ex), npix, outtype, + outptr, totpix) + + # Write vector of merged pixels. + if (outtype == TY_UBYTE) + call achtsb (Memc[outptr], Memc[outptr], totpix) + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, outptr, totpix) + else { + call ex_listpix (fd, outtype, outptr, totpix, + i, EX_NEXPR(ex), EX_NEXPR(ex), YES) + } + + if (outtype != TY_CHAR && outtype != TY_UBYTE) + call mfree (outptr, outtype) + else + call mfree (outptr, TY_CHAR) + do j = 1, EX_NIMOPS(ex) { + op = IMOP(ex,j) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + do j = 1, EX_NEXPR(ex) { + if (outtype != TY_CHAR && outtype != TY_UBYTE) + call mfree (Memi[pp+j-1], outtype) + else + call mfree (Memi[pp+j-1], TY_CHAR) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + + call sfree (sp) + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_GETPIX - Get the pixels from the image and load each operand. + +procedure ex_getpix (ex, line) + +pointer ex #i task struct pointer +int line #i current line number + +pointer im, op, data +int nptrs, i, band + +pointer imgl3s(), imgl3i(), imgl3l() +pointer imgl3r(), imgl3d() + +begin + # Loop over each of the image operands. + nptrs = EX_NIMOPS(ex) + do i = 1, nptrs { + op = IMOP(ex,i) + im = IO_IMPTR(op) + band = max (1, IO_BAND(op)) + + if (line > IM_LEN(im,2)) { + call calloc (IO_DATA(op), IM_LEN(im,1), IM_PIXTYPE(im)) + IO_ISIM(op) = NO + IO_NPIX(op) = IM_LEN(im,1) + next + } else if (IO_DATA(op) == NULL) + call malloc (IO_DATA(op), IM_LEN(im,1), IM_PIXTYPE(im)) + + switch (IM_PIXTYPE(im)) { + case TY_USHORT: + data = imgl3s (im, line, band) + call amovs (Mems[data], Mems[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_SHORT + IO_NBYTES(op) = SZ_SHORT * SZB_CHAR + IO_ISIM(op) = YES + $for (silrd) + case TY_PIXEL: + data = imgl3$t (im, line, band) + call amov$t (Mem$t[data], Mem$t[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_PIXEL + $if (datatype == i) + IO_NBYTES(op) = SZ_INT32 * SZB_CHAR + $else + IO_NBYTES(op) = SZ_PIXEL * SZB_CHAR + $endif + IO_ISIM(op) = YES + $endfor + } + IO_NPIX(op) = IM_LEN(im,1) + } +end + + +# EX_WPIXELS - Write the pixels to the current file. + +procedure ex_wpixels (fd, otype, pix, npix) + +int fd #i output file descriptor +int otype #i output data type +pointer pix #i pointer to pixel data +int npix #i number of pixels to write + +begin + # Write binary output. + switch (otype) { + case TY_UBYTE: + call write (fd, Mems[pix], npix / SZB_CHAR) + case TY_USHORT: + call write (fd, Mems[pix], npix * SZ_SHORT/SZ_CHAR) + $for (silrd) + case TY_PIXEL: + $if (datatype == i) + if (SZ_INT != SZ_INT32) + call ipak32 (Memi[pix], Memi[pix], npix) + call write (fd, Memi[pix], npix * SZ_INT32/SZ_CHAR) + $else + call write (fd, Mem$t[pix], npix * SZ_PIXEL/SZ_CHAR) + $endif + $endfor + } +end + + +# EX_LISTPIX - Write the pixels to the current file as ASCII text. + +procedure ex_listpix (fd, type, data, npix, line, band, nbands, merged) + +int fd #i output file descriptor +int type #i output data type +pointer data #i pointer to pixel data +int npix #i number of pixels to write +int line #i current output line number +int band #i current output band number +int nbands #i no. of output bands +int merged #i are pixels interleaved? + +int i, j, k +int val, pix, shifti(), andi() + +begin + if (merged == YES && nbands > 1) { + do i = 1, npix { + k = 0 + do j = 1, nbands { + call fprintf (fd, "%4d %4d %4d ") + call pargi (i) + call pargi (line) + call pargi (j) + + switch (type) { + case TY_UBYTE: + val = Memc[data+k] + if (mod(i,2) == 1) { + pix = shifti (val, -8) + } else { + pix = andi (val, 000FFX) + k = k + 1 + } + if (pix < 0) pix = pix + 256 + call fprintf (fd, "%d\n") + call pargi (pix) + case TY_CHAR, TY_SHORT, TY_USHORT: + call fprintf (fd, "%d\n") + call pargs (Mems[data+((j-1)*npix+i)-1]) + case TY_INT: + call fprintf (fd, "%d\n") + call pargi (Memi[data+((j-1)*npix+i)-1]) + case TY_LONG: + call fprintf (fd, "%d\n") + call pargl (Meml[data+((j-1)*npix+i)-1]) + case TY_REAL: + call fprintf (fd, "%g\n") + call pargr (Memr[data+((j-1)*npix+i)-1]) + case TY_DOUBLE: + call fprintf (fd, "%g\n") + call pargd (Memd[data+((j-1)*npix+i)-1]) + } + } + } + } else { + j = 0 + do i = 1, npix { + if (nbands > 1) { + call fprintf (fd, "%4d %4d %4d ") + call pargi (i) + call pargi (line) + call pargi (band) + } else { + call fprintf (fd, "%4d %4d ") + call pargi (i) + call pargi (line) + } + + switch (type) { + case TY_UBYTE: + val = Memc[data+j] + if (mod(i,2) == 1) { + pix = shifti (val, -8) + } else { + pix = andi (val, 000FFX) + j = j + 1 + } + if (pix < 0) pix = pix + 256 + call fprintf (fd, "%d\n") + call pargi (pix) + case TY_CHAR, TY_SHORT, TY_USHORT: + call fprintf (fd, "%d\n") + call pargs (Mems[data+i-1]) + case TY_INT: + call fprintf (fd, "%d\n") + call pargi (Memi[data+i-1]) + case TY_LONG: + call fprintf (fd, "%d\n") + call pargl (Meml[data+i-1]) + case TY_REAL: + call fprintf (fd, "%g\n") + call pargr (Memr[data+i-1]) + case TY_DOUBLE: + call fprintf (fd, "%g\n") + call pargd (Memd[data+i-1]) + } + } + } +end + + +# EX_MERGE_PIXELS - Merge a group of pixels arrays into one array by combining +# the elements. Returns an allocated pointer which must be later freed and +# the total number of pixels. + +procedure ex_merge_pixels (ptrs, nptrs, npix, dtype, pix, totpix) + +pointer ptrs[ARB] #i array of pixel ptrs +int nptrs #i number of ptrs +int npix #i no. of pixels in each array +int dtype #i type of pointer to alloc +pointer pix #o output pixel array ptr +int totpix #o total no. of output pixels + +int i, j, ip + +begin + # Calculate the number of output pixels and allocate the pointer. + totpix = nptrs * npix + if (dtype != TY_CHAR && dtype != TY_UBYTE) + call realloc (pix, totpix, dtype) + else { + call realloc (pix, totpix, TY_CHAR) + do i = 1, nptrs + call achtbs (Mems[ptrs[i]], Mems[ptrs[i]], npix) + } + + # Fill the output array + ip = 0 + for (i = 1; i<=npix; i=i+1) { + do j = 1, nptrs { + switch (dtype) { + case TY_UBYTE: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + case TY_USHORT: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + $for (silrd) + case TY_PIXEL: + Mem$t[pix+ip] = Mem$t[ptrs[j]+i-1] + $endfor + } + + ip = ip + 1 + } + } +end + + +# EX_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. Any IEEE or byte-swapping +# requests are also handled here. + +pointer procedure ex_chtype (ex, op, type) + +pointer ex #i task struct pointer +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() +int swap, flags + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # If this is a color index image subtract one from the pixel value + # to get the index. + if (bitset (flags, OF_CMAP)) + call ex_pix_to_index (O_VALP(op), O_TYPE(op), O_LEN(op)) + + # Change the pixel type. + flags = EX_OUTFLAGS(ex) + swap = EX_BSWAP(ex) + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I2) || bitset (swap, S_ALL)) + call bswap4 (Mems[out], 1, Mems[out], 1, O_LEN(op)) + + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I4) || bitset (swap, S_ALL)) + call bswap4 (Memi[out], 1, Memi[out], 1, O_LEN(op)) + + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I4) || bitset (swap, S_ALL)) + call bswap4 (Meml[out], 1, Meml[out], 1, O_LEN(op)) + + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + + # See if we need to convert to IEEE + if (bitset (flags, OF_IEEE) && IEEE_USED == NO) + call ieevpakr (Memr[out], Memr[out], O_LEN(op)) + + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + + # See if we need to convert to IEEE + if (bitset (flags, OF_IEEE) && IEEE_USED == NO) + call ieevpakd (Memd[P2D(out)], Memd[P2D(out)], O_LEN(op)) + + default: + call error (0, "Invalid output type requested.") + } + + if (type != TY_UBYTE && type != TY_CHAR) + out = coerce (out, TY_CHAR, type) + return (out) +end + + +# EX_PIX_TO_INDEX - Convert pixel values to color index values. We assume +# the colormap has at most 256 entries. + +procedure ex_pix_to_index (ptr, type, len) + +pointer ptr #i data ptr +int type #i data type of array +int len #i length of array + +$for (silrd) +PIXEL $tindx, $tmin, $tmax +$endfor + +begin + $for (silrd) + $tindx = PIXEL (1) + $tmin = PIXEL (0) + $tmax = PIXEL (255) + $endfor + + switch (type) { + $for (silrd) + case TY_PIXEL: + call asubk$t (Mem$t[ptr], $tindx, Mem$t[ptr], len) + call amaxk$t (Mem$t[ptr], $tmin, Mem$t[ptr], len) + call amink$t (Mem$t[ptr], $tmax, Mem$t[ptr], len) + $endfor + } +end + + +# EX_PSTAT - Print information about the progress we're making. + +procedure ex_pstat (ex, row, percent) + +pointer ex #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / EX_OROWS(ex) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/export/exrgb8.x b/pkg/dataio/export/exrgb8.x new file mode 100644 index 00000000..9eac4705 --- /dev/null +++ b/pkg/dataio/export/exrgb8.x @@ -0,0 +1,994 @@ +include <imhdr.h> +include "export.h" + + +# Size definitions +define A_BITS 8 # Number of bits of color +define B_BITS 5 # Number of bits/pixel to use +define C_BITS 3 # Number of cells/color to use +define A_LEN 256 # 2 ** A_BITS +define B_LEN 32 # 2 ** B_BITS +define C_LEN 8 # 2 ** C_BITS +define AB_SHIFT 8 # 2 ** (A_BITS - B_BITS) +define BC_SHIFT 4 # 2 ** (B_BITS - C_BITS) +define AC_SHIFT 32 # 2 ** (A_BITS - C_BITS) + +# Color metric definitions +define R2FACT 20 # .300 * .300 * 256 = 23 +define G2FACT 39 # .586 * .586 * 256 = 88 +define B2FACT 8 # .114 * .114 * 256 = 3 + +define RED 1 +define GREEN 2 +define BLUE 3 + +# Colorbox structure +define CBOX_LEN 9 +define CBOX_NEXT Memi[$1] # pointer to next colorbox structure +define CBOX_PREV Memi[$1+1] # pointer to previous colorbox structure +define CBOX_RMIN Memi[$1+2] +define CBOX_RMAX Memi[$1+3] +define CBOX_GMIN Memi[$1+4] +define CBOX_GMAX Memi[$1+5] +define CBOX_BMIN Memi[$1+6] +define CBOX_BMAX Memi[$1+7] +define CBOX_TOTAL Memi[$1+8] + +# Color cell structure +define CCELL_LEN (A_LEN*2+1) +define CCELL_NUM_ENTS Memi[$1] +define CCELL_ENTRIES Memi[$1+2*($2)+$3+1] + +# Output number of colors +define NCOLORS 256 + + +# EX_MKCMAP -- Generate an 8-bit colormap from three input image expressions +# using Heckbert's Median Cut algorithm. The implementation of this algorithm +# was modeled, with permission, on that in the program XV written by John +# Bradley. + +procedure ex_mkcmap (ex) + +pointer ex #i task struct pointer + +pointer oim # Output image +real z1[3], dz[3] # Display ranges + +int i, ncolors +pointer sp, cmap, box_list, histogram, ColorCells +pointer freeboxes, usedboxes, ptr, im + +pointer immap(), cm_largest_box() +errchk open, immap + +begin + # Since we're creating a colormap we force the output pixel size + # to be 8-bits. + call ex_do_outtype (ex, "b1") + + # Create a temporary image of the processed expressions. We'll + # evaluate the expressions only once an save the results, later + # we'll path up the operand and expressions structs to it copies + # this out to the requested format. + + if (EX_TIMPTR(ex) == NULL) + call calloc (EX_TIMPTR(ex), SZ_FNAME, TY_CHAR) + else + call aclrc (TIMNAME(ex), SZ_FNAME) + call mktemp ("tmp$ex", TIMNAME(ex), SZ_FNAME) + oim = immap (TIMNAME(ex), NEW_IMAGE, 0) + IM_PIXTYPE(oim) = TY_SHORT + IM_LEN(oim,1) = EX_OCOLS(ex) + IM_LEN(oim,2) = EX_OROWS(ex) + IM_NDIM(oim) = 2 + + # Set input image intensity scaling. + z1[1] = 0.0 + dz[1] = 1.0 + z1[2] = 0.0 + dz[2] = 1.0 + z1[3] = 0.0 + dz[3] = 1.0 + + # Allocate color map. + ncolors = NCOLORS + call smark (sp) + call salloc (cmap, 3 * ncolors, TY_SHORT) + + # Allocate and initialize color boxes. + call salloc (box_list, ncolors * CBOX_LEN, TY_STRUCT) + + freeboxes = box_list + usedboxes = NULL + ptr = freeboxes + CBOX_PREV(ptr) = NULL + CBOX_NEXT(ptr) = ptr + CBOX_LEN + for (i=2; i<ncolors; i=i+1) { + ptr = ptr + CBOX_LEN + CBOX_PREV(ptr) = ptr - CBOX_LEN + CBOX_NEXT(ptr) = ptr + CBOX_LEN + } + ptr = ptr + CBOX_LEN + CBOX_PREV(ptr) = ptr - CBOX_LEN + CBOX_NEXT(ptr) = NULL + + ptr = freeboxes + freeboxes = CBOX_NEXT(ptr) + if (freeboxes != NULL) + CBOX_PREV(freeboxes) = NULL + + CBOX_NEXT(ptr) = usedboxes + usedboxes = ptr + if (CBOX_NEXT(ptr) != NULL) + CBOX_PREV(CBOX_NEXT(ptr)) = ptr + + # Allocate and get histogram. + if (EX_VERBOSE(ex) == YES) { + call printf ("Computing colormap....\n") + call flush (STDOUT) + } + call salloc (histogram, B_LEN*B_LEN*B_LEN, TY_INT) + call aclri (Memi[histogram], B_LEN*B_LEN*B_LEN) + call cm_get_histogram(ex, z1, dz, ptr, Memi[histogram]) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_CMAP) + + # Subdivide boxes until no more free boxes remain + while (freeboxes != NULL) { + ptr = cm_largest_box (usedboxes) + if (ptr != NULL) + call cm_splitbox (ptr, usedboxes, freeboxes, Memi[histogram]) + else + break + } + + # Set color map and write it out. + ptr = usedboxes + for (i=0; i<ncolors && ptr!=NULL; i=i+1) { + call cm_assign_color (ptr, Mems[cmap+3*i]) + ptr = CBOX_NEXT(ptr) + } + ncolors = i + + # Copy the colormap to the main task array. + call cm_save_cmap (ex, Mems[cmap], ncolors) + + # Scan histogram and map all values to closest color. + # First create cell list as described in Heckbert[2] and then + # create mapping from truncated pixel space to color table entries + + call salloc (ColorCells, C_LEN*C_LEN*C_LEN, TY_POINTER) + call aclri (Memi[ColorCells], C_LEN*C_LEN*C_LEN) + call cm_map_colortable (Memi[histogram], Mems[cmap], ncolors, + Memi[ColorCells]) + + # Scan image and match input values to table entries. + # Apply Floyd-Steinberg dithering. + + if (EX_VERBOSE(ex) == YES) { + call printf ("Computing color indices....\n") + call flush (STDOUT) + } + call cm_quant_fsdither (ex, z1, dz, Memi[histogram], + Memi[ColorCells], Mems[cmap], ncolors, oim) + + # Unmap the current image pointer(s). + do i = 1, EX_NIMAGES(ex) { + im = IO_IMPTR(IMOP(ex,i)) + if (im != NULL) + call imunmap (im) + } + + # Free the current operand and outbands pointers and fake up a new + # one that processes the temporary image. + for (i=1; i < EX_NEXPR(ex); i=i+1) + call ex_free_outbands (OBANDS(ex,i)) + for (i=1; i < EX_NIMOPS(ex); i=i+1) + call ex_free_operand (IMOP(ex,i)) + call ex_do_outbands (ex, "b1") + O_HEIGHT(ex,1) = EX_OROWS(ex) + O_WIDTH(ex,1) = EX_OCOLS(ex) + + # Set the temp image as the only valid image and fudge the operands. + EX_NIMAGES(ex) = 1 + EX_NEXPR(ex) = 1 + EX_NLINES(ex) = EX_OROWS(ex) + IO_IMPTR(IMOP(ex,1)) = oim + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), OF_BAND) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), BAND_STORAGE) + + for (i=0; i < C_LEN*C_LEN*C_LEN; i=i+1) { + if (Memi[ColorCells+i] != NULL) + call mfree (Memi[ColorCells+i], TY_STRUCT) + } + + call sfree (sp) +end + + +# CM_SAVE_CMAP -- Save color map for to main structure. + +procedure cm_save_cmap (ex, map, ncolors) + +pointer ex #i task struct pointer +short map[3,ncolors] #i Color map +int ncolors #i Number of colors + +int i +pointer cmap + +begin + # Allocate the colormap pointer and read the colormap. + iferr (call calloc (EX_CMAP(ex), 3*CMAP_SIZE, TY_CHAR)) + call error (0, "Error allocating colormap pointer.") + cmap = EX_CMAP(ex) + + for (i=1; i<=min(ncolors,256); i=i+1) { + CMAP(cmap,EX_RED,i) = (map[1,i] + 0.5) + CMAP(cmap,EX_GREEN,i) = (map[2,i] + 0.5) + CMAP(cmap,EX_BLUE,i) = (map[3,i] + 0.5) + } + for (; i<=256; i=i+1) { + CMAP(cmap,EX_RED,i) = 0 + CMAP(cmap,EX_GREEN,i) = 0 + CMAP(cmap,EX_BLUE,i) = 0 + } +end + + +# CM_GETLINE -- Get a line of intensity mapped input data. + +procedure cm_getline (ex, z1, dz, line, data) + +pointer ex #I task struct pointer +real z1[3] #I Intensity mapping origins +real dz[3] #I Intensity mapping ranges +int line #I Line to be obtained +pointer data #O Intensity mapped data + +int i, j, nc, lnum +pointer iptr, optr, bptr, op + +pointer ex_evaluate(), ex_chtype() + +begin + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + lnum = EX_NLINES(ex) - line + 1 + else + lnum = line + + # Get the pixels. + call ex_getpix (ex, lnum) + + nc = EX_OCOLS(ex) + call malloc (iptr, nc, TY_SHORT) + do i = 1, 3 { + op = ex_evaluate (ex, O_EXPR(ex,i)) + bptr = ex_chtype (ex, op, EX_OUTTYPE(ex)) + call achtbs (Memc[bptr], Mems[iptr], nc) + call evvfree (op) + + optr = data + i - 1 + do j = 1, nc { + Memi[optr] = max (0, min (255, int (Mems[iptr+j-1]))) + optr = optr + 3 + } + + call mfree (bptr, TY_CHAR) + } + call mfree (iptr, TY_SHORT) +end + + +# CM_GET_HISTOGRAM -- Compute color histogram + +procedure cm_get_histogram (ex, z1, dz, box, histogram) + +pointer ex #I task struct pointer +real z1[3] #I Intensity mapping origins +real dz[3] #I Intensity mapping ranges +pointer box #O Initial box +int histogram[B_LEN,B_LEN,B_LEN] #O Histogram + +int i, j, nc, nl, r, g, b, rmin, gmin, bmin, rmax, gmax, bmax +pointer sp, data, ptr + +begin + nc = EX_OCOLS(ex) + nl = EX_OROWS(ex) + + call smark (sp) + call salloc (data, 3 * nc, TY_INT) + + rmin = A_LEN; rmax = -1 + gmin = A_LEN; gmax = -1 + bmin = A_LEN; bmax = -1 + + # calculate histogram + do j = 1, nl { + call cm_getline (ex, z1, dz, j, data) + ptr = data + do i = 1, nc { + r = Memi[ptr] / AB_SHIFT + 1 + g = Memi[ptr+1] / AB_SHIFT + 1 + b = Memi[ptr+2] / AB_SHIFT + 1 + ptr = ptr + 3 + + histogram[r,g,b] = histogram[r,g,b] + 1 + + rmin = min (rmin, r) + rmax = max (rmax, r) + gmin = min (gmin, g) + gmax = max (gmax, g) + bmin = min (bmin, b) + bmax = max (bmax, b) + } + } + + CBOX_RMIN(box) = rmin + CBOX_GMIN(box) = gmin + CBOX_BMIN(box) = bmin + CBOX_RMAX(box) = rmax + CBOX_GMAX(box) = gmax + CBOX_BMAX(box) = bmax + CBOX_TOTAL(box) = nc * nl + + call sfree (sp) +end + + + +# CM_LARGEST_BOX -- Return pointer to largest box + +pointer procedure cm_largest_box (usedboxes) + +pointer usedboxes #I Pointer to used boxes + +pointer tmp, ptr +int size + +begin + size = -1 + ptr = NULL + + for (tmp=usedboxes; tmp!=NULL; tmp=CBOX_NEXT(tmp)) { + if ((CBOX_RMAX(tmp) > CBOX_RMIN(tmp) || + CBOX_GMAX(tmp) > CBOX_GMIN(tmp) || + CBOX_BMAX(tmp) > CBOX_BMIN(tmp)) && + CBOX_TOTAL(tmp) > size) { + ptr = tmp + size = CBOX_TOTAL(tmp) + } + } + return(ptr) +end + + +# CM_SPLITBOX -- Split a box along largest dimension + +procedure cm_splitbox (box, usedboxes, freeboxes, histogram) + +pointer box #U Box to split +pointer usedboxes #U Used boxes +pointer freeboxes #U Free boxes +int histogram[B_LEN, B_LEN, B_LEN] #I Histogram + +int first, last, i, j, rdel, gdel, bdel, sum1, sum2 +pointer sp, hist, new +int ir, ig, ib +int rmin, rmax, gmin, gmax, bmin, bmax +int which + +begin + call smark (sp) + call salloc (hist, B_LEN, TY_INT) + + # see which axis is the largest, do a histogram along that + # axis. Split at median point. Contract both new boxes to + # fit points and return + + first = 1; last = 1 + rmin = CBOX_RMIN(box); rmax = CBOX_RMAX(box) + gmin = CBOX_GMIN(box); gmax = CBOX_GMAX(box) + bmin = CBOX_BMIN(box); bmax = CBOX_BMAX(box) + + rdel = rmax - rmin + gdel = gmax - gmin + bdel = bmax - bmin + + if (rdel>=gdel && rdel>=bdel) + which = RED + else if (gdel>=bdel) + which = GREEN + else + which = BLUE + + # get histogram along longest axis + switch (which) { + case RED: + for (ir=rmin; ir<=rmax; ir=ir+1) { + sum1 = 0 + for (ig=gmin; ig<=gmax; ig=ig+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + sum1 = sum1 + histogram[ir,ig,ib] + } + } + Memi[hist+ir-1] = sum1 + } + first = rmin; last = rmax + + case GREEN: + for (ig=gmin; ig<=gmax; ig=ig+1) { + sum1 = 0 + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + sum1 = sum1 + histogram[ir,ig,ib] + } + } + Memi[hist+ig-1] = sum1 + } + first = gmin; last = gmax + + case BLUE: + for (ib=bmin; ib<=bmax; ib=ib+1) { + sum1 = 0 + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + sum1 = sum1 + histogram[ir,ig,ib] + } + } + Memi[hist+ib-1] = sum1 + } + first = bmin; last = bmax + } + + + # find median point + sum1 = 0 + sum2 = CBOX_TOTAL(box) / 2 + for (i=first; i<=last; i=i+1) { + sum1 = sum1 + Memi[hist+i-1] + if (sum1 >= sum2) + break + } + if (i == first) + i = i + 1 + + + # Create new box, re-allocate points + + new = freeboxes + freeboxes = CBOX_NEXT(new) + if (freeboxes != NULL) + CBOX_PREV(freeboxes) = NULL + if (usedboxes != NULL) + CBOX_PREV(usedboxes) = new + CBOX_NEXT(new) = usedboxes + usedboxes = new + + sum1 = 0 + sum2 = 0 + for (j = first; j < i; j=j+1) + sum1 = sum1 + Memi[hist+j-1] + for (; j <= last; j=j+1) + sum2 = sum2 + Memi[hist+j-1] + CBOX_TOTAL(new) = sum1 + CBOX_TOTAL(box) = sum2 + + CBOX_RMIN(new) = rmin; CBOX_RMAX(new) = rmax + CBOX_GMIN(new) = gmin; CBOX_GMAX(new) = gmax + CBOX_BMIN(new) = bmin; CBOX_BMAX(new) = bmax + + switch (which) { + case RED: + CBOX_RMAX(new) = i-1; CBOX_RMIN(box) = i + case GREEN: + CBOX_GMAX(new) = i-1; CBOX_GMIN(box) = i + case BLUE: + CBOX_BMAX(new) = i-1; CBOX_BMIN(box) = i + } + + call cm_shrinkbox (new, histogram) + call cm_shrinkbox (box, histogram) + call sfree (sp) +end + + +# CM_SHRINKBOX -- Shrink box + +procedure cm_shrinkbox (box, histogram) + +pointer box #U Box +int histogram[B_LEN,B_LEN,B_LEN] #I Histogram + +int ir, ig, ib +int rmin, rmax, gmin, gmax, bmin, bmax + +define have_rmin 11 +define have_rmax 12 +define have_gmin 13 +define have_gmax 14 +define have_bmin 15 +define have_bmax 16 + +begin + + rmin = CBOX_RMIN(box); rmax = CBOX_RMAX(box) + gmin = CBOX_GMIN(box); gmax = CBOX_GMAX(box) + bmin = CBOX_BMIN(box); bmax = CBOX_BMAX(box) + + if (rmax > rmin) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + if (histogram[ir,ig,ib] != 0) { + rmin = ir + CBOX_RMIN(box) = rmin + goto have_rmin + } + } + } + } + +have_rmin + if (rmax > rmin) { + for (ir=rmax; ir>=rmin; ir=ir-1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + if (histogram[ir,ig,ib] != 0) { + rmax = ir + CBOX_RMAX(box) = rmax + goto have_rmax + } + } + } + } + } + } + + +have_rmax + if (gmax > gmin) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + if (histogram[ir,ig,ib] != 0) { + gmin = ig + CBOX_GMIN(box) = gmin + goto have_gmin + } + } + } + } + +have_gmin + if (gmax > gmin) { + for (ig=gmax; ig>=gmin; ig=ig-1) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + if (histogram[ir,ig,ib] != 0) { + gmax = ig + CBOX_GMAX(box) = gmax + goto have_gmax + } + } + } + } + } + } + +have_gmax + if (bmax > bmin) { + for (ib=bmin; ib<=bmax; ib=ib+1) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + if (histogram[ir,ig,ib] != 0) { + bmin = ib + CBOX_BMIN(box) = bmin + goto have_bmin + } + } + } + } + +have_bmin + if (bmax > bmin) { + for (ib=bmax; ib>=bmin; ib=ib-1) { + for (ir=rmin; ir<=rmax; ir=ir+1) { + for (ig=gmin; ig<=gmax; ig=ig+1) { + if (histogram[ir,ig,ib] != 0) { + bmax = ib + CBOX_BMAX(box) = bmax + goto have_bmax + } + } + } + } + } + } + +have_bmax + return +end + + + +# CM_ASSIGN_COLOR -- Assign colors + +procedure cm_assign_color (box, cmap) + +pointer box #I Box +short cmap[3] #O Color map entry + +begin + # +1 ensures that color represents the middle of the box + + cmap[1] = ((CBOX_RMIN(box) + CBOX_RMAX(box) - 2) * AB_SHIFT) / 2 + cmap[2] = ((CBOX_GMIN(box) + CBOX_GMAX(box) - 2) * AB_SHIFT) / 2 + cmap[3] = ((CBOX_BMIN(box) + CBOX_BMAX(box) - 2) * AB_SHIFT) / 2 +end + + + +# CM_MAP_COLORTABLE -- Map the color table + +procedure cm_map_colortable (histogram, cmap, ncolor, ColorCells) + +int histogram[B_LEN,B_LEN,B_LEN] #U Histogram +short cmap[3,ncolor] #I Color map +int ncolor #I Number of colors +pointer ColorCells[C_LEN,C_LEN,C_LEN] #O Color cells + +int i, j, ir, ig, ib, rcell, bcell, gcell +long dist, d2, tmp +pointer cell, cm_create_colorcell() + +begin + for (ir=0; ir<B_LEN; ir=ir+1) { + rcell = 1 + ir / BC_SHIFT + for (ig=0; ig<B_LEN; ig=ig+1) { + gcell = 1 + ig / BC_SHIFT + for (ib=0; ib<B_LEN; ib=ib+1) { + bcell = 1 + ib / BC_SHIFT + if (histogram[1+ir,1+ig,1+ib]==0) + histogram[1+ir,1+ig,1+ib] = -1 + else { + cell = ColorCells[rcell, gcell, bcell] + + if (cell == NULL) + cell = cm_create_colorcell (ColorCells, + ir*AB_SHIFT, ig*AB_SHIFT, ib*AB_SHIFT, + cmap, ncolor) + + dist = 2000000000 + for (i=0; i<CCELL_NUM_ENTS(cell) && + dist>CCELL_ENTRIES(cell,i,1); i=i+1) { + j = CCELL_ENTRIES(cell,i,0) + d2 = cmap[1,1+j] - (ir * BC_SHIFT) + d2 = (d2 * d2 * R2FACT) + tmp = cmap[2,1+j] - (ig * BC_SHIFT) + d2 = d2 + (tmp*tmp * G2FACT) + tmp = cmap[3,1+j] - (ib * BC_SHIFT) + d2 = d2 + (tmp*tmp * B2FACT) + if (d2 < dist) { + dist = d2 + histogram[1+ir,1+ig,1+ib] = j + } + } + } + } + } + } +end + + + +# CM_CREATE_COLORCELL -- Create a color cell structure + +pointer procedure cm_create_colorcell (ColorCells, ra, ga, ba, cmap, ncolor) + +pointer ColorCells[C_LEN,C_LEN,C_LEN] #U Color cells +int ra, ga, ba #I Color to create cell for +short cmap[3,ncolor] #I Color map +int ncolor #I Number of colors + +int i, n, next_n, ir,ig,ib, r1,g1,b1 +long dist, mindist, tmp +pointer ptr + +begin + ir = ra / AC_SHIFT + ig = ga / AC_SHIFT + ib = ba / AC_SHIFT + + r1 = ir * AC_SHIFT + g1 = ig * AC_SHIFT + b1 = ib * AC_SHIFT + + call malloc (ptr, CCELL_LEN, TY_STRUCT) + ColorCells[1+ir,1+ig,1+ib] = ptr + CCELL_NUM_ENTS(ptr) = 0 + + # step 1: find all colors inside this cell, while we're at + # it, find distance of centermost point to furthest corner + + mindist = 2000000000 + + for (i=1; i<=ncolor; i=i+1) { + if (cmap[1,i]/AC_SHIFT == ir && + cmap[2,i]/AC_SHIFT == ig && + cmap[3,i]/AC_SHIFT == ib) { + CCELL_ENTRIES(ptr,CCELL_NUM_ENTS(ptr),0) = i - 1 + CCELL_ENTRIES(ptr,CCELL_NUM_ENTS(ptr),1) = 0 + CCELL_NUM_ENTS(ptr) = CCELL_NUM_ENTS(ptr) + 1 + + tmp = cmap[1,i] - r1 + if (tmp < (A_LEN/C_LEN/2)) + tmp = A_LEN/C_LEN-1 - tmp + dist = (tmp*tmp * R2FACT) + + tmp = cmap[2,i] - g1 + if (tmp < (A_LEN/C_LEN/2)) + tmp = A_LEN/C_LEN-1 - tmp + dist = dist + (tmp*tmp * G2FACT) + + tmp = cmap[3,i] - b1 + if (tmp < (A_LEN/C_LEN/2)) + tmp = A_LEN/C_LEN-1 - tmp + dist = dist + (tmp*tmp * B2FACT) + + mindist = min (mindist, dist) + } + } + + + # step 3: find all points within that distance to box + + for (i=1; i<=ncolor; i=i+1) { + if (cmap[1,i]/AC_SHIFT != ir || + cmap[2,i]/AC_SHIFT != ig || + cmap[3,i]/AC_SHIFT != ib) { + dist = 0 + tmp = r1 - cmap[1,i] + if (tmp>0) { + dist = dist + (tmp*tmp * R2FACT) + } else { + tmp = cmap[1,i] - (r1 + A_LEN/C_LEN-1) + if (tmp > 0) + dist = dist + (tmp*tmp * R2FACT) + } + + tmp = g1 - cmap[2,i] + if (tmp>0) { + dist = dist + (tmp*tmp * G2FACT) + } else { + tmp = cmap[2,i] - (g1 + A_LEN/C_LEN-1) + if (tmp > 0) + dist = dist + (tmp*tmp * G2FACT) + } + + tmp = b1 - cmap[3,i] + if (tmp>0) { + dist = dist + (tmp*tmp * B2FACT) + } else { + tmp = cmap[3,i] - (b1 + A_LEN/C_LEN-1) + if (tmp > 0) + dist = dist + (tmp*tmp * B2FACT) + } + + if (dist < mindist) { + CCELL_ENTRIES(ptr,CCELL_NUM_ENTS(ptr),0) = i - 1 + CCELL_ENTRIES(ptr,CCELL_NUM_ENTS(ptr),1) = dist + CCELL_NUM_ENTS(ptr) = CCELL_NUM_ENTS(ptr) + 1 + } + } + } + + + # sort color cells by distance, use cheap exchange sort + n = CCELL_NUM_ENTS(ptr) - 1 + while (n > 0) { + next_n = 0 + for (i=0; i<n; i=i+1) { + if (CCELL_ENTRIES(ptr,i,1) > CCELL_ENTRIES(ptr,i+1,1)) { + tmp = CCELL_ENTRIES(ptr,i,0) + CCELL_ENTRIES(ptr,i,0) = CCELL_ENTRIES(ptr,i+1,0) + CCELL_ENTRIES(ptr,i+1,0) = tmp + tmp = CCELL_ENTRIES(ptr,i,1) + CCELL_ENTRIES(ptr,i,1) = CCELL_ENTRIES(ptr,i+1,1) + CCELL_ENTRIES(ptr,i+1,1) = tmp + next_n = i + } + } + n = next_n + } + + return (ptr) +end + + + +# CM_QUANT_FSDITHER -- Quantized Floyd-Steinberg Dither + +procedure cm_quant_fsdither (ex, z1, dz, histogram, + ColorCells, cmap, ncolor, oim) + +pointer ex #I task struct pointer +real z1[3] #I Intensity mapping origins +real dz[3] #I Intensity mapping ranges +int histogram[B_LEN,B_LEN,B_LEN] #U Histogram +pointer ColorCells[C_LEN,C_LEN,C_LEN] #U Color cell data +short cmap[3,ncolor] #I Color map +int ncolor #I Number of colors +pointer oim #O Output IMIO pointer + +pointer thisptr, nextptr, optr, impl2s() +pointer sp, thisline, nextline, tmpptr +int ir, ig, ib, r1, g1, b1, rcell, bcell, gcell +int i, j, nc, nl, oval + +int ci, cj +long dist, d2, tmp +pointer cell + +pointer cm_create_colorcell() + +begin + nc = EX_OCOLS(ex) + nl = EX_OROWS(ex) + + call smark (sp) + call salloc (thisline, nc * 3, TY_INT) + call salloc (nextline, nc * 3, TY_INT) + + # get first line of picture + call cm_getline (ex, z1, dz, 1, nextline) + + for (i=1; i<=nl; i=i+1) { + # swap thisline and nextline + tmpptr = thisline + thisline = nextline + nextline = tmpptr + + # read in next line + if (i < nl) + #call cm_getline (ex, z1, dz, i, nextline, nc) + call cm_getline (ex, z1, dz, i, nextline) + + # dither this line and put it into the output picture + thisptr = thisline + nextptr = nextline + optr = impl2s (oim, i) + + for (j=1; j<=nc; j=j+1) { + r1 = Memi[thisptr] + g1 = Memi[thisptr+1] + b1 = Memi[thisptr+2] + thisptr = thisptr + 3 + + r1 = max (0, min (A_LEN-1, r1)) + g1 = max (0, min (A_LEN-1, g1)) + b1 = max (0, min (A_LEN-1, b1)) + + ir = r1 / AB_SHIFT + ig = g1 / AB_SHIFT + ib = b1 / AB_SHIFT + + oval = histogram[1+ir,1+ig,1+ib] + if (oval == -1) { + rcell = 1 + ir / BC_SHIFT + gcell = 1 + ig / BC_SHIFT + bcell = 1 + ib / BC_SHIFT + cell = ColorCells[rcell, gcell, bcell] + if (cell == NULL) + cell = cm_create_colorcell (ColorCells, r1, g1, b1, + cmap, ncolor) + + dist = 2000000000 + for (ci=0; ci<CCELL_NUM_ENTS(cell) && + dist>CCELL_ENTRIES(cell,ci,1); ci=ci+1) { + cj = CCELL_ENTRIES(cell,ci,0) + d2 = (cmap[1,1+cj]/AB_SHIFT) - ir + d2 = (d2*d2 * R2FACT) + tmp = (cmap[2,1+cj]/AB_SHIFT) - ig + d2 = d2 + (tmp*tmp * G2FACT) + tmp = (cmap[3,1+cj]/AB_SHIFT) - ib + d2 = d2 + (tmp*tmp * B2FACT) + if (d2<dist) { + dist = d2 + oval = cj + } + } + histogram[1+ir,1+ig,1+ib] = oval + } + + Mems[optr] = 1 + oval + optr = optr + 1 + + r1 = r1 - cmap[1,1+oval] + g1 = g1 - cmap[2,1+oval] + b1 = b1 - cmap[3,1+oval] + + # don't use tables, because r1,g1,b1 could go negative + if (j < nc) { + tmpptr = thisptr + if (r1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (r1*7-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (r1*7+8)/16 + tmpptr = tmpptr + 1 + if (g1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (g1*7-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (g1*7+8)/16 + tmpptr = tmpptr + 1 + if (b1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (b1*7-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (b1*7+8)/16 + } + + if (i < nl) { + if (j > 1) { + tmpptr = nextptr - 3 + if (r1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (r1*3-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (r1*3+8)/16 + tmpptr = tmpptr + 1 + if (g1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (g1*3-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (g1*3+8)/16 + tmpptr = tmpptr + 1 + if (b1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (b1*3-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (b1*3+8)/16 + } + + tmpptr = nextptr + if (r1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (r1*5-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (r1*5+8)/16 + tmpptr = tmpptr + 1 + if (g1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (g1*5-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (g1*5+8)/16 + tmpptr = tmpptr + 1 + if (b1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (b1*5-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (b1*5+8)/16 + + if (j < nc) { + tmpptr = nextptr + 3 + if (r1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (r1-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (r1+8)/16 + tmpptr = tmpptr + 1 + if (g1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (g1-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (g1+8)/16 + tmpptr = tmpptr + 1 + if (b1 < 0) + Memi[tmpptr] = Memi[tmpptr] + (b1-8)/16 + else + Memi[tmpptr] = Memi[tmpptr] + (b1+8)/16 + } + nextptr = nextptr + 3 + } + } + } + + # Flush the pixels to the output image, otherwise we end up with an + # odd line which may or may not be actual pixels. + call imflush (oim) + + call sfree (sp) +end diff --git a/pkg/dataio/export/exzscale.x b/pkg/dataio/export/exzscale.x new file mode 100644 index 00000000..f0a4b506 --- /dev/null +++ b/pkg/dataio/export/exzscale.x @@ -0,0 +1,755 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <evvexpr.h> +include "export.h" + +define DEBUG false + + +.help ex_zscale +.nf ___________________________________________________________________________ +EX_ZSCALE -- Compute the optimal Z1, Z2 (range of greyscale values to be +displayed) of an expression. For efficiency a statistical subsample of the +expression is used. The pixel sample evenly subsamples the expression in x +and y. The entire expression is used if the number of pixels in the expression +is smaller than the desired sample. + +The sample is accumulated in a buffer and sorted by greyscale value. +The median value is the central value of the sorted array. The slope of a +straight line fitted to the sorted sample is a measure of the standard +deviation of the sample about the median value. Our algorithm is to sort +the sample and perform an iterative fit of a straight line to the sample, +using pixel rejection to omit gross deviants near the endpoints. The fitted +straight line is the transfer function used to map image Z into display Z. +If more than half the pixels are rejected the full range is used. The slope +of the fitted line is divided by the user-supplied contrast factor and the +final Z1 and Z2 are computed, taking the origin of the fitted line at the +median value. +.endhelp ______________________________________________________________________ + +define MIN_NPIXELS 5 # smallest permissible sample +define MAX_REJECT 0.5 # max frac. of pixels to be rejected +define GOOD_PIXEL 0 # use pixel in fit +define BAD_PIXEL 1 # ignore pixel in all computations +define REJECT_PIXEL 2 # reject pixel after a bit +define KREJ 2.5 # k-sigma pixel rejection factor +define MAX_ITERATIONS 5 # maximum number of fitline iterations + + +# EX_PATCH_ZSCALE - Rather than compute the optimal zscale values for each +# line in the expression we'll go through the expression string and compute +# the values here. The expression string is modified with the values so that +# when evaluated they are seen as arguments to the function. + +procedure ex_patch_zscale (ex, expnum) + +pointer ex #i task struct pointer +int expnum #i expression number to fix + +pointer sp, exp, func +int ip, pp + +bool streq() + +begin + call smark (sp) + call salloc (exp, SZ_EXPSTR, TY_CHAR) + call salloc (func, SZ_FNAME, TY_CHAR) + call aclrc(Memc[exp], SZ_EXPSTR) + call aclrc(Memc[func], SZ_FNAME) + + # Copy the final expression string to the output buffer. + call strcpy (O_EXPR(ex,expnum), Memc[exp], SZ_EXPSTR) + + # Now fix up any zscale functions calls embedded in the expression. + ip = 0 + repeat { + # Skip ahead to a possible zscale()/mzscale() call. + while (Memc[exp+ip] != 'z' && Memc[exp+ip] != EOS) + ip = ip + 1 + if (Memc[exp+ip] == EOS) + break + + # Get the function name. + pp = 0 + call aclrc (Memc[func], SZ_FNAME) + while (Memc[exp+ip] != '(' && Memc[exp+ip] != EOS) { + Memc[func+pp] = Memc[exp+ip] + ip = ip + 1 + pp = pp + 1 + } + Memc[func+pp+1] = EOS + if (Memc[exp+ip] == EOS) + break + + if (DEBUG) { call eprintf("\tfunc=`%s'\n");call pargstr(Memc[func])} + + # Update pointer into string past '('. + ip = ip + 1 + + if (streq(Memc[func],"zscale") || streq(Memc[func],"zscalem")) { + iferr (call ex_edit_zscale (ex, Memc[exp], ip+1)) + call erract (EA_FATAL) + ip = ip + 1 + } + } + + # Copy the final expression string to the output buffer. + call strcpy (Memc[exp], O_EXPR(ex,expnum), SZ_EXPSTR) + + call sfree (sp) +end + + +# EX_EDIT_ZSCALE - Process the ZSCALE special function. This function requires +# preprocessing in the event the user didn't supply a z1/z2 value. What +# we'll do here is pre-compute those values and patch up the expression +# string. Otherwise we'll make sure the rest of the arguments are legal. + +procedure ex_edit_zscale (ex, expstr, pp) + +pointer ex #i task struct pointer +char expstr[ARB] #i expression string +int pp #i position pointer + +pointer sp, arg, arg2, exp, buf +pointer exptr, exptr2, ep +char ch +int ip, op, tp, tp2, plev +real z1, z2 + +pointer ex_evaluate() + +begin + call smark (sp) + call salloc (arg, SZ_EXPSTR, TY_CHAR); call aclrc (Memc[arg], SZ_EXPSTR) + call salloc (arg2, SZ_EXPSTR,TY_CHAR); call aclrc (Memc[arg2],SZ_EXPSTR) + call salloc (exp, SZ_EXPSTR, TY_CHAR); call aclrc (Memc[exp], SZ_EXPSTR) + call salloc (buf, SZ_EXPSTR, TY_CHAR); call aclrc (Memc[buf], SZ_EXPSTR) + + if (DEBUG) { call eprintf("\t\texp=`%s'\n");call pargstr(expstr)} + + # Gather the expression argument. + ip = pp + op = 0 + plev = 0 + repeat { + ch = expstr[ip] + if (ch == '(') plev = plev + 1 + if (ch == ')') plev = plev - 1 + Memc[arg+op] = ch + if ((ch == ',' && plev == 0) || (ch == ')' && plev < 0)) + break + ip = ip + 1 + op = op + 1 + } + Memc[arg+op] = EOS + tp = ip - 1 + tp2 = tp + if (DEBUG) {call eprintf("\t\targ = `%s'\n");call pargstr(Memc[arg])} + + # Gather the mask argument. + if (expstr[pp-2] == 'm' && ch == ',') { + ip = ip + 1 + op = 0 + plev = 0 + repeat { + ch = expstr[ip] + if (ch == '(') plev = plev + 1 + if (ch == ')') plev = plev - 1 + Memc[arg2+op] = ch + if ((ch == ',' && plev == 0) || (ch == ')' && plev < 0)) + break + ip = ip + 1 + op = op + 1 + } + Memc[arg2+op] = EOS + tp2 = ip - 1 + if (DEBUG) { + call eprintf("\t\targ2 = `%s'\n") + call pargstr(Memc[arg2]) + } + } + + if (ch == ',') { + # We have more arguments, assume they're okay and return. + call sfree (sp) + return + + } else if (ch == ')') { + # This is the end of the zscale function, so compute the optimal + # z1/z2 values for the given expression. First, dummy up an out- + # bands pointer. + + call ex_alloc_outbands (exptr) + call strcpy (Memc[arg], Memc[OB_EXPSTR(exptr)], SZ_EXPSTR) + + # Get the size of the expression. + call ex_getpix (ex, 1) + ep = ex_evaluate (ex, Memc[OB_EXPSTR(exptr)]) + OB_WIDTH(exptr) = O_LEN(ep) + call evvfree (ep) + if (OB_WIDTH(exptr) == 0) + OB_HEIGHT(exptr) = 1 + else + OB_HEIGHT(exptr) = EX_NLINES(ex) + + # Setup the mask expression if needed. + if (Memc[arg2] != EOS) { + call ex_alloc_outbands (exptr2) + call strcpy (Memc[arg2], Memc[OB_EXPSTR(exptr2)], SZ_EXPSTR) + + # Get the size of the expression. + ep = ex_evaluate (ex, Memc[OB_EXPSTR(exptr2)]) + OB_WIDTH(exptr2) = O_LEN(ep) + call evvfree (ep) + if (OB_WIDTH(exptr2) == 0) + OB_HEIGHT(exptr2) = 1 + else + OB_HEIGHT(exptr2) = EX_NLINES(ex) + if (OB_WIDTH(exptr2) != OB_WIDTH(exptr) || + OB_WIDTH(exptr2) != OB_WIDTH(exptr)) + call error (1, "Sizes of zscalem arguments not the same.") + } else + exptr2 = NULL + + if (EX_VERBOSE(ex) == YES) { + call printf ("Computing zscale values...") + call flush (STDOUT) + } + + call ex_zscale (ex, exptr, exptr2, z1, z2, + CONTRAST, SAMPLE_SIZE, SAMP_LEN) + call ex_free_outbands (exptr) + if (exptr2 != NULL) + call ex_free_outbands (exptr2) + + if (DEBUG) {call eprintf("\t\t\tz1=%g z2=%g\n") + call pargr(z1) ; call pargr (z2) } + + # Now patch up the expression string to insert the computed values. + if (expstr[pp-2] == 'm') { + call strcpy (expstr, Memc[exp], pp-3) + call strcat (expstr[pp-1], Memc[exp], tp-1) + } else + call strcpy (expstr, Memc[exp], tp) + call sprintf (Memc[buf], SZ_EXPSTR, ",%g,%g,256") + call pargr (z1) + call pargr (z2) + call strcat (Memc[buf], Memc[exp], SZ_EXPSTR) + call strcat (expstr[tp2+1], Memc[exp], SZ_EXPSTR) + + # Print the computed values to the screen. + if (EX_VERBOSE(ex) == YES) { + call printf ("z1=%g z2=%g\n") + call pargr (z1) + call pargr (z2) + } + } + + # Copy fixed-up expression to input buffer. + call aclrc (expstr, SZ_EXPSTR) + call strcpy (Memc[exp], expstr, SZ_EXPSTR) + + if (DEBUG){call eprintf("\t\tnew expr=`%s'\n");call pargstr(expstr)} + + call sfree (sp) +end + + +# EX_ZSCALE -- Sample the expression and compute Z1 and Z2. + +procedure ex_zscale (ex, exptr, exptr2, z1, z2, contrast, optimal_sample_size, + len_stdline) + +pointer ex # task struct pointer +pointer exptr # expression struct pointer +pointer exptr2 # expression struct pointer (mask) +real z1, z2 # output min and max greyscale values +real contrast # adj. to slope of transfer function +int optimal_sample_size # desired number of pixels in sample +int len_stdline # optimal number of pixels per line + +int npix, minpix, ngoodpix, center_pixel, ngrow +real zmin, zmax, median +real zstart, zslope +pointer sample, left +int ex_sample_expr(), ex_fit_line() + +begin + # Subsample the expression. + npix = ex_sample_expr (ex, exptr, exptr2, sample, optimal_sample_size, + len_stdline) + center_pixel = max (1, (npix + 1) / 2) + + # Sort the sample, compute the minimum, maximum, and median pixel + # values. + + call asrtr (Memr[sample], Memr[sample], npix) + zmin = Memr[sample] + zmax = Memr[sample+npix-1] + + # The median value is the average of the two central values if there + # are an even number of pixels in the sample. + + left = sample + center_pixel - 1 + if (mod (npix, 2) == 1 || center_pixel >= npix) + median = Memr[left] + else + median = (Memr[left] + Memr[left+1]) / 2 + + # Fit a line to the sorted sample vector. If more than half of the + # pixels in the sample are rejected give up and return the full range. + # If the user-supplied contrast factor is not 1.0 adjust the scale + # accordingly and compute Z1 and Z2, the y intercepts at indices 1 and + # npix. + + minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT)) + ngrow = max (1, nint (npix * .01)) + ngoodpix = ex_fit_line (Memr[sample], npix, zstart, zslope, + KREJ, ngrow, MAX_ITERATIONS) + + if (ngoodpix < minpix) { + z1 = zmin + z2 = zmax + } else { + if (contrast > 0) + zslope = zslope / contrast + z1 = max (zmin, median - (center_pixel - 1) * zslope) + z2 = min (zmax, median + (npix - center_pixel) * zslope) + } + + call mfree (sample, TY_REAL) +end + + +# EX_SAMPLE_EXPR -- Extract an evenly gridded subsample of the pixels from +# a possibly two-dimensional expression into a one-dimensional vector. + +int procedure ex_sample_expr (ex, exptr, exptr2, sample, optimal_sample_size, + len_stdline) + +pointer ex # task struct pointer +pointer exptr # expression struct pointer +pointer exptr2 # expression struct pointer (mask) +pointer sample # output vector containing the sample +int optimal_sample_size # desired number of pixels in sample +int len_stdline # optimal number of pixels per line + +pointer op, ep, out, bpm +int ncols, nlines, col_step, line_step, maxpix, line +int opt_npix_per_line, npix_per_line, nsubsample +int opt_nlines_in_sample, min_nlines_in_sample, max_nlines_in_sample + +pointer ex_evaluate() + +begin + ncols = OB_WIDTH(exptr) + nlines = OB_HEIGHT(exptr) + + # Compute the number of pixels each line will contribute to the sample, + # and the subsampling step size for a line. The sampling grid must + # span the whole line on a uniform grid. + + opt_npix_per_line = max (1, min (ncols, len_stdline)) + col_step = max (1, (ncols + opt_npix_per_line-1) / opt_npix_per_line) + npix_per_line = max (1, (ncols + col_step-1) / col_step) + + # Compute the number of lines to sample and the spacing between lines. + # We must ensure that the image is adequately sampled despite its + # size, hence there is a lower limit on the number of lines in the + # sample. We also want to minimize the number of lines accessed when + # accessing a large image, because each disk seek and read is expensive. + # The number of lines extracted will be roughly the sample size divided + # by len_stdline, possibly more if the lines are very short. + + min_nlines_in_sample = max (1, optimal_sample_size / len_stdline) + opt_nlines_in_sample = max(min_nlines_in_sample, min(nlines, + (optimal_sample_size + npix_per_line-1) / npix_per_line)) + line_step = max (1, nlines / (opt_nlines_in_sample)) + max_nlines_in_sample = (nlines + line_step-1) / line_step + + # Allocate space for the output vector. Buffer must be freed by our + # caller. + + maxpix = npix_per_line * max_nlines_in_sample + call malloc (sample, maxpix, TY_REAL) + + # Extract the vector. + op = sample + call malloc (out, ncols, TY_REAL) + if (exptr2 != NULL) + call malloc (bpm, ncols, TY_INT) + do line = (line_step + 1) / 2, nlines, line_step { + + # Evaluate the expression at the current line. + call ex_getpix (ex, line) + ep = ex_evaluate (ex, Memc[OB_EXPSTR(exptr)]) + switch (O_TYPE(ep)) { + case TY_CHAR: + call achtcr (Memc[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_SHORT: + call achtsr (Mems[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_INT: + call achtir (Memi[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_LONG: + call achtlr (Meml[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_REAL: + call amovr (Memr[O_VALP(ep)], Memr[out], O_LEN(ep)) + case TY_DOUBLE: + call achtdr (Memd[O_VALP(ep)], Memr[out], O_LEN(ep)) + default: + call error (0, "Unknown expression type in zscale/zscalem().") + } + call evvfree (ep) + if (exptr2 != NULL) { + ep = ex_evaluate (ex, Memc[OB_EXPSTR(exptr2)]) + switch (O_TYPE(ep)) { + case TY_BOOL: + call amovi (Memi[O_VALP(ep)], Memi[bpm], O_LEN(ep)) + default: + call error (0, + "Selection expression must be boolean in zscalem().") + } + call ex_subsample1 (Memr[out], Memi[bpm], Memr[op], O_LEN(ep), + npix_per_line, col_step, nsubsample) + call evvfree (ep) + } else + call ex_subsample (Memr[out], Memr[op], O_LEN(ep), + npix_per_line, col_step, nsubsample) + + op = op + nsubsample + if (op - sample + npix_per_line > maxpix) + break + } + call mfree (out, TY_REAL) + + return (op - sample) +end + + +# EX_SUBSAMPLE -- Subsample an image line. Extract the first pixel and +# every "step"th pixel thereafter for a total of npix pixels. + +procedure ex_subsample (a, b, n, npix, step, nsubsample) + +real a[n] +real b[npix] +int n +int npix, step, nsubsample +int ip, i + +begin + nsubsample = npix + if (step <= 1) + call amovr (a, b, npix) + else { + ip = 1 + do i = 1, npix { + b[i] = a[ip] + ip = ip + step + } + } +end + + +# EX_SUBSAMPLE1 -- Subsample an image line. Extract the first pixel and +# every "step"th pixel thereafter for a total of npix pixels. +# +# Check for mask values and exclude them from the sample. In case a +# subsampled line has fewer than 75% good pixels then increment the starting +# pixel and step through again. Return the number of good pixels. + +procedure ex_subsample1 (a, c, b, n, npix, step, nsubsample) + +real a[ARB] +int c[ARB] +real b[npix] +int n +int npix, step, nsubsample +int i, j + +begin + nsubsample = 0 + if (step <= 1) { + do i = 1, n { + if (c[i] == 0) + next + nsubsample = nsubsample + 1 + b[nsubsample] = a[i] + if (nsubsample == npix) + break + } + } else { + do j = 1, step-1 { + do i = j, n, step { + if (c[i] == 0) + next + nsubsample = nsubsample + 1 + b[nsubsample] = a[i] + if (nsubsample == npix) + break + } + if (nsubsample >= 0.75 * npix) + break + } + } +end + + +# EX_FIT_LINE -- Fit a straight line to a data array of type real. This is +# an iterative fitting algorithm, wherein points further than ksigma from the +# current fit are excluded from the next fit. Convergence occurs when the +# next iteration does not decrease the number of pixels in the fit, or when +# there are no pixels left. The number of pixels left after pixel rejection +# is returned as the function value. + +int procedure ex_fit_line (data, npix, zstart, zslope, krej, ngrow, maxiter) + +real data[npix] #i data to be fitted +int npix #i number of pixels before rejection +real zstart #o Z-value of pixel data[1] +real zslope #o dz/pixel +real krej #i k-sigma pixel rejection factor +int ngrow #i number of pixels of growing +int maxiter #i max iterations + +int i, ngoodpix, last_ngoodpix, minpix, niter +real xscale, z0, dz, x, z, mean, sigma, threshold +double sumxsqr, sumxz, sumz, sumx, rowrat +pointer sp, flat, badpix, normx +int ex_reject_pixels(), ex_compute_sigma() + +begin + if (npix <= 0) + return (0) + else if (npix == 1) { + zstart = data[1] + zslope = 0.0 + return (1) + } else + xscale = 2.0 / (npix - 1) + + # Allocate a buffer for data minus fitted curve, another for the + # normalized X values, and another to flag rejected pixels. + + call smark (sp) + call salloc (flat, npix, TY_REAL) + call salloc (normx, npix, TY_REAL) + call salloc (badpix, npix, TY_SHORT) + call aclrs (Mems[badpix], npix) + + # Compute normalized X vector. The data X values [1:npix] are + # normalized to the range [-1:1]. This diagonalizes the lsq matrix + # and reduces its condition number. + + do i = 0, npix - 1 + Memr[normx+i] = i * xscale - 1.0 + + # Fit a line with no pixel rejection. Accumulate the elements of the + # matrix and data vector. The matrix M is diagonal with + # M[1,1] = sum x**2 and M[2,2] = ngoodpix. The data vector is + # DV[1] = sum (data[i] * x[i]) and DV[2] = sum (data[i]). + + sumxsqr = 0 + sumxz = 0 + sumx = 0 + sumz = 0 + + do i = 1, npix { + x = Memr[normx+i-1] + z = data[i] + sumxsqr = sumxsqr + (x ** 2) + sumxz = sumxz + z * x + sumz = sumz + z + } + + # Solve for the coefficients of the fitted line. + z0 = sumz / npix + dz = sumxz / sumxsqr + + # Iterate, fitting a new line in each iteration. Compute the flattened + # data vector and the sigma of the flat vector. Compute the lower and + # upper k-sigma pixel rejection thresholds. Run down the flat array + # and detect pixels to be rejected from the fit. Reject pixels from + # the fit by subtracting their contributions from the matrix sums and + # marking the pixel as rejected. + + ngoodpix = npix + minpix = max (MIN_NPIXELS, int (npix * MAX_REJECT)) + + for (niter=1; niter <= maxiter; niter=niter+1) { + last_ngoodpix = ngoodpix + + # Subtract the fitted line from the data array. + call ex_flatten_data (data, Memr[flat], Memr[normx], npix, z0, dz) + + # Compute the k-sigma rejection threshold. In principle this + # could be more efficiently computed using the matrix sums + # accumulated when the line was fitted, but there are problems with + # numerical stability with that approach. + + ngoodpix = ex_compute_sigma (Memr[flat], Mems[badpix], npix, + mean, sigma) + threshold = sigma * krej + + # Detect and reject pixels further than ksigma from the fitted + # line. + ngoodpix = ex_reject_pixels (data, Memr[flat], Memr[normx], + Mems[badpix], npix, sumxsqr, sumxz, sumx, sumz, threshold, + ngrow) + + # Solve for the coefficients of the fitted line. Note that after + # pixel rejection the sum of the X values need no longer be zero. + + if (ngoodpix > 0) { + rowrat = sumx / sumxsqr + z0 = (sumz - rowrat * sumxz) / (ngoodpix - rowrat * sumx) + dz = (sumxz - z0 * sumx) / sumxsqr + } + + if (ngoodpix >= last_ngoodpix || ngoodpix < minpix) + break + } + + # Transform the line coefficients back to the X range [1:npix]. + zstart = z0 - dz + zslope = dz * xscale + + call sfree (sp) + return (ngoodpix) +end + + +# EX_FLATTEN_DATA -- Compute and subtract the fitted line from the data array, +# returned the flattened data in FLAT. + +procedure ex_flatten_data (data, flat, x, npix, z0, dz) + +real data[npix] # raw data array +real flat[npix] # flattened data (output) +real x[npix] # x value of each pixel +int npix # number of pixels +real z0, dz # z-intercept, dz/dx of fitted line +int i + +begin + do i = 1, npix + flat[i] = data[i] - (x[i] * dz + z0) +end + + +# EX_COMPUTE_SIGMA -- Compute the root mean square deviation from the +# mean of a flattened array. Ignore rejected pixels. + +int procedure ex_compute_sigma (a, badpix, npix, mean, sigma) + +real a[npix] # flattened data array +short badpix[npix] # bad pixel flags (!= 0 if bad pixel) +int npix +real mean, sigma # (output) + +real pixval +int i, ngoodpix +double sum, sumsq, temp + +begin + sum = 0 + sumsq = 0 + ngoodpix = 0 + + # Accumulate sum and sum of squares. + do i = 1, npix + if (badpix[i] == GOOD_PIXEL) { + pixval = a[i] + ngoodpix = ngoodpix + 1 + sum = sum + pixval + sumsq = sumsq + pixval ** 2 + } + + # Compute mean and sigma. + switch (ngoodpix) { + case 0: + mean = INDEF + sigma = INDEF + case 1: + mean = sum + sigma = INDEF + default: + mean = sum / ngoodpix + temp = sumsq / (ngoodpix - 1) - sum**2 / (ngoodpix * (ngoodpix - 1)) + if (temp < 0) # possible with roundoff error + sigma = 0.0 + else + sigma = sqrt (temp) + } + + return (ngoodpix) +end + + +# EX_REJECT_PIXELS -- Detect and reject pixels more than "threshold" greyscale +# units from the fitted line. The residuals about the fitted line are given +# by the "flat" array, while the raw data is in "data". Each time a pixel +# is rejected subtract its contributions from the matrix sums and flag the +# pixel as rejected. When a pixel is rejected reject its neighbors out to +# a specified radius as well. This speeds up convergence considerably and +# produces a more stringent rejection criteria which takes advantage of the +# fact that bad pixels tend to be clumped. The number of pixels left in the +# fit is returned as the function value. + +int procedure ex_reject_pixels (data, flat, normx, badpix, npix, + sumxsqr, sumxz, sumx, sumz, threshold, ngrow) + +real data[npix] # raw data array +real flat[npix] # flattened data array +real normx[npix] # normalized x values of pixels +short badpix[npix] # bad pixel flags (!= 0 if bad pixel) +int npix +double sumxsqr,sumxz,sumx,sumz # matrix sums +real threshold # threshold for pixel rejection +int ngrow # number of pixels of growing + +int ngoodpix, i, j +real residual, lcut, hcut +double x, z + +begin + ngoodpix = npix + lcut = -threshold + hcut = threshold + + do i = 1, npix + if (badpix[i] == BAD_PIXEL) + ngoodpix = ngoodpix - 1 + else { + residual = flat[i] + if (residual < lcut || residual > hcut) { + # Reject the pixel and its neighbors out to the growing + # radius. We must be careful how we do this to avoid + # directional effects. Do not turn off thresholding on + # pixels in the forward direction; mark them for rejection + # but do not reject until they have been thresholded. + # If this is not done growing will not be symmetric. + + do j = max(1,i-ngrow), min(npix,i+ngrow) { + if (badpix[j] != BAD_PIXEL) { + if (j <= i) { + x = normx[j] + z = data[j] + sumxsqr = sumxsqr - (x ** 2) + sumxz = sumxz - z * x + sumx = sumx - x + sumz = sumz - z + badpix[j] = BAD_PIXEL + ngoodpix = ngoodpix - 1 + } else + badpix[j] = REJECT_PIXEL + } + } + } + } + + return (ngoodpix) +end diff --git a/pkg/dataio/export/generic/exobands.x b/pkg/dataio/export/generic/exobands.x new file mode 100644 index 00000000..d8a7d636 --- /dev/null +++ b/pkg/dataio/export/generic/exobands.x @@ -0,0 +1,489 @@ +include <error.h> +include <mach.h> +include <evvexpr.h> +include <fset.h> +include <ctype.h> +include "../export.h" +include "../exfcn.h" + +define DEBUG false +define VDEBUG false + + +# EX_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ex_evaluate (ex, expr) + +pointer ex #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ex_getop(), ex_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ex_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ex_getop), ex, locpr(ex_obfcn), ex, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# EX_GETOP -- Called by evvexpr to get an operand. + +procedure ex_getop (ex, opname, o) + +pointer ex #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype, imnum +pointer sp, buf +pointer op, param, emsg +pointer im + +#int ex_ptype() +int imgeti(), imgftype(), btoi(), ctoi() +bool streq(), imgetb() +double imgetd() + +define getpar_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (emsg, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[param], SZ_FNAME) + call aclrc (Memc[emsg], SZ_LINE) + + if (VDEBUG) { call eprintf ("getop: opname=%s ");call pargstr(opname)} + + # First see if it's one of the special image operands that was + # referenced in an "@param" call. + + if (((opname[1] != 'i' && opname[1] != 'b') && !IS_DIGIT(opname[2])) || + (opname[1] == 'i' && opname[2] == '_')) { + call strcpy (opname, Memc[param], SZ_FNAME) + im = IO_IMPTR(IMOP(ex,1)) +getpar_ O_LEN(o) = 0 + switch (imgftype (im, Memc[param])) { + case TY_BOOL: + O_TYPE(o) = TY_BOOL + O_VALI(o) = btoi (imgetb (im, Memc[param])) + case TY_CHAR: + O_TYPE(o) = TY_CHAR + O_LEN(o) = SZ_LINE + call malloc (O_VALP(o), SZ_LINE, TY_CHAR) + call imgstr (im, Memc[param], O_VALC(o), SZ_LINE) + case TY_INT: + O_TYPE(o) = TY_INT + O_VALI(o) = imgeti (im, Memc[param]) + case TY_REAL: + O_TYPE(o) = TY_DOUBLE + O_VALD(o) = imgetd (im, Memc[param]) + default: + call sprintf (Memc[emsg], SZ_LINE, "param %s not found\n") + call pargstr (Memc[param]) + call error (6, Memc[emsg]) + } + + call sfree (sp) + return + + } else if (IS_LOWER(opname[1]) && opname[3] == '.') { + # This is a tag.param operand. Break out the image tag name and + # get the image pointer for it, then get the parameter + if (opname[1] == 'b') { # band of 3-D image, only 1 ptr + imnum = 1 + } else if (opname[1] == 'i') { # image descriptor + i = 2 + if (ctoi (opname, i, imnum) == 0) + call error (6, "can't parse operand") + } else { + call sprintf (Memc[buf], SZ_LINE, + "Unknown outbands operand `%s'\n") + call pargstr(opname) + call error (1, Memc[buf]) + } + + # Get the parameter value. + im = IO_IMPTR(IMOP(ex,imnum)) + call strcpy (opname[4], Memc[param], SZ_FNAME) + goto getpar_ + } + + nops = EX_NIMOPS(ex) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = IMOP(ex,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG && found == YES) { + call eprintf (" tag=%s found=%d ") + call pargstr(Memc[IO_TAG(op)]) ; call pargi(found) + call zze_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + #optype = ex_ptype (IO_TYPE(op), IO_NBYTES(op)) + optype = IO_TYPE(op) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + + case TY_INT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_INT + call malloc (O_VALP(o), IO_NPIX(op), TY_INT) + call amovi (Memi[IO_DATA(op)], Memi[O_VALP(o)], IO_NPIX(op)) + + case TY_LONG: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_LONG + call malloc (O_VALP(o), IO_NPIX(op), TY_LONG) + call amovl (Meml[IO_DATA(op)], Meml[O_VALP(o)], IO_NPIX(op)) + + case TY_REAL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), IO_NPIX(op), TY_REAL) + call amovr (Memr[IO_DATA(op)], Memr[O_VALP(o)], IO_NPIX(op)) + + case TY_DOUBLE: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_DOUBLE + call malloc (O_VALP(o), IO_NPIX(op), TY_DOUBLE) + call amovd (Memd[IO_DATA(op)], Memd[O_VALP(o)], IO_NPIX(op)) + + } + + } else { + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call error (1, Memc[buf]) + } + + call sfree (sp) +end + + +# EX_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ex_obfcn (ex, fcn, args, nargs, o) + +pointer ex #i package pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray +pointer scaled, data +int i, len, v_nargs, func, nbins +short sz1, sz2, sb1, sb2, zero +real gamma, bscale, bzero, scale, pix +real z1, z2 + +int strdic() +bool fp_equalr(), strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case ZSCALE: + v_nargs = -1 + case BSCALE: + v_nargs = 3 + case GAMMA: + v_nargs = -1 + case BLOCK: + v_nargs = 3 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zze_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + zero = 0 + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + + case TY_INT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memi[r+i] + + G_COEFF * Memi[g+i] + + B_COEFF * Memi[b+i] + } + + case TY_LONG: + do i = 0, len { + Memr[gray+i] = R_COEFF * Meml[r+i] + + G_COEFF * Meml[g+i] + + B_COEFF * Meml[b+i] + } + + case TY_REAL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memr[r+i] + + G_COEFF * Memr[g+i] + + B_COEFF * Memr[b+i] + } + + case TY_DOUBLE: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memd[r+i] + + G_COEFF * Memd[g+i] + + B_COEFF * Memd[b+i] + } + + } + + case ZSCALE: + data = O_VALP(args[1]) + switch (O_TYPE(args[2])) { + case TY_SHORT: z1 = O_VALS(args[2]) + case TY_INT: z1 = O_VALI(args[2]) + case TY_LONG: z1 = O_VALL(args[2]) + case TY_REAL: z1 = O_VALR(args[2]) + case TY_DOUBLE: z1 = O_VALD(args[2]) + } + switch (O_TYPE(args[3])) { + case TY_SHORT: z2 = O_VALS(args[3]) + case TY_INT: z2 = O_VALI(args[3]) + case TY_LONG: z2 = O_VALL(args[3]) + case TY_REAL: z2 = O_VALR(args[3]) + case TY_DOUBLE: z2 = O_VALD(args[3]) + } + if (nargs < 4) + nbins = 256 + else + nbins = O_VALI(args[4]) + len = O_LEN(args[1]) + O_LEN(o) = len + O_TYPE(o) = O_TYPE(args[1]) + call malloc (O_VALP(o), len, O_TYPE(args[1])) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + sz1 = z1 + sz2 = z2 + sb1 = 0 + sb2 = nbins - 1 + if (abs(sz2-sz1) > 1.0e-5) + call amaps (Mems[data], Mems[scaled], len, sz1, sz2, + sb1, sb2) + else + call amovks (0, Mems[scaled], len) + + case TY_INT: + if (abs(z2-z1) > 1.0e-5) + call amapi (Memi[data], Memi[scaled], len, int (z1), + int(z2), int (0), int (nbins-1)) + else + call amovki (int (0), Memi[scaled], len) + + case TY_LONG: + if (abs(z2-z1) > 1.0e-5) + call amapl (Meml[data], Meml[scaled], len, long (z1), + long(z2), long (0), long (nbins-1)) + else + call amovkl (long (0), Meml[scaled], len) + + case TY_REAL: + if (abs(z2-z1) > 1.0e-5) + call amapr (Memr[data], Memr[scaled], len, real (z1), + real(z2), real (0), real (nbins-1)) + else + call amovkr (real (0), Memr[scaled], len) + + case TY_DOUBLE: + if (abs(z2-z1) > 1.0e-5) + call amapd (Memd[data], Memd[scaled], len, double (z1), + double(z2), double (0), double (nbins-1)) + else + call amovkd (double (0), Memd[scaled], len) + + } + + case BSCALE: + data = O_VALP(args[1]) + bzero = O_VALR(args[2]) + bscale = O_VALR(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Mems[data+i] - bzero) / bscale + } else + call amovks (zero, Mems[scaled], len) + + case TY_INT: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Memi[data+i] - bzero) / bscale + } else + call amovki (int(0), Memi[scaled], len) + + case TY_LONG: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Meml[data+i] - bzero) / bscale + } else + call amovkl (long(0), Meml[scaled], len) + + case TY_REAL: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Memr[data+i] - bzero) / bscale + } else + call amovkr (real(0), Memr[scaled], len) + + case TY_DOUBLE: + if (!fp_equalr (0.0, bscale)) { + do i = 0, len + Memr[scaled+i] = (Memd[data+i] - bzero) / bscale + } else + call amovkd (double(0), Memd[scaled], len) + + } + + case GAMMA: + data = O_VALP(args[1]) + gamma = 1.0 / O_VALR(args[2]) + if (nargs == 3) + scale = max (1.0, O_VALR(args[3])) + else + scale = 255.0 + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + pix = max (zero, Mems[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + case TY_INT: + do i = 0, len { + pix = max (int(0), Memi[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + case TY_LONG: + do i = 0, len { + pix = max (long(0), Meml[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + case TY_REAL: + do i = 0, len { + pix = max (real(0), Memr[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + case TY_DOUBLE: + do i = 0, len { + pix = max (double(0), Memd[data+i]) + Memr[scaled+i] = scale * ((pix/scale) ** gamma) + } + + } + + case BLOCK: + len = O_VALI(args[2]) + O_LEN(o) = len + O_TYPE(o) = O_TYPE(args[1]) + call malloc (O_VALP(o), len, O_TYPE(args[1])) + scaled = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovks (O_VALS(args[1]), Mems[scaled], len) + case TY_INT: + call amovki (O_VALI(args[1]), Memi[scaled], len) + case TY_LONG: + call amovkl (O_VALL(args[1]), Meml[scaled], len) + case TY_REAL: + call amovkr (O_VALR(args[1]), Memr[scaled], len) + case TY_DOUBLE: + call amovkd (O_VALD(args[1]), Memd[scaled], len) + } + + + } + + if (DEBUG) { call zze_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/export/generic/exraster.x b/pkg/dataio/export/generic/exraster.x new file mode 100644 index 00000000..9838894f --- /dev/null +++ b/pkg/dataio/export/generic/exraster.x @@ -0,0 +1,709 @@ +include <imhdr.h> +include <mach.h> +include <evvexpr.h> +include "../export.h" + +define DEBUG false + + +# EX_NO_INTERLEAVE - Write out the image with no interleaving. + +procedure ex_no_interleave (ex) + +pointer ex #i task struct pointer + +pointer op, out +int i, j, k, line, percent, orow +int fd, outtype + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_no_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + # Loop over the number of image expressions. + fd = EX_FD(ex) + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NEXPR(ex) { + + # Process each line in the image. + do j = 1, O_HEIGHT(ex,i) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + #line = EX_NLINES(ex) - j + 1 + line = O_HEIGHT(ex,i) - j + 1 + else + line = j + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,i)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, outtype) + + # Write evaluated pixels. + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, out, O_LEN(op)) + else { + call ex_listpix (fd, outtype, out, O_LEN(op), j, i, + EX_NEXPR(ex), NO) + } + + # Clean up the pointers. + if (outtype == TY_UBYTE || outtype == TY_CHAR) + call mfree (out, TY_CHAR) + else + call mfree (out, outtype) + call evvfree (op) + do k = 1, EX_NIMOPS(ex) { + op = IMOP(ex,k) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + } + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_LN_INTERLEAVE - Write out the image with line interleaving. + +procedure ex_ln_interleave (ex) + +pointer ex #i task struct pointer + +pointer op, out +int i, j, line, percent, orow +int fd, outtype + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_ln_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + # Process each line in the image. + fd = EX_FD(ex) + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - i + 1 + else + line = i + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Loop over the number of image expressions. + do j = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,j)) + + # Convert to the output pixel type. + out = ex_chtype (ex, op, outtype) + + # Write evaluated pixels. + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, out, O_LEN(op)) + else { + call ex_listpix (fd, outtype, out, O_LEN(op), i, j, + EX_NEXPR(ex), NO) + } + + # Clean up the pointers. + if (outtype == TY_UBYTE || outtype == TY_CHAR) + call mfree (out, TY_CHAR) + else + call mfree (out, outtype) + call evvfree (op) + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + + do j = 1, EX_NIMOPS(ex) { + op = IMOP(ex,j) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + } + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_PX_INTERLEAVE - Write out the image with pixel interleaving. + +procedure ex_px_interleave (ex) + +pointer ex #i task struct pointer + +pointer sp, pp, op +pointer o, outptr +int i, j, line, npix, outtype +long totpix +int fd, percent, orow + +pointer ex_evaluate(), ex_chtype() + +begin + if (DEBUG) { call eprintf ("ex_px_interleave:\n") + call eprintf ("NEXPR = %d OCOLS = %d OROWS = %d\n") + call pargi(EX_NEXPR(ex));call pargi(EX_OCOLS(ex)) + call pargi(EX_OROWS(ex)) + } + + call smark (sp) + call salloc (pp, EX_NEXPR(ex), TY_POINTER) + + # Process each line in the image. + fd = EX_FD(ex) + outptr = NULL + outtype = EX_OUTTYPE(ex) + percent = 0 + orow = 0 + do i = 1, EX_NLINES(ex) { + + # See if we're flipping the image. + if (bitset (EX_OUTFLAGS(ex), OF_FLIPY)) + line = EX_NLINES(ex) - i + 1 + else + line = i + + # Get pixels from image(s). + call ex_getpix (ex, line) + + # Loop over the number of image expressions. + totpix = 0 + do j = 1, EX_NEXPR(ex) { + + # Evaluate expression. + op = ex_evaluate (ex, O_EXPR(ex,j)) + + # Convert to the output pixel type. + o = ex_chtype (ex, op, outtype) + Memi[pp+j-1] = o + + npix = O_LEN(op) + #npix = EX_OCOLS(op) + call evvfree (op) + } + + # Merge pixels into a single vector. + call ex_merge_pixels (Memi[pp], EX_NEXPR(ex), npix, outtype, + outptr, totpix) + + # Write vector of merged pixels. + if (outtype == TY_UBYTE) + call achtsb (Memc[outptr], Memc[outptr], totpix) + if (EX_FORMAT(ex) != FMT_LIST) + call ex_wpixels (fd, outtype, outptr, totpix) + else { + call ex_listpix (fd, outtype, outptr, totpix, + i, EX_NEXPR(ex), EX_NEXPR(ex), YES) + } + + if (outtype != TY_CHAR && outtype != TY_UBYTE) + call mfree (outptr, outtype) + else + call mfree (outptr, TY_CHAR) + do j = 1, EX_NIMOPS(ex) { + op = IMOP(ex,j) +# if (IO_ISIM(op) == NO) + call mfree (IO_DATA(op), IM_PIXTYPE(IO_IMPTR(op))) + } + do j = 1, EX_NEXPR(ex) { + if (outtype != TY_CHAR && outtype != TY_UBYTE) + call mfree (Memi[pp+j-1], outtype) + else + call mfree (Memi[pp+j-1], TY_CHAR) + } + + # Print percent done if being verbose + orow = orow + 1 + #if (EX_VERBOSE(ex) == YES) + call ex_pstat (ex, orow, percent) + } + + call sfree (sp) + + if (DEBUG) { call zze_prstruct ("Finished processing", ex) } +end + + +# EX_GETPIX - Get the pixels from the image and load each operand. + +procedure ex_getpix (ex, line) + +pointer ex #i task struct pointer +int line #i current line number + +pointer im, op, data +int nptrs, i, band + +pointer imgl3s(), imgl3i(), imgl3l() +pointer imgl3r(), imgl3d() + +begin + # Loop over each of the image operands. + nptrs = EX_NIMOPS(ex) + do i = 1, nptrs { + op = IMOP(ex,i) + im = IO_IMPTR(op) + band = max (1, IO_BAND(op)) + + if (line > IM_LEN(im,2)) { + call calloc (IO_DATA(op), IM_LEN(im,1), IM_PIXTYPE(im)) + IO_ISIM(op) = NO + IO_NPIX(op) = IM_LEN(im,1) + next + } else if (IO_DATA(op) == NULL) + call malloc (IO_DATA(op), IM_LEN(im,1), IM_PIXTYPE(im)) + + switch (IM_PIXTYPE(im)) { + case TY_USHORT: + data = imgl3s (im, line, band) + call amovs (Mems[data], Mems[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_SHORT + IO_NBYTES(op) = SZ_SHORT * SZB_CHAR + IO_ISIM(op) = YES + + case TY_SHORT: + data = imgl3s (im, line, band) + call amovs (Mems[data], Mems[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_SHORT + IO_NBYTES(op) = SZ_SHORT * SZB_CHAR + IO_ISIM(op) = YES + + case TY_INT: + data = imgl3i (im, line, band) + call amovi (Memi[data], Memi[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_INT + IO_NBYTES(op) = SZ_INT32 * SZB_CHAR + IO_ISIM(op) = YES + + case TY_LONG: + data = imgl3l (im, line, band) + call amovl (Meml[data], Meml[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_LONG + IO_NBYTES(op) = SZ_LONG * SZB_CHAR + IO_ISIM(op) = YES + + case TY_REAL: + data = imgl3r (im, line, band) + call amovr (Memr[data], Memr[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_REAL + IO_NBYTES(op) = SZ_REAL * SZB_CHAR + IO_ISIM(op) = YES + + case TY_DOUBLE: + data = imgl3d (im, line, band) + call amovd (Memd[data], Memd[IO_DATA(op)], IM_LEN(im,1)) + IO_TYPE(op) = TY_DOUBLE + IO_NBYTES(op) = SZ_DOUBLE * SZB_CHAR + IO_ISIM(op) = YES + + } + IO_NPIX(op) = IM_LEN(im,1) + } +end + + +# EX_WPIXELS - Write the pixels to the current file. + +procedure ex_wpixels (fd, otype, pix, npix) + +int fd #i output file descriptor +int otype #i output data type +pointer pix #i pointer to pixel data +int npix #i number of pixels to write + +begin + # Write binary output. + switch (otype) { + case TY_UBYTE: + call write (fd, Mems[pix], npix / SZB_CHAR) + case TY_USHORT: + call write (fd, Mems[pix], npix * SZ_SHORT/SZ_CHAR) + + case TY_SHORT: + call write (fd, Mems[pix], npix * SZ_SHORT/SZ_CHAR) + + case TY_INT: + if (SZ_INT != SZ_INT32) + call ipak32 (Memi[pix], Memi[pix], npix) + call write (fd, Memi[pix], npix * SZ_INT32/SZ_CHAR) + + case TY_LONG: + call write (fd, Meml[pix], npix * SZ_LONG/SZ_CHAR) + + case TY_REAL: + call write (fd, Memr[pix], npix * SZ_REAL/SZ_CHAR) + + case TY_DOUBLE: + call write (fd, Memd[pix], npix * SZ_DOUBLE/SZ_CHAR) + + } +end + + +# EX_LISTPIX - Write the pixels to the current file as ASCII text. + +procedure ex_listpix (fd, type, data, npix, line, band, nbands, merged) + +int fd #i output file descriptor +int type #i output data type +pointer data #i pointer to pixel data +int npix #i number of pixels to write +int line #i current output line number +int band #i current output band number +int nbands #i no. of output bands +int merged #i are pixels interleaved? + +int i, j, k +int val, pix, shifti(), andi() + +begin + if (merged == YES && nbands > 1) { + do i = 1, npix { + k = 0 + do j = 1, nbands { + call fprintf (fd, "%4d %4d %4d ") + call pargi (i) + call pargi (line) + call pargi (j) + + switch (type) { + case TY_UBYTE: + val = Memc[data+k] + if (mod(i,2) == 1) { + pix = shifti (val, -8) + } else { + pix = andi (val, 000FFX) + k = k + 1 + } + if (pix < 0) pix = pix + 256 + call fprintf (fd, "%d\n") + call pargi (pix) + case TY_CHAR, TY_SHORT, TY_USHORT: + call fprintf (fd, "%d\n") + call pargs (Mems[data+((j-1)*npix+i)-1]) + case TY_INT: + call fprintf (fd, "%d\n") + call pargi (Memi[data+((j-1)*npix+i)-1]) + case TY_LONG: + call fprintf (fd, "%d\n") + call pargl (Meml[data+((j-1)*npix+i)-1]) + case TY_REAL: + call fprintf (fd, "%g\n") + call pargr (Memr[data+((j-1)*npix+i)-1]) + case TY_DOUBLE: + call fprintf (fd, "%g\n") + call pargd (Memd[data+((j-1)*npix+i)-1]) + } + } + } + } else { + j = 0 + do i = 1, npix { + if (nbands > 1) { + call fprintf (fd, "%4d %4d %4d ") + call pargi (i) + call pargi (line) + call pargi (band) + } else { + call fprintf (fd, "%4d %4d ") + call pargi (i) + call pargi (line) + } + + switch (type) { + case TY_UBYTE: + val = Memc[data+j] + if (mod(i,2) == 1) { + pix = shifti (val, -8) + } else { + pix = andi (val, 000FFX) + j = j + 1 + } + if (pix < 0) pix = pix + 256 + call fprintf (fd, "%d\n") + call pargi (pix) + case TY_CHAR, TY_SHORT, TY_USHORT: + call fprintf (fd, "%d\n") + call pargs (Mems[data+i-1]) + case TY_INT: + call fprintf (fd, "%d\n") + call pargi (Memi[data+i-1]) + case TY_LONG: + call fprintf (fd, "%d\n") + call pargl (Meml[data+i-1]) + case TY_REAL: + call fprintf (fd, "%g\n") + call pargr (Memr[data+i-1]) + case TY_DOUBLE: + call fprintf (fd, "%g\n") + call pargd (Memd[data+i-1]) + } + } + } +end + + +# EX_MERGE_PIXELS - Merge a group of pixels arrays into one array by combining +# the elements. Returns an allocated pointer which must be later freed and +# the total number of pixels. + +procedure ex_merge_pixels (ptrs, nptrs, npix, dtype, pix, totpix) + +pointer ptrs[ARB] #i array of pixel ptrs +int nptrs #i number of ptrs +int npix #i no. of pixels in each array +int dtype #i type of pointer to alloc +pointer pix #o output pixel array ptr +int totpix #o total no. of output pixels + +int i, j, ip + +begin + # Calculate the number of output pixels and allocate the pointer. + totpix = nptrs * npix + if (dtype != TY_CHAR && dtype != TY_UBYTE) + call realloc (pix, totpix, dtype) + else { + call realloc (pix, totpix, TY_CHAR) + do i = 1, nptrs + call achtbs (Mems[ptrs[i]], Mems[ptrs[i]], npix) + } + + # Fill the output array + ip = 0 + for (i = 1; i<=npix; i=i+1) { + do j = 1, nptrs { + switch (dtype) { + case TY_UBYTE: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + case TY_USHORT: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + + case TY_SHORT: + Mems[pix+ip] = Mems[ptrs[j]+i-1] + + case TY_INT: + Memi[pix+ip] = Memi[ptrs[j]+i-1] + + case TY_LONG: + Meml[pix+ip] = Meml[ptrs[j]+i-1] + + case TY_REAL: + Memr[pix+ip] = Memr[ptrs[j]+i-1] + + case TY_DOUBLE: + Memd[pix+ip] = Memd[ptrs[j]+i-1] + + } + + ip = ip + 1 + } + } +end + + +# EX_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. Any IEEE or byte-swapping +# requests are also handled here. + +pointer procedure ex_chtype (ex, op, type) + +pointer ex #i task struct pointer +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() +int swap, flags + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # If this is a color index image subtract one from the pixel value + # to get the index. + if (bitset (flags, OF_CMAP)) + call ex_pix_to_index (O_VALP(op), O_TYPE(op), O_LEN(op)) + + # Change the pixel type. + flags = EX_OUTFLAGS(ex) + swap = EX_BSWAP(ex) + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I2) || bitset (swap, S_ALL)) + call bswap4 (Mems[out], 1, Mems[out], 1, O_LEN(op)) + + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I4) || bitset (swap, S_ALL)) + call bswap4 (Memi[out], 1, Memi[out], 1, O_LEN(op)) + + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + + # Do any requested byte swapping. + if (bitset (swap, S_I4) || bitset (swap, S_ALL)) + call bswap4 (Meml[out], 1, Meml[out], 1, O_LEN(op)) + + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + + # See if we need to convert to IEEE + if (bitset (flags, OF_IEEE) && IEEE_USED == NO) + call ieevpakr (Memr[out], Memr[out], O_LEN(op)) + + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + + # See if we need to convert to IEEE + if (bitset (flags, OF_IEEE) && IEEE_USED == NO) + call ieevpakd (Memd[P2D(out)], Memd[P2D(out)], O_LEN(op)) + + default: + call error (0, "Invalid output type requested.") + } + + if (type != TY_UBYTE && type != TY_CHAR) + out = coerce (out, TY_CHAR, type) + return (out) +end + + +# EX_PIX_TO_INDEX - Convert pixel values to color index values. We assume +# the colormap has at most 256 entries. + +procedure ex_pix_to_index (ptr, type, len) + +pointer ptr #i data ptr +int type #i data type of array +int len #i length of array + + +short sindx, smin, smax + +int iindx, imin, imax + +long lindx, lmin, lmax + +real rindx, rmin, rmax + +double dindx, dmin, dmax + + +begin + + sindx = short (1) + smin = short (0) + smax = short (255) + + iindx = int (1) + imin = int (0) + imax = int (255) + + lindx = long (1) + lmin = long (0) + lmax = long (255) + + rindx = real (1) + rmin = real (0) + rmax = real (255) + + dindx = double (1) + dmin = double (0) + dmax = double (255) + + + switch (type) { + + case TY_SHORT: + call asubks (Mems[ptr], sindx, Mems[ptr], len) + call amaxks (Mems[ptr], smin, Mems[ptr], len) + call aminks (Mems[ptr], smax, Mems[ptr], len) + + case TY_INT: + call asubki (Memi[ptr], iindx, Memi[ptr], len) + call amaxki (Memi[ptr], imin, Memi[ptr], len) + call aminki (Memi[ptr], imax, Memi[ptr], len) + + case TY_LONG: + call asubkl (Meml[ptr], lindx, Meml[ptr], len) + call amaxkl (Meml[ptr], lmin, Meml[ptr], len) + call aminkl (Meml[ptr], lmax, Meml[ptr], len) + + case TY_REAL: + call asubkr (Memr[ptr], rindx, Memr[ptr], len) + call amaxkr (Memr[ptr], rmin, Memr[ptr], len) + call aminkr (Memr[ptr], rmax, Memr[ptr], len) + + case TY_DOUBLE: + call asubkd (Memd[ptr], dindx, Memd[ptr], len) + call amaxkd (Memd[ptr], dmin, Memd[ptr], len) + call aminkd (Memd[ptr], dmax, Memd[ptr], len) + + } +end + + +# EX_PSTAT - Print information about the progress we're making. + +procedure ex_pstat (ex, row, percent) + +pointer ex #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / EX_OROWS(ex) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/export/generic/mkpkg b/pkg/dataio/export/generic/mkpkg new file mode 100644 index 00000000..4902710d --- /dev/null +++ b/pkg/dataio/export/generic/mkpkg @@ -0,0 +1,12 @@ +# Compile the generic sources. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + exobands.x ../exfcn.h ../export.h <error.h> <evvexpr.h> \ + <fset.h> <mach.h> <ctype.h> + exraster.x ../export.h <evvexpr.h> <imhdr.h> <mach.h> + ; diff --git a/pkg/dataio/export/mkpkg b/pkg/dataio/export/mkpkg new file mode 100644 index 00000000..986450a7 --- /dev/null +++ b/pkg/dataio/export/mkpkg @@ -0,0 +1,36 @@ +# MKPKG file for the EXPORT task + +$call update +$exit + +update: + $checkout libpkg.a ../ + $update libpkg.a + $checkin libpkg.a ../ + ; + +generic: + $set GEN = "$$generic -k" + $ifolder (generic/exobands.x, exobands.gx) + $(GEN) exobands.gx -o generic/exobands.x $endif + $ifolder (generic/exraster.x, exraster.gx) + $(GEN) exraster.gx -o generic/exraster.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + + @generic # compile the generic format code + @bltins # compile the builtin format code + + exbltins.x exbltins.h export.h <mach.h> + excmap.x cmaps.inc export.h <lexnum.h> + exhdr.x export.h <error.h> <fset.h> <imhdr.h> \ + <imio.h> <mach.h> <time.h> + expreproc.x exfcn.h cmaps.inc export.h <ctype.h> <error.h> + exrgb8.x export.h <imhdr.h> + exzscale.x export.h <error.h> <evvexpr.h> + t_export.x export.h <ctype.h> <error.h> <evvexpr.h> \ + <fset.h> <imhdr.h> <mach.h> + zzedbg.x exbltins.h export.h <evvexpr.h> + ; diff --git a/pkg/dataio/export/t_export.x b/pkg/dataio/export/t_export.x new file mode 100644 index 00000000..6516ed11 --- /dev/null +++ b/pkg/dataio/export/t_export.x @@ -0,0 +1,1160 @@ +include <error.h> +include <ctype.h> +include <evvexpr.h> +include <mach.h> +include <fset.h> +include <imhdr.h> +include "export.h" + +define DEBUG false + + +# T_EXPORT -- Task entry. Convert one or more IRAF image to an output binary +# file. Output may be a raw binary raster, with or without header information, +# a pixel listing, or a specified (supported) format. Arbitrary expressions +# may be applied to the input images before conversion. + +procedure t_export () + +pointer ex # task struct pointer +pointer sp, blist, bfname # stack pointers +pointer imname[MAX_OPERANDS] +pointer imlist # image list pointer +pointer im # image descriptor +int binlist # binary file list pointer +int imdim # dimensionality of images +int imtype # datatype of images +int i + +pointer ex_init(), immap() +int ex_getpars() +int clgfil(), access(), fntopnb() +int imtlen(), imtopenp(), open(), imtgetim() +bool streq() + +errchk open, immap, ex_chkimlist + +define quit_ 99 + +begin + # Allocate local stack storage. + call smark (sp) + call salloc (bfname, SZ_FNAME, TY_CHAR) + call salloc (blist, SZ_FNAME, TY_CHAR) + call aclrc (Memc[blist], SZ_FNAME) + call aclrc (Memc[bfname], SZ_FNAME) + do i = 1, MAX_OPERANDS { + call salloc (imname[i], SZ_FNAME, TY_CHAR) + call aclrc (Memc[imname[i]], SZ_FNAME) + } + + # Get the image and file lists. + imlist = imtopenp ("images") + call clgstr ("binfiles", Memc[blist], SZ_FNAME) + if (!streq("", Memc[blist]) && !streq(" ", Memc[blist])) { + binlist = fntopnb (Memc[blist], YES) + iferr (call ex_chkimlist (imlist, binlist, imdim, imtype)) { + call imtclose (imlist) + call clpcls (binlist) + call sfree (sp) + call erract (EA_FATAL) + } + call clprew (binlist) + } else { + binlist = -1 + iferr (call ex_chkimlist (imlist, binlist, imdim, imtype)) { + call imtclose (imlist) + call sfree (sp) + call erract (EA_FATAL) + } + } + call imtrew (imlist) # rewind the list ptrs + + # Allocate structure and get the task parameters. + ex = ex_init () + EX_IMDIM(ex) = imdim + EX_IMTYPE(ex) = imtype + if (ex_getpars (ex) != OK) + goto quit_ + + # Do some last minute error checking. + if (imtlen(imlist) < EX_NIMAGES(ex)) + call error (0, "Too many image operands in expression list") + + # Start processing the files. + repeat { + + # Open the output binary file. + if (binlist > 0) { + if (clgfil(binlist, Memc[bfname], SZ_FNAME) == EOF) + break + + # If this is a builtin format append the format suffix if it's + # not already there and then open the file. + call ex_mkfname (ex, Memc[bfname]) + if (access (BFNAME(ex), 0, 0) == YES) { + call eprintf ("Output file `%s' already exists.\n") + call pargstr (BFNAME(ex)) + goto quit_ + } + if (EX_FORMAT(ex) != FMT_LIST) + EX_FD(ex) = open (BFNAME(ex), NEW_FILE, BINARY_FILE) + else + EX_FD(ex) = open (BFNAME(ex), NEW_FILE, TEXT_FILE) + } else { + call strcpy ("STDOUT", Memc[bfname], SZ_FNAME) + call strcpy ("STDOUT", BFNAME(ex), SZ_FNAME) + EX_FD(ex) = STDOUT + } + + # Open the image pointers. If no outbands expressions were given + # we're converting only one image, but we need to fake up the + # image operands. + if (EX_NIMAGES(ex) == EX_UNDEFINED) { + i = imtgetim(imlist, Memc[imname[1]], SZ_FNAME) + im = immap (Memc[imname[1]], READ_ONLY, 0) + EX_NIMAGES(ex) = 1 + EX_NEXPR(ex) = max (1, IM_LEN(im,3)) + EX_NCOLS(ex) = IM_LEN(im,1) + EX_NLINES(ex) = IM_LEN(im,2) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), BAND_STORAGE) + if (EX_IMDIM(ex) == 0) + EX_IMDIM(ex) = IM_NDIM(im) + if (EX_IMTYPE(ex) == 0) { + EX_IMTYPE(ex) = IM_PIXTYPE(im) + EX_OUTTYPE(ex) = IM_PIXTYPE(im) + } + + # Fake the expressions and break out the operands. + do i = 1, EX_NEXPR(ex) { + call ex_alloc_outbands (OBANDS(ex,i)) + call sprintf (O_EXPR(ex,i), SZ_LINE, "b%d") + call pargi (i) + } + call ex_parse_operands (ex) + if (EX_NEXPR(ex) > 1) { + EX_OUTFLAGS(ex) = and (EX_OUTFLAGS(ex), not(BAND_STORAGE)) + EX_OUTFLAGS(ex) = and (EX_OUTFLAGS(ex), not(LINE_STORAGE)) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), PIXEL_STORAGE) + } + IO_IMPTR(IMOP(ex,1)) = im + + # Print some status stuff so we know what's being converted. + call eprintf ("%s -> %s\n") + call pargstr (Memc[imname[1]]) + call pargstr (BFNAME(ex)) + } else { + EX_NLINES(ex) = 0 + do i = 1, EX_NIMAGES(ex) { + if (imtgetim(imlist, Memc[imname[i]], SZ_FNAME) == EOF) + call error (1, "Short image list") + im = immap (Memc[imname[i]], READ_ONLY, 0) + EX_NCOLS(ex) = IM_LEN(im,1) + EX_NLINES(ex) = max (EX_NLINES(ex), IM_LEN(im,2)) + IO_IMPTR(IMOP(ex,i)) = im + if (EX_IMDIM(ex) == 0) + EX_IMDIM(ex) = IM_NDIM(im) + if (EX_IMTYPE(ex) == 0) { + EX_IMTYPE(ex) = IM_PIXTYPE(im) + EX_OUTTYPE(ex) = IM_PIXTYPE(im) + } + + # Print some status stuff so we know what's being converted. + call eprintf ("%s") + call pargstr (Memc[imname[i]]) + if (i < EX_NIMAGES(ex)) + call eprintf (",") + else { + call eprintf (" -> %s\n") + call pargstr (BFNAME(ex)) + } + call flush (STDERR) + } + } + + # For 3-D data we only have one image, but we may have multiple + # image operands (bands) within the image. If this is the case + # then copy the image pointer to the remaining operand structs. + if (EX_NIMAGES(ex) == 1 && EX_NIMOPS(ex) > 1) { + do i = 2, EX_NIMOPS(ex) + IO_IMPTR(IMOP(ex,i)) = IO_IMPTR(IMOP(ex,1)) + } + + # Now patch up any zscale calls in the expression string. + do i = 1, EX_NEXPR(ex) + call ex_patch_zscale (ex, i) + + # Now that we have all the image information and things are going + # well, compute the size of the output image. + call ex_outsize (ex) + + # If we're being verbose the print some more information on the + # input images and output file. + if (EX_VERBOSE(ex) == YES) + call ex_prinfo (ex, imname) + + # Write the header now if this is a generic raster. + if (EX_HEADER(ex) != HDR_NONE && EX_FORMAT(ex) != FMT_BUILTIN) + call ex_wheader (ex, Memc[bfname]) + + # Process the image. + call ex_process_image (ex) + + # Unmap the image pointer(s). + do i = 1, EX_NIMAGES(ex) { + im = IO_IMPTR(IMOP(ex,i)) + if (im != NULL) + call imunmap (im) + } + + # Close the output file descriptor. + if (EX_FD(ex) != NULL) + call close (EX_FD(ex)) + + # If we created a temp image then delete that now. + if (EX_TIMPTR(ex) != NULL) + call imdelete (TIMNAME(ex)) + + if (binlist < 0) + break + } + + # Clean up. +quit_ call imtclose (imlist) + if (binlist > 0) + call clpcls (binlist) + call sfree (sp) +end + + +# EX_INIT - Initialize the export task structure. + +pointer procedure ex_init () + +pointer ex + +begin + # Allocate the task structure pointer. + iferr (call calloc (ex, SZ_EXPSTRUCT, TY_STRUCT)) + call error (0, "Error allocating EXPORT task structure.") + + # Allocate internal pointers. + call calloc (EX_HDRPTR(ex), SZ_FNAME, TY_CHAR) + call calloc (EX_CMPTR(ex), SZ_FNAME, TY_CHAR) + call calloc (EX_LUTPTR(ex), SZ_FNAME, TY_CHAR) + call calloc (EX_BFNPTR(ex), SZ_FNAME, TY_CHAR) + call calloc (EX_OBANDS(ex), MAX_OBEXPR, TY_STRUCT) + call calloc (EX_IMOPS(ex), MAX_OPERANDS, TY_STRUCT) + call calloc (EX_OTPTR(ex), SZ_LINE, TY_CHAR) + call calloc (EX_OBPTR(ex), SZ_EXPSTR, TY_CHAR) + + # Initialize some parameters. + EX_OUTFLAGS(ex) = NULL + EX_NLUTEL(ex) = INDEFI + EX_NCOLORS(ex) = CMAP_SIZE + EX_PSDPI(ex) = EPS_DPI + EX_PSSCALE(ex) = EPS_SCALE + EX_BRIGHTNESS(ex) = 0.5 + EX_CONTRAST(ex) = 1.0 + + return (ex) +end + + +# EX_FREE - Free the export task structure. + +procedure ex_free (ex) + +pointer ex #i task struct pointer + +int i + +begin + # Free internal pointers. + call mfree (EX_HDRPTR(ex), TY_CHAR) + call mfree (EX_CMPTR(ex), TY_CHAR) + call mfree (EX_LUTPTR(ex), TY_CHAR) + call mfree (EX_BFNPTR(ex), TY_CHAR) + call mfree (EX_TIMPTR(ex), TY_CHAR) + call mfree (EX_OTPTR(ex), TY_CHAR) + call mfree (EX_OBPTR(ex), TY_CHAR) + + # Free outbands pointers. + for (i=1; i < MAX_OBEXPR; i=i+1) + call ex_free_outbands (OBANDS(ex,i)) + call mfree (EX_OBANDS(ex), TY_POINTER) + + # Free operand pointers. + for (i=1; i < MAX_OPERANDS; i=i+1) + call ex_free_operand (IMOP(ex,i)) + call mfree (EX_IMOPS(ex), TY_POINTER) + + # Free the colormap. + if (EX_CMAP(ex) != NULL) + call mfree (EX_CMAP(ex), TY_CHAR) + + call mfree (ex, TY_STRUCT) +end + + +# EX_GETPARS - Get the task parameters. + +int procedure ex_getpars (ex) + +pointer ex #i task struct pointer + +pointer sp, format, header, bswap +pointer outtype, outbands + +int ex_chkpars(), clgeti(), btoi() +bool clgetb() + +errchk ex_do_format, ex_do_header, ex_do_bswap +errchk ex_do_outtype, ex_do_outbands + +begin + call smark (sp) + call salloc (format, SZ_FNAME, TY_CHAR) + call salloc (header, SZ_FNAME, TY_CHAR) + call salloc (bswap, SZ_FNAME, TY_CHAR) + call salloc (outtype, SZ_LINE, TY_CHAR) + call salloc (outbands, SZ_EXPSTR, TY_CHAR) + + call aclrc (Memc[format], SZ_FNAME) + call aclrc (Memc[header], SZ_FNAME) + call aclrc (Memc[bswap], SZ_FNAME) + call aclrc (Memc[outtype], SZ_FNAME) + call aclrc (Memc[outbands], SZ_EXPSTR) + + # Get the string valued parameters. + call clgstr ("format", Memc[format], SZ_FNAME) + call clgstr ("header", Memc[header], SZ_FNAME) + call clgstr ("bswap", Memc[bswap], SZ_FNAME) + call clgstr ("outtype", Memc[outtype], SZ_LINE) + call strcpy (Memc[outtype], Memc[EX_OTPTR(ex)], SZ_LINE) + call clgstr ("outbands", Memc[outbands], SZ_EXPSTR) + call strcpy (Memc[outbands], Memc[EX_OBPTR(ex)], SZ_EXPSTR) + + # Get the simple params. + EX_INTERLEAVE(ex) = clgeti ("interleave") + EX_VERBOSE(ex) = btoi (clgetb ("verbose")) + + # Process the parameter values, due error checking + iferr { + call ex_do_format (ex, Memc[format]) + call ex_do_header (ex, Memc[header]) + call ex_do_bswap (ex, Memc[bswap]) + call ex_do_outtype (ex, Memc[outtype]) + call ex_do_outbands(ex, Memc[outbands]) + } then { + call sfree (sp) + call erract (EA_FATAL) + } + + call sfree (sp) + + if (DEBUG) { + call eprintf("ex_format=%d\n"); call pargi (EX_FORMAT(ex)) + call eprintf("ex_bswap=%d\n"); call pargi (EX_BSWAP(ex)) + call eprintf("ex_outtype=%d\n"); call pargi (EX_OUTTYPE(ex)) + call eprintf("ex_header=%d\n"); call pargi (EX_HEADER(ex)) + } + + # Do a sanity check on the params so we can exit now if needed. + return (ex_chkpars (ex)) +end + + +# EX_CHKPARS - Check task parameters to be sure we have a valid conversion. + +int procedure ex_chkpars (ex) + +pointer ex #i task struct pointer + +int flags, exb_chkpars() + +begin + flags = EX_OUTFLAGS(ex) + if (EX_FORMAT(ex) == FMT_BUILTIN && !bitset(EX_OUTFLAGS(ex),OF_MKCMAP)){ + return (exb_chkpars(ex)) + } else { + if (bitset (flags, OF_CMAP)) { + call error (1, "Colormap creation not supported for raw output") + return (ERR) + } + } + + return (OK) +end + + +# EX_CHKIMLIST - Check the image list to be sure it's valid. + +procedure ex_chkimlist (images, files, ndim, type) + +int images #i image list pointer +int files #i binary files list pointer +int ndim #o dimensionality of images +int type #o datatype of images + +pointer im, sp, imname +int dim + +pointer immap() +int imtlen(), imtgetim(), clplen() + +errchk immap + +begin + call smark (sp) + call salloc (imname, SZ_FNAME, TY_CHAR) + call aclrc (Memc[imname], SZ_FNAME) + + # Get dimension of first image. + if (imtgetim (images, Memc[imname], SZ_FNAME) != EOF) { + im = immap (Memc[imname], READ_ONLY, 0) + ndim = IM_NDIM(im) + type = IM_PIXTYPE(im) + call imunmap (im) + } else + call error (0, "Unexpected EOF in image list.\n") + + # Loop over remaining images in the list. + while (imtgetim (images, Memc[imname], SZ_FNAME) != EOF) { + im = immap (Memc[imname], READ_ONLY, 0) + dim = IM_NDIM(im) + call imunmap (im) + if (dim != ndim) + call error (0, "Images must all be the same dimension.\n") + } + + if (files > 0) { + if (ndim == 3 && (imtlen (images) != clplen (files))) + call error (0, "No. of images must equal no. of output files\n") + } + + call sfree (sp) +end + + +# EX_OUTSIZE - Compute the output file dimensions. We don't require that +# the expressions all evaluate to same length so we'll patch up the expr +# string to pad with zeroes to the maximum width. + +procedure ex_outsize (ex) + +pointer ex #i task struct pointer + +pointer sp, expr +int i, ip, imnum, plev +int height, maxlen, maxhgt +char ch + +pointer op, ex_evaluate() +int ctoi(), strncmp() + +begin + call smark (sp) + call salloc (expr, SZ_EXPSTR, TY_CHAR) + call aclrc (Memc[expr], SZ_EXPSTR) + + call ex_getpix (ex, 1) + maxlen = 0 + do i = 1, EX_NEXPR(ex) { # get length of each expr + op = ex_evaluate (ex, O_EXPR(ex,i)) + O_WIDTH(ex,i) = O_LEN(op) + maxlen = max (maxlen, O_WIDTH(ex,i)) + call evvfree (op) + } + + do i = 1, EX_NEXPR(ex) { # patch expressions + + if (O_WIDTH(ex,i) <= 1) { + # If the width is 1 we have a constant, meaning we only want + # one line on output and need to pad the constant. + O_HEIGHT(ex,i) = 1 + O_WIDTH(ex,i) = maxlen + call aclrc (Memc[expr], SZ_EXPSTR) + call sprintf (Memc[expr], SZ_EXPSTR, "repl(%s,%d)") + call pargstr (O_EXPR(ex,i)) + call pargi (maxlen) + call strcpy (Memc[expr], O_EXPR(ex,i), SZ_EXPSTR) + + } else if (O_WIDTH(ex,i) <= maxlen) { + # If this is a vector expression then look for image operands. + # The 'height' of the expression will be the largest height + # of the found operands. + + ip = 1 + maxhgt = 1 + call strcpy (O_EXPR(ex,i), Memc[expr], SZ_EXPSTR) + repeat { + while (Memc[expr+ip-1] != 'i' && Memc[expr+ip-1] != 'b' && + Memc[expr+ip-1] != EOS) + ip = ip + 1 + if (Memc[expr+ip-1] == EOS) + break + if (IS_DIGIT(Memc[expr+ip])) { + ip = ip + 1 + if (ctoi (Memc[expr], ip, imnum) == 0) + call error (4, "ex_outsize: can't parse operand") + maxhgt = max (maxhgt,IM_LEN(IO_IMPTR(IMOP(ex,imnum)),2)) + + } else if (strncmp(Memc[expr+ip-1], "block", 5) == 0) { + ip = ip + 1 + + # This is a "block" function call to fill a vertical + # area. The syntax is "block(constant, width, height)" + # so get the height argument. + while (Memc[expr+ip] != '(') + ip = ip + 1 + plev = 0 + repeat { # skip over 1st arg + ip = ip + 1 + ch = Memc[expr+ip] + if (ch == '(') plev = plev + 1 + if (ch == ')') plev = plev - 1 + if (ch == ',' && plev == 0) + break + } + # Should be the start of arg2. + ip = ip + 2 # should be the width + if (ctoi (Memc[expr], ip, height) == 0) + call error (4, "ex_outsize: block() syntax error") + ip = ip + 1 # should be the height + if (ctoi (Memc[expr], ip, height) == 0) + call error (4, "ex_outsize: block() syntax error") + + maxhgt = max (maxhgt, height) + } else + ip = ip + 1 + } + O_HEIGHT(ex,i) = maxhgt + + if (O_WIDTH(ex,i) < maxlen) { + call aclrc (Memc[expr], SZ_EXPSTR) + call sprintf (Memc[expr], SZ_EXPSTR, "%s//repl(0,%d)") + call pargstr (O_EXPR(ex,i)) + call pargi (maxlen - O_WIDTH(ex,i)) + call strcpy (Memc[expr], O_EXPR(ex,i), SZ_EXPSTR) + O_WIDTH(ex,i) = maxlen + } + } + + if (DEBUG) { call eprintf ("%d: len=%d maxlen=%d height=%d\n") + call pargi(i) ; call pargi(O_WIDTH(ex,i)) + call pargi(maxlen) ; call pargi (O_HEIGHT(ex,i)) } + + } + EX_OCOLS(ex) = maxlen + + # Now compute the total number of rows. + if (EX_IMDIM(ex) == 3) { + if (!bitset (EX_OUTFLAGS(ex), PIXEL_STORAGE)) { + if (EX_NEXPR(ex) > 1 && bitset (EX_OUTFLAGS(ex), OF_BAND)) + EX_OROWS(ex) = IM_LEN(IO_IMPTR(IMOP(ex,1)),3)*EX_NLINES(ex) + else + EX_OROWS(ex) = EX_NLINES(ex) + } else + EX_OROWS(ex) = EX_NLINES(ex) + } else if (bitset (EX_OUTFLAGS(ex), OF_BAND)) { + EX_OROWS(ex) = 0 + do i = 1, EX_NEXPR(ex) + EX_OROWS(ex) = EX_OROWS(ex) + O_HEIGHT(ex,i) + } else + EX_OROWS(ex) = EX_NLINES(ex) + + call sfree (sp) +end + + +# EX_DO_FORMAT - Get the task format parameter and set appropriate flags. + +procedure ex_do_format (ex, format) + +pointer ex #i task struct pointer +char format[ARB] #i format parameter value + +bool streq() + +begin + if (DEBUG) { call eprintf("format='%s'\n");call pargstr (format) } + + EX_COLOR(ex) = NO + if (streq(format,"raw")) + EX_FORMAT(ex) = FMT_RAW + else if (streq(format,"list")) + EX_FORMAT(ex) = FMT_LIST + else { + EX_FORMAT(ex) = FMT_BUILTIN + call exb_do_format (ex, format) + } +end + + +# EX_DO_HEADER - Process the header parameter. + +procedure ex_do_header (ex, header) + +pointer ex #i task struct pointer +char header[ARB] #i header parameter string + +bool streq() +int access() + +begin + if (DEBUG) { call eprintf("header='%s'\n") ; call pargstr (header) } + + if (streq(header,"no")) + EX_HEADER(ex) = HDR_NONE + else if (streq(header,"yes")) + EX_HEADER(ex) = HDR_SHORT + else if (streq(header,"long")) + EX_HEADER(ex) = HDR_LONG + else { + EX_HEADER(ex) = HDR_USER + if (access (header, 0, 0) == NO) + call error (2, "User-defined header file does not exist.") + else + call strcpy (header, HDRFILE(ex), SZ_FNAME) + } +end + + +# EX_DO_OUTTYPE - Process the output pixel type parameter. + +procedure ex_do_outtype (ex, outtype) + +pointer ex #i task struct pointer +char outtype[ARB] #i outtype parameter string + +int pixtype, nbytes + +int ex_ptype(), stridx() + +begin + if (DEBUG) { call eprintf("outtype='%s'\n");call pargstr (outtype) } + + if (outtype[1] == EOS) { + EX_OUTTYPE(ex) = EX_IMTYPE(ex) # use type of input image + return + } + + pixtype = stridx(outtype[1],"buirn") + if (pixtype == 0) + call error (2, "Invalid 'outtype' value specified\n") + + if (outtype[2] == EOS) { + if (outtype[1] == 'b') # set minimal sizes + nbytes = 1 + else if (outtype[1] == 'u') + nbytes = 2 + else + nbytes = 4 + } else + nbytes = outtype[2] - '1' + 1 + + # Set struct param. + EX_OUTTYPE(ex) = ex_ptype (pixtype, nbytes) + call sprintf (Memc[EX_OTPTR(ex)], SZ_FNAME, "%c%d") + call pargc (Memc[EX_OTPTR(ex)]) + call pargi (nbytes) +end + + +# EX_DO_BSWAP -- Read the byte-swap string an load the ip structure. + +procedure ex_do_bswap (ex, bswap) + +pointer ex #i task struct pointer +char bswap[ARB] #i byte swap string + +char ch, flag[SZ_FNAME] +int sp, i + +int strdic() + +begin + if (DEBUG) { call eprintf("swap='%s'\n");call pargstr (bswap) } + + sp = 1 + EX_BSWAP(ex) = NULL + while (bswap[sp] != EOS) { + i = 1 + for (ch=bswap[sp]; ch != EOS && ch != ','; ch=bswap[sp]) { + flag[i] = ch + i = i + 1 + sp = sp + 1 + } + flag[i] = EOS + + switch (strdic (flag, flag, SZ_FNAME, SWAP_STR)) { + case 1, 2: + EX_BSWAP(ex) = or (EX_BSWAP(ex), S_NONE) + case 3: + EX_BSWAP(ex) = or (EX_BSWAP(ex), S_ALL) + case 4: + EX_BSWAP(ex) = or (EX_BSWAP(ex), S_I2) + case 5: + EX_BSWAP(ex) = or (EX_BSWAP(ex), S_I4) + default: + break + } + } +end + + +# EX_DO_OUTBANDS - Parse the 'outbands' expressions. The operand tags are +# caught and space allocated. + +procedure ex_do_outbands (ex, outbands) + +pointer ex #i task struct pointer +char outbands[ARB] #i outbands expression string + +pointer sp, exp, expr +int fd, nchars, nexpr +int j, ip, plevel + +int open(), fstatl(), strlen() +char getc() + +errchk open + +begin + if (DEBUG) { call eprintf("outbands='%s'\n");call pargstr (outbands) } + + if (outbands[1] == EOS) { + EX_NIMAGES(ex) = EX_UNDEFINED # convert the whole image + EX_NEXPR(ex) = EX_UNDEFINED + return + } + + call smark (sp) + call salloc (exp, SZ_EXPSTR, TY_CHAR) + call aclrc (Memc[exp], SZ_EXPSTR) + + # If the outbands parameter is an @-file read in the expression from + # the file, otherwise just copy the param to the working buffer. + if (outbands[1] == '@') { + fd = open (outbands[2], READ_ONLY, TEXT_FILE) + nchars = fstatl (fd, F_FILESIZE) + 1 + call calloc (expr, max(SZ_EXPSTR,nchars), TY_CHAR) + ip = 0 + for (j=0; j<nchars && ip != EOF; j=j+1) + ip = getc (fd, Memc[expr+j]) + Memc[expr+nchars-1] = EOS + call close (fd) + } else { + nchars = strlen (outbands) + 1 + call calloc (expr, max(SZ_EXPSTR,nchars), TY_CHAR) + call strcpy (outbands, Memc[expr], nchars) + } + + nexpr = 0 # initialize variables + + # Preprocess the expression string to strip out functions that aren't + # really evaluated for each line in the image. The processing is + # done in-place and the returned string should contain only processing + # functions. + call ex_preprocess (ex, Memc[expr]) + if (DEBUG) { call eprintf("\texpr1='%s'\n");call pargstr(Memc[expr]) } + + ip = 0 + while (Memc[expr+ip] != EOS) { + # Parse each expression into an outbands struct buffer. + plevel = 0 + for (j=0; j<SZ_LINE && Memc[expr+ip] != EOS; j=j+1) { + Memc[exp+j] = Memc[expr+ip] + if (Memc[expr+ip] == '(') + plevel = plevel + 1 + else if (Memc[expr+ip] == ')') + plevel = plevel - 1 + else if (Memc[expr+ip] == ',' && plevel == 0) + break + else if (Memc[expr+ip] == EOS) + break + + ip = ip + 1 + } + if (Memc[expr+ip] != EOS) + ip = ip + 1 + Memc[exp+j] = '\0' + nexpr = nexpr + 1 + + if (DEBUG) { + call eprintf ("\texpr[%d] = `%s'\n") + call pargi(nexpr);call pargstr(Memc[exp]) + } + + # Save expression in outbands struct. + call ex_alloc_outbands (OBANDS(ex,nexpr)) + call strcpy (Memc[exp], O_EXPR(ex,nexpr), SZ_EXPSTR) + } + EX_NEXPR(ex) = nexpr + + # Now that we have the expressions break out the operands. + call ex_parse_operands (ex) + + # Set the output type flag if not already defined in preprocessing. + if (EX_OUTFLAGS(ex) == 0) { + if (EX_INTERLEAVE(ex) == 0 && EX_NEXPR(ex) > 1) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), PIXEL_STORAGE) + else if (EX_INTERLEAVE(ex) > 0 && EX_NEXPR(ex) > 1) + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), LINE_STORAGE) + else + EX_OUTFLAGS(ex) = or (EX_OUTFLAGS(ex), BAND_STORAGE) + } + + call mfree (expr, TY_CHAR) + call sfree (sp) +end + + +# EX_PARSE_OPERANDS - Parse each expression string to break out the image +# operands. If the input image list is 2-D data we'll be generous and +# allow either 'b1' or 'i1', otherwise require the bands number. + +define SZ_TAG 7 + +procedure ex_parse_operands (ex) + +pointer ex #i task struct pointer + +pointer sp, expr +int i, ip, opnum +char ch, tag[SZ_TAG] + +int ctoi() + +begin + call smark (sp) + call salloc (expr, SZ_EXPSTR, TY_CHAR) + + EX_NIMOPS(ex) = 0 + EX_NIMAGES(ex) = 0 + do i = 1, EX_NEXPR(ex) { + call aclrc (Memc[expr], SZ_EXPSTR) + call strcpy (O_EXPR(ex,i), Memc[expr], SZ_EXPSTR) + + ip = 1 + while (Memc[expr+ip] != EOS) { + ch = Memc[expr+ip-1] + + # See if we have an operand descriptor. + if ((ch == 'b' || ch == 'i') && IS_DIGIT(Memc[expr+ip])) { + ip = ip + 1 + if (ctoi (Memc[expr], ip, opnum) == 0) + call error (4, "can't parse operand") + call sprintf (tag, SZ_TAG, "%c%d") + call pargc (ch) + call pargi (opnum) + + # Allocate the operand structure + if (IMOP(ex,opnum) == NULL) { + call ex_alloc_operand (IMOP(ex,opnum)) + call strcpy (tag, OP_TAG(IMOP(ex,opnum)), SZ_TAG) + EX_NIMOPS(ex) = EX_NIMOPS(ex) + 1 + } + + # For 2-D images allow either name interchangeably. Here + # we set the struct image band, we'll load the image de- + # scriptor later. + if (EX_IMDIM(ex) == 2) { + IO_BAND(IMOP(ex,opnum)) = 1 + EX_NIMAGES(ex) = EX_NIMOPS(ex) + } else if (EX_IMDIM(ex) == 3) { + if (ch == 'i') + call error (4, "Image operand illegal w/ 3-D lists") + IO_BAND(IMOP(ex,opnum)) = opnum + EX_NIMAGES(ex) = 1 + } + if (DEBUG) call zze_prop (IMOP(ex,opnum)) + } + ip = ip + 1 + } + } + + call sfree (sp) +end + + +# EX_PROCESS_IMAGE - Process the image pixels. + +procedure ex_process_image (ex) + +pointer ex #i task struct pointer + +int flags + +begin + flags = EX_OUTFLAGS(ex) + + # Create the (if any) requested colormap first. + if (bitset (flags, OF_MKCMAP)) + call ex_mkcmap (ex) + + # Process the images. + if (EX_FORMAT(ex) == FMT_BUILTIN) { + # Write the builtin format. + call exb_process_image (ex) + + } else { + if (bitset (flags, OF_BAND) || bitset (flags, BAND_STORAGE)) + call ex_no_interleave (ex) + else if (bitset (flags, OF_LINE) || bitset (flags, LINE_STORAGE)) + call ex_ln_interleave (ex) + else if (bitset (flags, PIXEL_STORAGE)) + call ex_px_interleave (ex) + else + call error (0, "Unknown processing param.") + } + + #if (EX_VERBOSE(ex) == YES) { + call eprintf (" Status: Done. \n") + call flush (STDERR) + #} +end + + +# EX_PRINFO - Print verbose information about the conversion. + +procedure ex_prinfo (ex, np) + +pointer ex #i task struct pointer +pointer np[ARB] #i ptr to image names + +pointer im +int i, j, flags + +begin + # Print information about the input images. + call eprintf (" Input images:\n") + do i = 1, EX_NIMAGES(ex) { + im = IO_IMPTR(IMOP(ex,i)) + call eprintf ("\t%s: %s %40t") + call pargstr (OP_TAG(IMOP(ex,i))) + call pargstr (Memc[np[i]]) + do j = 1, IM_NDIM(im) { + call eprintf ("%d ") + call pargi (IM_LEN(im,j)) + if (j < IM_NDIM(im)) + call eprintf ("x ") + } + call eprintf (" `%s'\n") + call pargstr (IM_TITLE(im)) + } + + # Print information about the output file. + flags = EX_OUTFLAGS(ex) + call eprintf (" Output file:\n") + call eprintf ("\tName: %30t%s\n") + call pargstr (BFNAME(ex)) + call eprintf ("\tFormat: %30t%s\n") + switch (EX_FORMAT(ex)) { + case FMT_RAW: call pargstr ("Raw") + case FMT_LIST: call pargstr ("List") + case FMT_BUILTIN: + call exb_pname (ex) + } + + if (EX_FORMAT(ex) == FMT_RAW) { + call eprintf ("\tHeader: %30t%s%s\n") + switch(EX_HEADER(ex)) { + case HDR_NONE: call pargstr ("None") ; call pargstr ("") + case HDR_SHORT: call pargstr ("Short") ; call pargstr ("") + case HDR_LONG: call pargstr ("Long") ; call pargstr ("") + case HDR_USER: call pargstr ("User: ") + call pargstr (HDRFILE(ex)) + } + } + + call eprintf ("\tByte Order: %30t%s\n") + if (EX_FORMAT(ex) == FMT_BUILTIN) + call exb_pendian (ex) + else if (EX_BSWAP(ex) == 0 && (BYTE_SWAP2==NO || BYTE_SWAP4==NO)) + call pargstr ("Most Significant Byte First") + else + call pargstr ("Least Significant Byte First") + + call eprintf ("\tResolution: %30t%d x %d\n") + call pargi (EX_OCOLS(ex)) + call pargi (EX_OROWS(ex)) + + call eprintf ("\tPixel Storage: %30t%s\n") + if (EX_FORMAT(ex) == FMT_BUILTIN) + call exb_pstorage (ex) + else if (bitset(flags, OF_BAND) || bitset(flags,BAND_STORAGE)) + call pargstr ("Band Interleaved") + else if (bitset(flags, OF_LINE) || bitset(flags,LINE_STORAGE)) + call pargstr ("Line Interleaved") + else if (bitset(flags,PIXEL_STORAGE)) + call pargstr ("Pixel Interleaved") + else + call pargstr ("Unknown") + + if (bitset(flags, OF_CMAP) || bitset(flags, OF_MKCMAP)) + call eprintf ("\tType: %30t8-bit Color Indexed\n") + else { + if (bitset(flags, OF_BAND) && EX_NEXPR(ex) > 1) + call eprintf ("\tType: %30tGrayscale\n") + else + call eprintf ("\tType: %30tRGB\n") + } + + if (bitset(flags, OF_CMAP) || bitset(flags, OF_MKCMAP)) { + call eprintf ("\tColor Table: %30t%d entries\n") + call pargi (EX_NCOLORS(ex)) + } else + call eprintf ("\tColor Table: %30tnone\n") + + if (DEBUG && EX_NEXPR(ex) != 0) { + call eprintf ("\tEvaluated Expressions:\n") + do i = 1, EX_NEXPR(ex) { + call eprintf ("\t %d) %s\n") + call pargi (i) + call pargstr (O_EXPR(ex,i)) + } + } +end + + +# EX_PTYPE -- For a given outtype parameter return the corresponding IRAF +# data type. + +define NTYPES 6 +define NBITPIX 4 + +int procedure ex_ptype (type, nbytes) + +int type #i pixel type +int nbytes #i number of bytes + +int i, pt, pb, ptype +int tindex[NTYPES], bindex[NBITPIX], ttbl[NTYPES*NBITPIX] + +data tindex /PT_BYTE, PT_UINT, PT_INT, PT_IEEE, PT_NATIVE, PT_SKIP/ +data bindex /1, 2, 4, 8/ + +data (ttbl(i), i= 1, 4) /TY_UBYTE, TY_USHORT, TY_INT, 0/ # B +data (ttbl(i), i= 5, 8) /TY_UBYTE, TY_USHORT, 0, 0/ # U +data (ttbl(i), i= 9,12) /TY_UBYTE, TY_SHORT, TY_INT, 0/ # I +data (ttbl(i), i=13,16) / 0, 0, TY_REAL, TY_DOUBLE/ # R +data (ttbl(i), i=17,20) / 0, 0, TY_REAL, TY_DOUBLE/ # N +data (ttbl(i), i=21,24) /TY_UBYTE, TY_USHORT, TY_REAL, TY_DOUBLE/ # X + +begin + if (type == 0 || nbytes == 0) # uninitialized values + return (0) + + pt = NTYPES + do i = 1, NTYPES { + if (tindex[i] == type) + pt = i + } + pb = NBITPIX + do i = 1, NBITPIX { + if (bindex[i] == nbytes) + pb = i + } + + ptype = ttbl[(pt-1)*NBITPIX+pb] + + if (DEBUG) { call eprintf("pt=%d pb=%d -> ptype=%d\n") + call pargi (pt) ; call pargi (pb) ; call pargi (ptype) } + + if (ptype == 0) + call error (0, "Invalid outtype specified.") + else + return (ptype) +end + + +# EX_MKFNAME - Create an output filename based on the requested format. + +procedure ex_mkfname (ex, fname) + +pointer ex #i task struct pointer +char fname[ARB] # generate the output filename + +pointer sp, suffix, test +int fnextn() +bool streq() +pointer exb_fmt_ext() + +begin + call smark (sp) + call salloc (test, SZ_FNAME, TY_CHAR) + + if (EX_FORMAT(ex) == FMT_BUILTIN) + suffix = exb_fmt_ext (ex) + else if (EX_FORMAT(ex) == FMT_RAW || EX_FORMAT(ex) == FMT_LIST) { + call strcpy (fname, BFNAME(ex), SZ_FNAME) + call sfree (sp) + return + } + + # If the current extension is not the same as the format extn add it. + if (fnextn (fname, Memc[test], SZ_FNAME) > 0) { + if (streq(Memc[test], Memc[suffix+1])) { + call strcpy (fname, BFNAME(ex), SZ_FNAME) + call sfree (sp) + return + } + } + + call sprintf (BFNAME(ex), SZ_FNAME, "%s%s") + call pargstr (fname) + call pargstr (Memc[suffix]) + + call mfree (suffix, TY_CHAR) + call sfree (sp) +end + + +# EX_ALLOC_OUTBANDS -- Allocate an outbands structure. + +procedure ex_alloc_outbands (op) + +pointer op #i outbands struct pointer + +begin + call calloc (op, LEN_OUTBANDS, TY_STRUCT) + call calloc (OB_EXPSTR(op), SZ_EXPSTR, TY_CHAR) +end + + +# EX_FREE_OUTBANDS -- Free an outbands structure. + +procedure ex_free_outbands (op) + +pointer op #i outbands struct pointer + +begin + call mfree (OB_EXPSTR(op), TY_CHAR) + call mfree (op, TY_STRUCT) +end + + +# EX_ALLOC_OPERAND -- Allocate an operand structure. + +procedure ex_alloc_operand (op) + +pointer op #i operand struct pointer + +begin + call calloc (op, LEN_OPERAND, TY_STRUCT) + call calloc (IO_TAG(op), SZ_FNAME, TY_CHAR) +end + + +# EX_FREE_OPERAND -- Free an operand structure. + +procedure ex_free_operand (op) + +pointer op #i operand struct pointer + +begin + call mfree (IO_TAG(op), TY_CHAR) + call mfree (op, TY_STRUCT) +end diff --git a/pkg/dataio/export/zzedbg.x b/pkg/dataio/export/zzedbg.x new file mode 100644 index 00000000..d1eba755 --- /dev/null +++ b/pkg/dataio/export/zzedbg.x @@ -0,0 +1,157 @@ +include <evvexpr.h> +include "exbltins.h" +include "export.h" + +procedure zze_prstruct (whence, ex) + +char whence[SZ_FNAME] +pointer ex +int i + +begin + call eprintf ("%s:\n") ; call pargstr (whence) + call eprintf ("\tformat=%s %s outflags=%d interleave=%d bswap=%s\n") + switch (EX_FORMAT(ex)) { + case FMT_RAW: call pargstr ("FMT_RAW") + case FMT_LIST: call pargstr ("FMT_LIST") + case FMT_BUILTIN: call pargstr ("FMT_BUILTIN") + default: call pargstr ("ERR") + } + switch (EX_BLTIN(ex)) { + case EPS: call pargstr ("(eps)") + case GIF: call pargstr ("(gif)") + case PGM: call pargstr ("(pgm)") + case PPM: call pargstr ("(ppm)") + case RAS: call pargstr ("(ras)") + case RGB: call pargstr ("(rgb)") + case XWD: call pargstr ("(xwd)") + default: call pargstr ("") + } + call pargi (EX_OUTFLAGS(ex)) + call pargi (EX_INTERLEAVE(ex)) + switch(EX_BSWAP(ex)) { + case S_NONE: call pargstr ("S_NONE") + case S_ALL: call pargstr ("S_ALL") + case S_I2: call pargstr ("S_I2") + case S_I4: call pargstr ("S_I4") + default: call pargstr ("ERR") + } + call eprintf ("\touttype=%s header='%s' verbose=%d\n") + switch(EX_OUTTYPE(ex)) { + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + default: call pargstr ("ERR") + } + switch(EX_HEADER(ex)) { + case HDR_NONE: call pargstr ("HDR_NONE") + case HDR_SHORT: call pargstr ("HDR_SHORT") + case HDR_LONG: call pargstr ("HDR_LONG") + case HDR_USER: call pargstr ("HDR_USER") + default: call pargstr ("ERR") + } + call pargi (EX_VERBOSE(ex)) + call eprintf ("\toutbands (%d):\n") ; call pargi (EX_NEXPR(ex)) + do i = 1, EX_NEXPR(ex) + call zze_proband (ex, i) + call eprintf ("\tocols=%d orows=%d:\n") + call pargi (EX_OCOLS(ex)) ; call pargi (EX_OROWS(ex)) + call eprintf ("\tnimages=%d nimops=%d ncols=%d nlines=%d:\n") + call pargi (EX_NIMAGES(ex)) + call pargi (EX_NIMOPS(ex)) + call pargi (EX_NCOLS(ex)) + call pargi (EX_NLINES(ex)) + do i = 1, MAX_OPERANDS { + if (IMOP(ex,i) != NULL) { + call eprintf ("\t ") ; call zze_prop (IMOP(ex,i)) + } + } + + call eprintf ("\tuser header = '%s' LUT file = '%s'\n") + call pargstr (HDRFILE(ex)) + call pargstr (LUTFILE(ex)) + call eprintf ("\tEPS dpi = %g scale = %g ncolors = %d\n") + call pargr (EX_PSDPI(ex)) + call pargr (EX_PSSCALE(ex)) + call pargi (EX_NCOLORS(ex)) + call eprintf ("\tbrightness = %g contrast = %g\n") + call pargr (EX_BRIGHTNESS(ex)) + call pargr (EX_CONTRAST(ex)) + call flush (STDERR) +end + + +procedure zze_proband (ex, band) + +pointer ex +int band + +begin + call eprintf ("\t ob=%d w=%d h=%d expr='%s'\n") + call pargi (OBANDS(ex,band)) + call pargi (OB_WIDTH(OBANDS(ex,band))) + call pargi (OB_HEIGHT(OBANDS(ex,band))) + call pargstr (O_EXPR(ex,band)) +end + + +procedure zze_prop (o) + +pointer o +char buf[8] +int type, ex_ptype() + +begin + if (o == NULL) + return + + call sprintf (buf, 8, " buirnx") + type = ex_ptype(IO_TYPE(o), IO_NBYTES(o)) + call eprintf("(o=%d im=%d band=%d tag=%s (t='%c' N=%d=>%s) Np=%d %d)\n") + call pargi (o) + call pargi (IO_IMPTR(o)) + call pargi (IO_BAND(o)) + if (IO_TAG(o) == NULL) call pargstr ("") + else call pargstr (OP_TAG(o)) + #call pargc (buf[IO_TYPE(o)+1]) + call pargc (IO_TYPE(o)) + call pargi (IO_NBYTES(o)) + switch (type) { + case TY_UBYTE: call pargstr ("TY_UBYTE") + case TY_USHORT: call pargstr ("TY_USHORT") + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + default: call pargstr ("ERR") + } + call pargi (IO_NPIX(o)) + call pargi (IO_DATA(o)) + call flush (STDERR) +end + + +procedure zze_pevop (o) + +pointer o + +begin + call eprintf ("o=%d type=%d len=%d flags=%d ") + call pargi (o) + call pargi (O_TYPE(o)) + call pargi (O_LEN(o)) + call pargi (O_FLAGS(o)) + switch (O_TYPE(o)) { + case TY_CHAR: call eprintf ("val='%s'\n") ; call pargstr (O_VALC(o)) + case TY_SHORT: call eprintf ("val=%d\n") ; call pargs (O_VALS(o)) + case TY_INT: call eprintf ("val=%d\n") ; call pargi (O_VALI(o)) + case TY_LONG: call eprintf ("val=%d\n") ; call pargl (O_VALL(o)) + case TY_REAL: call eprintf ("val=%g\n") ; call pargr (O_VALR(o)) + case TY_DOUBLE: call eprintf ("val=%g\n") ; call pargd (O_VALD(o)) + default: call eprintf ("ptr=%d\n") ; call pargi (O_VALP(o)) + } + call flush (STDERR) +end diff --git a/pkg/dataio/fits/fits_cards.x b/pkg/dataio/fits/fits_cards.x new file mode 100644 index 00000000..0ddfa230 --- /dev/null +++ b/pkg/dataio/fits/fits_cards.x @@ -0,0 +1,292 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "wfits.h" + +# WFT_STANDARD_CARD -- Procedure for fetching the minimum header +# parameters required by fits. The end card is encoded separately. + +int procedure wft_standard_card (cardno, im, fits, axisno, card) + +int cardno # number of FITS standard card +pointer im # pointer to the IRAF image +pointer fits # pointer to the FITS structure +int axisno # axis number +char card[ARB] # FITS card image + +char keyword[LEN_KEYWORD] +int len_object +int strlen() +errchk wft_encodeb, wft_encodei, wft_encodel, wft_encode_axis + +begin + # Get mandatory keywords. + switch (cardno) { + case FIRST_CARD: + if (XTENSION(fits) == EXT_PRIMARY) { + call wft_encodeb ("SIMPLE", YES, card, "FITS STANDARD") + } else { + len_object = max (min (LEN_OBJECT, strlen ("IMAGE")), + LEN_STRING) + call wft_encodec ("XTENSION", "IMAGE", len_object, card, + "IMAGE EXTENSION") + } + case SECOND_CARD: + call wft_encodei ("BITPIX", FITS_BITPIX(fits), card, + "FITS BITS/PIXEL") + case THIRD_CARD: + call wft_encodei ("NAXIS", NAXIS(im), card, "NUMBER OF AXES") + default: + call wft_encode_axis ("NAXIS", keyword, axisno) + call wft_encodel (keyword, NAXISN(im, axisno), card, "") + axisno = axisno + 1 + } + + return (YES) +end + + +# WFT_OPTION_CARD -- Procedure for fetching optional FITS header parameters. +# At present these are bscale, bzero, bunit, blank, object, origin, date, +# irafmax, irafmin, iraf type and iraf bits per pixel. Blank is only encoded +# if there are a nonzero number of blanks in the IRAF image. Bunit and object +# are only encoded if the appropriate IRAF strings are defined. Bzero, bscale, +# irafmax, irafmin, iraf type and iraf bits per pixel are only encoded if +# there is a pixel file. + +int procedure wft_option_card (im, fits, optiono, card) + +pointer im # pointer to the IRAF image +pointer fits # pointer to FITS structure +int optiono # number of the option card +char card[ARB] # FITS card image + +char datestr[LEN_DATE] +int len_object, stat +int strlen() +errchk wft_encoded, wft_encodec, wft_encode_blank, wft_encoder, wft_encodei +errchk wft_encode_date +include "wfits.com" + +begin + stat = YES + + # get optional keywords + switch (optiono) { + case KEY_EXTEND: + if (XTENSION(fits) == EXT_IMAGE || wextensions == NO) + stat = NO + else + call wft_encodeb ("EXTEND", YES, card, + "STANDARD EXTENSIONS MAY BE PRESENT") + case KEY_PCOUNT: + if (XTENSION(fits) == EXT_PRIMARY) + stat = NO + else + call wft_encodei ("PCOUNT", 0, card, "NO RANDOM PARAMETERS") + case KEY_GCOUNT: + if (XTENSION(fits) == EXT_PRIMARY) + stat = NO + else + call wft_encodei ("GCOUNT", 1, card, "ONLY ONE GROUP") + case KEY_BSCALE: + if ((NAXIS(im) <= 0) || (FITS_BITPIX(fits) < 0)) + stat = NO + else { + call wft_encoded ("BSCALE", BSCALE(fits), card, + "REAL = TAPE*BSCALE + BZERO", NDEC_DOUBLE) + } + case KEY_BZERO: + if ((NAXIS(im) <= 0) || (FITS_BITPIX(fits) < 0)) + stat = NO + else + call wft_encoded ("BZERO", BZERO(fits), card, "", NDEC_DOUBLE) + case KEY_BUNIT: + stat = NO + case KEY_BLANK: + stat = NO + #if (NBPIX(im) == 0) + #stat = NO + #else + #call wft_encode_blank ("BLANK", BLANK_STRING(fits), card, + #"TAPE VALUE OF BLANK PIXEL") + case KEY_OBJECT: + if (OBJECT(im) == EOS) + stat = NO + else { + len_object = max (min (LEN_OBJECT, strlen (OBJECT(im))), + LEN_STRING) + call wft_encodec ("OBJECT", OBJECT(im), len_object, card, "") + } + case KEY_ORIGIN: + call wft_encodec ("ORIGIN", "KPNO-IRAF", LEN_ORIGIN, card, "") + case KEY_DATE: + call wft_encode_date (datestr, LEN_DATE) + len_object = max (min (LEN_OBJECT, strlen (datestr)), LEN_STRING) + call wft_encodec ("DATE", datestr, len_object, card, "") + case KEY_IRAFNAME: + len_object = max (min (LEN_OBJECT, strlen (IRAFNAME(fits))), + LEN_STRING) + call wft_encodec ("IRAFNAME", IRAFNAME(fits), len_object, card, + "NAME OF IRAF IMAGE FILE") + case KEY_IRAFMAX: + if (NAXIS(im) <= 0) + stat = NO + else + call wft_encoder ("IRAF-MAX", IRAFMAX(fits), card, "DATA MAX", + NDEC_REAL) + case KEY_IRAFMIN: + if (NAXIS(im) <= 0) + stat = NO + else + call wft_encoder ("IRAF-MIN", IRAFMIN(fits), card, "DATA MIN", + NDEC_REAL) + case KEY_IRAFBP: + if (NAXIS(im) <= 0) + stat = NO + else + call wft_encodei ("IRAF-BPX", DATA_BITPIX(fits), card, + "DATA BITS/PIXEL") + case KEY_IRAFTYPE: + if (NAXIS(im) <= 0) + stat = NO + else + call wft_encodec ("IRAFTYPE", TYPE_STRING(fits), LEN_STRING, + card, "PIXEL TYPE") + default: + stat = NO + } + + optiono = optiono + 1 + + return (stat) +end + + +# WFT_HISTORY_CARD -- Procedure to fetch a single history line, trim newlines +# and pad with blanks to size LEN_CARD in order to create a FITS HISTORY card. + +int procedure wft_history_card (im, hp, card) + +pointer im # pointer to the IRAF image +int hp # pointer to first character to extract from string +char card[ARB] # FITS card image + +char cval +char chfetch() + +begin + if (chfetch (HISTORY(im), hp, cval) == EOS) + return (NO) + else { + hp = hp - 1 + call strcpy ("HISTORY ", card, LEN_KEYWORD) + call wft_fits_card (HISTORY(im), hp, card, COL_VALUE - 2, LEN_CARD, + '\n') + return (YES) + } +end + + +# WFT_UNKNOWN_CARD -- Procedure to fetch a single unknown +# "line", trim newlines and pad blanks to size LEN_CARD in order to +# create an unknown keyword card. At present user area information is +# assumed to be in the form of FITS card images, less then or equal to +# 80 characters and delimited by a newline. + +int procedure wft_unknown_card (im, up, card) + +pointer im # pointer to the IRAF image +int up # pointer to next character in the unknown string +char card[ARB] # FITS card image + +char cval +int stat, axis, index +char chfetch() +int strmatch(), ctoi() + +begin + if (chfetch (UNKNOWN(im), up, cval) == EOS) + return (NO) + else { + up = up - 1 + stat = NO + while (stat == NO) { + call wft_fits_card (UNKNOWN(im), up, card, 1, LEN_CARD, '\n') + if (card[1] == EOS) + break + if (strmatch (card, "^GROUPS ") != 0) { + stat = NO + } else if (strmatch (card, "^SIMPLE ") != 0) { + stat = NO + } else if (strmatch (card, "^BITPIX ") != 0) { + stat = NO + } else if (strmatch (card, "^NAXIS ") != 0) { + stat = NO + } else if (strmatch (card, "^NAXIS") != 0) { + index = LEN_NAXIS_KYWRD + 1 + if (ctoi (card, index, axis) > 0) + stat = NO + else + stat = YES + } else if (strmatch (card, "^GCOUNT ") != 0) { + stat = NO + } else if (strmatch (card, "^PCOUNT ") != 0) { + stat = NO + } else if (strmatch (card, "^PSIZE ") != 0) { + stat = NO + } else if (strmatch (card, "^BSCALE ") != 0) { + stat = NO + } else if (strmatch (card, "^BZERO ") != 0) { + stat = NO + } else if (strmatch (card, "^BLANK ") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-MAX") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-MIN") != 0) { + stat = NO + } else if (strmatch (card, "^IRAFTYPE") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-B/P") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-BPX") != 0) { + stat = NO + } else if (strmatch (card, "^FILENAME") != 0) { + stat = NO + } else if (strmatch (card, "^IRAFNAME") != 0) { + stat = NO + } else if (strmatch (card, "^EXTEND ") != 0) { + stat = NO + } else if (strmatch (card, "^EXTNAME ") != 0) { + stat = NO + } else if (strmatch (card, "^EXTVER ") != 0) { + stat = NO + } else if (strmatch (card, "^INHERIT ") != 0) { + stat = NO + } else if (strmatch (card, "^IRAF-TLM") != 0) { + stat = NO + } else if (strmatch (card, "^OBJECT ") != 0) { + stat = NO + } else if (strmatch (card, "^END ") != 0) { + stat = NO + } else + stat = YES + } + + return (stat) + } +end + + +# WFT_LAST_CARD -- Procedure to encode the FITS end card. + +int procedure wft_last_card (card) + +char card[ARB] # FITS card image + +begin + call sprintf (card, LEN_CARD, "%-8.8s %70w") + call pargstr ("END") + + return (YES) +end diff --git a/pkg/dataio/fits/fits_files.x b/pkg/dataio/fits/fits_files.x new file mode 100644 index 00000000..ce2c553c --- /dev/null +++ b/pkg/dataio/fits/fits_files.x @@ -0,0 +1,374 @@ +include <ctype.h> +include <plset.h> + +define DEF_MAXNCOLS 1000 +define DEF_MAXNLINES 4096 +define MAX_NRANGES 100 + + +# RFT_FLIST -- Decode a list of files and associated extensions into a pixel +# list. + +pointer procedure rft_flist (file_list, first_file, last_file, nfiles) + +char file_list[ARB] # the input file list string +int first_file # the first file in the list +int last_file # the last file in the list +int nfiles # the number of files in the list + +int i, j, maxncols, maxnlines, nrfiles, rp, rbegin, rend, rstep +int last_ext, ebegin, eend, estep, ep, nefiles +pointer sp, extensions, str, axes, pl + +bool pl_linenotempty() +int rft_gfranges() +pointer pl_create() + +begin + # Allocate some working space. + call smark (sp) + call salloc (extensions, SZ_LINE, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (axes, 2, TY_INT) + + # Initialize the file list. + pl = NULL + maxncols = DEF_MAXNCOLS + maxnlines = DEF_MAXNLINES + + repeat { + + # Initialize the file counter parameters. + first_file = INDEFI + last_file = INDEFI + nfiles = 0 + rp = 1 + + # Open the file list. + Memi[axes] = maxncols + Memi[axes+1] = maxnlines + pl = pl_create (2, Memi[axes], 1) + + # Decode the file list. + nrfiles = rft_gfranges (file_list, rp, YES, maxnlines, rbegin, + rend, rstep, NO, Memc[extensions]) + while (nrfiles > 0) { + + # Check the file number limits and terminate the loop if + # the current list size is exceeded. + if (IS_INDEFI(first_file)) + first_file = rbegin + else + first_file = min (rbegin, first_file) + if (IS_INDEFI(last_file)) + last_file = rend + else + last_file = max (last_file, rend) + if (last_file > maxnlines) + break + + # Initialize the extensions list decoding. + ep = 1 + last_ext = INDEFI + + # Decode the associated extensions files. If the extensions + # list is empty + nefiles = rft_gfranges (Memc[extensions], ep, YES, maxncols, + ebegin, eend, estep, YES, Memc[str]) + while (nefiles > 0) { + + # Check the extensions number limits and quit if they + # are exceeded. + if (IS_INDEFI(last_ext)) + last_ext = eend + else + last_ext = max (last_ext, eend) + if (last_ext > maxncols) + break + + # Set the appropriate elements in the list. + if (rstep == 1) { + if (estep == 1) + call pl_box (pl, ebegin, rbegin, eend, + rend, PIX_SET + PIX_VALUE(1)) + else { + do i = ebegin, eend, estep + call pl_box (pl, i, rbegin, i, rend, + PIX_SET + PIX_VALUE(1)) + } + } else { + do i = rbegin, rend, rstep { + do j = ebegin, eend, estep + call pl_point (pl, j, i, PIX_SET + + PIX_VALUE(1)) + } + } + + nefiles = rft_gfranges (Memc[extensions], ep, NO, maxncols, + ebegin, eend, estep, YES, Memc[str]) + } + + # Break if an extensions list decode error occurs. + if (nefiles == 0) + break + + nrfiles = rft_gfranges (file_list, rp, NO, maxnlines, rbegin, + rend, rstep, NO, Memc[extensions]) + } + + # Break if a file or extensions list decode error ocurred. + if (nrfiles == 0 || nefiles == 0) + break + + # If the file or extensions list is larger than the current maximum + # then free the list increase the default space and repeat the + # procedure. + + if (!IS_INDEFI(last_file)) { + if (last_file > maxnlines) { + if (pl != NULL) + call pl_close (pl) + pl = NULL + maxnlines = maxnlines + DEF_MAXNLINES + } else { + do i = first_file, last_file { + Memi[axes] = 1 + Memi[axes+1] = i + if (pl_linenotempty (pl, Memi[axes])) + nfiles = nfiles + 1 + } + } + } + + if (!IS_INDEFI(last_ext)) { + if (last_ext > maxncols) { + if (pl != NULL) + call pl_close (pl) + pl = NULL + maxncols = maxncols + DEF_MAXNCOLS + } + } + + } until (pl != NULL) + + # Free space. + call sfree (sp) + + # If the file list is empty or a decode error occurred return + # a NULL list, otherwise return the pointer to the list. + + if (nfiles <= 0 || nrfiles == 0 || nefiles == 0) { + nfiles = 0 + first_file = INDEFI + last_file = INDEFI + call pl_close (pl) + return (NULL) + } else + return (pl) +end + + +# RFT_GFRANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Each range may have an +# associated extensions lists delimited by square brackets. Return as output +# each range in sequence. Range limits must be positive nonnegative integers. +# EOF is returned if the end of the file_list is reached. 0 is returned if a +# conversion error takes place. Otherwise the number of elements in the +# range is returned. + +int procedure rft_gfranges (range_string, ip, firstr, rmax, rbegin, rend, + rstep, zeroindex, extensions) + +char range_string[ARB] # range string to be decoded +int ip # the range string pointer +int firstr # first range to be returned +int rmax # the maximum file number +int rbegin # the begining of the range +int rend # the end of the range +int rstep # the range step size +int zeroindex # allow zero indexing ? +char extensions[ARB] # the output extensions string + +int ep, itemp +int ctoi() + +begin + # Initialize. + if (zeroindex == YES) { + rbegin = 0 + rend = rmax - 1 + } else { + rbegin = 1 + rend = rmax + } + rstep = 1 + extensions[1] = EOS + + # Return default range if the range string is NULL. + if (range_string[ip] == EOS) { + rbegin = 1 + rend = rmax + if (firstr == YES) + return (rend) + else + return (EOF) + } + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', *, or EOS. + if (range_string[ip] == EOS) { # end of list + rbegin = 1 + rend = rmax + if (firstr == YES) + return (rend) + else + return (EOF) + } else if (range_string[ip] == '*') { + ; + } else if (range_string[ip] == '-') { + ; + } else if (range_string[ip] == 'x') { + ; + } else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, rbegin) == 0) + return (0) + else if (zeroindex == NO) { + if (rbegin <= 0) + return (0) + } else { + if (rbegin < 0) + return (0) + } + } else + return (0) + + # Extract extensions file list. + if (range_string[ip] == '[') { + ip = ip + 1 + ep = 1 + while (range_string[ip] != EOS) { + if (range_string[ip] == ']') { + ip = ip + 1 + break + } + extensions[ep] = range_string[ip] + ip = ip + 1 + ep = ep + 1 + } + extensions[ep] = EOS + if (range_string[ip-1] != ']') + return (0) + } + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', 'x', or '*' otherwise last = first. + if (range_string[ip] == '*') + ; + else if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, rend) == 0) + return (0) + else if (zeroindex == NO) { + if (rend <= 0) + return (0) + } else { + if (rend < 0) + return (0) + } + } else if (range_string[ip] == 'x') + ; + else + return (0) + } else + rend = rbegin + + # Skip extensions files for now. + if (range_string[ip] == '[') { + ip = ip + 1 + ep = 1 + while (range_string[ip] != EOS) { + if (range_string[ip] == ']') { + ip = ip + 1 + break + } + extensions[ep] = range_string[ip] + ip = ip + 1 + ep = ep + 1 + } + extensions[ep] = EOS + if (range_string[ip-1] != ']') + return (0) + } + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == '*') + ip = ip + 1 + else if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, rstep) == 0) + ; + else if (rstep <= 0) + return (0) + } else if (range_string[ip] == '-') + ; + else + return (0) + } + + # Skip extensions files for now. + if (range_string[ip] == '[') { + ip = ip + 1 + ep = 1 + while (range_string[ip] != EOS) { + if (range_string[ip] == ']') { + ip = ip + 1 + break + } + extensions[ep] = range_string[ip] + ip = ip + 1 + ep = ep + 1 + } + extensions[ep] = EOS + if (range_string[ip-1] != ']') + return (0) + } + + # Output the range triple. + if (rend < rbegin) { + itemp = rbegin + rbegin = rend + rend = itemp + } + if (zeroindex == YES) { + rbegin = rbegin + 1 + rend = rend + 1 + } + return (abs (rend - rbegin) / rstep + 1 ) +end + + diff --git a/pkg/dataio/fits/fits_params.x b/pkg/dataio/fits/fits_params.x new file mode 100644 index 00000000..6911a925 --- /dev/null +++ b/pkg/dataio/fits/fits_params.x @@ -0,0 +1,248 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <time.h> +include "wfits.h" + +# WFT_ENCODEB -- Procedure to encode a boolean parameter into a FITS card. + +procedure wft_encodeb (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter equal to YES/NO +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +char truth + +begin + if (param == YES) + truth = 'T' + else + truth = 'F' + + call sprintf (card, LEN_CARD, "%-8.8s= %20c / %-45.45s") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# WFT_ENCODEI -- Procedure to encode an integer parameter into a FITS card. + +procedure wft_encodei (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +int param # integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-45.45s") + call pargstr (keyword) + call pargi (param) + call pargstr (comment) +end + + +# WFT_ENCODEL -- Procedure to encode a long parameter into a FITS card. + +procedure wft_encodel (keyword, param, card, comment) + +char keyword[ARB] # FITS keyword +long param # long integer parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20d / %-45.45s") + call pargstr (keyword) + call pargl (param) + call pargstr (comment) +end + + +# WFT_ENCODER -- Procedure to encode a real parameter into a FITS card. + +procedure wft_encoder (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +real param # real parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment card +int precision # precision of real + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-45.45s") + call pargstr (keyword) + call pargi (precision) + call pargr (param) + call pargstr (comment) +end + + +# WFT_ENCODED -- Procedure to encode a double parameter into a FITS card. + +procedure wft_encoded (keyword, param, card, comment, precision) + +char keyword[ARB] # FITS keyword +double param # double parameter +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string +int precision # FITS precision + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.*e / %-45.45s") + call pargstr (keyword) + call pargi (precision) + call pargd (param) + call pargstr (comment) +end + + +# WFT_ENCODE_AXIS -- Procedure to add the axis number to axis dependent +# keywords. + +procedure wft_encode_axis (root, keyword, axisno) + +char root[ARB] # FITS root keyword +char keyword[ARB] # FITS keyword +int axisno # FITS axis number + +begin + call strcpy (root, keyword, LEN_KEYWORD) + call sprintf (keyword, LEN_KEYWORD, "%-5.5s%-3.3s") + call pargstr (root) + call pargi (axisno) +end + + +# WFT_ENCODEC -- Procedure to encode an IRAF string parameter into a FITS card. + +procedure wft_encodec (keyword, param, maxch, card, comment) + +char keyword[ARB] # FITS keyword +char param[ARB] # FITS string parameter +int maxch # maximum number of characters in string parameter +char card[ARB] # FITS card image +char comment[ARB] # comment string + +char strparam[LEN_ALIGN+2] +int maxchar, nblanks + +begin + maxchar = min (maxch, LEN_OBJECT) + if (maxchar <= LEN_ALIGN - 1) { + strparam[1] = '\'' + call sprintf (strparam[2], maxchar, "%*.*s") + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + strparam[maxchar+2] = '\'' + strparam[maxchar+3] = EOS + call sprintf (card, LEN_CARD, "%-8.8s= %-20.20s / %-45.45s") + call pargstr (keyword) + call pargstr (strparam) + call pargstr (comment) + } else { + nblanks = LEN_OBJECT - maxchar + if (comment[1] == EOS) + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' %*.*s") + else + call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' / %*.*s") + call pargstr (keyword) + call pargi (-maxchar) + call pargi (maxchar) + call pargstr (param) + call pargi (-nblanks) + call pargi (nblanks) + call pargstr (comment) + } +end + + +# WFT_ENCODE_BLANK -- Procedure to encode the FITS blank parameter. Necessary +# because the 32 bit blank value equals INDEFL. + +procedure wft_encode_blank (keyword, blank_str, card, comment) + +char keyword[ARB] # FITS keyword +char blank_str[ARB] # string containing values of FITS blank integer +char card[ARB] # FITS card image +char comment[ARB] # FITS comment string + +begin + call sprintf (card, LEN_CARD, "%-8.8s= %20.20s / %-45.45s") + call pargstr (keyword) + call pargstr (blank_str) + call pargstr (comment) +end + + +# WFT_ENCODE_DATE -- Procedure to encode the date in the form dd-mm-yy. + +procedure wft_encode_date (datestr, szdate) + +char datestr[ARB] # string containing the date +int szdate # number of chars in the date string + +long ctime +int time[LEN_TMSTRUCT] +long clktime(), lsttogmt() + +begin + ctime = clktime (long (0)) + ctime = lsttogmt (ctime) + call brktime (ctime, time) + + if (TM_YEAR(time) >= NEW_CENTURY) { + call sprintf (datestr, szdate, "%04d-%02d-%02dT%02d:%02d:%02d") + call pargi (TM_YEAR(time)) + call pargi (TM_MONTH(time)) + call pargi (TM_MDAY(time)) + call pargi (TM_HOUR(time)) + call pargi (TM_MIN(time)) + call pargi (TM_SEC(time)) + } else { + call sprintf (datestr, szdate, "%02d-%02d-%02d") + call pargi (TM_MDAY(time)) + call pargi (TM_MONTH(time)) + call pargi (mod (TM_YEAR(time), CENTURY)) + } +end + + +# WFT_FITS_CARD -- Procedure to fetch a single line from a string parameter +# padding it to a maximum of maxcols characters and trimmimg the delim +# character. + +procedure wft_fits_card (instr, ip, card, col_out, maxcols, delim) + +char instr[ARB] # input string +int ip # input string pointer, updated at each call +char card[ARB] # FITS card image +int col_out # pointer to column in card +int maxcols # maximum columns in card +int delim # 1 character string delimiter + +int op + +begin + op = col_out + + # Copy string + while (op <= maxcols && instr[ip] != EOS && instr[ip] != delim) { + card[op] = instr[ip] + ip = ip + 1 + op = op + 1 + } + + # Fill remainder of card with blanks + while (op <= maxcols ) { + card[op] = ' ' + op = op + 1 + } + + if (instr[ip] == delim) + ip = ip + 1 + +end diff --git a/pkg/dataio/fits/fits_read.x b/pkg/dataio/fits/fits_read.x new file mode 100644 index 00000000..f9b0e46c --- /dev/null +++ b/pkg/dataio/fits/fits_read.x @@ -0,0 +1,469 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <error.h> +include <imhdr.h> +include <fset.h> +include <plset.h> +include "rfits.h" + +define MAX_RANGES 100 # the maximum number of ranges + +# RFT_READ_FITZ -- Convert a FITS file. An EOT is signalled by returning EOF. + +int procedure rft_read_fitz (fitsfile, iraffile, pl, file_number) + +char fitsfile[ARB] # FITS file name +char iraffile[ARB] # root IRAF file name +pointer pl # pointer to the file/extensions list +int file_number # the current file number + +bool strne() +int fits_fd, stat, min_lenuserarea, ip, len_elist, oshort_header +int olong_header, ext_count, ext_number, max_extensions, naxes +pointer im, gim, sp, fits, axes, extensions, imname, gimname, gfname, str +pointer himname +int rft_read_header(), mtopen(), immap(), strlen(), envfind(), ctoi() +int rft_ext_skip() +real asumi() +errchk smark, sfree, salloc, rft_read_header, rft_read_image, rft_find_eof() +errchk rft_scan_file, mtopen, immap, imdelete, close, imunmap + +include "rfits.com" + +begin + # Open input FITS data. + fits_fd = mtopen (fitsfile, READ_ONLY, 0) + + # Allocate memory for the FITS data structure and initialize the file + # dependent components of that structure. + call smark (sp) + call salloc (fits, LEN_FITS, TY_STRUCT) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (himname, SZ_FNAME, TY_CHAR) + call salloc (gimname, SZ_FNAME, TY_CHAR) + call salloc (gfname, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Initialize. + SIMPLE(fits) = NO + EXTEND(fits) = NO + GLOBALHDR(fits) = NO + gim = NULL + Memc[gfname] = EOS + + # Determine the length of the user area. + if (envfind ("min_lenuserarea", Memc[imname], SZ_FNAME) > 0) { + ip = 1 + if (ctoi (Memc[imname], ip, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Store the current values of the header printing options. + olong_header = long_header + oshort_header = short_header + + # Get the extensions list for a given line and count the number of + # extensions files. + call salloc (axes, 2, TY_INT) + call pl_gsize (pl, naxes, Memi[axes], stat) + max_extensions = Memi[axes+1] + call salloc (extensions, max_extensions, TY_INT) + Memi[axes] = 1 + Memi[axes+1] = file_number + call pl_glpi (pl, Memi[axes], Memi[extensions], 1, max_extensions, + PIX_SRC) + len_elist = nint (asumi (Memi[extensions], max_extensions)) + + # Loop over the extensions. + ext_count = 1; stat = BOF + do ext_number = 1, max_extensions { + + if (stat == EOF) + break + if (Memi[extensions+ext_number-1] == 0) + next + + # Locate the next extension to be read. + while (ext_count <= ext_number) { + + # Create the IRAF image header. If only a header listing is + # desired or the image extension is to be skipped then map + # the scratch image onto DEV$NULL (faster than a real file). + # If more than one extension is to be read then append the + # extension number to the input name. + + if (make_image == NO || ext_count != ext_number) { + call strcpy ("dev$null", Memc[imname], SZ_FNAME) + } else if (len_elist > 1 && ext_count == ext_number) { + call sprintf (Memc[imname], SZ_FNAME, "%s%04d") + call pargstr (iraffile) + call pargi (ext_number - 1) + } else + call strcpy (iraffile, Memc[imname], SZ_FNAME) + im = immap (Memc[imname], NEW_IMAGE, min_lenuserarea) + call strcpy (IM_HDRFILE(im), Memc[himname], SZ_FNAME) + + # Skip any extensions the user does not want. In order to do + # this we must read the header to see how big the data array + # to be skipped is. + if (ext_count != ext_number) { + + # Turn off header printing. + long_header = NO + short_header = NO + + # Decode the header and skip the data. + iferr { + stat = rft_read_header (fits_fd, fits, im, gim) + if (stat != EOF) + stat = rft_ext_skip (fits_fd, fits, im) + if (stat == EOF) { + if (ext_count == 1) { + call printf ("File: %s\n") + call pargstr (fitsfile) + } else if (asumi(Memi[extensions], + ext_count - 1) < 1.0) { + call printf ("File: %s\n") + call pargstr (fitsfile) + } + if (ext_count > 1) { + call printf ("Extension: %d End of data\n") + call pargi (ext_count - 1) + } else + call printf (" End of data\n") + } else if (EXTEND(fits) == NO) { + call printf ("File: %s\n") + call pargstr (fitsfile) + call printf ("Extension: 1 End of data\n") + } + } then { + call flush (STDOUT) + call erract (EA_WARN) + } + + # Restore the default header printing values. + long_header = olong_header + short_header = oshort_header + + # Read the extension the user specified. If the extension + # is not the primary data or IMAGE skip the data and + # continue. + } else { + + # Set up for printing a long or a short header. + if (long_header == YES || short_header == YES) { + if (long_header == YES) { + if (ext_number == 1) { + if (make_image == YES) { + call printf ("File: %s Image: %s") + call pargstr (fitsfile) + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + } else { + call printf ("File: %s") + call pargstr (fitsfile) + } + } else if (asumi (Memi[extensions], + ext_number -1) < 1.0) { + if (make_image == YES) { + call printf ( + "File: %s\nExtension: %d Image: %s") + call pargstr (fitsfile) + call pargi (ext_number - 1) + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + } else { + call printf ("File: %s Extension: %d") + call pargstr (fitsfile) + call pargi (ext_number - 1) + } + } else { + if (make_image == YES) { + call printf ("Extension: %d Image: %s") + call pargi (ext_number - 1) + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + } else { + call printf ("File: %s Extension: %d") + call pargstr (fitsfile) + call pargi (ext_number - 1) + } + } + } else { + if (ext_number == 1) { + call printf ("File: %s ") + call pargstr (fitsfile) + } else if (asumi (Memi[extensions], + ext_number - 1) < 1.0) { + call printf ("File: %s\nExtension: %d ") + call pargstr (fitsfile) + call pargi (ext_number - 1) + } else { + call printf ("Extension: %d ") + call pargi (ext_number - 1) + } + } + if (long_header == YES) + call printf ("\n") + } + call flush (STDOUT) + + # Read header. EOT is signalled by an EOF status from + # fits_read_header. Create an IRAF image if desired. + + iferr { + stat = rft_read_header (fits_fd, fits, im, gim) + if (stat == EOF) { + call printf ("End of data\n") + } else if (make_image == YES) { + if (XTENSION(fits) == EXT_PRIMARY || + XTENSION(fits) == EXT_IMAGE) { + call rft_read_image (fits_fd, fits, im) + } else if (EXTEND(fits) == YES) { + stat = rft_ext_skip (fits_fd, fits, im) + if (stat == EOF) + call printf ("End of data\n") + } else if (EXTEND(fits) == NO && fe > 0.0) { + call rft_find_eof (fits_fd) + } + } else { + if (EXTEND(fits) == YES) { + stat = rft_ext_skip (fits_fd, fits, im) + if (stat == EOF) + call printf ("End of data\n") + } else if (EXTEND(fits) == NO && fe > 0.0) + call rft_scan_file (fits_fd, fits, im, fe) + } + } then { + call flush (STDOUT) + call erract (EA_WARN) + } + } + + + # Deal with the global header issue. Save the global header + # file name for possible future use. + if (GLOBALHDR(fits) == YES) { + if (gim == NULL && XTENSION(fits) == EXT_PRIMARY) { + call mktemp ("tmp$", Memc[gimname], SZ_FNAME) + gim = immap (Memc[gimname], NEW_COPY, im) + call strcpy (IRAFNAME(fits), Memc[gfname], SZ_FNAME) + } else if (IRAFNAME(fits) == EOS) + call strcpy (Memc[gfname], IRAFNAME(fits), SZ_FNAME) + + } + + # Close the output image. + call imunmap (im) + + # Optionally restore the old IRAF name. + if (stat == EOF) { + call imdelete (Memc[imname]) + break + } else if (make_image == NO || ext_number != ext_count) { + call imdelete (Memc[imname]) + } else if (XTENSION(fits) != EXT_PRIMARY && XTENSION(fits) != + EXT_IMAGE) { + call imdelete (Memc[imname]) + if (XTENSION(fits) != EXT_SPECIAL && ext_count == + ext_number) + call printf (" Skipping non-image data\n") + } else if (old_name == YES && strlen (IRAFNAME(fits)) != 0) { + iferr { + call imgimage (IRAFNAME(fits), IRAFNAME(fits), SZ_FNAME) + call imrename (Memc[imname], IRAFNAME(fits)) + } then { + if (len_elist > 1) { + call sprintf (Memc[str], SZ_FNAME, ".%d") + call pargi (ext_number - 1) + call strcat (Memc[str], IRAFNAME(fits), SZ_FNAME) + iferr (call imrename (Memc[imname], + IRAFNAME(fits))) { + call printf ( + " Cannot rename image %s to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (IRAFNAME(fits)) + call flush (STDOUT) + call erract (EA_WARN) + } else { + call printf (" Image %s renamed to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (IRAFNAME(fits)) + } + } else { + call printf (" Cannot rename image %s to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (IRAFNAME(fits)) + call flush (STDOUT) + call erract (EA_WARN) + } + } else { + call printf (" Image %s renamed to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (IRAFNAME(fits)) + } + } else if (EXTEND(fits) == NO && strne (Memc[imname], + iraffile)) { + iferr { + call imrename (Memc[imname], iraffile) + } then { + call printf (" Cannot rename image %s to %s\n") + #call pargstr (Memc[imname]) + call pargstr (Memc[himname]) + call pargstr (iraffile) + call flush (STDOUT) + call erract (EA_WARN) + } else { + call printf ( + " No FITS extensions Image renamed to %s\n") + #call pargstr (Memc[imname]) + call pargstr (iraffile) + } + } + + if (EXTEND(fits) == YES && XTENSION(fits) == EXT_PRIMARY && + len_elist == 1 && ext_number == 1) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ( + "Warning: FITS extensions may be present\n") + } + } + if (long_header == YES) + call printf ("\n") + + ext_count = ext_count + 1 + if (EXTEND(fits) == NO || XTENSION(fits) == EXT_SPECIAL) + break + } + + if (EXTEND(fits) == NO || XTENSION(fits) == EXT_SPECIAL) + break + } + + if (gim != NULL) { + call imunmap (gim) + call imdelete (Memc[gimname]) + } + call close (fits_fd) + call sfree (sp) + + if (ext_count == 1) + return (EOF) + else + return (OK) +end + + +# RFT_FIND_EOF -- Read the FITS data file until EOF is reached. + +procedure rft_find_eof (fd) + +int fd # the FITS file descriptor + +int szbuf +pointer sp, buf +int fstati(), read() +errchk read + +begin + # Scan through the file. + szbuf = fstati (fd, F_BUFSIZE) + call smark (sp) + call salloc (buf, szbuf, TY_CHAR) + while (read (fd, Memc[buf], szbuf) != EOF) + ; + call sfree (sp) +end + + +# RFT_SCAN_FILE -- Determine whether it is more efficient to read the +# entire file or to skip forward to the next file if the parameter +# make_image was set to no. + +procedure rft_scan_file (fd, fits, im, fe) + +int fd # the FITS file descriptor +pointer fits # pointer to the FITS descriptor +pointer im # pointer to the output image +real fe # maximum file size in Kb for scan mode + +int i, szbuf +pointer sp, buf +real file_size +int fstati(), read() +errchk read + +begin + # Compute the file size in Kb and return if it is bigger than fe. + file_size = 1.0 + do i = 1, IM_NDIM(im) + file_size = file_size * IM_LEN(im,i) + if (IM_NDIM(im) <= 0) + file_size = 0.0 + else + file_size = file_size * abs (BITPIX(fits)) / FITS_BYTE / 1.0e3 + if (file_size >= fe) + return + + # Scan through the file. + szbuf = fstati (fd, F_BUFSIZE) + call smark (sp) + call salloc (buf, szbuf, TY_CHAR) + while (read (fd, Memc[buf], szbuf) != EOF) + ; + call sfree (sp) +end + + +# RFT_EXT_SKIP -- Compute the size of the data extension to be skipped +# and do the skipping. + +int procedure rft_ext_skip (fits_fd, fits, im) + +int fits_fd # fits file descriptor +pointer fits # pointer to the fits structure +pointer im # pointer to the output image + +int i, nbits, nblocks, sz_rec, blksize, stat +pointer buf +int fstati(), rft_getbuf() + +begin + # Compute the number of blocks to skip. + nbits = NAXISN(im,1) + do i = 2, NAXIS(im) + nbits = nbits * NAXISN(im,i) + nbits = nbits + PCOUNT(fits) + nbits = abs (BITPIX(fits)) * GCOUNT(fits) * nbits + nblocks = int ((nbits + 23039) / 23040) + + sz_rec = FITS_RECORD / SZB_CHAR + call malloc (buf, sz_rec, TY_CHAR) + blksize = fstati (fits_fd, F_SZBBLK) + if (mod (blksize, FITS_RECORD) == 0) + blksize = blksize / FITS_RECORD + else + blksize = 1 + + # Skip the blocks. + do i = 1, nblocks { + stat = rft_getbuf (fits_fd, Memc[buf], sz_rec, blksize, + NRECORDS(fits)) + if (stat == EOF) + break + } + + call mfree (buf, TY_CHAR) + + return (stat) +end diff --git a/pkg/dataio/fits/fits_rheader.x b/pkg/dataio/fits/fits_rheader.x new file mode 100644 index 00000000..e15a3559 --- /dev/null +++ b/pkg/dataio/fits/fits_rheader.x @@ -0,0 +1,888 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <imhdr.h> +include <imio.h> +include <mach.h> +include "rfits.h" + +define NEPSILON 10.0d0 # number of machine epsilon + +# RFT_READ_HEADER -- Read a FITS header. +# If BSCALE and BZERO are different from 1.0 and 0.0 scale is set to true +# otherwise scale is false. +# EOT is detected by an EOF on the first read and EOF is returned to the calling +# routine. Any error is passed to the calling routine. + +int procedure rft_read_header (fits_fd, fits, im, gim) + +int fits_fd # FITS file descriptor +pointer fits # FITS data structure +pointer im # IRAF image descriptor +pointer gim # IRAF global header image descriptor + +int i, stat, nread, max_lenuser, fd_usr, ndiscard +char card[LEN_CARD+1], type_str[LEN_TYPESTR] +int rft_decode_card(), rft_init_read_pixels(), rft_read_pixels(), strmatch() +int stropen() +errchk rft_decode_card, rft_init_read_pixels, rft_read_pixels +errchk stropen, close + +include "rfits.com" + +begin + # Initialization. + XTENSION(fits) = EXT_PRIMARY + BITPIX(fits) = INDEFI + NAXIS(im) = 0 + do i = 1, IM_MAXDIM + IM_LEN(im,i) = 0 + PCOUNT(fits) = 0 + GCOUNT(fits) = 1 + SCALE(fits) = NO + FITS_BSCALE(fits) = 1.0d0 + FITS_BZERO(fits) = 0.0d0 + BLANKS(fits) = NO + BLANK_VALUE(fits) = INDEFL + NRECORDS(fits) = 0 + IRAFNAME(fits) = EOS + INHERIT(fits) = NO + ndiscard = 0 + OBJECT(im) = EOS + UNKNOWN(im) = EOS + max_lenuser = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + + # The FITS header is character data in FITS_BYTE form. Open the + # header for reading. Open the user area which is a character + # string as a file. + + i = rft_init_read_pixels (len_record, FITS_BYTE, LSBF, TY_CHAR) + fd_usr = stropen (UNKNOWN(im), max_lenuser, NEW_FILE) + + # Loop until the END card is encountered. + nread = 0 + repeat { + + # Read the card. + i = rft_read_pixels (fits_fd, card, LEN_CARD, NRECORDS(fits), 1) + card[LEN_CARD + 1] = '\n' + card[LEN_CARD + 2] = EOS + + # Decode the card images. + if ((i == EOF) && (nread == 0)) { + call close (fd_usr) + return (EOF) + } else if ((nread == 0) && SIMPLE(fits) == NO && + strmatch (card, "^SIMPLE ") == 0) { + call flush (STDOUT) + call close (fd_usr) + call error (30, + "RFT_READ_HEADER: Not a FITS file (no SIMPLE keyword)") + } else if ((nread == 0) && EXTEND(fits) == YES && + strmatch (card, "^XTENSION") == 0) { + XTENSION(fits) = EXT_SPECIAL + call flush (STDOUT) + call close (fd_usr) + call error (30, + "RFT_READ_HEADER: Not a FITS extension (no XTENSION keyword)") + } else if (i != LEN_CARD) { + call close (fd_usr) + call error (2, "RFT_READ_HEADER: Error reading FITS header") + } else + nread = nread + 1 + + # Remove contaminating control characters and replace with blanks. + call rft_control_to_blank (card, card, LEN_CARD) + + # Print FITS card images if long_header option specified. + if (long_header == YES) { + call printf ("%-80.80s\n") + call pargstr (card) + } + + # Stat = YES if FITS END card is encountered. + stat = rft_decode_card (fits, im, fd_usr, card, ndiscard) + + } until (stat == YES) + + # Check for the possibility of a global header. + if (NAXIS(im) == 0 && XTENSION(fits) == EXT_PRIMARY) + GLOBALHDR(fits) = YES + + # Set the output image pixel type. + call rft_set_image_pixtype (fits, im, FITS_BSCALE(fits), + FITS_BZERO(fits)) + + # Copy the global header title and user area into the output image. + if (GLOBALHDR(fits) == YES) { + if (XTENSION(fits) == EXT_IMAGE && INHERIT(fits) == YES && + gim != NULL) { + if (OBJECT(im) == EOS) + call strcpy (OBJECT(gim), OBJECT(im), SZ_OBJECT) + call close (fd_usr) + fd_usr = stropen (UNKNOWN(im), max_lenuser, APPEND) + call rft_gheader (im, gim, fd_usr, card, LEN_CARD, ndiscard, + long_header) + } + } + + # Print optional short header. + if (short_header == YES && long_header == NO) { + call printf ("%s ") + switch (XTENSION(fits)) { + case EXT_PRIMARY: + call pargstr ("") + case EXT_IMAGE: + call pargstr ("IMAGE") + case EXT_TABLE: + call pargstr ("TABLE") + case EXT_BINTABLE: + call pargstr ("BINTABLE") + case EXT_UNKNOWN: + call pargstr ("UNKNOWN") + default: + call pargstr ("UNDEFINED") + } + if (make_image == NO) { + if (old_name == YES) { + call printf ("-> %s ") + call pargstr (IRAFNAME(fits)) + } + } else { + call printf ("-> %s ") + call pargstr (IM_HDRFILE(im)) + } + call printf ("%-20.20s ") + call pargstr (OBJECT(im)) + call printf ("size=") + if (NAXIS(im) == 0) + call printf ("0") + else { + do i = 1, NAXIS(im) { + if (i == 1) { + call printf ("%d") + call pargl (NAXISN(im,i)) + } else { + call printf ("x%d") + call pargl (NAXISN(im,i)) + } + } + } + call printf ("\n") + if (XTENSION(fits) == EXT_PRIMARY || XTENSION(fits) == EXT_IMAGE) { + call printf (" bitpix=%d") + call pargi (BITPIX(fits)) + if (SCALE(fits) == NO) { + call printf (" scaling=none") + } else { + call printf (" bscale=%.7g bzero=%.7g") + call pargd (FITS_BSCALE(fits)) + call pargd (FITS_BZERO(fits)) + } + call rft_typestring (PIXTYPE(im), type_str, LEN_TYPESTR) + call strlwr (type_str) + call printf (" pixtype=%s") + call pargstr (type_str) + call printf ("\n") + } + } + + # Let the user know if there is not enough space in the user area. + if (ndiscard > 0) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ( + "Warning: User area too small %d card images discarded\n") + call pargi (ndiscard) + } + call rft_last_user (UNKNOWN(im), max_lenuser) + } + + call close (fd_usr) + return (OK) +end + + +# RFT_CONTROL_TO_BLANK -- Replace an ACSII control characters in the +# FITS card image with blanks. + +procedure rft_control_to_blank (incard, outcard, len_card) + +char incard[ARB] # the input FITS card image +char outcard[ARB] # the output FITS card image +int len_card # the length of the FITS card image + +int i + +begin + for (i = 1; i <= len_card; i = i + 1) { + if (IS_PRINT(incard[i])) + outcard[i] = incard[i] + else + outcard[i] = ' ' + } +end + + +# RFT_DECODE_CARD -- Decode a FITS card and return YES when the END +# card is encountered. The keywords understood are given in rfits.h. + +int procedure rft_decode_card (fits, im, fd_usr, card, ndiscard) + +pointer fits # FITS data structure +pointer im # IRAF image descriptor +int fd_usr # file descriptor of user area +char card[ARB] # FITS card +int ndiscard # Number of cards for which no space available + +char cval +double dval +int nchar, i, j, k, len +pointer sp, str, comment + +bool rft_equald() +int strmatch(), ctoi(), ctol(), ctod(), cctoc(), rft_hms() +errchk putline + +include "rfits.com" + +begin + call smark (sp) + call salloc (str, LEN_CARD, TY_CHAR) + call salloc (comment, SZ_LINE, TY_CHAR) + + i = COL_VALUE + if (strmatch (card, "^END ") != 0) { + call sfree (sp) + return(YES) + } else if (strmatch (card, "^SIMPLE ") != 0) { + if (SIMPLE(fits) == YES) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate SIMPLE keyword ignored\n") + } + } else { + nchar = cctoc (card, i, cval) + if (cval != 'T') + call error (13, "RFT_DECODE_CARD: Non-standard FITS format") + else + SIMPLE(fits) = YES + } + } else if (strmatch (card, "^XTENSION") != 0) { + call rft_get_fits_string (card, Memc[str], LEN_CARD) + if (strmatch (Memc[str], "^IMAGE") != 0) + XTENSION(fits) = EXT_IMAGE + else if (strmatch (Memc[str], "^TABLE") != 0) + XTENSION(fits) = EXT_TABLE + else if (strmatch (Memc[str], "^BINTABLE") != 0) + XTENSION(fits) = EXT_BINTABLE + else + XTENSION(fits) = EXT_UNKNOWN + } else if (strmatch (card, "^BITPIX ") != 0) { + if (! IS_INDEFI(BITPIX(fits))) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate BITPIX keyword ignored\n") + } + } else + nchar = ctoi (card, i, BITPIX(fits)) + } else if (strmatch (card, "^NAXIS ") != 0) { + if (NAXIS(im) != 0) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate NAXIS keyword ignored\n") + } + } else + nchar = ctoi (card, i, NAXIS(im)) + if (NAXIS(im) > IM_MAXDIM) + call error (5, "RFT_DECODE_CARD: FITS NAXIS too large") + } else if (strmatch (card, "^NAXIS") != 0) { + k = strmatch (card, "^NAXIS") + nchar = ctoi (card, k, j) + if (NAXISN(im,j) != 0) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate NAXIS%d keyword ignored\n") + call pargi (j) + } + } else + nchar = ctol (card, i, NAXISN(im, j)) + } else if (strmatch (card, "^GROUPS ") != 0) { + nchar = cctoc (card, i, cval) + if (cval == 'T') { + NAXIS(im) = 0 + call error (6, "RFT_DECODE_CARD: Group data not implemented") + } + } else if (strmatch (card, "^EXTEND ") != 0) { + if (EXTEND(fits) == YES) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate EXTEND keyword ignored\n") + } + } else { + nchar = cctoc (card, i, cval) + if (cval == 'T') + EXTEND(fits) = YES + } + } else if (strmatch (card, "^INHERIT ") != 0) { + if (INHERIT(fits) == YES) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Duplicate INHERIT keyword ignored\n") + } + } else { + nchar = cctoc (card, i, cval) + if (cval == 'T') + INHERIT(fits) = YES + } + } else if (strmatch (card, "^PCOUNT ") != 0) { + nchar = ctoi (card, i, PCOUNT(fits)) + if (nchar <= 0) + PCOUNT(fits) = 0 + } else if (strmatch (card, "^GCOUNT ") != 0) { + nchar = ctoi (card, i, GCOUNT(fits)) + if (nchar <= 0) + GCOUNT(fits) = 1 + #} else if (strmatch (card, "^TABLES ") != 0) { + #nchar = ctoi (card, i, ival) + #if (ival > 0) + #call printf ("Warning: FITS special records not decoded\n") + } else if (strmatch (card, "^BSCALE ") != 0) { + nchar = ctod (card, i, dval) + if (nchar > 0) + FITS_BSCALE(fits) = dval + else if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Error decoding BSCALE, BSCALE=1.0\n") + } + if (! rft_equald (dval, 1.0d0) && (scale == YES)) + SCALE(fits) = YES + } else if (strmatch (card, "^BZERO ") != 0) { + nchar = ctod (card, i, dval) + if (nchar > 0) + FITS_BZERO(fits) = dval + else if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: Error decoding BZERO, BZERO=0.0\n") + } + if (! rft_equald (dval, 0.0d0) && (scale == YES)) + SCALE(fits) = YES + } else if (strmatch (card, "^BLANK ") != 0) { + BLANKS(fits) = YES + nchar = ctol (card, i, BLANK_VALUE(fits)) + } else if (strmatch (card, "^OBJECT ") != 0) { + call rft_get_fits_string (card, OBJECT(im), SZ_OBJECT) + } else if (strmatch (card, "^IRAFNAME") != 0) { + call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) + } else if (strmatch (card, "^FILENAME") != 0) { + if (IRAFNAME(fits) == EOS) + call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) + } else if (strmatch (card, "^EXTNAME ") != 0) { + if (XTENSION(fits) != EXT_PRIMARY && XTENSION(fits) != EXT_IMAGE) + call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) + } else if (strmatch (card, "^EXTVER ") != 0) { + # Filter this quantitity out and ignore it for now. + ; + } else if (strmatch (card, "^ORIGIN ") != 0) { + call rft_trim_card (card, card, LEN_CARD) + call strcat (card[i], HISTORY(im), SZ_HISTORY) + } else if (strmatch (card, "^DATE ") != 0) { + call rft_trim_card (card, card, LEN_CARD) + call strcat (card[i], HISTORY(im), SZ_HISTORY) + } else if (strmatch (card, "^IRAF-TLM") != 0) { + call rft_trim_card (card, card, LEN_CARD) + call strcat (card[i], HISTORY(im), SZ_HISTORY) + #} else if (strmatch (card, "^HISTORY ") != 0) { + #call rft_trim_card (card, card, LEN_CARD) + #call strcat (card[i - 2], HISTORY(im), SZ_HISTORY) + } else if (strmatch (card, "^UT ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("UT", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else if (strmatch (card, "^ZD ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("ZD", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else if (strmatch (card, "^ST ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("ST", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else if (strmatch (card, "^RA ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("RA", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else if (strmatch (card, "^DEC ") != 0) { + len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) + if (len > 0) { + call wft_encodec ("DEC", Memc[str], len, card, Memc[comment]) + card[LEN_CARD+1] = '\n' + card[LEN_CARD+2] = EOS + } + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } else { + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + } + } + + call sfree (sp) + + return (NO) + +end + + +# RFT_HMS -- Procedure to decode a FITS HMS card from the mountain. + +int procedure rft_hms (card, str, comment, maxch) + +char card[ARB] # FITS card +char str[ARB] # string +char comment[ARB] # comment string +int maxch # maximum number of characters + +char colon, minus +int ip, nchar, fst, lst, deg, min +real sec +int stridx(), strldx(), strlen(), ctoi(), ctor() + +begin + # Return if not a FITS string parameter. + if (card[COL_VALUE] != '\'') + return (0) + + # Set up key characters. + colon = ':' + minus = '-' + + # Get the FITS string. + call rft_get_fits_string (card, str, maxch) + + # Get the comment string. + call rft_get_comment (card, comment, maxch) + + # Test for blank string and for 2 colon delimiters. + if (str[1] == EOS) + return (0) + fst = stridx (colon, str) + if (fst == 0) + return (0) + lst = strldx (colon, str) + if (lst == 0) + return (0) + if (fst == lst) + return (0) + + # Decode the degrees field. + ip = 1 + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == '+' || str[ip] == '-') + ip = ip + 1 + nchar = ctoi (str, ip, deg) + if (nchar == 0) + deg = 0 + + # Decode the minutes field. + ip = fst + 1 + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == '+' || str[ip] == '-') + ip = ip + 1 + nchar = ctoi (str, ip, min) + if (nchar == 0) + min = 0 + + # Decode the seconds field. + ip = lst + 1 + while (IS_WHITE(str[ip])) + ip = ip + 1 + if (str[ip] == '+' || str[ip] == '-') + ip = ip + 1 + nchar = ctor (str, ip, sec) + if (nchar == 0) + sec = 0.0 + + # Reformat the HMS card. + if (stridx (minus, str) > 0 || deg < 0 || min < 0 || sec < 0.0) { + call sprintf (str, maxch, "%c%d:%02d:%05.2f") + call pargc (minus) + call pargi (abs (deg)) + call pargi (abs (min)) + call pargr (abs (sec)) + } else { + call sprintf (str, maxch, "%2d:%02d:%05.2f") + call pargi (deg) + call pargi (abs (min)) + call pargr (abs (sec)) + } + + return (strlen (str)) +end + + +# RFT_GET_COMMENT -- Extract the comment field from a FITS card. + +procedure rft_get_comment (card, comment, maxch) + +char card[ARB] # FITS card +char comment[ARB] # comment string +int maxch # maximum number of characters + +int istart, j + +begin + istart = 0 + for (j = LEN_CARD; (j >= 1) && (card[j] != '\''); j = j - 1) { + if (card[j] == '/') { + for (istart = j + 1; IS_WHITE(card[istart]) && istart <= + LEN_CARD; istart = istart + 1) + ; + break + } + } + + if (istart == 0) + comment[1] = EOS + else + call strcpy (card[istart], comment, LEN_CARD - istart + 1 ) +end + + +# RFT_GET_FITS_STRING -- Extract a string from a FITS card and trim trailing +# blanks. The EOS is marked by either ', /, or the end of the card. +# There may be an optional opening ' (FITS standard). + +procedure rft_get_fits_string (card, str, maxchar) + +char card[ARB] # FITS card +char str[ARB] # FITS string +int maxchar # maximum number of characters + +int j, istart, nchar + +begin + # Check for opening quote + for (istart = COL_VALUE; istart <= LEN_CARD && card[istart] != '\''; + istart = istart + 1) + ; + istart = istart + 1 + + # Check for closing quote. + for (j = istart; (j<LEN_CARD)&&(card[j]!='\''); j = j + 1) + ; + for (j = j - 1; (j >= istart) && (card[j] == ' '); j = j - 1) + ; + nchar = min (maxchar, j - istart + 1) + + # Copy the string. + if (nchar <= 0) + str[1] = EOS + else + call strcpy (card[istart], str, nchar) +end + + +# RFT_EQUALD -- Procedure to compare two double precision numbers for equality +# to within the machine precision for doubles. + +bool procedure rft_equald (x, y) + +double x, y # the two numbers to be compared for equality + +int ex, ey +double x1, x2, normed_x, normed_y + +begin + if (x == y) + return (true) + + call rft_normd (x, normed_x, ex) + call rft_normd (y, normed_y, ey) + + if (ex != ey) + return (false) + else { + x1 = 1.0d0 + abs (normed_x - normed_y) + x2 = 1.0d0 + NEPSILON * EPSILOND + return (x1 <= x2) + } +end + + +# RFT_NORMED -- Normalize a double precision number x to the value normed_x, +# in the range [1-10]. Expon is returned such that x = normed_x * +# (10.0d0 ** expon). + +procedure rft_normd (x, normed_x, expon) + +double x # number to be normailized +double normed_x # normalized number +int expon # exponent + +double ax + +begin + ax = abs (x) + expon = 0 + + if (ax > 0) { + while (ax < (1.0d0 - NEPSILON * EPSILOND)) { + ax = ax * 10.0d0 + expon = expon - 1 + } + + while (ax >= (10.0d0 - NEPSILON * EPSILOND)) { + ax = ax / 10.0d0 + expon = expon + 1 + } + } + + if (x < 0) + normed_x = -ax + else + normed_x = ax +end + + +# RFT_TRIM_CARD -- Procedure to trim trailing whitespace from the card + +procedure rft_trim_card (incard, outcard, maxch) + +char incard[ARB] # input FITS card image +char outcard[ARB] # output FITS card +int maxch # maximum size of card + +int ip + +begin + ip = maxch + while (incard[ip] == ' ' || incard[ip] == '\t' || incard[ip] == '\0') + ip = ip - 1 + call amovc (incard, outcard, ip) + outcard[ip+1] = '\n' + outcard[ip+2] = EOS +end + + +# RFT_LAST_CARD -- Remove a partially written card from the data base + +procedure rft_last_user (user, maxch) + +char user[ARB] # user area +int maxch # maximum number of characters + +int ip + +begin + ip = maxch + while (user[ip] != '\n') + ip = ip - 1 + user[ip+1] = EOS +end + + +# RFT_SET_IMAGE_PIXTYPE -- Set remaining header fields not set in +# rft_read_header. + +procedure rft_set_image_pixtype (fits, im, bscale, bzero) + +pointer fits # FITS data structure +pointer im # IRAF image pointer +double bscale # FITS scaling parameter +double bzero # FITS offset parameter + +bool rft_equald() +include "rfits.com" + +begin + # Determine data type from BITPIX if user data type not specified. + + if (data_type == ERR) { + if (BITPIX(fits) < 0) { + if (abs (BITPIX(fits)) <= (SZ_REAL * SZB_CHAR * NBITS_BYTE)) + PIXTYPE(im) = TY_REAL + else + PIXTYPE(im) = TY_DOUBLE + } else if (SCALE(fits) == YES) { + if (rft_equald (bscale, 1.0d0)) { + if (rft_equald (bzero / 32768.0d0, 1.0d0)) + PIXTYPE(im) = TY_USHORT + else + PIXTYPE(im) = TY_REAL + } else + PIXTYPE(im) = TY_REAL + } else { + if (BITPIX(fits) <= (SZ_SHORT * SZB_CHAR * NBITS_BYTE)) + PIXTYPE(im) = TY_SHORT + else + PIXTYPE(im) = TY_LONG + } + + } else + PIXTYPE(im) = data_type +end + + +# Copy the global header into the output image header. + +procedure rft_gheader (im, gim, fd_usr, card, len_card, ndiscard, long_header) + +pointer im # IRAF image header descriptor +pointer gim # IRAF global image header descriptor +int fd_usr # IRAF image header user area +char card[ARB] # FITS card +int len_card # length of FITS card +int ndiscard # number of cards discarded +int long_header # print the long header + +int ngcards, gim_lenuser, ninherit, count +pointer sp, indices, idb_gim, grp, irp +bool streq() +int strlen(), idb_nextcard(), idb_find() +pointer idb_open() +errchk putline() + +begin + # Initialize. + call smark (sp) + ngcards = strlen (UNKNOWN(gim)) / (len_card + 1) + call salloc (indices, ngcards, TY_INT) + + # Mark the global header cards which are to be inherited. These + # include all COMMENT, HISTORY, and BLANK cards, plus all those + # cards which do not already have values in the extension header. + count = 0 + idb_gim = idb_open (gim, gim_lenuser) + while (idb_nextcard (idb_gim, grp) != EOF) { + if (count >= ngcards) + break + call strcpy (Memc[grp], card, 8) + if (streq (card, "COMMENT ")) + Memi[indices+count] = YES + else if (streq (card, "HISTORY ")) + Memi[indices+count] = YES + else if (streq (card, " ")) + Memi[indices+count] = YES + else if (idb_find (im, card, irp) > 0) + Memi[indices+count] = NO + else + Memi[indices+count] = YES + count = count + 1 + } + call idb_close (idb_gim) + + # Open the global header image user area and loop through the cards. + ninherit = 0 + count = 0 + idb_gim = idb_open (gim, gim_lenuser) + while (idb_nextcard (idb_gim, grp) != EOF) { + if (Memi[indices+count] == YES) { + call strcpy (Memc[grp], card, len_card) + card[len_card+1] = '\n' + card[len_card+2] = EOS + if (ndiscard > 1) + ndiscard = ndiscard + 1 + else { + iferr (call putline (fd_usr, card)) + ndiscard = ndiscard + 1 + else + ninherit = ninherit + 1 + } + } + count = count + 1 + } + call idb_close (idb_gim) + + if (long_header == YES) { + call printf ("%d global header keywords were inherited\n") + call pargi (ninherit) + } + + call sfree (sp) +end + + +# RFT_TYPESTRING -- Procedure to set the iraf datatype keyword. + +procedure rft_typestring (data_type, type_str, maxch) + +int data_type # the IRAF data type +char type_str[ARB] # the output IRAF type string +int maxch # maximum size of the type string + +begin + switch (data_type) { + case TY_SHORT: + call strcpy ("SHORT", type_str, maxch) + case TY_USHORT: + call strcpy ("USHORT", type_str, maxch) + case TY_INT: + call strcpy ("INTEGER", type_str, maxch) + case TY_LONG: + call strcpy ("LONG", type_str, maxch) + case TY_REAL: + call strcpy ("REAL", type_str, maxch) + case TY_DOUBLE: + call strcpy ("DOUBLE", type_str, maxch) + case TY_COMPLEX: + call strcpy ("COMPLEX", type_str, maxch) + default: + call strcpy ("UNKNOWN", type_str, maxch) + } +end + + diff --git a/pkg/dataio/fits/fits_rimage.x b/pkg/dataio/fits/fits_rimage.x new file mode 100644 index 00000000..9994c1d4 --- /dev/null +++ b/pkg/dataio/fits/fits_rimage.x @@ -0,0 +1,557 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include <fset.h> +include "rfits.h" + +# RFT_READ_IMAGE -- Convert FITS image pixels to IRAF image pixels. + +procedure rft_read_image (fits_fd, fits, im) + +int fits_fd # FITS file descriptor +pointer fits # FITS data structure +pointer im # IRAF image descriptor + +int i, npix, npix_record, blksize, ndummy +long v[IM_MAXDIM], nlines, il +pointer tempbuf, buf +real linemax, linemin, lirafmin, lirafmax +double dblank + +long clktime() +int fstati(), rft_init_read_pixels(), rft_read_pixels() + +errchk malloc, mfree, rft_init_read_pixels, rft_read_pixels, rft_lscale_pix +errchk rft_lchange_pix, rft_rchange_pix, rfit_dchange_pix, rft_put_image_line +errchk rft_pix_limits, rft_rscale_pix, rft_dscale_pix + +include "rfits.com" + +begin + # No pixel file was created. + if (NAXIS(im) == 0) { + if (short_header == YES || long_header == YES) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: No pixel file created\n") + } + return + } + + # Compute the number of columns and lines in the image. + npix = NAXISN(im, 1) + nlines = 1 + do i = 2, NAXIS(im) + nlines = nlines * NAXISN(im, i) + lirafmax = -MAX_REAL + lirafmin = MAX_REAL + + # Compute the number of pixels per record and the number of records + # per output block. + + npix_record = len_record * FITS_BYTE / abs (BITPIX(fits)) + blksize = fstati (fits_fd, F_SZBBLK) + if (mod (blksize, FITS_RECORD) == 0) + blksize = blksize / FITS_RECORD + else + blksize = 1 + + # FITS data is converted to type LONG, REAL or DOUBLE. If BITPIX is + # not one of the MII types then rft_read_pixels returns an ERROR. + + call amovkl (long(1), v, IM_MAXDIM) + switch (BITPIX(fits)) { + case FITS_REAL: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_REAL) + + # Initialize the read. + i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_REAL) + + # Turn on the ieee NaN mapping. + call ieesnanr (blank) + call ieemapr (YES, NO) + #call ieezstatr () + NBPIX(im) = 0 + + # Allocate the space for the output line, read in the image + # line, convert from the ieee to native format, and compute the + # minimum and maximum. + + do il = 1, nlines { + call rft_put_image_line (im, buf, v, PIXTYPE(im)) + if (rft_read_pixels (fits_fd, Memr[tempbuf], npix, + NRECORDS(fits), blksize) != npix) + call printf ("Error reading FITS data\n") + if (SCALE(fits) == YES) + call rft_rscale_pix (Memr[tempbuf], buf, npix, + FITS_BSCALE(fits), FITS_BZERO(fits), PIXTYPE(im)) + else + call rft_rchange_pix (Memr[tempbuf], buf, npix, PIXTYPE(im)) + call rft_pix_limits (buf, npix, PIXTYPE(im), linemin, linemax) + lirafmax = max (lirafmax, linemax) + lirafmin = min (lirafmin, linemin) + } + + # Set the number of bad pixels. + call ieestatr (NBPIX(im), ndummy) + + # Free space. + call mfree (tempbuf, TY_REAL) + + case FITS_DOUBLE: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_DOUBLE) + + # Initialize the read. + i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, + TY_DOUBLE) + + # Turn on the ieee NaN mapping. + dblank = blank + call ieesnand (dblank) + call ieemapd (YES, NO) + #call ieezstatd () + NBPIX(im) = 0 + + # Allocate the space for the output line, read in the image + # line, convert from the ieee to native format, and compute the + # minimum and maximum. + + do il = 1, nlines { + call rft_put_image_line (im, buf, v, PIXTYPE(im)) + if (rft_read_pixels (fits_fd, Memd[tempbuf], npix, + NRECORDS(fits), blksize) != npix) + call printf ("Error reading FITS data\n") + if (SCALE(fits) == YES) + call rft_dscale_pix (Memd[tempbuf], buf, npix, + FITS_BSCALE(fits), FITS_BZERO(fits), PIXTYPE(im)) + else + call rft_dchange_pix (Memd[tempbuf], buf, npix, PIXTYPE(im)) + call rft_pix_limits (buf, npix, PIXTYPE(im), linemin, linemax) + if (IS_INDEFR(linemax)) + lirafmax = INDEFR + else + lirafmax = max (lirafmax, linemax) + if (IS_INDEFR(linemin)) + lirafmin = INDEFR + else + lirafmin = min (lirafmin, linemin) + } + + # Set the number of bad pixels. + call ieestatd (NBPIX(im), ndummy) + + # Free space. + call mfree (tempbuf, TY_DOUBLE) + + default: + + # Allocate the required space. + call malloc (tempbuf, npix, TY_LONG) + + # Allocate the space for the output line, read in the image + # line, convert from the ieee to native format, and compute the + # minimum and maximum. + + i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_LONG) + do il = 1, nlines { + call rft_put_image_line (im, buf, v, PIXTYPE(im)) + if (rft_read_pixels (fits_fd, Meml[tempbuf], npix, + NRECORDS(fits), blksize) != npix) + call printf ("Error reading FITS data\n") + if (SCALE(fits) == YES) + call rft_lscale_pix (Meml[tempbuf], buf, npix, + FITS_BSCALE(fits), FITS_BZERO(fits), PIXTYPE(im)) + else + call rft_lchange_pix (Meml[tempbuf], buf, npix, PIXTYPE(im)) + if (BLANKS(fits) == YES) + call rft_map_blanks (Meml[tempbuf], buf, npix, PIXTYPE(im), + BLANK_VALUE(fits), blank, NBPIX(im)) + call rft_pix_limits (buf, npix, PIXTYPE(im), linemin, linemax) + lirafmax = max (lirafmax, linemax) + lirafmin = min (lirafmin, linemin) + } + + # Free space. + call mfree (tempbuf, TY_LONG) + } + + IRAFMIN(im) = lirafmin + IRAFMAX(im) = lirafmax + LIMTIME(im) = clktime (long(0)) + + if (short_header == YES || long_header == YES) { + if (NBPIX (im) != 0) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: %d bad pixels replaced in image\n") + call pargl (NBPIX (im)) + } + if (IS_INDEFR(lirafmax) || lirafmax > MAX_REAL) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: image contains pixel values > %g\n") + call pargr (MAX_REAL) + } + if (IS_INDEFR(lirafmin) || lirafmin < -MAX_REAL) { + if (long_header == NO) + call printf (" ") + call printf ("Warning: image contains pixel values < %g\n") + call pargr (-MAX_REAL) + } + } +end + + +# RFT_PUT_IMAGE_LINE -- Procedure to output an image line to and IRAF file. + +procedure rft_put_image_line (im, buf, v, data_type) + +pointer im # IRAF image descriptor +pointer buf # Pointer to output image line +long v[ARB] # imio pointer +int data_type # output pixel type + +int impnll(), impnlr(), impnld(), impnlx() +errchk impnll, impnlr, impnld, impnlx + +begin + switch (data_type) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + if (impnll (im, buf, v) == EOF) + call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") + case TY_REAL: + if (impnlr (im, buf, v) == EOF) + call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") + case TY_DOUBLE: + if (impnld (im, buf, v) == EOF) + call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") + case TY_COMPLEX: + if (impnlx (im, buf, v) == EOF) + call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") + default: + call error (10, "RFT_PUT_IMAGE_LINE: Unsupported IRAF image type") + } +end + + +# RFT_RSCALE_PIX -- Procedure to convert an IRAF image line from type real +# to the requested output data type with optional scaling using the +# FITS parameters BSCALE and BZERO. + +procedure rft_rscale_pix (inbuf, outbuf, npix, bscale, bzero, data_type) + +real inbuf[ARB] # buffer of FITS integers +pointer outbuf # pointer to output image line +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero +int data_type # IRAF image pixel type + +errchk altmdr, achtrl, amovr, achtrd, achtrx + +begin + switch (data_type) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call altmdr (inbuf, inbuf, npix, bscale, bzero) + call achtrl (inbuf, Meml[outbuf], npix) + case TY_REAL: + call altmdr (inbuf, inbuf, npix, bscale, bzero) + call amovr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call altmdr (inbuf, inbuf, npix, bscale, bzero) + call achtrd (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call altmdr (inbuf, inbuf, npix, bscale, bzero) + call achtrx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_SCALE_LINE: Illegal IRAF image type") + } +end + + +# RFT_DSCALE_PIX -- Procedure to convert an IRAF image line from type double +# to the requested output data type with optional scaling using the +# FITS parameters BSCALE and BZERO. + +procedure rft_dscale_pix (inbuf, outbuf, npix, bscale, bzero, data_type) + +double inbuf[ARB] # buffer of FITS integers +pointer outbuf # pointer to output image line +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero +int data_type # IRAF image pixel type + +errchk altmd, achtdl, amovd, achtdr, achtdx + +begin + switch (data_type) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call altmd (inbuf, inbuf, npix, bscale, bzero) + call achtdl (inbuf, Meml[outbuf], npix) + case TY_REAL: + call altmd (inbuf, inbuf, npix, bscale, bzero) + call achtdr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call altmd (inbuf, inbuf, npix, bscale, bzero) + call amovd (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call altmd (inbuf, inbuf, npix, bscale, bzero) + call achtdx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_SCALE_LINE: Illegal IRAF image type") + } +end + + + +# RFT_LSCALE_PIX -- Procedure to convert an IRAF image line from type long +# to the requested output data type with optional scaling using the +# FITS parameters BSCALE and BZERO. + +procedure rft_lscale_pix (inbuf, outbuf, npix, bscale, bzero, data_type) + +long inbuf[ARB] # buffer of FITS integers +pointer outbuf # pointer to output image line +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero +int data_type # IRAF image pixel type + +errchk achtll, achtlr, achtld, achtlx +errchk altml, altmr, altmd, altmx + +begin + switch (data_type) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call achtll (inbuf, Meml[outbuf], npix) + call altml (Meml[outbuf], Meml[outbuf], npix, bscale, bzero) + case TY_REAL: + call altmlr (inbuf, Memr[outbuf], npix, bscale, bzero) + case TY_DOUBLE: + call achtld (inbuf, Memd[outbuf], npix) + call altmd (Memd[outbuf], Memd[outbuf], npix, bscale, bzero) + case TY_COMPLEX: + call achtlx (inbuf, Memx[outbuf], npix) + call altmx (Memx[outbuf], Memx[outbuf], npix, real (bscale), + real (bzero)) + default: + call error (10, "RFT_SCALE_LINE: Illegal IRAF image type") + } +end + + +# RFT_RCHANGE_PIX -- Procedure to change a line of real numbers to the +# IRAF image type. + +procedure rft_rchange_pix (inbuf, outbuf, npix, data_type) + +real inbuf[ARB] # array of FITS integers +pointer outbuf # pointer to IRAF image line +int npix # number of pixels +int data_type # IRAF pixel type + +errchk achtrl, amovr, achtrd, achtrx + +begin + switch (data_type) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + call achtrl (inbuf, Meml[outbuf], npix) + case TY_REAL: + call amovr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call achtrd (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call achtrx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_RCHANGE_LINE: Illegal IRAF image type") + } +end + + +# RFT_DCHANGE_PIX -- Procedure to change a line of double precision numbers +# to the IRAF image type. + +procedure rft_dchange_pix (inbuf, outbuf, npix, data_type) + +double inbuf[ARB] # array of FITS integers +pointer outbuf # pointer to IRAF image line +int npix # number of pixels +int data_type # IRAF pixel type + +errchk achtdl, achtdr, amovd, achtdx + +begin + switch (data_type) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + call achtdl (inbuf, Meml[outbuf], npix) + case TY_REAL: + call achtdr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call amovd (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call achtdx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_DCHANGE_LINE: Illegal IRAF image type") + } +end + + + +# RFT_LCHANGE_PIX -- Procedure to change a line of long integers to the +# IRAF image type. + +procedure rft_lchange_pix (inbuf, outbuf, npix, data_type) + +long inbuf[ARB] # array of FITS integers +pointer outbuf # pointer to IRAF image line +int npix # number of pixels +int data_type # IRAF pixel type + +begin + switch (data_type) { + case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: + call achtll (inbuf, Meml[outbuf], npix) + case TY_REAL: + call achtlr (inbuf, Memr[outbuf], npix) + case TY_DOUBLE: + call achtld (inbuf, Memd[outbuf], npix) + case TY_COMPLEX: + call achtlx (inbuf, Memx[outbuf], npix) + default: + call error (10, "RFT_CHANGE_LINE: Illegal IRAF image type") + } +end + + +# RFT_MAP_BLANKS -- Map the blank pixels. Currently only the number of blank +# pixels is determined without an further mapping. + +procedure rft_map_blanks (a, buf, npts, pixtype, blank_value, blank, nbadpix) + +long a[ARB] # integer input buffer +pointer buf # pointer to output image buffer +int npts # number of points +int pixtype # image data type +long blank_value # FITS blank value +real blank # user blank value +long nbadpix # number of bad pixels + +int i + +begin + # Do blank mapping here + switch (pixtype) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + do i = 1, npts { + if (a[i] == blank_value) { + nbadpix = nbadpix + 1 + Meml[buf+i-1] = blank + } + } + case TY_REAL: + do i = 1, npts { + if (a[i] == blank_value) { + nbadpix = nbadpix + 1 + Memr[buf+i-1] = blank + } + } + case TY_DOUBLE: + do i = 1, npts { + if (a[i] == blank_value) { + nbadpix = nbadpix + 1 + Memd[buf+i-1] = blank + } + } + case TY_COMPLEX: + do i = 1, npts { + if (a[i] == blank_value) { + nbadpix = nbadpix + 1 + Memx[buf+i-1] = blank + } + } + } +end + + +# RFT_PIX_LIMITS -- Procedure to determine to maxmimum and minimum values in a +# line. Note that double precision is somewhat of a special case because +# MAX_DOUBLE is a lot less than the maximum permitted ieee numbers for iraf. + +procedure rft_pix_limits (buf, npix, pixtype, linemin, linemax) + +pointer buf # pointer to IRAF image line +int npix # number of pixels +int pixtype # output data type +real linemax, linemin # min and max pixel values + +long lmax, lmin +real rmax, rmin +double dmax, dmin +complex xmax, xmin + +begin + switch (pixtype) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + call aliml (Meml[buf], npix, lmin, lmax) + linemax = lmax + linemin = lmin + case TY_REAL: + call alimr (Memr[buf], npix, rmin, rmax) + linemax = rmax + linemin = rmin + case TY_DOUBLE: + call alimd (Memd[buf], npix, dmin, dmax) + if (dmax > MAX_REAL) + linemax = INDEFR + else + linemax = dmax + if (dmin < -MAX_REAL) + linemin = INDEFR + else + linemin = dmin + case TY_COMPLEX: + call alimx (Memx[buf], npix, xmin, xmax) + linemax = xmax + linemin = xmin + default: + call error (30, "RFT_PIX_LIMITS: Unknown IRAF type") + } +end + + +# ALTMDR -- procedure to scale a long vector into a real vector using +# double precision constants to preserve accuracy + +procedure altmlr (a, b, npix, bscale, bzero) + +long a[ARB] # input array +real b[ARB] # output array +int npix # number of pixels +double bscale, bzero # scaling parameters + +int i + +begin + do i = 1, npix + b[i] = a[i] * bscale + bzero +end + + +# ALTMDR -- procedure to scale a real vector with double precision constants. + +procedure altmdr (a, b, npix, bscale, bzero) + +real a[ARB] # input array +real b[ARB] # output array +int npix # number of pixels +double bscale, bzero # scaling parameters + +int i + +begin + do i = 1, npix + b[i] = a[i] * bscale + bzero +end diff --git a/pkg/dataio/fits/fits_rpixels.x b/pkg/dataio/fits/fits_rpixels.x new file mode 100644 index 00000000..6183120d --- /dev/null +++ b/pkg/dataio/fits/fits_rpixels.x @@ -0,0 +1,154 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <mii.h> +include <mach.h> + +# RFT_INIT_READ_PIXELS and READ_PIXELS -- Read pixel data with record buffering +# and data type conversion. The input data must meet the MII standard +# except for possibly in the case of integers having the least significant +# byte first. +# +# Read data in records of len_record and convert to the specified IRAF +# data type. Successive calls of rft_read_pixels returns the next npix pixels. +# Read_pixels returns EOF or the number of pixels converted. +# Init_read_pixels must be called before read_pixels. +# +# Error conditions are: +# 1. A short input record +# 2. Error in converting the pixels by miiup. +# +# This routine is based on the MII unpack routine which is machine dependent. +# The bitpix must correspond to an MII type. If the lsbf (least significant +# byte first) flag is YES then the pixels do not satisfy the MII standard. +# In this case the bytes are first swapped into most significant byte first +# before the MII unpack routine is called. + +int procedure rft_init_read_pixels (npix_record, bitpix, lsbf, spp_type) + +int npix_record # number of pixels per input record +int bitpix # bits per pixel (must correspond to an MII type) +int lsbf # byte swap? +int spp_type # SPP data type to be returned + +# entry rft_read_pixels (fd, buffer, npix) + +int rft_read_pixels +int fd # input file descriptor +char buffer[1] # output buffer +int npix # number of pixels to read + +int swap +int ty_mii, ty_spp, npix_rec, nch_rec, sz_rec, nchars, len_mii, recptr +int bufsize, i, n, ip, op +pointer mii, spp + +int rft_getbuf(), sizeof(), miilen() +errchk miilen, mfree, malloc, rft_getbuf, miiupk +data mii/NULL/, spp/NULL/ + +begin + ty_mii = bitpix + ty_spp = spp_type + swap = lsbf + npix_rec = npix_record + nch_rec = npix_rec * sizeof (ty_spp) + + len_mii = miilen (npix_rec, ty_mii) + sz_rec = len_mii * SZ_INT32 + + if (mii != NULL) + call mfree (mii, TY_INT) + call malloc (mii, len_mii, TY_INT) + + if (spp != NULL) + call mfree (spp, TY_CHAR) + call malloc (spp, nch_rec, TY_CHAR) + + ip = nch_rec + return (OK) + +entry rft_read_pixels (fd, buffer, npix, recptr, bufsize) + + nchars = npix * sizeof (ty_spp) + op = 0 + + repeat { + + # If data is exhausted read the next record + if (ip == nch_rec) { + + i = rft_getbuf (fd, Memi[mii], sz_rec, bufsize, recptr) + if (i == EOF) + return (EOF) + + if (swap == YES) + switch (ty_mii) { + case MII_SHORT: + call bswap2 (Memi[mii], 1, Memi[mii], 1, + sz_rec * SZB_CHAR) + case MII_LONG: + call bswap4 (Memi[mii], 1, Memi[mii], 1, + sz_rec * SZB_CHAR) + } + + call miiupk (Memi[mii], Memc[spp], npix_rec, ty_mii, ty_spp) + + ip = 0 + #recptr = recptr + 1 + } + + n = min (nch_rec - ip, nchars - op) + call amovc (Memc[spp+ip], buffer[1+op], n) + ip = ip + n + op = op + n + + } until (op == nchars) + + return (npix) +end + + +# RFT_GETBUF -- Procedure to get the buffer. + +int procedure rft_getbuf (fd, buf, sz_rec, bufsize, recptr) + +int fd # file descriptor +char buf[ARB] # buffer to be filled +int sz_rec # size in chars of record to be read +int bufsize # buffer size in records +int recptr # last successful FITS record read + +int i, nchars +int read(), fstati() +errchk read + +begin + nchars = 0 + repeat { + iferr { + i = read (fd, buf[nchars+1], sz_rec - nchars) + } then { + call printf ("Error reading FITS record %d\n") + if (mod (recptr + 1, bufsize) == 0) + call pargi ((recptr + 1) / bufsize) + else + call pargi ((recptr + 1) / bufsize + 1) + call fseti (fd, F_VALIDATE, fstati (fd, F_SZBBLK) / SZB_CHAR) + i = read (fd, buf[nchars+1], sz_rec - nchars) + } + + if (i == EOF) + break + else + nchars = nchars + i + + } until (nchars >= sz_rec) + + if ((i == EOF) && (nchars == 0)) + return (EOF) + else { + recptr = recptr + 1 + return (nchars) + } +end diff --git a/pkg/dataio/fits/fits_wheader.x b/pkg/dataio/fits/fits_wheader.x new file mode 100644 index 00000000..ec06f968 --- /dev/null +++ b/pkg/dataio/fits/fits_wheader.x @@ -0,0 +1,469 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include <fset.h> +include "wfits.h" + +# WFT_WRITE_HEADER -- Write the FITS headers. The FITS header +# parameters are encoded one by one until the FITS END keyword is detected. +# If the long_header switch is set the full FITS header is printed on the +# standard output. If the short header parameter is specified only the image +# title and dimensions are printed. + +procedure wft_write_header (im, fits, fits_fd) + +pointer im # pointer to the IRAF image +pointer fits # pointer to the FITS structure +int fits_fd # the FITS file descriptor + +char card[LEN_CARD+1], trim_card[LEN_CARD+1] +int nrecords, recntr, cardptr, cardcnt, stat, cards_per_rec, i +int wft_card_encode(), wft_set_bitpix(), sizeof(), strncmp() +int wft_init_card_encode(), fstati() + +errchk wft_set_bitpix, wft_get_iraf_typestring, wft_set_scale, wft_set_blank +errchk wft_fits_set_scale, wft_init_card_encode, wft_card_encode +errchk wft_init_write_pixels, wft_write_pixels, wft_write_last_record + +include "wfits.com" + +begin + # SET the data and FITS bits per pixel. + + DATA_BITPIX(fits) = sizeof (PIXTYPE(im)) * SZB_CHAR * NBITS_BYTE + FITS_BITPIX(fits) = wft_set_bitpix (bitpix, PIXTYPE(im), + DATA_BITPIX(fits)) + + # Calculate the FITS bscale and bzero parameters. Notice for the + # time being that scaling is turned off if IEEE floating point + # output is selected. May decide to change this later after + # checking the specifications. + + if (FITS_BITPIX(fits) < 0) { + + IRAFMIN(fits) = IM_MIN(im) + IRAFMAX(fits) = IM_MAX(im) + SCALE(fits) = NO + BZERO(fits) = 0.0d0 + BSCALE(fits) = 1.0d0 + + } else if (autoscale == YES) { + + call wft_get_tape_limits (FITS_BITPIX(fits), TAPEMIN(fits), + TAPEMAX(fits)) + call wft_data_limits (im, IRAFMIN(fits), IRAFMAX(fits)) + call wft_fits_set_scale (im, DATA_BITPIX(fits), FITS_BITPIX(fits), + IRAFMIN(fits), IRAFMAX(fits), TAPEMIN(fits), TAPEMAX(fits), + SCALE(fits), BSCALE(fits), BZERO(fits)) + + } else { + + IRAFMIN(fits) = IM_MIN(im) + IRAFMAX(fits) = IM_MAX(im) + SCALE(fits) = scale + BZERO(fits) = bzero + BSCALE(fits) = bscale + } + + # If blanks in the image set the blank parameter. Currently information + # on blanks is not written out so this is effectively a null operation + # in IRAF. + + if (NBPIX(im) > 0) + call wft_set_blank (FITS_BITPIX(fits), BLANK(fits), + BLANK_STRING(fits)) + + # Set the IRAF datatype parameter. + call wft_get_iraf_typestring (PIXTYPE(im), TYPE_STRING(fits)) + + # Initialize the card counters. These counters are used only for + # information printed to the standard output. + + recntr = 1 + cardptr = 1 + cardcnt = 1 + cards_per_rec = len_record / LEN_CARD + + # Get set up to write the FITS header. Initialize for an ASCII write. + stat = wft_init_card_encode (im, fits) + if (make_image == YES) + call wft_init_wrt_pixels (len_record, TY_CHAR, FITS_BYTE, blkfac) + + # Print short header. + if (short_header == YES && long_header == NO) { + + call printf ("%-20.20s ") + call pargstr (OBJECT(im)) + do i = 1, NAXIS(im) { + if (i == 1) { + call printf ("Size = %d") + call pargl (NAXISN(im,i)) + } else { + call printf (" x %d") + call pargl (NAXISN(im,i)) + } + } + call printf ("\n") + + call strlwr (TYPE_STRING(fits)) + call printf ("\tpixtype=%s bitpix=%d") + call pargstr (TYPE_STRING(fits)) + call pargi (FITS_BITPIX(fits)) + + if (fstati (fits_fd, F_BLKSIZE) == 0) { + call printf (" blkfac=%d") + call pargi (blkfac) + } else + call printf (" blkfac=fixed") + + if (SCALE(fits) == YES) { + call printf (" bscale=%.7g bzero=%.7g\n") + call pargd (BSCALE(fits)) + call pargd (BZERO(fits)) + } else + call printf (" scaling=none\n") + call strupr (TYPE_STRING(fits)) + } + + # Write the cards to the FITS header. + repeat { + + # Encode the card. + stat = wft_card_encode (im, fits, card) + if (stat == NO) + next + + # Write the card to the output file if make_image is yes. + if (make_image == YES) + call wft_write_pixels (fits_fd, card, LEN_CARD) + + # Trim the card and write is to the standard output if + # long_header is yes. + + if (long_header == YES) { + call wft_trimstr (card, trim_card, LEN_CARD) + call printf ("%2d/%2d:-- %s\n") + call pargi (recntr) + call pargi (cardptr) + call pargstr (trim_card) + } + + if (mod (cardcnt, cards_per_rec) == 0) { + recntr = recntr + 1 + cardptr = 1 + } else + cardptr = cardptr + 1 + cardcnt = cardcnt + 1 + + } until (strncmp (card, "END ", LEN_KEYWORD) == 0) + + # Issue warning about possible precision loss. Comment this out + # for time being, since the short header was modified. + #if (SCALE(fits) == YES && bitpix != ERR) { + #call printf ( + #"\tDefault bitpix overridden: maximum precision loss ~%.7g\n") + #call pargd (BSCALE(fits)) + #} + + # Write the last header records. + if (make_image == YES) { + call wft_write_last_record (fits_fd, nrecords) + if (short_header == YES || long_header == YES) { + call printf ("\t%d Header ") + call pargi (nrecords) + } + } +end + + +# WFT_SET_BITPIX -- This procedure sets the FITS bitpix for each image based on +# either the user given value or the precision of the IRAF data. Notice that +# the user must explicitly set the bitpix parameter to -16 or -32 to select +# the IEEE output format. + +int procedure wft_set_bitpix (bitpix, datatype, data_bitpix) + +int bitpix # the user set bits per pixel, ERR or legal bitpix +int datatype # the IRAF image data type +int data_bitpix # the bits per pixel in the data + +begin + if (bitpix == ERR) { + switch (datatype) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + if (data_bitpix <= FITS_BYTE) + return (FITS_BYTE) + else if (data_bitpix <= FITS_SHORT) { + #if (datatype == TY_USHORT) + #return (FITS_LONG) + #else + return (FITS_SHORT) + } else + return (FITS_LONG) + case TY_REAL, TY_COMPLEX: + return (FITS_REAL) + case TY_DOUBLE: + return (FITS_DOUBLE) + default: + call error (2, "SET_BITPIX: Unknown IRAF data type.") + } + } else + return (bitpix) +end + + +# WFT_GET_IRAF_TYPESTRING -- Procedure to set the iraf datatype keyword. + +procedure wft_get_iraf_typestring (datatype, type_str) + +int datatype # the IRAF data type +char type_str[ARB] # the output IRAF type string + +begin + switch (datatype) { + case TY_SHORT: + call strcpy ("SHORT", type_str, LEN_STRING) + case TY_USHORT: + call strcpy ("USHORT", type_str, LEN_STRING) + case TY_INT: + call strcpy ("INTEGER", type_str, LEN_STRING) + case TY_LONG: + call strcpy ("LONG", type_str, LEN_STRING) + case TY_REAL: + call strcpy ("REAL", type_str, LEN_STRING) + case TY_DOUBLE: + call strcpy ("DOUBLE", type_str, LEN_STRING) + case TY_COMPLEX: + call strcpy ("COMPLEX", type_str, LEN_STRING) + default: + call error (3, "IRAF_TYPE: Unknown IRAF image type.") + } +end + + +# WFT_FITS_SET_SCALE -- Procedure to set the FITS scaling parameters if +# autoscaling is enabled. + +procedure wft_fits_set_scale (im, data_bitpix, fits_bitpix, irafmin, irafmax, + tapemin, tapemax, scale, bscale, bzero ) + +pointer im # pointer to IRAF image +int data_bitpix # bits per pixel of data +int fits_bitpix # fits bits per pixel +real irafmin # minimum picture value +real irafmax # maximum picture value +double tapemin # minimum tape value +double tapemax # maximum tape value +int scale # scale data ? +double bscale # FITS bscale +double bzero # FITS bzero + +errchk wft_set_scale + +begin + switch (PIXTYPE(im)) { + case TY_SHORT, TY_INT, TY_LONG: + if (data_bitpix > fits_bitpix) { + scale = YES + call wft_set_scale (fits_bitpix, irafmin, irafmax, tapemin, + tapemax, bscale, bzero) + } else { + scale = NO + bscale = 1.0d0 + bzero = 0.0d0 + } + case TY_USHORT: + if (data_bitpix > fits_bitpix) { + scale = YES + call wft_set_scale (fits_bitpix, irafmin, irafmax, tapemin, + tapemax, bscale, bzero) + } else if (data_bitpix == fits_bitpix) { + scale = YES + bscale = 1.0d0 + bzero = 3.2768d4 + } else { + scale = NO + bscale = 1.0d0 + bzero = 0.0d0 + } + case TY_REAL, TY_DOUBLE, TY_COMPLEX: + scale = YES + call wft_set_scale (fits_bitpix, irafmin, irafmax, tapemin, tapemax, + bscale, bzero) + default: + call error (1, "WRT_HEADER: Unknown IRAF image type.") + } + +end + + +# WFT_SET_SCALE -- This procedure calculates bscale and bzero for each frame +# from the FITS bitpix and the maximum and minimum data values. + +procedure wft_set_scale (fits_bitpix, datamin, datamax, mintape, maxtape, + bscale, bzero) + +int fits_bitpix # the FITS integer bits per pixels +real datamax, datamin # the IRAF image data minimum and maximum +double mintape, maxtape # min and max FITS tape values +double bscale, bzero # the calculated bscale and bzero values + +double maxdata, mindata, num, denom +bool rft_equald() + +begin + # Calculate the maximum and minimum values in the data. + maxdata = datamax #+ abs ((datamax / (10.0 ** (NDIGITS_RP - 1)))) + mindata = datamin #- abs ((datamin / (10.0 ** (NDIGITS_RP - 1)))) + num = maxdata - mindata + denom = (maxtape - mintape) * PREC_RATIO + + # Check for constant image case. + #mindata = datamin + #maxdata = datamax + if (rft_equald (num, 0.0d0)) { + bscale = 1.0d0 + bzero = maxdata + } else { + bscale = num / denom + #bzero = (maxtape / denom) * mindata - (mintape / denom) * maxdata + bzero = (maxdata + mindata) / 2.0d0 + } +end + + +# WFT_GET_TAPE_LIMITS -- Procedure for calculating the maximum and minimum FITS +# integer values from the FITS bitpix. + +procedure wft_get_tape_limits (fits_bitpix, mintape, maxtape) + +int fits_bitpix # the bits per pixel of a FITS integer +double maxtape, mintape # the maximun and minimum FITS tape integers + +begin + switch (fits_bitpix) { + case FITS_BYTE: + maxtape = BYTE_MAX + mintape = BYTE_MIN + case FITS_SHORT: + maxtape = SHORT_MAX + mintape = SHORT_MIN + case FITS_LONG: + maxtape = LONG_MAX + mintape = LONG_MIN + default: + call error (4, "TAPE_LIMITS: Unknown FITS type.") + } +end + + +# WFT_SET_BLANK -- Determine the FITS integer value for a blank pixel from the +# FITS bitpix. Notice that these are null ops for IEEE floating point format. + +procedure wft_set_blank (fits_bitpix, blank, blank_str) + +int fits_bitpix # the requested FITS bits per pixel +long blank # the FITS integer value of a blank pixel +char blank_str[ARB] # the encoded FITS integer value of a blank pixel + +begin + switch (fits_bitpix) { + case FITS_BYTE: + blank = long (BYTE_BLANK) + call strcpy ("0", blank_str, LEN_BLANK) + case FITS_SHORT: + blank = long (SHORT_BLANK) + call strcpy ("-32768", blank_str, LEN_BLANK) + case FITS_LONG: + blank = long (LONG_BLANK) + call strcpy ("-2147483648", blank_str, LEN_BLANK) + case FITS_REAL: + blank = INDEFL + call strcpy ("", blank_str, LEN_BLANK) + case FITS_DOUBLE: + blank = INDEFL + call strcpy ("", blank_str, LEN_BLANK) + default: + call error (5, "SET_BLANK: Unknown FITS type.") + } +end + + +# WFT_INIT_CARD_ENCODE -- This procedure initializes the card encoding +# procedure. The cards counters are initialized and the number of history cards +# calculated. + +int procedure wft_init_card_encode (im, fits) + +# both entry points +pointer im # pointer to the IRAF image +pointer fits # pointer to the WFITS structure + +# entry wft_card_encode +int wft_card_encode # entry point +char card[LEN_CARD+1] # string containing the card image + +int cardno, axisno, optiono, hist_ptr, unknown_ptr +int nstandard, noptions, stat +int wft_standard_card(), wft_option_card(), wft_last_card() +int wft_history_card(), wft_unknown_card() +errchk wft_standard_card, wft_option_card, wft_history_card +errchk wft_unknown_card, wft_last_card + +begin + # Initialize the card pointers. + cardno = 1 + axisno = 1 + optiono = 1 + unknown_ptr = 1 + hist_ptr = 1 + + # Initilaize the card counters. + nstandard = 3 + NAXIS(im) + noptions = NOPTIONS + nstandard + + return (YES) + + +# WFT_CARD_ENCODE -- Procedure to encode the FITS header parameters into +# FITS card images. + +entry wft_card_encode (im, fits, card) + + # Fetch the appropriate FITS header card image. + if (cardno <= nstandard) { + stat = wft_standard_card (cardno, im, fits, axisno, card) + } else if (cardno <= noptions) { + stat = wft_option_card (im, fits, optiono, card) + } else if (wft_unknown_card (im, unknown_ptr, card) == YES) { + stat = YES + } else if (wft_history_card (im, hist_ptr, card) == YES) { + stat = YES + } else { + stat = wft_last_card (card) + } + + cardno = cardno + 1 + + return (stat) +end + + +# WFT_TRIMSTR -- Procedure to trim trailing blanks from a fixed size string. + +procedure wft_trimstr (instr, outstr, nchars) + +char instr[ARB] # input string +char outstr[ARB] # output string +int nchars # last character of instr + +int ip + +begin + call strcpy (instr, outstr, nchars) + ip = nchars + while (outstr[ip] == ' ') + ip = ip - 1 + outstr[ip+1] = EOS +end diff --git a/pkg/dataio/fits/fits_wimage.x b/pkg/dataio/fits/fits_wimage.x new file mode 100644 index 00000000..7ed00372 --- /dev/null +++ b/pkg/dataio/fits/fits_wimage.x @@ -0,0 +1,497 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <imhdr.h> +include "wfits.h" + +# WFT_WRITE_IMAGE -- Procedure to convert IRAF image data to FITS format line by +# line. + +procedure wft_write_image (im, fits, fits_fd) + +pointer im # IRAF image descriptor +pointer fits # FITS data structure +int fits_fd # FITS file descriptor + +int npix, nlines, npix_record, i, stat, nrecords +long v[IM_MAXDIM] +pointer tempbuf, buf + +int wft_get_image_line() +errchk malloc, mfree, wft_get_image_line, wft_lscale_line, wft_long_line +errchk wft_init_write_pixels, wft_write_pixels, wft_write_last_record +errchk wft_rscale_line, wft_dscale_line + +include "wfits.com" + +begin + if (NAXIS(im) == 0) { + if (short_header == YES || long_header == YES) { + call printf ("0 Data logical (2880 byte) records written\n") + } + return + } + + # Initialize. + npix = NAXISN(im,1) + nlines = 1 + do i = 2, NAXIS(im) + nlines = nlines * NAXISN(im, i) + npix_record = len_record * FITS_BYTE / abs (FITS_BITPIX(fits)) + + call amovkl (long(1), v, IM_MAXDIM) + switch (FITS_BITPIX(fits)) { + case FITS_REAL: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_REAL) + + # Initialize the pixel write. + call wft_init_write_pixels (npix_record, TY_REAL, + FITS_BITPIX(fits), blkfac) + + # For the time being explicitly turn off ieee NaN mapping. + call ieemapr (NO, NO) + + # Scale the lines, deal with the blanks via the ieee code which + # is currently turned off, and write the output records. + + do i = 1, nlines { + iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) { + call erract (EA_WARN) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + } + if (stat == EOF ) + return + if (stat != npix) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + if (SCALE(fits) == YES) + call wft_rscale_line (buf, Memr[tempbuf], npix, + 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im)) + else + call wft_real_line (buf, Memr[tempbuf], npix, PIXTYPE(im)) + call wft_write_pixels (fits_fd, Memr[tempbuf], npix) + } + + # Free space. + call mfree (tempbuf, TY_REAL) + + case FITS_DOUBLE: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_DOUBLE) + + # Initialize the pixel write. + call wft_init_write_pixels (npix_record, TY_DOUBLE, + FITS_BITPIX(fits), blkfac) + + # For the time being explicitly turn off ieee NaN mapping. + call ieemapd (NO, NO) + + # Scale the lines, deal with the blanks via the ieee code which + # is currently turned off, and write the output records. + + do i = 1, nlines { + iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) { + call erract (EA_WARN) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + } + if (stat == EOF ) + return + if (stat != npix) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + if (SCALE(fits) == YES) + call wft_dscale_line (buf, Memd[tempbuf], npix, + 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im)) + else + call wft_double_line (buf, Memd[tempbuf], npix, + PIXTYPE(im)) + call wft_write_pixels (fits_fd, Memd[tempbuf], npix) + } + + # Free space. + call mfree (tempbuf, TY_DOUBLE) + + default: + + # Allocate temporary space. + call malloc (tempbuf, npix, TY_LONG) + + # Scale the line, deal with the blanks, and write the output + # record. At the moement blanks are not dealt with. + + call wft_init_write_pixels (npix_record, TY_LONG, FITS_BITPIX(fits), + blkfac) + do i = 1, nlines { + iferr (stat = wft_get_image_line (im, buf, v, PIXTYPE(im))) { + call erract (EA_WARN) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + } + if (stat == EOF ) + return + if (stat != npix) + call error (10, "WRT_IMAGE: Error writing IRAF image.") + if (SCALE(fits) == YES) + call wft_lscale_line (buf, Meml[tempbuf], npix, + 1. / BSCALE(fits), -BZERO(fits), PIXTYPE(im)) + else + call wft_long_line (buf, Meml[tempbuf], npix, PIXTYPE(im)) + # call map_blanks (im, Meml[tempbuf], blank) + call wft_write_pixels (fits_fd, Meml[tempbuf], npix) + } + # Free space. + call mfree (tempbuf, TY_LONG) + } + + # Write the final record. + call wft_write_last_record (fits_fd, nrecords) + if (short_header == YES || long_header == YES) { + call printf ("%d Data logical (2880 byte) records written\n") + call pargi (nrecords) + } +end + + +# WFT_GET_IMAGE_LINE -- Procedure to fetch the next image line. + +int procedure wft_get_image_line (im, buf, v, datatype) + +pointer im # IRAF image descriptor +pointer buf # pointer to image line +long v[ARB] # imio dimension descriptor +int datatype # IRAF image data type + +int npix +int imgnll(), imgnlr(), imgnld(), imgnlx() +errchk imgnll, imgnlr, imgnld, imgnlx + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + npix = imgnll (im, buf, v) + case TY_REAL: + npix = imgnlr (im, buf, v) + case TY_DOUBLE: + npix = imgnld (im, buf, v) + case TY_COMPLEX: + npix = imgnlx (im, buf, v) + default: + call error (11, "GET_IMAGE_LINE: Unknown IRAF image type.") + } + + return (npix) +end + + +# WFT_RSCALE_LINE -- This procedure converts the IRAF data to type real +# and scales by the FITS parameters bscale and bzero. + +procedure wft_rscale_line (buf, outbuffer, npix, bscale, bzero, datatype) + +pointer buf # pointer to IRAF image line +real outbuffer[ARB] # FITS integer buffer +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero parameters +int datatype # data type of image + +errchk achtlr, altadr, amovr, achtdr, acthxr + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call achtlr (Meml[buf], outbuffer, npix) + call altadr (outbuffer, outbuffer, npix, bzero, bscale) + case TY_REAL: + call amovr (Memr[buf], outbuffer, npix) + call altadr (outbuffer, outbuffer, npix, bzero, bscale) + case TY_DOUBLE: + call achtdr (Memd[buf], outbuffer, npix) + call altadr (outbuffer, outbuffer, npix, bzero, bscale) + case TY_COMPLEX: + call achtxr (Memx[buf], outbuffer, npix) + call altadr (outbuffer, outbuffer, npix, bzero, bscale) + default: + call error (12, "WFT_RSCALE_LINE: Unknown IRAF image type.") + } +end + + +# WFT_DSCALE_LINE -- This procedure converts the IRAF data to type double with +# after scaling by the FITS parameters bscale and bzero. + +procedure wft_dscale_line (buf, outbuffer, npix, bscale, bzero, datatype) + +pointer buf # pointer to IRAF image line +double outbuffer[ARB] # FITS integer buffer +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero parameters +int datatype # data type of image + +errchk achtld, altad, amovd, achtrd, achtxd + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call achtld (Meml[buf], outbuffer, npix) + call altad (outbuffer, outbuffer, npix, bzero, bscale) + case TY_REAL: + call achtrd (Memr[buf], outbuffer, npix) + call altad (outbuffer, outbuffer, npix, bzero, bscale) + case TY_DOUBLE: + call amovd (Memd[buf], outbuffer, npix) + call altad (outbuffer, outbuffer, npix, bzero, bscale) + case TY_COMPLEX: + call achtxd (Memx[buf], outbuffer, npix) + call altad (outbuffer, outbuffer, npix, bzero, bscale) + default: + call error (12, "WFT_DSCALE_LINE: Unknown IRAF image type.") + } +end + + +# WFT_LSCALE_LINE -- This procedure converts the IRAF data to type long with +# after scaling by the FITS parameters bscale and bzero. + +procedure wft_lscale_line (buf, outbuffer, npix, bscale, bzero, datatype) + +pointer buf # pointer to IRAF image line +long outbuffer[ARB] # FITS integer buffer +int npix # number of pixels +double bscale, bzero # FITS bscale and bzero parameters +int datatype # data type of image + +errchk altall, altarl, altadl, altaxl + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call altall (Meml[buf], outbuffer, npix, bzero, bscale) + case TY_REAL: + call altarl (Memr[buf], outbuffer, npix, bzero, bscale) + case TY_DOUBLE: + call altadl (Memd[buf], outbuffer, npix, bzero, bscale) + case TY_COMPLEX: + call altaxl (Memx[buf], outbuffer, npix, bzero, bscale) + default: + call error (12, "WFT_LSCALE_LINE: Unknown IRAF image type.") + } +end + + +# WFT_REAL_LINE -- This procedure converts the IRAF image line to type long with +# no scaling. + +procedure wft_real_line (buf, outbuffer, npix, datatype) + +pointer buf # pointer to IRAF image line +real outbuffer[ARB] # buffer of FITS integers +int npix # number of pixels +int datatype # IRAF image datatype + +errchk achtlr, achtdr, amovr, achtxr + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call achtlr (Meml[buf], outbuffer, npix) + case TY_REAL: + call amovr (Memr[buf], outbuffer, npix) + case TY_DOUBLE: + call achtdr (Memd[buf], outbuffer, npix) + case TY_COMPLEX: + call achtxr (Memx[buf], outbuffer, npix) + default: + call error (13, "WFT_REAL_LINE: Unknown IRAF data type.") + } +end + + +# WFT_DOUBLE_LINE -- This procedure converts the IRAF image line to type long +# with no scaling. + +procedure wft_double_line (buf, outbuffer, npix, datatype) + +pointer buf # pointer to IRAF image line +double outbuffer[ARB] # buffer of FITS integers +int npix # number of pixels +int datatype # IRAF image datatype + +errchk achtld, achtrd, amovd, achtxd + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call achtld (Meml[buf], outbuffer, npix) + case TY_REAL: + call achtrd (Memr[buf], outbuffer, npix) + case TY_DOUBLE: + call amovd (Memd[buf], outbuffer, npix) + case TY_COMPLEX: + call achtxd (Memx[buf], outbuffer, npix) + default: + call error (13, "WFT_DOUBLE_LINE: Unknown IRAF data type.") + } +end + + +# WFT_LONG_LINE -- This procedure converts the IRAF image line to type long with +# no scaling. + +procedure wft_long_line (buf, outbuffer, npix, datatype) + +pointer buf # pointer to IRAF image line +long outbuffer[ARB] # buffer of FITS integers +int npix # number of pixels +int datatype # IRAF image datatype + +errchk amovl, achtrl, achtdl, achtxl + +begin + switch (datatype) { + case TY_SHORT, TY_INT, TY_LONG, TY_USHORT: + call amovl (Meml[buf], outbuffer, npix) + case TY_REAL: + call achtrl (Memr[buf], outbuffer, npix) + case TY_DOUBLE: + call achtdl (Memd[buf], outbuffer, npix) + case TY_COMPLEX: + call achtxl (Memx[buf], outbuffer, npix) + default: + call error (13, "WFT_LONG_LINE: Unknown IRAF data type.") + } +end + + +# ALTALL -- Procedure to linearly scale a long vector into a long vector +# using double precision constants to preserve precision. + +procedure altall (a, b, npix, k1, k2) + +long a[ARB] # input vector +long b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +double dtemp +int i + +begin + do i = 1, npix { + dtemp = (a[i] + k1) * k2 + if (dtemp >= 0.0d0) + dtemp = dtemp + 0.5d0 + else + dtemp = dtemp - 0.5d0 + b[i] = dtemp + } +end + + +# ALTARL -- Procedure to linearly scale a real vector into a long vector +# using double precision constants to preserve precision. + +procedure altarl (a, b, npix, k1, k2) + +real a[ARB] # input vector +long b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i +double dtemp + +begin + do i = 1, npix { + dtemp = (a[i] + k1) * k2 + if (dtemp >= 0.0d0) + dtemp = dtemp + 0.5d0 + else + dtemp = dtemp - 0.5d0 + b[i] = dtemp + } +end + + +# ALTADL -- Procedure to linearly scale a double vector into a long vector +# using double precision constants to preserve precision. + +procedure altadl (a, b, npix, k1, k2) + +double a[ARB] # input vector +long b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i +double dtemp + +begin + do i = 1, npix { + dtemp = (a[i] + k1) * k2 + if (dtemp >= 0.0d0) + dtemp = dtemp + 0.5d0 + else + dtemp = dtemp - 0.5d0 + b[i] = dtemp + } +end + + +# ALTAXL -- Procedure to linearly scale a complex vector into a long vector +# using double precision constants to preserve precision. + +procedure altaxl (a, b, npix, k1, k2) + +complex a[ARB] # input vector +long b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i +double dtemp + +begin + do i = 1, npix { + dtemp = (a[i] + k1) * k2 + if (dtemp >= 0.0d0) + dtemp = dtemp + 0.5d0 + else + dtemp = dtemp - 0.5d0 + b[i] = dtemp + } +end + + +# ALTADR -- Procedure to linearly scale a real vector in double precision + +procedure altadr (a, b, npix, k1, k2) + +real a[ARB] # input vector +real b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end + + +# ALTADX -- Procedure to linearly scale a complex vector in double precision + +procedure altadx (a, b, npix, k1, k2) + +complex a[ARB] # input vector +complex b[ARB] # output vector +int npix # number of pixels +double k1, k2 # scaling factors + +int i + +begin + do i = 1, npix + b[i] = (a[i] + k1) * k2 +end + diff --git a/pkg/dataio/fits/fits_wpixels.x b/pkg/dataio/fits/fits_wpixels.x new file mode 100644 index 00000000..7a9389ac --- /dev/null +++ b/pkg/dataio/fits/fits_wpixels.x @@ -0,0 +1,162 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <fset.h> +include "wfits.h" + +# WFT_INIT_WRITE_PIXELS -- This procedure calculates the input and +# output buffer sizes based in the spp and mii data types and allocates +# the required space. + +procedure wft_init_write_pixels (npix_record, spp_type, bitpix, blkfac) + +int npix_record # number of data pixels per record +int spp_type # pixel data type +int bitpix # output bits per pixel +int blkfac # fits blocking factor (0 for disk) + +# entry wft_write_pixels, wft_write_last_record + +int fd # output file descriptor +char buffer[1] # input buffer +int npix # number of pixels in the input buffer +int nrecords # number of FITS records written + +char blank, zero +int ty_mii, ty_spp, npix_rec, nch_rec, len_mii, sz_rec, nchars, n, nrec +int bf, szblk +pointer spp, mii, ip, op + +int sizeof(), miilen(), fstati() +long note() +errchk malloc, mfree, write, miipak, amovc +data mii /NULL/, spp/NULL/ + +begin + # Change input parameters into local variables. + ty_mii = bitpix + ty_spp = spp_type + npix_rec = npix_record + nch_rec = npix_rec * sizeof (ty_spp) + bf = blkfac + blank = ' ' + zero = 0 + + # Compute the size of the mii buffer. + len_mii = miilen (npix_rec, ty_mii) + sz_rec = len_mii * SZ_INT32 + + # Allocate space for the buffers. + if (spp != NULL) + call mfree (spp, TY_CHAR) + call malloc (spp, nch_rec, TY_CHAR) + if (mii != NULL) + call mfree (mii, TY_INT) + call malloc (mii, len_mii, TY_INT) + + op = 0 + nrec = 0 + + return + +# WFT_WRITE_PIXELS -- Wft_wrt_pixels gets an image line and places it in the +# output buffer. When the output buffer is full the data are packed by the mii +# routines and written to the specified output. + +entry wft_write_pixels (fd, buffer, npix) + + nchars = npix * sizeof (ty_spp) + ip = 0 + + repeat { + + # Fill output buffer. + n = min (nch_rec - op, nchars - ip) + call amovc (buffer[1 + ip], Memc[spp + op], n) + ip = ip + n + op = op + n + + # Write output record. + if (op == nch_rec) { + call miipak (Memc[spp], Memi[mii], npix_rec, ty_spp, ty_mii) + iferr (call write (fd, Memi[mii], sz_rec)) { + if (ty_spp == TY_CHAR) { + call printf (" File incomplete: %d logical header") + call pargi (nrec) + call printf (" (2880 byte) records written\n") + call error (18, + "WRT_RECORD: Error writing header record.") + } else { + call printf (" File incomplete: %d logical data") + call pargi (nrec) + call printf (" (2880 byte) records written\n") + call error (19, + "WRT_RECORD: Error writing data record.") + } + } + + nrec = nrec + 1 + op = 0 + } + + } until (ip == nchars) + + return + + +# WFT_WRITE_LAST_RECORD -- Procedure to write the last partially filled record +# to tape. Fill with blanks if header record otherwise fill with zeros. + +entry wft_write_last_record (fd, nrecords) + + if (op != 0) { + + # Blank or zero fill the last record. + n = nch_rec - op + if (ty_spp == TY_CHAR) + call amovkc (blank, Memc[spp + op], n) + else + call amovkc (zero, Memc[spp + op], n) + + # Write last record. + call miipak (Memc[spp], Memi[mii], npix_rec, ty_spp, ty_mii) + iferr (call write (fd, Memi[mii], sz_rec)) { + if (ty_spp == TY_CHAR) { + call printf ("File incomplete: %d logical header") + call pargi (nrec) + call printf (" (2880 byte) records written\n") + call error (18, + "WRT_LAST_RECORD: Error writing last header record.") + } else { + call printf ("File incomplete: %d logical data") + call pargi (nrec) + call printf (" (2880 byte) records written\n") + call error (19, + "WRT_LAST_RECORD: Error writing last data record.") + } + } + + + nrec = nrec + 1 + + # Pad out the record if the blocking is non-standard. + szblk = fstati (fd, F_BUFSIZE) * SZB_CHAR + if ((bf > 0) && mod (szblk, FITS_RECORD) != 0 && + (ty_spp != TY_CHAR)) { + szblk = szblk / SZB_CHAR + n = note (fd) - 1 + if (mod (n, szblk) == 0) + n = 0 + else + n = szblk - mod (n, szblk) + for (op = 1; op <= n; op = op + nch_rec) { + szblk = min (nch_rec, n - op + 1) + call amovkc (zero, Memc[spp], szblk) + #call write (fd, Memc[spp], szblk) + } + } + + } + + nrecords = nrec +end diff --git a/pkg/dataio/fits/fits_write.x b/pkg/dataio/fits/fits_write.x new file mode 100644 index 00000000..edfc9f83 --- /dev/null +++ b/pkg/dataio/fits/fits_write.x @@ -0,0 +1,246 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <error.h> +include <mach.h> +include <imhdr.h> +include "wfits.h" + +# WFT_WRITE_FITZ -- Procedure to convert a single IRAF file to a FITS file. +# If the make_image switch is set the header and pixel files are output +# to the output destination. If the make_image switch is off the header +# is printed to the standard output. + +procedure wft_write_fitz (iraf_file, fits_file, image_number, nimages) + +char iraf_file[ARB] # IRAF file name +char fits_file[ARB] # FITS file name +int image_number # the current image number +int nimages # the number of images + +int fits_fd, chars_rec, nchars, ip, min_lenuserarea +pointer im, sp, fits, envstr + +int mtfile(), mtopen(), open(), fnldir(), envfind(), ctoi() +pointer immap() +errchk immap, imunmap, open, mtopen, close, smark, salloc, sfree +errchk delete, wft_write_header, wft_write_image, wft_data_limits + +include "wfits.com" + +begin + # Open the output file. Check whether the output file is a magtape + # device or a binary file. If the output file is magtape check + # for a legal blocking factor. + + if (image_number == 1 || wextensions == NO) { + if (make_image == NO) + call strcpy ("dev$null", fits_file, SZ_FNAME) + if (mtfile (fits_file) == YES) { + chars_rec = (blkfac * len_record * FITS_BYTE) / (SZB_CHAR * + NBITS_BYTE) + fits_fd = mtopen (fits_file, WRITE_ONLY, chars_rec) + } else + fits_fd = open (fits_file, NEW_FILE, BINARY_FILE) + } + + # Allocate memory for program data structure. + call smark (sp) + call salloc (fits, LEN_FITS, TY_STRUCT) + call salloc (envstr, SZ_FNAME, TY_CHAR) + + # Set up the minimum length of the user area. + if (envfind ("min_lenuserarea", Memc[envstr], SZ_FNAME) > 0) { + ip = 1 + if (ctoi (Memc[envstr], ip, min_lenuserarea) <= 0) + min_lenuserarea = LEN_USERAREA + else + min_lenuserarea = max (LEN_USERAREA, min_lenuserarea) + } else + min_lenuserarea = LEN_USERAREA + + # Write the global header. + if (image_number == 1 && gheader == YES) { + + XTENSION(fits) = EXT_PRIMARY + + # Open a dummy image. + im = immap ("dev$null", NEW_IMAGE, 0) + NAXIS(im) = 0 + PIXTYPE(im) = TY_SHORT + OBJECT(im) = EOS + IRAFNAME(fits) = EOS + + if (long_header == YES || short_header == YES) { + call printf ("Global header") + if (make_image == YES) { + call printf (" -> %s[0] ") + call pargstr (fits_file) + } + if (long_header == YES) + call printf ("\n") + else if (short_header == YES) + call printf (" ") + } + call flush (STDOUT) + + iferr { + call wft_write_header (im, fits, fits_fd) + if (make_image == YES) + call wft_write_image (im, fits, fits_fd) + } then { + + # Print the error message. + call flush (STDOUT) + call erract (EA_WARN) + + # Close files and cleanup. + call imunmap (im) + #if (image_number == nimages || wextensions == NO) + call close (fits_fd) + if (make_image == NO) + call delete (fits_file) + call sfree (sp) + + # Assert an error. + call erract (EA_ERROR) + + } else { + call imunmap (im) + } + + if (long_header == YES) + call printf ("\n") + } + + # Map the input image. Construct the old iraf name by removing + # the directory specification. + # Print the id string. + if (long_header == YES || short_header == YES) { + call printf ("Image %d: %s") + call pargi (image_number) + call pargstr (iraf_file) + } + + # Define whether the image to be written is to be the FITS primary + # data image file or a FITS image extension file. + if (image_number == 1) { + if (wextensions == YES && gheader == YES) + XTENSION(fits) = EXT_IMAGE + else + XTENSION(fits) = EXT_PRIMARY + } else { + if (wextensions == YES) + XTENSION(fits) = EXT_IMAGE + else + XTENSION(fits) = EXT_PRIMARY + } + + im = immap (iraf_file, READ_ONLY, min_lenuserarea) + call imgcluster (iraf_file, IRAFNAME(fits), SZ_FNAME) + nchars = fnldir (IRAFNAME(fits), IRAFNAME(fits), SZ_FNAME) + call strcpy (iraf_file[nchars+1], IRAFNAME(fits), SZ_FNAME) + + # Write header and image. + iferr { + + if (short_header == YES || long_header == YES) { + if (make_image == YES) { + if (wextensions == YES && nimages > 1) { + call printf (" -> %s[%d] ") + call pargstr (fits_file) + if (gheader == YES) + call pargi (image_number) + else + call pargi (image_number - 1) + } else { + call printf (" -> %s ") + call pargstr (fits_file) + } + } + if (long_header == YES) + call printf ("\n") + else if (short_header == YES) + call printf (" ") + } + call flush (STDOUT) + + call wft_write_header (im, fits, fits_fd) + if (make_image == YES) + call wft_write_image (im, fits, fits_fd) + + if (long_header == YES) + call printf ("\n") + + } then { + + # Print the error message. + call flush (STDOUT) + call erract (EA_WARN) + + # Close files and cleanup. + call imunmap (im) + #if (image_number == nimages || wextensions == NO) + call close (fits_fd) + if (make_image == NO) + call delete (fits_file) + call sfree (sp) + + # Assert an error. + call erract (EA_ERROR) + + } else { + + # Close files and cleanup. + call imunmap (im) + if (image_number == nimages || wextensions == NO) + call close (fits_fd) + if (make_image == NO) + call delete (fits_file) + call sfree (sp) + } + +end + + +# WFT_DATA_LIMITS -- Procedure to calculate the maximum and minimum data values +# in an IRAF image. Values are only calculated if the max and min are unknown +# or the image has been modified since the last values were calculated. + +procedure wft_data_limits (im, irafmin, irafmax) + +pointer im # image pointer +real irafmin # minimum picture value +real irafmax # maximum picture value + +int npix +long v[IM_MAXDIM] +pointer buf +real maxval, minval +int imgnlr() +errchk imgnlr + +begin + # Compute the data minimum and maximum if the image values + # are undefined out-of-date. + + if (LIMTIME(im) < MTIME(im) && NAXIS(im) > 0) { + + irafmax = -MAX_REAL + irafmin = MAX_REAL + npix = NAXISN(im,1) + + call amovkl (long(1), v, IM_MAXDIM) + while (imgnlr (im, buf, v) != EOF) { + call alimr (Memr[buf], npix, minval, maxval) + irafmin = min (irafmin, minval) + irafmax = max (irafmax, maxval) + } + + } else { + + irafmax = IM_MAX(im) + irafmin = IM_MIN(im) + + } +end diff --git a/pkg/dataio/fits/mkpkg b/pkg/dataio/fits/mkpkg new file mode 100644 index 00000000..ac5201d0 --- /dev/null +++ b/pkg/dataio/fits/mkpkg @@ -0,0 +1,24 @@ +# Make the RFITS / WFITS Tasks + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + fits_cards.x wfits.com wfits.h <imhdr.h> + fits_params.x wfits.h <time.h> + fits_read.x rfits.com rfits.h <error.h> <fset.h> <imhdr.h>\ + <mach.h> <plset.h> + fits_rheader.x rfits.com rfits.h <ctype.h> <imhdr.h> <imio.h>\ + <mach.h> + fits_rimage.x rfits.com rfits.h <imhdr.h> <fset.h> <mach.h> + fits_rpixels.x <fset.h> <mach.h> <mii.h> + fits_wheader.x wfits.com wfits.h <fset.h> <imhdr.h> <mach.h> + fits_wimage.x wfits.com wfits.h <error.h> <imhdr.h> + fits_wpixels.x wfits.h <fset.h> <mach.h> + fits_write.x <error.h> wfits.com wfits.h <fset.h> <imhdr.h> <mach.h> + fits_files.x <ctype.h> <plset.h> + t_rfits.x rfits.com rfits.h <error.h> <fset.h> + t_wfits.x wfits.com wfits.h <error.h> <fset.h> <mach.h> + ; diff --git a/pkg/dataio/fits/rfits.com b/pkg/dataio/fits/rfits.com new file mode 100644 index 00000000..08f44c0e --- /dev/null +++ b/pkg/dataio/fits/rfits.com @@ -0,0 +1,18 @@ + +# FITS reader common + +int len_record # Length of FITS records in bytes +int data_type # Output data type +real blank # Blank value +real fe # Maximum size in megabytes for scan mode + +# Option flags + +int make_image # Create an IRAF image +int long_header # Print a long header (FITS header cards) +int short_header # Print a short header (Title and size) +int scale # Scale the data +int old_name # Use old IRAF name? + +common /rfitscom/ len_record, data_type, blank, fe, make_image, long_header, + short_header, scale, old_name diff --git a/pkg/dataio/fits/rfits.h b/pkg/dataio/fits/rfits.h new file mode 100644 index 00000000..bab29220 --- /dev/null +++ b/pkg/dataio/fits/rfits.h @@ -0,0 +1,96 @@ +# FITS Definitions + +# The FITS standard readable by the FITS reader using these definitions: +# +# 1. 8 bits / byte +# 2. ASCII character code +# 3. MII integer data format (i.e. 8 bit unsigned integers and 16 and 32 +# bit signed twos complement integers with most significant bytes first.) +# 4. IEEE 32 and 64 bit floating point format +# +# +# The following deviations from the FITS standard are allowed: +# +# 1. The number of FITS bytes per record is normally 2880 or up to 10 times +# 2880 bytes but may be arbitrarily specified by the user. + +# Define the bits per pixel, precision and byte order of the basic FITS types + +define FITS_RECORD 2880 # number of bytes in a standard FITS record + +define FITS_BYTE 8 # Bits in a FITS byte +define FITS_SHORT 16 # Bits in a FITS short +define FITS_LONG 32 # Bits in a FITS long +define FITS_REAL -32 # Bits in a FITS real * -1 +define FITS_DOUBLE -64 # Bits in a FITS double * -1 + +define FITSB_PREC 3 # Decimal digits of precision in a FITS byte +define FITSS_PREC 5 # Decimal digits of precision in a FITS short +define FITSL_PREC 10 # Decimal digits of precision in a FITS long + +define LSBF NO # Least significant byte first + +# Define the basic format of a FITS cardimage + +define LEN_CARD 80 # Length of FITS card in characters +define COL_VALUE 11 # Starting column for parameter values + + +# FITS standards not recognized currently by IRAF. +# +# 1. SIMPLE SIMPLE = 'F' not implemented, file skipped +# 2. GROUPS Group data not currently implemented, file skippped + +# FITS extension currently recognised by IRAF + +define EXT_PRIMARY 1 # recognized and read +define EXT_IMAGE 2 # recognized and read +define EXT_TABLE 3 # recognized and skipped +define EXT_BINTABLE 4 # recognized and skipped +define EXT_UNKNOWN 5 # unrecognized and skipped +define EXT_SPECIAL 6 # undefined + + +# Values for the following quantities are stored in the structure below. + +define LEN_FITS (20 + SZ_FNAME + 1) + +define FITS_BSCALE Memd[P2D($1)] # FITS scaling parameter +define FITS_BZERO Memd[P2D($1+2)] # FITS zero parameter +define BLANK_VALUE Meml[P2L($1+4)] # Blank value +define BLANKS Memi[$1+5] # YES if blank keyword in header +define BITPIX Memi[$1+6] # Bits per pixel (Must be an MII type) +define SCALE Memi[$1+7] # Scale the data ? +define SIMPLE Memi[$1+8] # Standard FITS format +define NRECORDS Memi[$1+9] # Number of FITS logical records +define EXTEND Memi[$1+10] # FITS extensions may be present +define XTENSION Memi[$1+11] # FITS extension type +define PCOUNT Memi[$1+12] # Number of random parameters +define GCOUNT Memi[$1+13] # Number of groups +define GLOBALHDR Memi[$1+14] # Global header may be present +define INHERIT Memi[$1+15] # Inherit global header if present +define IRAFNAME Memc[P2C($1+16)] # Old IRAF name + +# Mapping of additional IRAF header parameters + +define PIXTYPE IM_PIXTYPE($1) +define NBPIX IM_NBPIX($1) +define IRAFMAX IM_MAX($1) +define IRAFMIN IM_MIN($1) +define LIMTIME IM_LIMTIME($1) +define LEN_USERAREA 28800 + +# Mapping of FITS Keywords to IRAF image header + +define NAXIS IM_NDIM($1) +define NAXISN IM_LEN($1,$2) +define OBJECT IM_TITLE($1) +define HISTORY IM_HISTORY($1) +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] # All unrecognized keywords + # are stored here +# Miscellaneous definitions. + +define SZ_OBJECT SZ_IMTITLE +define SZ_HISTORY SZ_IMHIST +define SZ_FCTYPE SZ_CTYPE +define LEN_TYPESTR 8 diff --git a/pkg/dataio/fits/t_rfits.x b/pkg/dataio/fits/t_rfits.x new file mode 100644 index 00000000..06c55ec1 --- /dev/null +++ b/pkg/dataio/fits/t_rfits.x @@ -0,0 +1,216 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <fset.h> +include "rfits.h" + +define NTYPES 7 # the number of image data types + +# RFITS -- Read FITS format data. Further documentation given in rfits.hlp + +procedure t_rfits() + +int inlist, outlist, len_inlist, len_outlist +int file_number, offset, stat, first_file, last_file +pointer sp, infile, file_list, outfile, ext_list, in_fname, out_fname +pointer pl, axes + +bool clgetb(), pl_linenotempty() +#char clgetc() +int rft_get_image_type(), clgeti(), mtfile(), strlen(), btoi(), fntlenb() +int rft_read_fitz(), fntgfnb(), fstati(), mtneedfileno(), fntrfnb() +pointer fntopnb(), rft_flist() +real clgetr(), rft_fe() + +include "rfits.com" + +begin + # Set up the standard output to flush on a newline. + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Allocate working space. + call smark (sp) + call salloc (infile, SZ_FNAME, TY_CHAR) + call salloc (file_list, SZ_LINE, TY_CHAR) + call salloc (outfile, SZ_FNAME, TY_CHAR) + call salloc (ext_list, SZ_LINE, TY_CHAR) + call salloc (in_fname, SZ_FNAME, TY_CHAR) + call salloc (out_fname, SZ_FNAME, TY_CHAR) + call salloc (axes, 2, TY_INT) + + # Get RFITS parameters. + call clgstr ("fits_file", Memc[infile], SZ_FNAME) + long_header = btoi (clgetb ("long_header")) + short_header = btoi (clgetb ("short_header")) + len_record = FITS_RECORD + old_name = btoi (clgetb ("oldirafname")) + make_image = btoi (clgetb ("make_image")) + + # Open the input file list. + call clgstr ("file_list", Memc[ext_list], SZ_LINE) + if (mtfile (Memc[infile]) == YES) { + inlist = NULL + if (mtneedfileno (Memc[infile]) == YES) { + call strcpy (Memc[ext_list], Memc[file_list], SZ_LINE) + } else { + call sprintf (Memc[file_list], SZ_LINE, "1[%s]") + call pargstr (Memc[ext_list]) + } + } else { + inlist = fntopnb (Memc[infile], NO) + len_inlist = fntlenb (inlist) + if (len_inlist > 0) { + if (Memc[ext_list] == EOS) { + call sprintf (Memc[file_list], SZ_LINE, "1-%d[0]") + call pargi (len_inlist) + #call pargstr (Memc[ext_list]) + } else { + call sprintf (Memc[file_list], SZ_LINE, "1-%d[%s]") + call pargi (len_inlist) + call pargstr (Memc[ext_list]) + } + } else { + call sprintf (Memc[file_list], SZ_LINE, "0[%s]") + call pargstr (Memc[ext_list]) + } + } + + # Decode the ranges string. + pl = rft_flist (Memc[file_list], first_file, last_file, len_inlist) + if (pl == NULL || len_inlist <= 0) + call error (1, "T_RFITS: Illegal file/extensions number list") + + # Open the output file list. + if (make_image == YES) { + call clgstr ("iraf_file", Memc[outfile], SZ_FNAME) + if (Memc[outfile] == EOS) { + if (old_name == YES) + call mktemp ("tmp$", Memc[outfile], SZ_FNAME) + else + call error (0, "T_RFITS: Undefined output file name") + } + outlist = fntopnb (Memc[outfile], NO) + len_outlist = fntlenb (outlist) + offset = clgeti ("offset") + } else { + Memc[outfile] = EOS + outlist = NULL + len_outlist = 1 + } + if ((len_outlist > 1) && (len_outlist != len_inlist)) + call error (0, + "T_RFITS: Output and input lists have different lengths") + + # Get the remaining parameters. Use the string in_fname as a + # temporary variable. + #data_type = rft_get_image_type (clgetc ("datatype")) + call clgstr ("datatype", Memc[in_fname], SZ_FNAME) + data_type = rft_get_image_type (Memc[in_fname]) + scale = btoi (clgetb ("scale")) + blank = clgetr ("blank") + + # Get the scan size parameter. + fe = rft_fe (Memc[infile]) + + # Read successive FITS files, convert and write into a numbered + # succession of output IRAF files. + + do file_number = first_file, last_file { + + # Get the next file number. + Memi[axes] = 1 + Memi[axes+1] = file_number + if (! pl_linenotempty (pl, Memi[axes])) + next + + # Get the input file name. + if (inlist != NULL) { + if (fntgfnb (inlist, Memc[in_fname], SZ_FNAME) == EOF) + call error (0, "T_RFITS: Error reading input file name") + } else { + if (mtneedfileno (Memc[infile]) == YES) + call mtfname (Memc[infile], file_number, Memc[in_fname], + SZ_FNAME) + else + call strcpy (Memc[infile], Memc[in_fname], SZ_FNAME) + } + + # Get the output file name. + if (outlist == NULL) { + Memc[out_fname] = EOS + } else if (len_inlist > len_outlist) { + if (fntrfnb (outlist, 1, Memc[out_fname], SZ_FNAME) == EOF) + call strcpy (Memc[outfile], Memc[out_fname], SZ_FNAME) + if (len_inlist > 1) { + call sprintf (Memc[out_fname+strlen(Memc[out_fname])], + SZ_FNAME, "%04d") + call pargi (file_number + offset) + } + } else if (fntgfnb (outlist, Memc[out_fname], SZ_FNAME) == EOF) + call error (0, "T_RFITS: Error reading output file name") + + # Convert FITS file to the output IRAF file. If EOT is reached + # then exit. If an error is detected then print a warning and + # continue with the next file. + + iferr (stat = rft_read_fitz (Memc[in_fname], Memc[out_fname], + pl, file_number)) + call erract (EA_FATAL) + if (stat == EOF) + break + } + + if (inlist != NULL) + call fntclsb (inlist) + if (outlist != NULL) + call fntclsb (outlist) + if (pl != NULL) + call pl_close (pl) + + call sfree (sp) +end + + +# RFT_GET_IMAGE_TYPE -- Convert a character to and IRAF image type. + +int procedure rft_get_image_type (c) + +char c + +int type_codes[NTYPES], i +string types "usilrdx" +int stridx() +data type_codes /TY_USHORT, TY_SHORT, TY_INT, TY_LONG, TY_REAL, + TY_DOUBLE, TY_COMPLEX/ +begin + i = stridx (c, types) + if (i == 0) + return (ERR) + else + return (type_codes[stridx(c,types)]) +end + + +# RFT_FE -- Fetch the maximum file size in MB for tape scanning mode. + +real procedure rft_fe (file) + +char file[ARB] # the input file name + +pointer gty +real fe +int mtfile(), gtygeti() +pointer mtcap() +errchk gtygeti() + +begin + if (mtfile (file) == NO) + return (0.0) + iferr (gty = mtcap (file)) + return (0.0) + iferr (fe = gtygeti (gty, "fe")) + fe = 0.0 + call gtyclose (gty) + return (fe) +end diff --git a/pkg/dataio/fits/t_wfits.x b/pkg/dataio/fits/t_wfits.x new file mode 100644 index 00000000..256b9cde --- /dev/null +++ b/pkg/dataio/fits/t_wfits.x @@ -0,0 +1,253 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <error.h> +include <fset.h> +include "wfits.h" + +# T_WFITS -- This procedure converts a series of IRAF image files to +# FITS image files. + +procedure t_wfits () + +char iraf_files[SZ_FNAME] # list of IRAF images +char fits_files[SZ_FNAME] # list of FITS files +bool newtape # new or used tape ? +char in_fname[SZ_FNAME] # input file name +char out_fname[SZ_FNAME] # output file name +char fextn[SZ_FNAME] # the fits extension + +char ch +int imlist, flist, nimages, nfiles, file_number, addext, index +bool clgetb(), streq() +double clgetd() +int imtopen(), imtlen (), wft_get_bitpix(), clgeti(), imtgetim() +int mtfile(), btoi(), fstati(), fntlenb(), fntgfnb(), mtneedfileno() +int wft_blkfac(), fntrfnb(), strlen(), strldx() +pointer fntopnb() + +include "wfits.com" + +begin + # Flush on a newline if STDOUT has not been redirected. + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Open iraf_files template and determine number of files in list. + call clgstr ("iraf_files", iraf_files, SZ_FNAME) + imlist = imtopen (iraf_files) + nimages = imtlen (imlist) + + # Get the wfits parameters. + if (nimages == 1) + wextensions = NO + else + wextensions = btoi (clgetb ("extensions")) + if (wextensions == NO) + gheader = NO + else + gheader = btoi (clgetb ("global_hdr")) + long_header = btoi (clgetb ("long_header")) + short_header = btoi (clgetb ("short_header")) + make_image = btoi (clgetb ("make_image")) + + # Get the FITS bits per pixel and the FITS logical record size. + bitpix = wft_get_bitpix (clgeti ("bitpix")) + len_record = FITS_RECORD + + # Get the scaling parameters. + scale = btoi (clgetb ("scale")) + if (scale == YES) { + if (clgetb ("autoscale")) + autoscale = YES + else { + bscale = clgetd ("bscale") + bzero = clgetd ("bzero") + autoscale = NO + } + } else { + autoscale = NO + bscale = 1.0d0 + bzero = 0.0d0 + } + + # Get the output file name and type (tape or disk). If no tape file + # number is given for output, the user is asked if the tape is blank + # or contains data. If the tape is blank output begins at BOT, + # otherwise at EOT. + + call clgstr ("fextn", fextn, SZ_FNAME) + ch = '.' + if (make_image == YES) { + call clgstr ("fits_files", fits_files, SZ_FNAME) + if (mtfile (fits_files) == YES) { + flist = NULL + if (mtneedfileno (fits_files) == YES) { + newtape = clgetb ("newtape") + if (newtape) + call mtfname (fits_files, 1, out_fname, SZ_FNAME) + else + call mtfname (fits_files, EOT, out_fname, SZ_FNAME) + } else { + call strcpy (fits_files, out_fname, SZ_FNAME) + newtape = false + } + } else { + flist = fntopnb (fits_files, NO) + nfiles = fntlenb (flist) + if (wextensions == YES && nfiles > 1) + call error (0, + "Only one output FITS extensions file can be written") + if ((nfiles > 1) && (nfiles != nimages)) + call error (0, + "T_WFITS: Input and output lists are not the same length") + } + } else { + fits_files[1] = EOS + flist = NULL + } + + # Get the fits file blocking factor. + blkfac = wft_blkfac (fits_files, clgeti ("blocking_factor")) + + # Loop through the list of input images files. + + file_number = 1 + while (imtgetim (imlist, in_fname, SZ_FNAME) != EOF) { + + # Get the output file name. If single file output to disk, use + # name fits_file. If multiple file output to disk, the file number + # is added to the output file name, if no output name list is + # supplied. If an output name list is supplied then the names + # are extracted one by one from that list. + + if (make_image == YES) { + if (mtfile (fits_files) == YES) { + if (wextensions == NO && file_number == 2) + call mtfname (out_fname, EOT, out_fname, SZ_FNAME) + } else if (nfiles > 1) { + if (fntgfnb (flist, out_fname, SZ_FNAME) == EOF) + call error (0, "Error reading output file name") + if (fextn[1] != EOS) { + addext = OK + index = strldx (ch, out_fname) + if (index > 0) { + if (streq (fextn, out_fname[index+1])) + addext = ERR + else + addext = OK + } + if (addext == OK){ + call strcat (".", out_fname, SZ_FNAME) + call strcat (fextn, out_fname, SZ_FNAME) + } + } + } else { + if (fntrfnb (flist, 1, out_fname, SZ_FNAME) == EOF) + call strcpy (fits_files, out_fname, SZ_FNAME) + if (nimages > 1 && wextensions == NO) { + call sprintf (out_fname[strlen(out_fname)+1], SZ_FNAME, + "%04d") + call pargi (file_number) + } + if (fextn[1] != EOS) { + addext = OK + index = strldx (ch, out_fname) + if (index > 0) { + if (streq (fextn, out_fname[index+1])) + addext = ERR + else + addext = OK + } + if (addext == OK){ + call strcat (".", out_fname, SZ_FNAME) + call strcat (fextn, out_fname, SZ_FNAME) + } + } + } + } + + # Write each output file. + iferr (call wft_write_fitz (in_fname, out_fname, file_number, + nimages)) { + call printf ("Error writing file: %s\n") + call pargstr (out_fname) + call erract (EA_WARN) + break + } else + file_number = file_number + 1 + } + + # Close up the input and output lists. + call clpcls (imlist) + if (flist != NULL) + call fntclsb (flist) +end + + +# WFT_GET_BITPIX -- This procedure fetches the user determined bitpix or ERR if +# the bitpix is not one of the permitted FITS types. + +int procedure wft_get_bitpix (bitpix) + +int bitpix + +begin + switch (bitpix) { + case FITS_BYTE, FITS_SHORT, FITS_LONG, FITS_REAL, FITS_DOUBLE: + return (bitpix) + default: + return (ERR) + } +end + + +# WFT_BLKFAC -- Get the fits tape blocking factor. + +int procedure wft_blkfac (file, ublkfac) + +char file[ARB] # the input file name +int ublkfac # the user supplied blocking factor + +int bs, fb, blkfac +pointer gty +int mtfile(), mtcap(), gtygeti() +errchk mtcap(), gtygeti() + +begin + # Return a blocking factor of 1 if the file is a disk file. + if (mtfile (file) == NO) + return (0) + + # Open the tapecap device entry for the given device, and get + # the device block size and default FITS blocking factor + # parameters. + + iferr (gty = mtcap (file)) + return (max (ublkfac,1)) + iferr (bs = gtygeti (gty, "bs")) { + call gtyclose (gty) + return (max (ublkfac,1)) + } + iferr (fb = max (gtygeti (gty, "fb"), 1)) + fb = 1 + + # Determine whether the device is a fixed or variable blocked + # device. Set the fits blocking factor to the value of the fb + # parameter if device is fixed block or if the user has + # requested the default blocking factor. Set the blocking factor + # to the user requested value if the device supports variable + # blocking factors. + + if (bs == 0) { + if (ublkfac <= 0) + blkfac = fb + else + blkfac = ublkfac + } else + blkfac = fb + + call gtyclose (gty) + + return (blkfac) +end diff --git a/pkg/dataio/fits/wfits.com b/pkg/dataio/fits/wfits.com new file mode 100644 index 00000000..04779ef3 --- /dev/null +++ b/pkg/dataio/fits/wfits.com @@ -0,0 +1,17 @@ +# FITS common block + +double bscale # FITS scaling factor +double bzero # FITS offset factor +int bitpix # Output bits per pixel +int len_record # Record length in FITS bytes +int long_header # Print long header? +int short_header # Print short header? +int make_image # Make a FITS image? +int scale # Scale the data with bzero and bscale? +int autoscale # Allow program to calculate bscale and bzero? +int blkfac # FITS tape blocking factor +int wextensions # Write a FITS extensions file +int gheader # Write a global FITS extensions file header + +common /wfitscom/ bscale, bzero, bitpix, len_record, long_header, short_header, + make_image, scale, autoscale, blkfac, wextensions, gheader diff --git a/pkg/dataio/fits/wfits.h b/pkg/dataio/fits/wfits.h new file mode 100644 index 00000000..a36caa89 --- /dev/null +++ b/pkg/dataio/fits/wfits.h @@ -0,0 +1,128 @@ +# WFITS header file + +# The basic FITS data structure + +define LEN_FITS (44 + SZ_FNAME + 1) + +define BSCALE Memd[P2D($1)] # FITS bscale value +define BZERO Memd[P2D($1+2)] # FITS bzero value +define TAPEMAX Memd[P2D($1+4)] # IRAF tape max +define TAPEMIN Memd[P2D($1+6)] # IRAF tape min +define IRAFMAX Memr[P2R($1+8)] # IRAF image maximum +define IRAFMIN Memr[P2R($1+9)] # IRAF image minimum +define BLANK Meml[P2L($1+10)] # FITS blank value +define FITS_BITPIX Memi[$1+11] # FITS bits per pixel +define DATA_BITPIX Memi[$1+12] # Data bits per pixel +define SCALE Memi[$1+13] # Scale data? +define XTENSION Memi[$1+14] # FITS extension type +define BLANK_STRING Memc[P2C($1+19)] # String containing FITS blank value +define TYPE_STRING Memc[P2C($1+31)] # String containing IRAF type +define IRAFNAME Memc[P2C($1+41)] # IRAF file name + + +# Define the FITS record size + +define FITS_RECORD 2880 # Size of standard FITS record (bytes) + +# Define the supported FITS extensions + +define EXT_PRIMARY 1 # the primary data array +define EXT_IMAGE 2 # the image extension + +# Define the FITS data types + +define FITS_BYTE 8 # Number of bits in a FITS byte +define FITS_SHORT 16 # Number of bits in a FITS short +define FITS_LONG 32 # Number of bits in a FITS long +define FITS_REAL -32 # Number of bits in a FITS real * -1 +define FITS_DOUBLE -64 # Number of bits in a FITS double * -1 + +# Define the FITS precision in decimal digits + +define BYTE_PREC 3 # Precision of FITS byte +define SHORT_PREC 5 # Precision of FITS short +define LONG_PREC 10 # Precision of FITS long + +# Define the FITS blank data values + +define BYTE_BLANK 0.0d0 # Blank value for a FITS byte +define SHORT_BLANK -3.2768d4 # Blank value for a FITS short +define LONG_BLANK -2.147483648d9 # Blank value for a FITS long +#define BYTE_BLANK 0 # Blank value for a FITS byte +#define SHORT_BLANK -32768 # Blank value for a FITS short +#define LONG_BLANK -2147483648 # Blank value for a FITS long + +# Define the FITS integer max and min values + +define BYTE_MAX 2.55d2 # Max value for a FITS byte +define BYTE_MIN 1.0d0 # Min value for a FITS byte +define SHORT_MAX 3.2767d4 # Max value for a FITS short +define SHORT_MIN -3.2767d4 # Min value for a FITS short +define LONG_MAX 2.147483647d9 # Max value for a FITS long +define LONG_MIN -2.147483647d9 # Min value for a FITS long +define PREC_RATIO .99978637d0 # Tape span reduction factor + +# Define the FITS card image parameters + +define LEN_CARD 80 # Length of FITS header card +define LEN_KEYWORD 8 # Length of FITS keyword +define LEN_NAXIS_KYWRD 5 # Length of the NAXIS keyword string +define COL_VALUE 11 # First column of value field + +# Mapping of FITS task keywords to IRAF image header keywords + +define NAXIS IM_NDIM($1) # Number of dimensions +define NAXISN IM_LEN($1, $2) # Length of each dimension +define OBJECT IM_TITLE($1) # Image title +define HISTORY IM_HISTORY($1) # History +define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] # IRAF user area + +define PIXTYPE IM_PIXTYPE($1) # Image pixel type +define NBPIX IM_NBPIX($1) # Number of bad pixels +define LIMTIME IM_LIMTIME($1) # Last modify limits time +define MTIME IM_MTIME($1) # Last modify time +define CTIME IM_CTIME($1) # Create time + +define LEN_USERAREA 28800 # Default user area size + +# Set up a structure for the WFITS parameters + +# Define the required keywords + +define FIRST_CARD 1 # FITS simple/xtension parameter +define SECOND_CARD 2 # FITS bitpix parameter +define THIRD_CARD 3 # FITS naxis parameter + +# Define the optional FITS KEYWORD parameters + +define NOPTIONS 15 # Number of optional keywords + +define KEY_EXTEND 1 # FITS EXTEND keyword +define KEY_PCOUNT 2 # Number of random parameter +define KEY_GCOUNT 3 # Number of groups +define KEY_BSCALE 4 # FITS bscale parameter +define KEY_BZERO 5 # FITS bzero parameter +define KEY_BUNIT 6 # FITS physical units +define KEY_BLANK 7 # FITS value of blank pixel +define KEY_OBJECT 8 # FITS title string +define KEY_ORIGIN 9 # Origin of FITS tape +define KEY_DATE 10 # Date the tape was written +define KEY_IRAFNAME 11 # Root name of IRAF image +define KEY_IRAFMAX 12 # Maximum value of IRAF image +define KEY_IRAFMIN 13 # Minimum value of IRAF image +define KEY_IRAFBP 14 # Bits per pixel in IRAF image +define KEY_IRAFTYPE 15 # IRAF image data type + +define LEN_STRING 8 # Minimum length of a string parameter +define LEN_DATE 19 # Length of the new date string +define LEN_OBJECT 63 # Maximum length of string parameter +define LEN_ALIGN 18 # Maximum length for aligning parameter +define LEN_ORIGIN 9 # Length of origin string +define LEN_BLANK 11 # Length of the blank string +define NDEC_REAL 7 # Precision of real data +define NDEC_DOUBLE 11 # Precision of double precision data + +# Miscellaneous + +define CENTURY 1900 +define NEW_CENTURY 2000 diff --git a/pkg/dataio/import.par b/pkg/dataio/import.par new file mode 100644 index 00000000..ba2792c1 --- /dev/null +++ b/pkg/dataio/import.par @@ -0,0 +1,30 @@ +# IMPORT Task Parameter File +binfiles,s,a,"",,,"The list of input binary files to be read" +images,s,a,"",,,"The list of output IRAF images to be written" +format,s,h,"sense",,,"The type of format to be processed + + INPUT PARAMETERS +" +dims,s,h,"",,,"Input file dimension string" +pixtype,s,h,"",,,"Input pixel type" +interleave,i,h,0,,,"Pixel interleave type" +bswap,s,h,"no","|no|yes|i2|i4||",,"Byte-swap flag" +hskip,i,h,0,,,"Bytes preceeding pixel data to skip" +tskip,i,h,0,,,"Bytes to skip at end of file" +bskip,i,h,0,,,"Bytes between image bands to skip" +lskip,i,h,0,,,"Bytes to skip at font of each line" +lpad,i,h,0,,,"Bytes to skip at end of each line + + OUTPUT PARAMETERS +" +output,s,h,"image","|none|image|list|info|",,"Type of output to generate" +outtype,s,h,"s","|u|s|i|l|r|d||",,"The data type of the output image" +outbands,s,h,"",,,"Output image band expressions" +imheader,s,h,"",,,"File of FITS-like header info to add +" +database,s,h,"dataio$import/images.dat",,,"Format database" +verbose,b,h,no,,,"Verbose output during conversion?" + +# Mode parameter +buffer_size,i,h,64,,,"Number of image lines to buffer in memory" +mode,s,h,"ql",,,"mode parameter" diff --git a/pkg/dataio/import/README b/pkg/dataio/import/README new file mode 100644 index 00000000..20ab02a1 --- /dev/null +++ b/pkg/dataio/import/README @@ -0,0 +1,2 @@ +This directory contains the source code for the IMPORT <something>-to-IRAF +format conversion task. diff --git a/pkg/dataio/import/bltins/README b/pkg/dataio/import/bltins/README new file mode 100644 index 00000000..c15b9cfe --- /dev/null +++ b/pkg/dataio/import/bltins/README @@ -0,0 +1,13 @@ + This directory contains the source code for the 'builtin' formats +converted with IMPORT. Here we implement three formats that require different +levels of processing: the GIF format uses LZW compression and a colormap for +pixel storage and requires the most work, Sun Rasterfiles have various formats +that may require colormap application or RLE decoding, and lastly the X +Window Dump format that fits the generic binary raster model with the exception +of an 8-bit file with a colormap. + Because formats are defined in the data base the user is unaware of +any special processing that occurs unless implementing a new format that +requires partivular handling. In the case of colormap files the example of +XWD can be followed and all that's needed is a routine to read the colormap +from the image. 'Builtin' formats must, however, be declared in the source +import$ipbuiltin.x to route execution to the format-specific code. diff --git a/pkg/dataio/import/bltins/ipcmap.x b/pkg/dataio/import/bltins/ipcmap.x new file mode 100644 index 00000000..ad44a7cf --- /dev/null +++ b/pkg/dataio/import/bltins/ipcmap.x @@ -0,0 +1,76 @@ +include "../import.h" + +# IPCMAP.X -- Procedures for colormap application or lookup. + + +# IP_GRAY_CMAP - Apply the colormap to an array of pixels and convert the +# pixels to grayscale using the NTSC formula. + +procedure ip_gray_cmap (data, len, cmap) + +char data[ARB] #i pixel values +int len #i how many of 'em +pointer cmap #i colormap pointer + +int i +short val, ip_gcmap_val() + +begin + do i = 1, len { + val = data[i] + 1 + data[i] = ip_gcmap_val (val, cmap) + } +end + + +# IP_GCMAP_VAL - Apply the colormap to a single pixel and convert the +# result to grayscale using the NTSC formula. + +short procedure ip_gcmap_val (pix, cmap) + +char pix #i pixel value +pointer cmap #i colormap pointer + +short val + +begin + val = (R_COEFF * CMAP(cmap,IP_RED,pix) + + G_COEFF * CMAP(cmap,IP_GREEN,pix) + + B_COEFF * CMAP(cmap,IP_BLUE,pix)) + return (val) +end + + +# IP_RGB_VAL - Given a grayscale value figure out what the requested color +# component is from the colormap. + +short procedure ip_rgb_val (pix, cmap, color) + +char pix #i pixel value +pointer cmap #i colormap pointer +int color #i requested color + +short i, val + +begin + # Need to optimize this later... For now just compute the colormap + # grayscale values until we find a match and use the index. + i = 0 + val = -1 + while (val != pix && i <= 256) { + i = i + 1 + val = (R_COEFF * CMAP(cmap,IP_RED,i) + + G_COEFF * CMAP(cmap,IP_GREEN,i) + + B_COEFF * CMAP(cmap,IP_BLUE,i)) + } + + switch (color) { + case IP_RED: + val = CMAP(cmap,IP_RED,i-1) + case IP_GREEN: + val = CMAP(cmap,IP_GREEN,i-1) + case IP_BLUE: + val = CMAP(cmap,IP_BLUE,i-1) + } + return (val) +end diff --git a/pkg/dataio/import/bltins/ipgif.x b/pkg/dataio/import/bltins/ipgif.x new file mode 100644 index 00000000..a7394e18 --- /dev/null +++ b/pkg/dataio/import/bltins/ipgif.x @@ -0,0 +1,883 @@ +include "../import.h" + + +# IPGIF.X - Source file for the GIF builtin format converter. + + +# Define the GIF data structure +define MAX_CODE_ENTRIES 4096 # because LZW has 12 bit max +define SZ_GIFSTRUCT 35 +define SZ_GIFCODE 280 +define SZ_GIFEXTN 256 +define SZ_GIFSTACK (2*MAX_CODE_ENTRIES+2) +define SZ_GIFCTAB (2*MAX_CODE_ENTRIES+2) + +define GIF_FD Memi[$1] # GIF file descriptor +define GIF_WIDTH Memi[$1+1] # Screen width +define GIF_HEIGHT Memi[$1+2] # Screen height +define GIF_CP Memi[$1+3] # Colormap pointer +define GIF_BITPIX Memi[$1+4] # Bits per pixel +define GIF_COLRES Memi[$1+5] # Color resolution +define GIF_BACKGROUND Memi[$1+6] # background color (unused?) +define GIF_ASPECT Memi[$1+7] # Aspect ratio +define GIF_IMNUM Memi[$1+8] # Image number +define GIF_CMAP Memi[$1+9] # Global colormap (ptr) + +define GIF_EXTBP Memi[$1+10] # Extension buffer (ptr) +define GIF_CODEP Memi[$1+11] # Code table buffer (ptr) +define GIF_CTABP Memi[$1+12] # Code table (ptr) +define GIF_STACKP Memi[$1+13] # Stack (ptr) +define GIF_CURBIT Memi[$1+14] # Decoder var +define GIF_LASTBIT Memi[$1+15] # Decoder var +define GIF_DONE Memi[$1+16] # Decoder var +define GIF_LASTBYTE Memi[$1+17] # Decoder var +define GIF_ZERO_DATABLOCK Memi[$1+18] # Decoder var +define GIF_SP Memi[$1+19] # stack pointer + +define GIF_CLEAR_CODE Memi[$1+20] # LZW clear code +define GIF_END_CODE Memi[$1+21] # LZW end code +define GIF_FIRST_CODE Memi[$1+22] # LZW decoder var +define GIF_OLD_CODE Memi[$1+23] # LZW decoder var +define GIF_MAX_CODE Memi[$1+24] # LZW free code +define GIF_MAX_CODE_SIZE Memi[$1+25] # LZW upper limit +define GIF_CODE_SIZE Memi[$1+26] # LZW current code size +define GIF_SET_CODE_SIZE Memi[$1+27] # LZW input code size +define GIF_FRESH Memi[$1+28] # LZW init var + +# The following are used for GIF89a only. +define GIF_TRANSPARENT Memi[$1+30] # Transparent Color Index +define GIF_DELAYTIME Memi[$1+31] # Delay time +define GIF_INPUTFLAG Memi[$1+32] # User input flag +define GIF_DISPOSAL Memi[$1+33] # Disposal Method + +# Array macros. +define CODEBUF Memc[GIF_CODEP($1)+$2] +define EXTBUF Memc[GIF_EXTBP($1)+$2] +define CODETAB Memc[GIF_CTABP($1)+($2*MAX_CODE_ENTRIES)+$3] +define STACK Memc[GIF_STACKP($1)+$2] + +#--------------------------------------------------------------------------- + +define INTERLACE 040X # Image descriptor flags +define LOCAL_COLORMAP 080X + +# Define the flags for the GIF89a extension blocks. +define GE_PLAINTEXT 001X # Plain Text Extension +define GE_APPLICATION 0FFX # Application Extension +define GE_COMMENT 0FEX # Comment Extension +define GE_GCONTROL 0F9X # Graphics Control Extension + +define DEBUG false +define VDEBUG false + + +# IP_GIF - Read and process a GIF format file into an IRAF image. + +procedure ip_gif (ip, fname, info_only, verbose) + +pointer ip #i import struct pointer +char fname[ARB] #i file name +int info_only #i print out image info only? +int verbose #i verbosity flag + +pointer gif +int fd +int bitpix, use_global_cmap, interlace +int width, height, version +char ch +short sig[7], screen[12] + +pointer gif_open() +int btoi(), strncmp(), gif_rdbyte(), gif_getbytes() +int shifti() + +long filepos +common /gifcom/ filepos + +begin + # Allocate the gif struct pointer. + gif = gif_open() + GIF_FD(gif) = IP_FD(ip) + fd = GIF_FD(gif) + + # The GIF signature is verified in the database file but check it + # here anyway. + filepos = 1 + call ip_lseek (fd, BOF) + if (gif_getbytes(fd, sig, 6) != OK) + call error (0, "Error reading GIF magic number.") + if (strncmp(sig[4],"87a",3) == 0) + version = 87 + else if (strncmp(sig[4],"89a",3) == 0) + version = 89 + else + call error (0, "Bad version: File is not a GIF 87a or 89A") + + # Now read the screen descriptor. + if (gif_getbytes(fd, screen, 7) != OK) + call error (0, "Error reading screen descriptor.") + + GIF_WIDTH(gif) = screen[1] + (256 * screen[2]) + GIF_HEIGHT(gif) = screen[3] + (256 * screen[4]) + GIF_BITPIX(gif) = shifti (2, and(int(screen[5]),07X)) + GIF_COLRES(gif) = shifti (and(int(screen[5]), 070X), -3) + 1 + GIF_BACKGROUND(gif) = screen[6] + GIF_ASPECT(gif) = screen[7] + if (DEBUG) { + call eprintf ("w:%d h:%d bpix:%d ncol:%d bkg:%d asp:%d\n") + call pargi(GIF_WIDTH(gif)); call pargi(GIF_HEIGHT(gif)) + call pargi(GIF_BITPIX(gif)); call pargi(GIF_COLRES(gif)) + call pargi(GIF_BACKGROUND(gif)); call pargi(GIF_ASPECT(gif)) + call flush (STDERR) + } + + # We'll set the buffer size to the full image to speed processing. + IP_SZBUF(ip) = GIF_HEIGHT(gif) + + # See if we have a global colormap. + if (and (int(screen[5]), LOCAL_COLORMAP) > 0) + call gif_rdcmap (gif, GIF_BITPIX(gif), GIF_CMAP(gif)) + IP_CMAP(ip) = GIF_CMAP(gif) + + # Now process the rest of the image blocks. + GIF_IMNUM(gif) = 0 + repeat { + if (gif_rdbyte(fd, ch) != OK) { + call error (0, "Bad data read.") + } + + if (ch == ';') { # GIF terminator + break + } + + if (ch == '!') { # Extension block + # Read the extension function code. + if (gif_rdbyte(fd, ch) != OK) + call error (0, "Bad data read.") + call gif_extension (gif, ch, IP_VERBOSE(ip)) + next + } + + if (ch != ',') { # not a valid start character + if (ch != '\0') { # quietly allow a NULL block + call eprintf ("Ignoring bogus start char 0x%02x.") + call pargc (ch) + } + next + } + + # Read the current image descriptor block. There may be more + # than one image in a file so we'll just copy each image into + # a separate band of the output image (should be rare). + GIF_IMNUM(gif) = GIF_IMNUM(gif) + 1 + if (gif_getbytes (fd, screen, 9) != OK) + call error (0, "Bad scene descriptor") + + # See if this image has a local colormap. There supposedly aren't + # a lot of files that use this (GIF89a only) but we'll read it + # anyway so we don't get stung on file positioning. + if (and (int(screen[9]), LOCAL_COLORMAP) == LOCAL_COLORMAP) + use_global_cmap = NO + else + use_global_cmap = YES + + # Unpack the image descriptor into useful things. + bitpix = shifti (1, (and (int(screen[9]), 07X) + 1)) + interlace = btoi (and (int(screen[9]), INTERLACE) == INTERLACE) + width = screen[5] + (screen[6] * 256) + height = screen[7] + (screen[8] * 256) + if (DEBUG) { + call eprintf ("global_cmap:%d bitpix:%d ") + call pargi(use_global_cmap); call pargi(bitpix) + call eprintf ("interlace:%d w:%d h:%d\n") + call pargi(interlace); call pargi(width); call pargi(height) + } + + if (info_only == NO) { + if (use_global_cmap == NO) { + # Process the image with a local colormap. + call gif_rdcmap (gif, bitpix, GIF_CMAP(gif)) + call gif_read_image (ip, gif, width, height, + GIF_CMAP(gif), interlace) + } else { + # Process the image with the global colormap. + call gif_read_image (ip, gif, width, height, + GIF_CMAP(gif), interlace) + } + } else { + call ip_gif_info (ip, fname, version, width, height, + GIF_BITPIX(gif), use_global_cmap, interlace, verbose) + break + } + } + + # Clean up. + call gif_close (gif) + IP_CMAP(ip) = NULL +end + + +# IP_GIF_INFO - Print information about the GIF file. + +procedure ip_gif_info (ip, fname, version, width, height, colres, global, + interlace, verbose) + +pointer ip #i task struct pointer +char fname[ARB] #i file name +int version #i GIF version +int width, height #i image dimensions +int colres #i number of colormap entries +int global #i image has global colormap +int interlace #i image is interlaced +int verbose #i verbosity flag + +begin + # If not verbose print a one-liner. + if (verbose == NO) { +# call printf ("Input file:\n\t") + call printf ("%s: %20t%d x %d \t\tCompuServe GIF %da format file\n") + call pargstr (fname) + call pargi (width) + call pargi (height) + call pargi (version) + + # Print out the format comment if any. +# if (IP_COMPTR(ip) != NULL) { +# if (COMMENT(ip) != '\0') { +# call printf ("%s\n") +# call pargstr (COMMENT(ip)) +# } +# call strcpy ("\0", COMMENT(ip), SZ_LINE) +# } + return + } + + # Print a more verbose description. + call printf ("%s: %20tCompuServe GIF %da Format File\n") + call pargstr (fname) + call pargi (version) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + + call printf ("%20tResolution:%38t%d x %d\n") + call pargi (width) + call pargi (height) + + call printf ("%20tPixel storage: %38t%s\n") + if (interlace == YES) + call pargstr ("Interlaced order") + else + call pargstr ("Sequential order") + + call printf ("%20tByte Order: %38t%s\n") + call pargstr ("LSB first") + + call printf ("%20tType: %38t%s\n") + call pargstr ("8-bit Color indexed") + + call printf ("%20t%s Colormap: %38t%d entries\n") + if (global == YES) + call pargstr ("Global") + else + call pargstr ("Local") + call pargi (colres) + + call printf ("%20tCompression: %38t%s\n") + call pargstr ("Lempel-Ziv and Welch (LZW)") +end + + +# GIF_OPEN - Open the GIF structure descriptor. + +pointer procedure gif_open () + +pointer gif + +begin + iferr (call calloc (gif, SZ_GIFSTRUCT, TY_STRUCT)) + call error (0, "Error allocating GIF structure.") + + # Allocate the extension and code buffers. + iferr (call calloc (GIF_CODEP(gif), SZ_GIFCODE, TY_CHAR)) + call error (0, "Error allocating GIF code buffer pointer.") + iferr (call calloc (GIF_EXTBP(gif), SZ_GIFEXTN, TY_CHAR)) + call error (0, "Error allocating GIF extension pointer.") + iferr (call calloc (GIF_CTABP(gif), SZ_GIFCTAB, TY_CHAR)) + call error (0, "Error allocating code table pointer.") + iferr (call calloc (GIF_STACKP(gif), SZ_GIFSTACK, TY_CHAR)) + call error (0, "Error allocating GIF stack pointer.") + + # Initialize some of the variables to non-zero values. + GIF_ZERO_DATABLOCK(gif) = NO + GIF_TRANSPARENT(gif) = -1 + GIF_DELAYTIME(gif) = -1 + GIF_INPUTFLAG(gif) = -1 + + return (gif) +end + + +# GIF_CLOSE - Close the GIF structure descriptor. + +procedure gif_close (gif) + +pointer gif #i GIF struct pointer + +begin + call mfree (GIF_STACKP(gif), TY_CHAR) + call mfree (GIF_CTABP(gif), TY_CHAR) + call mfree (GIF_EXTBP(gif), TY_CHAR) + call mfree (GIF_CODEP(gif), TY_CHAR) + + if (GIF_CMAP(gif) != NULL) + call mfree (GIF_CMAP(gif), TY_CHAR) + call mfree (gif, TY_STRUCT) +end + + +# GIF_READ_IMAGE - Read the image raster from the file. Decompress the +# LZW compressed data stream into 8-bit pixels. + +procedure gif_read_image (ip, gif, width, height, cmap, interlace) + +pointer ip #i task struct pointer +pointer gif #i GIF struct pointer +int width, height #i image dimensions +pointer cmap #i colormap pointer +int interlace #i interlace flag + +pointer im, op, out, data +char csize, pix, val +int i, v, xpos, ypos, pass +int nlines, line, percent + +pointer ip_evaluate() +int gif_rdbyte(), gif_lzw_rdbyte() +short ip_gcmap_val() + +begin + # Get the initial code_size for the compression routines. + if (gif_rdbyte(GIF_FD(gif), csize) != OK) + call error (0, "EOF or read error on image data.") + call gif_lzw_init (gif, csize) + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + im = IP_IM(ip) + op = PTYPE(ip,GIF_IMNUM(gif)) + call malloc (data, width, TY_CHAR) + IO_DATA(op) = data + IO_NPIX(op) = width + + # Get the pixels. + xpos = 0 + ypos = 0 + pass = 0 + nlines = 0 + percent = 0 + repeat { + v = gif_lzw_rdbyte (gif) + if (v < 0) + break # at the EOF + else { + if (cmap != NULL && IP_USE_CMAP(ip) == YES) { + # Apply the colormap since this is just an index. + val = v + 1 + pix = ip_gcmap_val (val, cmap) + } else + pix = char (v) + Memc[data+xpos] = pix # assign the pixel + } + + xpos = xpos + 1 + if (xpos == width) { + xpos = 0 + nlines = nlines + 1 + + # Evaluate outbands expression. + do i = 1, IP_NBANDS(ip) { + out = ip_evaluate (ip, O_EXPR(ip,i)) + + # Write bands to output image + if (IP_OUTPUT(ip) != IP_NONE) { + line = ypos + 1 + call ip_wrline (ip, im, out, GIF_WIDTH(gif), line, + (GIF_IMNUM(gif)-1)*IP_NBANDS(ip)+i) + } + call evvfree (out) + } + + # Print percent done if being verbose + if (IP_VERBOSE(ip) == YES) { + if (nlines * 100 / height >= percent + 10) { + percent = percent + 10 + call printf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDOUT) + } + } + + # if the image is interlaced adjust the line number accordingly, + # otherwise just increment it. + if (interlace == YES) { + switch (pass) { + case 0, 1: + ypos = ypos + 8 + case 2: + ypos = ypos + 4 + case 3: + ypos = ypos + 2 + } + + if (ypos >= height) { + pass = pass + 1 + switch (pass) { + case 1: + ypos = 4 + case 2: + ypos = 2 + case 3: + ypos = 1 + } + } + } else { + # Non-interlaced GIF so just increment the line number. + ypos = ypos + 1 + } + } + } + + if (IP_VERBOSE(ip) == YES) { + call printf (" Status: Done \n") + call flush (STDOUT) + } + + # Clean up the data pointer. + call mfree (data, TY_CHAR) +end + + +# GIF_RDCMAP - Read a colormap (local or global) from the GIF file. + +procedure gif_rdcmap (gif, ncolors, cmap) + +pointer gif #i GIF struct pointer +int ncolors #i number of colors to read +pointer cmap #u local or global colormap ptr + +int i +char rgb[3] +int gif_getbytes() + +begin + if (cmap == NULL) + iferr (call calloc (cmap, 3*CMAP_SIZE, TY_CHAR)) + call error (0, "Error allocating color map.") + + do i = 1, ncolors { + # Read RGB colors. + if (gif_getbytes (GIF_FD(gif), rgb, 3) != OK) + call error (0, "Bad GIF colormap - not enough colors.") + + # Load the colormap. + CMAP(cmap,IP_RED,i) = rgb[1] + CMAP(cmap,IP_GREEN,i) = rgb[2] + CMAP(cmap,IP_BLUE,i) = rgb[3] + } +end + + +# GIF_EXTENSION - Process a GIF extension block. For now we'll just ignore +# these when converting the image but read the data blocks anyway. We should +# still be able to read the image but won't take advantage of the GIF89a +# extensions. + +procedure gif_extension (gif, label, verbose) + +pointer gif #i Gif struct pointer +char label #i GIF extension label +int verbose #i print verbose info? + +pointer sp, buf +int val +int and(), gif_get_data_block() + +begin + call smark (sp) + call salloc (buf, SZ_GIFCODE, TY_CHAR) + + switch (label) { + case GE_PLAINTEXT: # Plain Text Extension + if (verbose == YES) { + call eprintf ("Warning: Ignoring a Plain Text Extension.\n") + call flush (STDERR) + } + case GE_APPLICATION: # Application Extension + if (verbose == YES) { + call eprintf ("Warning: Ignoring an Application Extension.\n") + call flush (STDERR) + } + case GE_COMMENT: # Comment Extension + # Simply print out the comment. + while (gif_get_data_block (gif, Memc[buf]) != 0) { + if (verbose == YES) { + call printf ("Comment: %s\n") + call pargstr (Memc[buf]) + } + } + call sfree (sp) + return + case GE_GCONTROL: # Graphic Control Extension + # Process the graphic control block. + val = gif_get_data_block (gif, Memc[buf]) + GIF_DISPOSAL(gif) = and (int(Memc[buf]/4), 07X) + GIF_INPUTFLAG(gif) = and (int(Memc[buf]/2), 01X) + GIF_DELAYTIME(gif) = Memc[buf+1] + (256 * Memc[buf+2]) + if (and(int(Memc[buf]),01X) == 1) + GIF_TRANSPARENT(gif) = Memc[buf+3] + + while (gif_get_data_block (gif, Memc[buf]) != 0) + ; + + call sfree (sp) + return + default: + call eprintf ("Warning: Unknown extension label (0x%02x).\n") + call pargc (label) + call flush (STDERR) + } + + # If we get here then we've ignored an extension but still need to + # eat the data blocks. + while (gif_get_data_block (gif, Memc[buf]) != 0) + ; + + call sfree (sp) +end + + +# GIF_LZW_INIT - Initialize the LZW decompression variables. + +procedure gif_lzw_init (gif, input_code_size) + +pointer gif #i GIF struct pointer +char input_code_size #i input code size + +int i, shifti() + +begin + GIF_SET_CODE_SIZE(gif) = input_code_size + GIF_CODE_SIZE(gif) = GIF_SET_CODE_SIZE(gif) + 1 + GIF_CLEAR_CODE(gif) = shifti (1, GIF_SET_CODE_SIZE(gif)) + GIF_END_CODE(gif) = GIF_CLEAR_CODE(gif) + 1 + GIF_MAX_CODE_SIZE(gif) = 2 * GIF_CLEAR_CODE(gif) + GIF_MAX_CODE(gif) = GIF_CLEAR_CODE(gif) + 2 + + GIF_CURBIT(gif) = 0 # initialize the code vars + GIF_LASTBIT(gif) = 0 + GIF_DONE(gif) = NO + + GIF_FRESH(gif) = YES + + # Initialize the code table. + for (i = 0; i < GIF_CLEAR_CODE(gif); i=i+1) { + CODETAB(gif,0,i) = 0 + CODETAB(gif,1,i) = i + } + for (; i < MAX_CODE_ENTRIES; i=i+1) { + CODETAB(gif,0,i) = 0 + CODETAB(gif,1,0) = 0 + } + + GIF_SP(gif) = 0 +end + + + +# GIF_LZW_RDBYTE - + +int procedure gif_lzw_rdbyte (gif) + +pointer gif #i GIF struct pointer + +pointer sp, buf +int i, count +int code, incode + +int gif_get_code(), gif_get_data_block() + +begin + if (GIF_FRESH(gif) == YES) { + GIF_FRESH(gif) = NO + repeat { + GIF_OLD_CODE(gif) = gif_get_code (gif, GIF_CODE_SIZE(gif)) + GIF_FIRST_CODE(gif) = GIF_OLD_CODE(gif) + } until (GIF_FIRST_CODE(gif) != GIF_CLEAR_CODE(gif)) + return (GIF_FIRST_CODE(gif)) + } + + if (GIF_SP(gif) > 0) { + GIF_SP(gif) = GIF_SP(gif) - 1 + return (STACK(gif,GIF_SP(gif))) + } + + code = gif_get_code (gif, GIF_CODE_SIZE(gif)) + while (code >= 0) { + + # The Clear Code sets everything back to its initial value, then + # reads the immediately subsequent code as uncompressed data. + if (code == GIF_CLEAR_CODE(gif)) { + for (i = 0; i < GIF_CLEAR_CODE(gif); i=i+1) { + CODETAB(gif,0,i) = 0 + CODETAB(gif,1,i) = i + } + for ( ; i < MAX_CODE_ENTRIES; i=i+1) { + CODETAB(gif,0,i) = 0 + CODETAB(gif,1,i) = 0 + } + GIF_CODE_SIZE(gif) = GIF_SET_CODE_SIZE(gif) + 1 + GIF_MAX_CODE_SIZE(gif) = 2 * GIF_CLEAR_CODE(gif) + GIF_MAX_CODE(gif) = GIF_CLEAR_CODE(gif) + 2 + GIF_SP(gif) = 0 + GIF_OLD_CODE(gif) = gif_get_code (gif, GIF_CODE_SIZE(gif)) + GIF_FIRST_CODE(gif) = GIF_OLD_CODE(gif) + return (GIF_FIRST_CODE(gif)) + + # If this is the End Code we'll clean up a little before returning. + } else if (code == GIF_END_CODE(gif)) { + if (GIF_ZERO_DATABLOCK(gif) == YES) + return (ERR) + + call smark (sp) + call salloc (buf, 260, TY_CHAR) + + repeat { + count = gif_get_data_block (gif, Memc[buf]) + } until (count <= 0) + + if (count != 0) { + call eprintf ( + "Missing EOD in data stream (common occurance)") + } + call sfree (sp) + return (ERR) + } + + # Must be data so save it in incode. + incode = code + + # If it's greater or equal than the Free Code it's not in the hash + # table yet, repeat the last character decoded. + if (code >= GIF_MAX_CODE(gif)) { + STACK(gif, GIF_SP(gif)) = GIF_FIRST_CODE(gif) + GIF_SP(gif) = GIF_SP(gif) + 1 + code = GIF_OLD_CODE(gif) + } + + while (code >= GIF_CLEAR_CODE(gif)) { + STACK(gif, GIF_SP(gif)) = CODETAB(gif,1,code) + GIF_SP(gif) = GIF_SP(gif) + 1 + if (code == CODETAB(gif,0,code)) + call error (0, "Circular GIF code table entry.") + code = CODETAB(gif,0,code) + } + + GIF_FIRST_CODE(gif) = CODETAB(gif,1,code) + STACK(gif, GIF_SP(gif)) = GIF_FIRST_CODE(gif) + GIF_SP(gif) = GIF_SP(gif) + 1 + + if (VDEBUG) { + call eprintf("code=%d gmax=%d gmaxsz=%d 4096 old:%d frst:%d\n") + call pargi(code) ; call pargi(GIF_MAX_CODE(gif)) + call pargi(GIF_MAX_CODE_SIZE(gif)) + call pargi(GIF_OLD_CODE(gif)) + call pargi(GIF_FIRST_CODE(gif)) + } + + # Point to the next slot in the table. If we exceed the current + # MaxCode value, increment the code size unless it's already 12. + # If it is, do nothing: the next code decompressed better be CLEAR + + code = GIF_MAX_CODE(gif) + if (code < MAX_CODE_ENTRIES) { + CODETAB(gif,0,code) = GIF_OLD_CODE(gif) + CODETAB(gif,1,code) = GIF_FIRST_CODE(gif) + GIF_MAX_CODE(gif) = GIF_MAX_CODE(gif) + 1 + if ((GIF_MAX_CODE(gif) >= GIF_MAX_CODE_SIZE(gif)) && + (GIF_MAX_CODE_SIZE(gif) < MAX_CODE_ENTRIES)) { + GIF_MAX_CODE_SIZE(gif) = GIF_MAX_CODE_SIZE(gif) * 2 + GIF_CODE_SIZE(gif) = GIF_CODE_SIZE(gif) + 1 + } + } + + GIF_OLD_CODE(gif) = incode + + if (GIF_SP(gif) > 0) { + GIF_SP(gif) = GIF_SP(gif) - 1 + return (STACK(gif,GIF_SP(gif))) + } + + code = gif_get_code (gif, GIF_CODE_SIZE(gif)) + } + return code +end + + +# GIF_GET_CODE - Fetch the next code from the raster data stream. The codes +# can be any length from 3 to 12 bits, packed into 8-bit bytes, so we have to +# maintain our location in the Raster array as a BIT Offset. We compute the +# byte Offset into the raster array by dividing this by 8, pick up three +# bytes, compute the bit Offset into our 24-bit chunk, shift to bring the +# desired code to the bottom, then mask it off and return it. Simple. + +int procedure gif_get_code (gif, code_size) + +pointer gif #i GIF struct pointer +int code_size #i op code size + +int i, j, count, ret +int val1, val2 +int btoi(), and(), shifti(), ori () +int gif_get_data_block() + +begin + # See if processing the next code will overflow our buffer. If so + # we get the next control block from the stream. + if ( (GIF_CURBIT(gif) + code_size) >= GIF_LASTBIT(gif)) { + if (GIF_DONE(gif) == YES) { + if (GIF_CURBIT(gif) >= GIF_LASTBIT(gif)) { + call error (0, "GIF_GET_CODE: Ran out of bits.\n") + return (ERR) + } + } + + CODEBUF(gif,0) = CODEBUF(gif,GIF_LASTBYTE(gif)-2) + CODEBUF(gif,1) = CODEBUF(gif,GIF_LASTBYTE(gif)-1) + + count = gif_get_data_block (gif, CODEBUF(gif,2)) + if (count == 0) + GIF_DONE(gif) = YES + + GIF_LASTBYTE(gif) = 2 + count + GIF_CURBIT(gif) = (GIF_CURBIT(gif) - GIF_LASTBIT(gif)) + 16 + GIF_LASTBIT(gif) = (2 + count) * 8 + } + + # for (i = GIF_CURBIT(gif), j = 0; j < code_size; ++i, ++j) + # ret |= ((buf[ i / 8 ] & (1 << (i % 8))) != 0) << j; + + i = GIF_CURBIT(gif) + j = 0 + ret = 0 + while (j < code_size) { + val1 = btoi ( and (int(CODEBUF(gif,i/8)), shifti(1,mod(i,8))) != 0 ) + val2 = shifti (val1, j) + ret = ori (ret, val2) + i = i + 1 + j = j + 1 + } + + GIF_CURBIT(gif) = GIF_CURBIT(gif) + code_size + if (VDEBUG) { + call eprintf (": returning %d\n");call pargi(ret);call flush(STDERR) + } + + return (ret) +end + + +# GIF_GET_DATA_BLOCK - Get the next block of GIF data from the data stream so +# it can be converted to raster data. + +int procedure gif_get_data_block (gif, buf) + +pointer gif #i GIF struct pointer +char buf[ARB] #o data block + +char count +int nb, btoi() +int gif_rdbyte(), gif_getbytes() + +begin + if (gif_rdbyte (GIF_FD(gif), count) != OK) { + call error (0, "error in getting DataBlock size") + return (ERR) + } + + GIF_ZERO_DATABLOCK(gif) = btoi (count == 0) + if (VDEBUG) { + call eprintf ("getDataBlock: count = %d "); call pargs(count) } + nb = count + if ((count != 0) && (gif_getbytes(GIF_FD(gif), buf, nb) != OK)) { + call error (0, "error in reading DataBlock") + return (ERR) + } + return count +end + + + +# Byte I/O routines. We use the normal IMPORT procedures but localize the code +# here to make it easier to keep track of the current file position (in bytes). + +# GIF_RDBYTE - Read a single byte at the current offset from the file. + +int procedure gif_rdbyte (fd, val) + +int fd #i file descriptor +char val #o byte read + +short ip_getb() + +long filepos +common /gifcom/ filepos + +begin + iferr (val = ip_getb (fd, filepos)) + return (ERR) + + filepos = filepos + 1 + call ip_lseek (fd, filepos) + + return (OK) +end + + +# GIF_GETBYTES - Read an array of bytes from the file at the current offset. + +int procedure gif_getbytes (fd, buffer, len) + +int fd #i file descriptor +char buffer[ARB] #o output buffer +int len #i no. of bytes to read + +pointer sp, bp + +long filepos +common /gifcom/ filepos + +begin + call smark (sp) + call salloc (bp, len+1, TY_CHAR) + call aclrc (Memc[bp], len+1) + + call ip_agetb (fd, bp, len) # read the bytes + call amovc (Memc[bp], buffer, len) # copy to output buffer + filepos = filepos + len + call ip_lseek (fd, filepos) + + call sfree (sp) + return (OK) +end diff --git a/pkg/dataio/import/bltins/ipras.x b/pkg/dataio/import/bltins/ipras.x new file mode 100644 index 00000000..100ca6dc --- /dev/null +++ b/pkg/dataio/import/bltins/ipras.x @@ -0,0 +1,504 @@ +include <mach.h> +include "../import.h" + + +# IPRAS.X - Source file for the IMPORT task rasterfile builtin format. + + +define SZ_RASHDR 13 +define RAS_MAGIC Memi[$1] # Magic number +define RAS_WIDTH Memi[$1+1] # Image width (pixels per line) +define RAS_HEIGHT Memi[$1+2] # Image height (number of lines) +define RAS_DEPTH Memi[$1+3] # Image depth (bits per pixel) +define RAS_LENGTH Memi[$1+4] # Image length (bytes) +define RAS_TYPE Memi[$1+5] # File type +define RAS_MAPTYPE Memi[$1+6] # Colormap type +define RAS_MAPLENGTH Memi[$1+7] # Colormap length (bytes) + +define RAS_CMAP Memi[$1+10] # Colormap (ptr) +define RAS_COUNT Memi[$1+11] # RLE decoding var +define RAS_CH Memi[$1+12] # RLE decoding var + +# Rasterfile magic number +define RAS_MAGIC_NUM 59A66A95X +define RAS_RLE 80X + +# Sun supported ras_types +define RT_OLD 0 # Raw pixrect image in 68000 byte order +define RT_STANDARD 1 # Raw pixrect image in 68000 byte order +define RT_BYTE_ENCODED 2 # Run-length compression of bytes +define RT_FORMAT_RGB 3 # XRGB or RGB instead of XBGR or BGR +define RT_FORMAT_TIFF 4 # tiff <-> standard rasterfile +define RT_FORMAT_IFF 5 # iff (TAAC format) <-> standard rasterfile +define RT_EXPERIMENTAL 65535 # Reserved for testing + +# Sun supported ras_maptypes +define RMT_NONE 0 # ras_maplength is expected to be 0 +define RMT_EQUAL_RGB 1 # red[ras_maplength/3],green[],blue[] +define RMT_RAW 2 + + + +# IP_RAS - Read and process a Sun Rasterfile into an IRAF image. + +procedure ip_ras (ip, fname, info_only, verbose) + +pointer ip #i import struct pointer +char fname[ARB] #i file name +int info_only #i print out image info only? +int verbose #i verbosity flag + +pointer ras +int fd, w, nchars +pointer ras_open() + +long filepos +common /rascom/ filepos + +begin + # Allocate the ras struct pointer. + ras = ras_open () + fd = IP_FD(ip) + + # Initialize the file position. + filepos = 1 + call ip_lseek (fd, BOF) + + # Read in the rasterfile header, dump it directly to the task struct. + call ip_ageti (fd, ras, 8) + filepos = filepos + SZ_INT32 * SZB_CHAR * 8 + call ip_lseek (fd, filepos) + + # Now do some sanity checking on the values. + if (RAS_MAGIC(ras) != RAS_MAGIC_NUM) + call error (0, "Not a Sun rasterfile.") + if (RAS_TYPE(ras) == RT_OLD && RAS_LENGTH(ras) == 0) + RAS_LENGTH(ras) = RAS_WIDTH(ras) * RAS_HEIGHT(ras) * + RAS_DEPTH(ras) / 8 + + # See if we really want to convert this thing. + if (info_only == YES) { + call ip_ras_info (ip, ras, fname, verbose) + call ras_close (ras) + return + } + + # Get the colormap (if any). + call ras_rdcmap (fd, ras, RAS_CMAP(ras)) + IP_CMAP(ip) = RAS_CMAP(ras) + + # Round up to account for 16 bit line blocking. + w = RAS_WIDTH(ras) * (RAS_DEPTH(ras) / 8) + nchars = w + mod (w, SZB_CHAR) + + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Now process the image. + switch (RAS_DEPTH(ras)) { + case 1: + call eprintf ("Bitmap rasterfiles aren not supported.") + call flush (STDERR) + + case 8: + # Standard or byte encoded 8-bit rasterfile. + if (RAS_TYPE(ras) == RT_OLD || RAS_TYPE(ras) == RT_STANDARD) { + call ip_prband (ip, fd, IP_IM(ip), RAS_CMAP(ras)) + + } else if (RAS_TYPE(ras) == RT_BYTE_ENCODED) { + call ras_rle8 (ip, ras, fd, nchars) + + } else { + call eprintf ("Unsupported 8-bit RAS_TYPE: %d\n") + call pargi (RAS_TYPE(ras)) + call flush (STDERR) + } + + case 24, 32: + # 24 or 32-bit rasterfiles have no colormap (at least they + # shouldn't) and are pixel-interleaved. We already know how to + # do this so just call the right routines for processing. + + if (RAS_TYPE(ras) == RT_BYTE_ENCODED) { + call ip_fix_pixtype (ip) + call ras_rle24 (ip, ras, fd, nchars) + } else { + call ip_fix_pixtype (ip) + call ip_prpix (ip, fd, IP_IM(ip), NULL) + } + + default: + call eprintf ("Invalid pixel size.") + call flush (STDERR) + } + + # Clean up. + call ras_close (ras) + IP_CMAP(ip) = NULL +end + + +# IP_RAS_INFO - Print information about the raster file. + +procedure ip_ras_info (ip, ras, fname, verbose) + +pointer ip #i ip struct pointer +pointer ras #i ras struct pointer +char fname[ARB] #i file name +int verbose #i verbosity flag + +begin + # If not verbose print a one-liner. + if (verbose == NO) { +# call printf ("Input file:\n\t") + call printf ("%s: %20t%d x %d \t\t%d-bit Sun Rasterfile\n") + call pargstr (fname) + call pargi (RAS_WIDTH(ras)) + call pargi (RAS_HEIGHT(ras)) + call pargi (RAS_DEPTH(ras)) + + # Print out the format comment if any. +# if (IP_COMPTR(ip) != NULL) { +# if (COMMENT(ip) != '\0') { +# call printf ("%s\n") +# call pargstr (COMMENT(ip)) +# } +# call strcpy ("\0", COMMENT(ip), SZ_LINE) +# } +# if (RAS_DEPTH(ras) > 8) { +# if (RAS_TYPE(ras) != RT_FORMAT_RGB && RAS_TYPE(ras) != RT_OLD) { +# call eprintf ("\tNote: %d-bit rasterfile is stored as %s\n") +# call pargi (RAS_DEPTH(ras)) +# call pargstr ("ABGR and not ARGB") +# } +# } + return + } + + # Print a more verbose description. + call printf ("%s: %20tSun Rasterfile\n") + call pargstr (fname) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + if (RAS_DEPTH(ras) > 8) { + if (RAS_TYPE(ras) != RT_FORMAT_RGB && RAS_TYPE(ras) != RT_OLD) { + call eprintf ("\tNote: %d-bit rasterfile is stored as %s\n") + call pargi (RAS_DEPTH(ras)) + call pargstr ("ABGR and not ARGB") + } + } + + call printf ("%20tByte Order:%38t%s\n") + if (IP_SWAP(ip) == S_NONE && BYTE_SWAP2 == NO ) + call pargstr ("Most Significant Byte First") + else + call pargstr ("Least Significant Byte First") + + call printf ("%20tResolution:%38t%d x %d\n") + call pargi (RAS_WIDTH(ras)) + call pargi (RAS_HEIGHT(ras)) + + call printf ("%20tType: %38t%d-bit %s %s\n") + call pargi (RAS_DEPTH(ras)) + switch (RAS_TYPE(ras)) { + case RT_OLD: + call pargstr ("Old") + case RT_STANDARD: + call pargstr ("Standard") + case RT_BYTE_ENCODED: + call pargstr ("Byte Encoded") + case RT_FORMAT_RGB: + call pargstr ("RGB") + case RT_FORMAT_TIFF: + call pargstr ("TIFF") + case RT_FORMAT_IFF: + call pargstr ("IFF") + default: + call pargstr ("Experimental (or unknown)") + } + if (RAS_MAPLENGTH(ras) > 0) + call pargstr ("Color Index") + else + call pargstr ("") + + if (RAS_MAPLENGTH(ras) > 0) { + call printf ("%20tColormap:%38t%d entries\n") + if (RAS_MAPTYPE(ras) == RMT_EQUAL_RGB) + call pargi (RAS_MAPLENGTH(ras)/3) + else + call pargi (RAS_MAPLENGTH(ras)) + } else + call printf ("%20tColormap:%38tnone\n") + + call printf ("%20tCompression: %38t%s\n") + if (RAS_TYPE(ras) == RT_BYTE_ENCODED) + call pargstr ("Run Length Encoded") + else + call pargstr ("None") + + call printf ("%20tAlpha Channel: %38t%s\n") + if (RAS_DEPTH(ras) == 32) + call pargstr ("yes") + else + call pargstr ("none") +end + + +# RAS_OPEN - Open the RAS structure descriptor. + +pointer procedure ras_open () + +pointer ras + +begin + iferr (call calloc (ras, SZ_RASHDR, TY_STRUCT)) + call error (0, "Error allocating RAS structure.") + RAS_CMAP(ras) = NULL + + return (ras) +end + + +# RAS_CLOSE - Close the RAS structure descriptor. + +procedure ras_close (ras) + +pointer ras #i RAS struct pointer + +begin + if (RAS_CMAP(ras) != NULL) + call mfree (RAS_CMAP(ras), TY_CHAR) + call mfree (ras, TY_STRUCT) +end + + +# RAS_RDCMAP - Read the colormap from the image if necessary. + +procedure ras_rdcmap (fd, ras, cmap) + +int fd #i file descriptor +pointer ras #i RAS struct pointer +pointer cmap #i colormap array ptr + +int ncolors + +long filepos +common /rascom/ filepos + +begin + # Now read the colormap, allocate the pointer if we need to. + ncolors = RAS_MAPLENGTH(ras) + if (RAS_MAPTYPE(ras) == RMT_EQUAL_RGB && ncolors > 0) { + if (cmap == NULL) + call calloc (cmap, ncolors*3, TY_CHAR) + call ip_agetb (fd, cmap, ncolors) + + } else if (RAS_MAPTYPE(ras) == RMT_RAW) { + call eprintf ("Warning: Can't handle RMT_RAW maptype - ignoring.\n") + call flush (STDERR) + + # Skip over the bytes anyway. + filepos = filepos + ncolors + call ip_lseek (fd, filepos) + return + } + + filepos = filepos + ncolors + call ip_lseek (fd, filepos) +end + + +# RAS_RLE8 - Process an 8-bit rasterfile into an IRAF image. This +# procedure handles both standard and RLE files. + +procedure ras_rle8 (ip, ras, fd, nchars) + +pointer ip #i ip struct pointer +pointer ras #i ras struct pointer +int fd #i input file descriptor +int nchars #i line size + +pointer im, data, op +int i, percent + +long filepos +common /rascom/ filepos + +begin + im = IP_IM(ip) + op = PTYPE(ip,1) + call malloc (data, nchars, TY_CHAR) + IO_DATA(op) = data + IO_NPIX(op) = RAS_WIDTH(ras) + + percent = 0 + do i = 1, RAS_HEIGHT(ras) { + call ras_read_rle (ras, fd, Memc[data], nchars) + + # Apply the colormap since this is just an index. + if (RAS_MAPLENGTH(ras) != 0 && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], RAS_WIDTH(ras), + RAS_CMAP(ras)) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, RAS_WIDTH(ras), i) + + # Print percent done if being verbose + if (IP_VERBOSE(ip) == YES) { + if (i * 100 / RAS_HEIGHT(ras) >= percent + 10) { + percent = percent + 10 + call printf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDOUT) + } + } + + } + + if (IP_VERBOSE(ip) == YES) { + call printf (" Status: Done \n") + call flush (STDOUT) + } +end + + +# RAS_RLE24 - Process an 24-bit rasterfile into an IRAF image. This +# procedure handles both standard and RLE files. + +procedure ras_rle24 (ip, ras, fd, nchars) + +pointer ip #i ip struct pointer +pointer ras #i ras struct pointer +int fd #i input file descriptor +int nchars #i line size + +pointer im, data, op +int i, percent, npix + +long filepos +common /rascom/ filepos + +begin + im = IP_IM(ip) + op = PTYPE(ip,1) + call malloc (data, nchars, TY_SHORT) + IO_DATA(op) = data + IO_NPIX(op) = RAS_WIDTH(ras) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Allocate the pixtype data pointers. + npix = RAS_WIDTH(ras) + do i = 1, IP_NPIXT(ip) { + op = PTYPE(ip,i) + IO_NPIX(op) = npix + call calloc (IO_DATA(op), npix, TY_SHORT) + } + + percent = 0 + do i = 1, RAS_HEIGHT(ras) { + call ras_read_rle (ras, fd, Memc[data], nchars) + + # Separate pixels into different vectors. + call ip_upkpix (ip, data, npix) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + if (IP_VERBOSE(ip) == YES) { + if (i * 100 / RAS_HEIGHT(ras) >= percent + 10) { + percent = percent + 10 + call printf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDOUT) + } + } + + } + if (IP_VERBOSE(ip) == YES) { + call printf (" Status: Done \n") + call flush (STDOUT) + } +end + + +# RAS_READ_RLE - Read a line of RLE encoded data from the file. + +procedure ras_read_rle (ras, fd, data, nchars) + +pointer ras #i ras struct pointer +int fd #i file descriptor +char data[ARB] #u output pixels +int nchars #i number of pixels to read + +int i +short pix, ras_rdbyte() + +long filepos +common /rascom/ filepos + +begin + i = 1 + while (i <= nchars) { + if (RAS_COUNT(ras) > 0) { + data[i] = RAS_CH(ras) + i = i + 1 + RAS_COUNT(ras) = RAS_COUNT(ras) - 1 + + } else { + pix = ras_rdbyte (fd) + if (pix == RAS_RLE) { + RAS_COUNT(ras) = ras_rdbyte (fd) + if (RAS_COUNT(ras) == 0) { + data[i] = pix + i = i + 1 + } else { + RAS_CH(ras) = ras_rdbyte (fd) + data[i] = RAS_CH(ras) + i = i + 1 + } + } else { + data[i] = pix + i = i + 1 + } + } + } +end + + +# RAS_RDBYTE - Read a single byte at the current offset from the file. + +short procedure ras_rdbyte (fd) + +int fd #i file descriptor + +short val +short ip_getb() + +long filepos +common /rascom/ filepos + +begin + iferr (val = ip_getb (fd, filepos)) + return (ERR) + + filepos = filepos + 1 + call ip_lseek (fd, filepos) + + return (val) +end diff --git a/pkg/dataio/import/bltins/ipxwd.x b/pkg/dataio/import/bltins/ipxwd.x new file mode 100644 index 00000000..62a48ff7 --- /dev/null +++ b/pkg/dataio/import/bltins/ipxwd.x @@ -0,0 +1,188 @@ +# IPXWD.X - Source file for the IMPORT task X Window Dump builtin format. + +include <mach.h> +include "../import.h" + + +# IP_XWD - Read and process an X Window Dump into an IRAF image. + +procedure ip_xwd (ip, fname, info_only, verbose) + +pointer ip #i import struct pointer +char fname[ARB] #i file name +int info_only #i print out image info only? +int verbose #i verbosity flag + +int fd +pointer im, cmap +int nchars +long depth, cmap_entries, hdr_size +long hskip, lpad, width,height + +long ip_getl() + +begin + # Get the input file descriptor and initialize the file position. + fd = IP_FD(ip) + im = IP_IM(ip) + call ip_lseek (fd, BOF) + + # Get some information from the header we'll need for processing. + hdr_size = ip_getl (fd, 1) + width = IP_AXLEN(ip,1) + height = IP_AXLEN(ip,2) + depth = ip_getl (fd, 45) + hskip = IP_HSKIP(ip) + lpad = IP_LPAD(ip) + cmap_entries = ip_getl (fd, 73) + nchars = width + lpad + + # See if we really want to convert this thing. + if (info_only == YES) { + call ip_xwd_info (ip, fname, depth, cmap_entries, verbose) + return + } + + # Now process the image. For 24-bit or 32-bit files we have an RGB + # image and can process normally, if this is an 8-bit image see if + # we have a colormap we need to use. + + if (depth > 8) { + call ip_prpix (ip, fd, im, NULL) + } else { + cmap = NULL + if (cmap_entries > 0) + call xwd_rdcmap (ip, fd, hdr_size, cmap_entries, cmap) + call ip_prband (ip, fd, im, cmap) + } + IP_CMAP(ip) = NULL +end + + +# IP_XWD_INFO - Print information about the xwd file. + +procedure ip_xwd_info (ip, fname, depth, ncolors, verbose) + +pointer ip #i ip struct pointer +char fname[ARB] #i file name +int depth #i bits per pixel +int ncolors #i number of colors +int verbose #i verbosity flag + +begin + # If not verbose print a one-liner. + if (verbose == NO) { + #call printf ("Input file:\n\t") + call printf ("%s: %20t%d x %d \t%d-bit X11 Window Dump\n") + call pargstr (fname) + call pargi (IP_AXLEN(ip,1)) + call pargi (IP_AXLEN(ip,2)) + call pargi (depth) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + return + } + + # Print a more verbose description. + call printf ("%s: %20tX11 Window Dump\n") + call pargstr (fname) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + + call printf ("%20tByte Order:%38t%s\n") + if (IP_SWAP(ip) == S_NONE && BYTE_SWAP2 == NO ) + call pargstr ("Most Significant Byte First") + else + call pargstr ("Least Significant Byte First") + + call printf ("%20tResolution:%38t%d x %d\n") + call pargi (IP_AXLEN(ip,1)) + call pargi (IP_AXLEN(ip,2)) + + call printf ("%20tType: %38t%d-bit %s\n") + call pargi (depth) + if (ncolors > 0) + call pargstr ("Color Index") + else + call pargstr ("") + + call printf ("%20tHeader size:%38t%d bytes\n") + call pargi (IP_HSKIP(ip)) + + if (ncolors > 0) { + call printf ("%20tColormap:%38t%d entries\n") + call pargi (ncolors) + } else + call printf ("%20tColormap:%38tnone\n") + + call printf ("%20tAlpha Channel: %38t%s\n") + if (depth == 32) + call pargstr ("8-bit") + else + call pargstr ("none") +end + + +# XWD_RDCMAP - Read colormap from an X11 Window Dump file and return a +# pointer to it. + +procedure xwd_rdcmap (ip, fd, hdr_size, ncolors, cmap) + +pointer ip #i task struct pointer +int fd #i file descriptor +int hdr_size #i header size +int ncolors #i number of colormap entries +pointer cmap #i colormap pointer + +int i +long filepos, pixel +int r, g, b +char flags, pad + +short ip_getb() +int ip_getu() +long ip_getl() + +define SZ_X11_CSTRUCT 12 + +begin + # Now read the colormap, allocate the pointer if we need to. + cmap = NULL + if (ncolors == 0) + return + else + call calloc (cmap, CMAP_SIZE*3, TY_CHAR) + + filepos = hdr_size + 3 + call ip_lseek (fd, filepos) + do i = 1, ncolors { + pixel = ip_getl (fd, filepos) + r = ip_getu (fd, filepos+4) + g = ip_getu (fd, filepos+6) + b = ip_getu (fd, filepos+8) + flags = ip_getb (fd, filepos+10) + pad = ip_getb (fd, filepos+11) + + CMAP(cmap,IP_RED,i) = r * 255 / 65535 + CMAP(cmap,IP_GREEN,i) = g * 255 / 65535 + CMAP(cmap,IP_BLUE,i) = b * 255 / 65535 + + filepos = filepos + SZ_X11_CSTRUCT + call ip_lseek (fd, filepos) + } + IP_CMAP(ip) = cmap +end diff --git a/pkg/dataio/import/bltins/mkpkg b/pkg/dataio/import/bltins/mkpkg new file mode 100644 index 00000000..88c4cadb --- /dev/null +++ b/pkg/dataio/import/bltins/mkpkg @@ -0,0 +1,13 @@ +# Mkpkg file for building the IMPORT task builtin formats. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + ipcmap.x ../import.h + ipgif.x ../import.h + ipras.x ../import.h <mach.h> + ipxwd.x ../import.h <mach.h> + ; diff --git a/pkg/dataio/import/fmtdb.x b/pkg/dataio/import/fmtdb.x new file mode 100644 index 00000000..8e5da296 --- /dev/null +++ b/pkg/dataio/import/fmtdb.x @@ -0,0 +1,610 @@ +include <ctotok.h> +include <evvexpr.h> +include <fset.h> +include <error.h> +include "import.h" + +define DEBUG false +define VDEBUG false + + +.help fmtdb Augl93 "Format Database Interface" +.ih +DESCRIPTION +Format Database Procedures -- Routines for opening the format database given +in the task parameter, reading sequential and randome records within it, as +well as getting entried from within a selected record. + +PROCEDURES +.nf + PUBLIC PROCEDURES: + + fd = fdb_opendb () + fdb_closedb (fd) + fmt = fdb_get_rec (fd, format) + fmt = fdb_next_rec (fd) + fmt = fdb_scan_records (fd, keyword, getop, opdata, fcn, fcndata) + fdbgstr (fmt, param, str, maxchar) + fdb_close (fmt) + + PRIVATE PROCEDURES: + + fdb_gfield (fd, fmt, key, val) + fdb_gexpr (fd, fmt, expr, maxchars) + fdb_strip_colon (in, out, maxch) + fdb_strip_quote (in, out, maxch) + +.fi + +The FDB_OPENDB procedure returns a file descriptor to the database file +(named in the task parameters), and FDB_CLOSEDB will close the file. When +searching for a specific format, the FDB_GET_REC procedure will return a +pointer to a symtab containing the database record. The FDB_NEXT_REC +will return a symtab pointer to the next record in the database when reading +it sequentially. The FDB_SCAN_RECS procedure can be used to scan the +database, returning the symtab pointer to a record whose 'keyword' field eval- +uates as true. The FDB_CLOSE procedure will free the symtab pointer returned +by the previous two routines. + +Once a pointer is found for a database record the FDBGSTR procedure +can be used to return a value for an entry within that database record. +.ih +SEE ALSO +Source code +.endhelp + + +# Symbol table definitions. +define LEN_INDEX 10 # Length of symtab index +define LEN_STAB (20*SZ_EXPR) # Length of symtab +define SZ_SBUF 512 # Size of symtab string buffer +define SYMLEN SZ_EXPR # Length of symbol structure +define SZ_FMTVAL SZ_EXPR # Size of format value string + +# Symbol table structure +define FMTVAL Memc[P2C($1)] # Format value string + + +# FDB_OPENDB -- Return a file descriptor to the format database. The +# specified database may be a list of files in which case they will be +# concatenated to a single temporary file that is removed when the database +# is closed. + +int procedure fdb_opendb () + +int fd, in, out +int stat, nfiles +pointer sp, fname, buf +pointer dbfiles + +int open() +int clpopni(), clplen(), clgfil() + +errchk open, clpopni + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + dbfiles = clpopni ("database") + nfiles = clplen (dbfiles) + if (nfiles == 0) { + call error (0, "No format database specified.") + + } else if (nfiles == 1) { + call clgstr ("database", Memc[fname], SZ_FNAME) + stat = clgfil (dbfiles, Memc[fname], SZ_FNAME) + + } else { + # The database parameter specified a list, concatenate the files + # to a temp file and open that instead. + call mktemp ("tmp$db", Memc[fname], SZ_FNAME) + out = open (Memc[fname], APPEND, TEXT_FILE) + while (clgfil (dbfiles, Memc[buf], SZ_FNAME) != EOF) { + in = open (Memc[buf], READ_ONLY, TEXT_FILE) + call fcopyo (in, out) + call close (in) + } + call close (out) + } + + # Open format database. + fd = open (Memc[fname], READ_ONLY, TEXT_FILE) + + call sfree (sp) + return (fd) +end + + +# FDB_CLOSEDB -- Close the format database. + +procedure fdb_closedb (fd) + +int fd #i file descriptor + +pointer sp, buf +int strncmp() + +begin + if (fd == NULL) + return + + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Get the database filename, if it's a temp file then the input + # was probably and list and we need to clean up. + call fstats (fd, F_FILENAME, Memc[buf], SZ_FNAME) + call close (fd) + if (strncmp (Memc[buf], "tmp$db", 6) == 0) + call delete (Memc[buf]) + + call sfree (sp) +end + + +# FDB_GET_REC -- Get the requested format information in symbol table. + +pointer procedure fdb_get_rec (fd, format) + +int fd #i database file descriptor +char format[ARB] #i format name + +pointer fmt #o format symbol table pointer +bool found +char colon +pointer sp, key, expr, sym + +int fscan(), stridx() +pointer stopen(), stenter() +bool streq() + +errchk stopen, stenter, fscan + +begin + # Allocate local storage. + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Find format entry. + found = false + colon = ':' + while (fscan (fd) != EOF) { + call fdb_gfield (fd, NULL, Memc[key], Memc[expr]) + if (stridx (colon, Memc[key]) > 0) { + call fdb_strip_colon (Memc[key], Memc[key], SZ_FNAME) + } else if (Memc[key]=='#') # skip comment lines + next + if (streq (Memc[key], format)) { + found = true + break + } + } + if (!found) { # check if entry was found + call sfree (sp) + return (NULL) + } + + # Create the symbol table. + fmt = stopen (format, LEN_INDEX, LEN_STAB, SZ_SBUF) + + # Read the file and enter the parameters in the symbol table. + sym = stenter (fmt, "format", SYMLEN) + call strcpy (format, FMTVAL(sym), SZ_FMTVAL) + while (fscan(fd) != EOF) { + call fdb_gfield (fd, fmt, Memc[key], Memc[expr]) + if (stridx (colon, Memc[key]) > 0) { + call fdb_strip_colon (Memc[key], Memc[expr], SZ_FNAME) + call strcpy ("alias", Memc[key], SZ_FNAME) + } else if (Memc[key] == '#' || Memc[key] == '') { + next + } else if (Memc[key] == EOS) { + call sfree (sp) + return (fmt) + } + sym = stenter (fmt, Memc[key], SYMLEN) + call strcpy (Memc[expr], FMTVAL(sym), SZ_FMTVAL) + } + + call close (fd) + call sfree (sp) + return (fmt) +end + + +# FDB_NEXT_REC -- Open format database and store the requested format +# information in symbol table. + +pointer procedure fdb_next_rec (fd) + +int fd #i input binary file descriptor + +pointer fmt # Format symbol table pointer +char colon +pointer sp, key, expr, sym, tmp + +int fscan(), stridx() +pointer stopen(), stenter() + +errchk stopen, stenter, fscan + +begin + # Allocate local storage. + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + call salloc (expr, SZ_FMTVAL, TY_CHAR) + + # Skip ahead top the beginning of the next record. + colon = ':' + while (fscan (fd) != EOF) { + Memc[key] = EOS + Memc[expr] = EOS + call fdb_gfield (fd, NULL, Memc[key], Memc[expr]) + if (stridx (colon, Memc[key]) > 0) { + call fdb_strip_colon (Memc[key], Memc[key], SZ_FNAME) + break + } else if (Memc[key] != '#' && Memc[key] != EOS) # skip comment + next + + } + + # The file will either be position at the BOF or at the end of the + # previous record. We will just read until the end of record and + # return the pointer. + + # Create symbol table, but strip the ':' first. + call fdb_strip_colon (Memc[key], Memc[tmp], SZ_FNAME) + fmt = stopen (Memc[tmp], LEN_INDEX, LEN_STAB, SZ_SBUF) + + if (DEBUG) {call eprintf("next_rec: fmt='%s' ");call pargstr(Memc[tmp])} + + # Read the file and enter the parameters in the symbol table. + sym = stenter (fmt, "format", SYMLEN) + call strcpy (Memc[tmp], FMTVAL(sym), SZ_FMTVAL) + while (fscan(fd) != EOF) { + call fdb_gfield (fd, fmt, Memc[key], Memc[expr]) + if (stridx (colon, Memc[key]) > 0) { + call fdb_strip_colon (Memc[key], Memc[expr], SZ_FNAME) + call strcpy ("alias", Memc[key], SZ_FNAME) + } else if (Memc[key] == '#' || Memc[key] == '') { + next + } else if (Memc[key] == EOS) { + call sfree (sp) + return (fmt) + } + sym = stenter (fmt, Memc[key], SYMLEN) + call strcpy (Memc[expr], FMTVAL(sym), SZ_FMTVAL) + } + + call sfree (sp) # shouldn't get here + return (NULL) +end + + +# FDB_SCAN_RECORDS -- Scan the database for a record whose image_id evaluates +# as true. + +pointer procedure fdb_scan_records (fd, keyword, getop, opdata, fcn, fcndata) + +int fd #i input binary file descriptor +char keyword[ARB] #i keyword to be evaluated +int getop #i func to get an operand +int opdata #i data pointer for getop +int fcn #i user functions in evvexpr +int fcndata #i data pointer for fcn + +pointer sp, expr, fm +pointer fmt, o + +pointer fdb_next_rec(), evvexpr() + +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + call salloc (fm, SZ_FNAME, TY_CHAR) + + # Rewind the file descriptor. + call seek (fd, BOF) + + if (DEBUG) { call eprintf("scan_rec: keyw='%s' ");call pargstr(keyword)} + + # Loop over all of the database records. + repeat { + fmt = fdb_next_rec (fd) + if (fmt == NULL) + break + call fdbgstr (fmt, keyword, Memc[expr], SZ_EXPR) + + if (DEBUG) { + call eprintf(" expr='%s'\n"); call pargstr(Memc[expr]) + call flush (STDERR) + } + + # Evaluate keyword expression. + iferr { + o = evvexpr (Memc[expr], getop, opdata, fcn, fcndata, EV_RNGCHK) + if (O_TYPE(o) != TY_BOOL) + call error (0, "Expression must be a boolean") + + } then { + call erract (EA_WARN) + break + } + + if (O_VALI(o) == YES) { # see if we've found it + if (DEBUG) { + call fdbgstr (fmt, "format", Memc[fm], SZ_FNAME) + call eprintf(" format='%s'\n");call pargstr(Memc[fm]) + } + call evvfree (o) + call sfree (sp) + return (fmt) + } + + call evvfree (o) + call fdb_close (fmt) # free fmt pointer + } + + call sfree (sp) + return (NULL) +end + + +# FDBCLOSE -- Close the format symbol table pointer. + +procedure fdb_close (fmt) + +pointer fmt #i Format symbol table pointer + +begin + if (fmt != NULL) + call stclose (fmt) +end + + +# FDBGSTR -- Get string valued format parameter. We simply return the +# expression, evaluation is up to the caller. + +procedure fdbgstr (fmt, param, str, maxchar) + +pointer fmt #i format symbol table pointer +char param[ARB] #i format parameter +char str[ARB] #o format parameter value +int maxchar #i maximum characters for string + +pointer sym, stfind() + +begin + call aclrc (str, maxchar) + sym = stfind (fmt, param) + if (sym == NULL) + call strcpy ("", str, maxchar) + else + call strcpy (FMTVAL(sym), str, maxchar) +end + + +## END OF PUBLIC PROCEDURES ## + + +# FDB_GFIELD - Get field in the database record. + +procedure fdb_gfield (fd, fmt, keyword, expr) + +int fd #i file descriptor +pointer fmt #i format symtab pointer +char keyword[ARB] #o field keyword +char expr[ARB] #o field expression + +pointer sp, tmp + +begin + call smark (sp) + call salloc (tmp, SZ_FNAME, TY_CHAR) + + call gargwrd (keyword, SZ_FNAME) + call gargwrd (Memc[tmp], SZ_FNAME) + + if (keyword[1] == EOS) { + call sfree (sp) + return + #} else if (Memc[tmp] == '#') { + } else if (keyword[1] == '#') { + expr[1] = EOS + } else if (Memc[tmp] != EOS) + call fdb_gexpr (fd, fmt, expr, SZ_EXPR) + else + expr[1] = EOS + + if (VDEBUG && keyword[1] != '#' && keyword[1] != '') { + call eprintf("'%s'='%s'\n") + call pargstr (keyword) ; call pargstr (expr) + } + + call sfree (sp) +end + + +# FDB_GEXPR - Get an expression from the input stream. + +procedure fdb_gexpr (fd, fmt, expr, maxchars) + +int fd #i file descriptor +pointer fmt #i format symtab pointer +char expr[ARB] #o returned expression +int maxchars #i maxchars + +pointer sp, ntok, tok, tokval, next_tok, last_tok +pointer sym +int level, qlevel + +int fscan() +pointer stfind() + +define dopar_ 99 + +begin + call smark (sp) + call salloc (tok, SZ_FNAME, TY_CHAR) + call salloc (ntok, SZ_FNAME, TY_CHAR) + + # Gather the expression. For now we'll just eat everything up until + # the closing parenthesis. + call aclrc (expr, maxchars) + + # An expression is made up of a numeric or symbolic constant, a + # quoted literal string, or some boolean or arithmetic operation. + # The strategy is to get the first token and take action depending + # on it's value and whether a following token completes the expr- + # ession. Expressions may break across newlines, literal strings + # must be enclosed in double quotes. + + level = 0 + qlevel = 0 + last_tok = TOK_UNKNOWN + repeat { + call gargtok (tokval, Memc[tok], SZ_EXPR) + + switch (tokval) { + case TOK_NUMBER: + call strcat (Memc[tok], expr, SZ_EXPR) + case TOK_STRING: + # There are no operations on strings, but they might be passed + # to a function as an argument, so check the level. Oh yeah, + # keep the double quotes in the string. + call strcat ("\"", expr, SZ_EXPR) + call strcat (Memc[tok], expr, SZ_EXPR) + call strcat ("\"", expr, SZ_EXPR) + case TOK_PUNCTUATION: + if (Memc[tok] == '(') + level = level + 1 + else if (Memc[tok] == ')') + level = level - 1 + call strcat (Memc[tok], expr, SZ_EXPR) + case TOK_OPERATOR: + if (Memc[tok] == '"') { # pass quoted strings + if (qlevel == 1) + qlevel = 0 + else if (qlevel == 0) + qlevel = 1 + } + if (Memc[tok] == '#' && qlevel == 0) { # skip comments + if (fscan (fd) == EOF) + call eprintf ("WARNING: Unexpected EOF\n") + if (level == 0 && last_tok != TOK_OPERATOR) + break + } else + call strcat (Memc[tok], expr, SZ_EXPR) + case TOK_NEWLINE: + if (level != 0 || last_tok == TOK_OPERATOR) { + if (fscan (fd) == EOF) + call eprintf ("WARNING: Unexpected EOF\n") + } + case TOK_IDENTIFIER: + if (Memc[tok] == '$') { + call strcat (Memc[tok], expr, SZ_EXPR) + } else if (fmt != NULL) { + sym = stfind (fmt, Memc[tok]) + if (sym == NULL) { + if (Memc[tok] == 'F') { + call strcat (Memc[tok], expr, SZ_EXPR) + } else { + call gargtok (next_tok, Memc[ntok], SZ_EXPR) + if (Memc[ntok] == '(') { + # Copy to output buffer, it's a function name. + call strcat (Memc[tok], expr, SZ_EXPR) + call strcat (Memc[ntok], expr, SZ_EXPR) + tokval = next_tok + level = level + 1 + next + } else { + # It's an undefined database field. + call eprintf("Undefined database field '%s'.\n") + call pargstr (Memc[tok]) + } + } + } else + call strcat (FMTVAL(sym), expr, SZ_EXPR) + } else { + call strcat (Memc[tok], expr, SZ_EXPR) + } + call gargtok (next_tok, Memc[tok], SZ_EXPR) +dopar_ if (Memc[tok] == '(') + level = level + 1 + else if (Memc[tok] == ')') { + level = level - 1 + if (level == 0) { + call strcat (Memc[tok], expr, SZ_EXPR) + break + } + } + if (next_tok != TOK_NEWLINE) + call strcat (Memc[tok], expr, SZ_EXPR) + tokval = next_tok + default: + break + } + + last_tok = tokval + } + + # Check for an obvious error. + if (level > 0) + call eprintf ("Missing right paren in expression: '%s'\n") + else if (level < 0) + call eprintf ("Missing left paren in expression: '%s'\n") + call pargstr (expr) + + call sfree (sp) +end + + +# FDB_STRIP_COLON -- Return the input string up to a ':' character. + +procedure fdb_strip_colon (in, out, maxch) + +char in[ARB] #i input string +char out[ARB] #o output string +int maxch #i max chars out + +int ip, op + +begin + op = 1 + do ip = 1, ARB { + if (in[ip] == ':' || op > maxch || in[ip] == EOS) + break + out[op] = in[ip] + op = op + 1 + } + out[op] = EOS +end + + +# FDB_STRIP_QUOTE -- Strip double quote chars from the string. + +procedure fdb_strip_quote (in, out, maxch) + +char in[ARB] #i input string +char out[ARB] #o output string +int maxch #i max chars out + +int ip, op + +begin + op = 1 + do ip = 1, ARB { + if (op > maxch || in[ip] == EOS) + break + if (in[ip] != '"') { + out[op] = in[ip] + op = op + 1 + } + } + out[op] = EOS +end diff --git a/pkg/dataio/import/generic/ipdb.x b/pkg/dataio/import/generic/ipdb.x new file mode 100644 index 00000000..4dfb81c7 --- /dev/null +++ b/pkg/dataio/import/generic/ipdb.x @@ -0,0 +1,813 @@ +include <evvexpr.h> +include <error.h> +include <mach.h> +include <imhdr.h> +include "../import.h" +include "../ipfcn.h" + +define DEBUG false + + +# IP_EVAL_DBREC -- For each of the keywords defined in the database record, +# evaluate the expression and load the task structure. + +procedure ip_eval_dbrec (ip) + +pointer ip #i task struct pointer + +int ival +pointer sp, dims, pixtype, err +pointer np, stp, sym + +pointer stname(), sthead(), stnext +int or(), ip_dbgeti() +bool streq() + +errchk ip_dbgeti() + +begin + call smark (sp) + call salloc (dims, SZ_EXPR, TY_CHAR) + call salloc (pixtype, SZ_EXPR, TY_CHAR) + call salloc (err, SZ_EXPR, TY_CHAR) + call aclrc (Memc[dims], SZ_EXPR) + call aclrc (Memc[pixtype], SZ_EXPR) + call aclrc (Memc[err], SZ_EXPR) + + # Load the defaults. + call ip_load_defaults (ip) + + # First thing we do is get the byte swap flag so the remaining + # fields will be interpreted correctly. + ifnoerr (ival = ip_dbgeti (ip, "bswap")) + IP_SWAP(ip) = ival + + # Next, we handle 'interleave', 'dims' and 'pixtype' as a special case + # since for band- and line-interleaved files we may need to fix up the + # pixtype pointers. + ifnoerr (ival = ip_dbgeti (ip, "interleave")) + IP_INTERLEAVE(ip) = ival + + ifnoerr (call ip_dbstr (ip, "dims", Memc[dims], SZ_EXPR)) + call ip_do_dims (ip, Memc[dims]) + + ifnoerr (call ip_dbstr (ip, "pixtype", Memc[pixtype], SZ_EXPR)) { + if (Memc[pixtype] == '"') + call fdb_strip_quote (Memc[pixtype], Memc[pixtype], SZ_EXPR) + call ip_do_pixtype (ip, Memc[pixtype]) + } + + # Loop over every symbol in the table. + stp = IP_FSYM(ip) + for (sym=sthead(stp); sym != NULL; sym=stnext(stp,sym)) { + np = stname (stp, sym) + + if (streq(Memc[np],"format") || # ignored or found already + streq(Memc[np],"alias") || + streq(Memc[np],"image_id") || + streq(Memc[np],"interleave") || + streq(Memc[np],"dims") || + streq(Memc[np],"pixtype") || + streq(Memc[np],"id_string") || + streq(Memc[np],"bswap")) { + next + } else if (streq(Memc[np],"hskip")) { + IP_HSKIP(ip) = ip_dbgeti (ip, "hskip") + } else if (streq(Memc[np],"tskip")) { + IP_TSKIP(ip) = ip_dbgeti (ip, "tskip") + } else if (streq(Memc[np],"bskip")) { + IP_BSKIP(ip) = ip_dbgeti (ip, "bskip") + } else if (streq(Memc[np],"lskip")) { + IP_LSKIP(ip) = ip_dbgeti (ip, "lskip") + } else if (streq(Memc[np],"lpad")) { + IP_LPAD(ip) = ip_dbgeti (ip, "lpad") + } else if (streq(Memc[np],"yflip")) { + if (ip_dbgeti (ip, "yflip") == YES) + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + } else if (streq(Memc[np],"error")) { + if (IP_OUTPUT(ip) != IP_INFO) + call ip_do_error (ip, Memc[P2C(sym)]) + } else if (streq(Memc[np],"comment")) { + call fdb_strip_quote (Memc[P2C(sym)], Memc[P2C(sym)], SZ_LINE) + call ip_do_comment (ip, Memc[P2C(sym)]) + } else { + call eprintf ("Warning: Unknown database keyword '%s'.\n") + call pargstr (Memc[np]) + } + } + + if (DEBUG) { call zzi_prstruct ("eval dbrec:", ip) } + call sfree (sp) +end + + +# IP_LOAD_DEFAULTS -- Load the default input parameters to the task structure. + +procedure ip_load_defaults (ip) + +pointer ip #i task struct pointer + +begin + IP_SWAP(ip) = DEF_SWAP # type of byte swapping + IP_INTERLEAVE(ip) = DEF_INTERLEAVE # type of data interleaving + IP_HSKIP(ip) = DEF_HSKIP # bytes to skip before data + IP_TSKIP(ip) = DEF_TSKIP # bytes to skip after data + IP_BSKIP(ip) = DEF_BSKIP # bytes between image bands + IP_LSKIP(ip) = DEF_LSKIP # bytes to skip at front of + IP_LPAD(ip) = DEF_LPAD # bytes to skip at end of + + # zero image dimensions + for (IP_NDIM(ip)=IM_MAXDIM; IP_NDIM(ip) > 0; IP_NDIM(ip)=IP_NDIM(ip)-1) + IP_AXLEN(ip,IP_NDIM(ip)) = 0 +end + + +# IP_DBFCN -- Called by evvexpr to execute format database special functions. + +procedure ip_dbfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf, outstr +int fd, func, v_nargs +int i, len, nchar, ival, cur_offset, swap +char ch +short sval +real rval +double dval + +short ip_getb(), ip_gets() +int strdic(), ip_line(), ip_locate(), ip_getu() +int ctoi(), ctol(), ctor(), ctod(), ctocc(), ctowrd() +int and(), strlen(), clgeti() +long ip_getl() +real ip_getr(), ip_getn() +double ip_getd(), ip_getn8() +bool strne(), streq() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[outstr], SZ_LINE) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, DB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case CTOCC, CTOD, CTOI, CTOL, CTOR, CTOWRD: + v_nargs = -1 + + case GETSTR: + v_nargs = -1 + case GETB, GETU, GETI, GETI2, GETI4, GETR, GETR4, GETR8, + GETN, GETN4, GETN8: + v_nargs = 1 + + case LOCATE: + v_nargs = -1 + case LINE, SKIP: + v_nargs = 1 + + case BSWAP: + v_nargs = 1 + case PARAMETER, DEFAULT: + v_nargs = 1 + case SUBSTR: + v_nargs = 3 + case STRIDX: + v_nargs = 2 + case LSB_HOST, MSB_HOST: + v_nargs = 0 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + fd = IP_FD(ip) + swap = IP_SWAP(ip) + cur_offset = IP_OFFSET(ip) + + if (DEBUG) { + call eprintf ("cur_offset=%d nargs=%d func=%s swap=%d\n") + call pargi(cur_offset) ; call pargi(nargs) + call pargstr(fcn) ; call pargi (swap) + do i = 1, nargs + call zzi_pevop (args[i]) + call eprintf ("init op => ") ; call zzi_pevop(o) + + } + + # Evaluate the function. + switch (func) { + case CTOCC: # run the fmtio equivalents of the argument + if (nargs == 1) + ch = ip_getb (fd, O_VALI(args[1])) + else + ch = ip_getb (fd, cur_offset) + len = ctocc (ch, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len) + cur_offset = cur_offset + 1 + call ip_lseek (fd, cur_offset) + + case CTOWRD: + if (nargs == 1) + call ip_gstr (fd, O_VALI(args[1]), SZ_FNAME, Memc[outstr]) + else + call ip_gstr (fd, cur_offset, SZ_FNAME, Memc[outstr]) + nchar = ctowrd (Memc[outstr], i, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, nchar, TY_CHAR) + call aclrc (O_VALC(o), nchar) + call amovc (Memc[outstr], O_VALC(o), nchar) + cur_offset = cur_offset + nchar + 1 + call ip_lseek (fd, cur_offset) + + case CTOI: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_INT + + case CTOL: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_LONG + + case CTOR: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_REAL + + case CTOD: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_DOUBLE + + case GETSTR: + if (nargs == 1) { + call ip_gstr (fd, cur_offset, O_VALI(args[1]), Memc[outstr]) + cur_offset = cur_offset + O_VALI(args[1]) + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + cur_offset = O_VALI(args[1]) + O_VALI(args[2]) - 1 + } + if (strlen(Memc[outstr]) == 0) { + len = strlen ("ERR") + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call strcpy ("ERR", O_VALC(o), len-1) + } else { + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len-1) + } + + case GETB: + if (nargs == 0) { + sval = ip_getb (fd, cur_offset) + cur_offset = cur_offset + SZB_CHAR + } else { + sval = ip_getb (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + SZB_CHAR + } + ival = sval + O_TYPE(o) = TY_INT + + case GETU: + if (nargs == 0) { + sval = short (ip_getu (fd, cur_offset)) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = short (ip_getu (fd, O_VALI(args[1]))) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI, GETI2: + if (nargs == 0) { + sval = ip_gets (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = ip_gets (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI4: + if (nargs == 0) { + ival = ip_getl (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_LONG) + } else { + ival = ip_getl (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_LONG) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) + call bswap4 (ival, 1, ival, 1, (SZ_INT32*SZB_CHAR)) + O_TYPE(o) = TY_INT + + case GETR, GETR4: + if (nargs == 0) { + rval = ip_getr (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getr (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETR8: + if (nargs == 0) { + dval = ip_getd (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getd (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case GETN, GETN4: + if (nargs == 0) { + rval = ip_getn (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getn (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETN8: + if (nargs == 0) { + dval = ip_getn8 (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getn8 (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case LOCATE: # locate the pattern in the file + if (nargs == 1) + ival = ip_locate (fd, cur_offset, O_VALC(args[1])) + else if (nargs == 2) + ival = ip_locate (fd, O_VALI(args[1]), O_VALC(args[2])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case LINE: # locate the line no. in the file + ival = ip_line (fd, O_VALI(args[1])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case SKIP: # skip a certain number of bytes + ival = O_VALI(args[1]) + O_TYPE(o) = TY_INT + cur_offset = cur_offset + ival + + case BSWAP: # byte-swap argument + O_TYPE(o) = O_TYPE(args[1]) + switch (O_TYPE(args[1])) { + case TY_SHORT: + call bswap2 (O_VALS(args[1]), 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + case TY_INT: + call bswap4 (O_VALI(args[1]), 1, ival, 1, (SZ_INT32*SZB_CHAR)) + case TY_LONG: + call bswap4 (O_VALL(args[1]), 1, ival, 1, (SZ_LONG*SZB_CHAR)) + case TY_REAL: + call bswap4 (O_VALR(args[1]), 1, rval, 1, (SZ_REAL*SZB_CHAR)) + case TY_DOUBLE: + call bswap8 (O_VALD(args[1]), 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + } + + case PARAMETER: # return current task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call clgstr ("dims", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call clgstr ("pixtype", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = clgeti ("interleave") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + call clgstr ("bswap", Memc[outstr], SZ_FNAME) + if (strne("no",Memc[outstr]) && strne("none",Memc[outstr])) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = clgeti ("hskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = clgeti ("tskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = clgeti ("bskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = clgeti ("lskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = clgeti ("lpad") + O_TYPE(o) = TY_INT + } + + case DEFAULT: # return default task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = DEF_INTERLEAVE + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + ival = DEF_SWAP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = DEF_HSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = DEF_TSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = DEF_BSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = DEF_LSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = DEF_LPAD + O_TYPE(o) = TY_INT + } + + case LSB_HOST: # host is an LSB byte ordered machine + if (BYTE_SWAP2 == YES) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case MSB_HOST: # host is an MSB byte ordered machine + if (BYTE_SWAP2 == NO) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case SUBSTR: # return a substring of the argument + + case STRIDX: # return offset of a char w/in str + + } + + # Write result to output operand. + O_LEN(o) = 0 + switch (O_TYPE(o)) { + case TY_USHORT, TY_SHORT: + O_VALS(o) = sval + case TY_INT, TY_BOOL: + O_VALI(o) = ival + case TY_LONG: + O_VALL(o) = ival + case TY_REAL: + O_VALR(o) = rval + case TY_DOUBLE: + O_VALD(o) = dval + } + + if (DEBUG) { call eprintf("ip_dbfcn: ") ; call zzi_pevop (o) } + + IP_OFFSET(ip) = cur_offset + call sfree (sp) +end + + +# IP_DBSTR -- Get a string valued expression from the database. + +procedure ip_dbstr (ip, param, outstr, maxch) + +pointer ip #i task struct pointer +char param[ARB] #i parameter to evaluate +char outstr[ARB] #o result string +int maxch #i max length of string + +pointer sp, expr, o + +int locpr(), strlen() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + call aclrc (Memc[expr], SZ_EXPR) + + # Get the requested parameter. + call aclrc (outstr, SZ_EXPR) + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "FDBGET: Format parameter not found") + + if (DEBUG) { + call eprintf("ip_dbstr: expr='%s' len=%d ");call pargstr(Memc[expr]) + call pargi(strlen(Memc[expr])) + } + + # Evaluate the expression. + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) != TY_CHAR) + call error (0, "ip_dbstr: Expression must be a string valued") + else + call amovc (O_VALC(o), outstr, (min(strlen(O_VALC(o)),maxch))) + } then + call erract (EA_WARN) + + if (DEBUG) { call eprintf ("outstr=:%s:\n") ; call pargstr (outstr) } + + call evvfree (o) + call sfree (sp) +end + + + +# IP_DBGETI -- Get integer valued format parameter from the database. + +int procedure ip_dbgeti (ip, param) + +pointer ip #i task struct pointer +char param[ARB] #i requested parameter + +int val +pointer sp, expr, o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Get the requested parameter. + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "IP_DBGET: Format parameter not found") + + # Evaluate the expression. + if (DEBUG) { + call eprintf ("ip_dbget: expr='%s'\n") + call pargstr (Memc[expr]) + call flush (STDERR) + } + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) == TY_BOOL) { + val = O_VALI(o) + } else if (O_TYPE(o) != TY_INT && O_TYPE(o) != TY_SHORT) { + call error (0, "Expression must be an integer") + } else + val = O_VALI(o) + + if (DEBUG) { + call eprintf ("ip_dbget: val=%d type=%d ecpr=:%s:\n") + call pargi (val) + call pargi (O_TYPE(o)) + call pargstr (Memc[expr]) + call flush (STDERR) + } + } then + call erract (EA_WARN) + + call evvfree (o) + call sfree (sp) + return (val) +end + + +# IP_DBGETR -- Get real valued format parameter from the database. + +real procedure ip_dbgetr (ip, param) + +pointer ip #i task struct pointer +char param[ARB] #i requested parameter + +real val +pointer sp, expr, o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Get the requested parameter. + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "IP_DBGET: Format parameter not found") + + # Evaluate the expression. + if (DEBUG) { + call eprintf ("ip_dbget: expr='%s'\n") + call pargstr (Memc[expr]) + call flush (STDERR) + } + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) == TY_BOOL) { + val = O_VALI(o) + } else if (O_TYPE(o) != TY_REAL) { + call error (0, "Expression must be a real") + } else + val = O_VALR(o) + + if (DEBUG) { + call eprintf ("ip_dbget: val=%d type=%d ecpr=:%s:\n") + call pargr (val) + call pargi (O_TYPE(o)) + call pargstr (Memc[expr]) + call flush (STDERR) + } + } then + call erract (EA_WARN) + + call evvfree (o) + call sfree (sp) + return (val) +end + + +# IP_DO_ERROR -- Process the error parameter. + +procedure ip_do_error (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i error string + +pointer o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +bool strne() +errchk evvexpr + +begin + if (DEBUG) {call eprintf ("error expr: '%s' ") ; call pargstr (expr)} + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_dbfcn), ip, + EV_RNGCHK) + + if (DEBUG) { call eprintf("-> '%s'\n") ; call pargstr(O_VALC(o)) } + + if (O_TYPE(o) != TY_CHAR) + call error (2, "do_error: Expression must be a string valued") + else { + if (strne("okay",O_VALC(o))) + call error (2, O_VALC(o)) + } + call evvfree (o) + + } then + if (IP_OUTPUT(ip) != IP_INFO) + call erract (EA_FATAL) +end + + +# IP_DO_COMMENT - Process a comment line in the format database. + +procedure ip_do_comment (ip, comstr) + +pointer ip #i task struct pointer +char comstr[ARB] #i comment to add + +pointer sp, buf + +begin + # Copy the comment line to the comment block. + if (IP_COMPTR(ip) == NULL) + call calloc (IP_COMPTR(ip), SZ_COMMENT, TY_CHAR) + + if (COMMENT(ip) == '\0') { + call strcpy ("\t", COMMENT(ip), SZ_LINE) + call strcat (comstr, COMMENT(ip), SZ_LINE) + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + Memc[buf] = '\0' + call strcpy ("\t", Memc[buf], SZ_LINE) + call strcat (comstr, Memc[buf], SZ_LINE) + call strcat ("\n", Memc[buf], SZ_LINE) + call strcat (COMMENT(ip), Memc[buf], SZ_COMMENT) + + call strcpy (Memc[buf], COMMENT(ip), SZ_COMMENT) + + call sfree (sp) + } +end + + +# IP_INITOP - Initialize an operand pointer to the requested values + +procedure ip_initop (o, len, type) + +pointer o #u operand pointer +int len #i length of array +int type #i data type of operand + +begin + O_LEN(o) = len + O_TYPE(o) = type + if (len > 1) + call calloc (O_VALP(o), len, type) +end diff --git a/pkg/dataio/import/generic/ipfio.x b/pkg/dataio/import/generic/ipfio.x new file mode 100644 index 00000000..2977d8cb --- /dev/null +++ b/pkg/dataio/import/generic/ipfio.x @@ -0,0 +1,569 @@ +include <mach.h> +include <fset.h> +include "../import.h" + +define DEBUG false + + +# IP_GSTR -- Get a string of the specifed length from the given offset. + +procedure ip_gstr (fd, offset, len, outstr) + +int fd +int offset +int len +char outstr[ARB] + +int nstat, read() +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, len+2, TY_CHAR) + call aclrc (Memc[buf], len+2) + call aclrc (outstr, len+2) + + call ip_lseek (fd, offset) + nstat = read (fd, Memc[buf], len) + + if (mod(offset,2) == 0 && offset > 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, len) + call chrupk (Memc[buf], 1, outstr, 1, len) + + if (DEBUG) { call eprintf ("ip_gstr: :%s: len=%d\n"); + call pargstr(outstr) ; call pargi (len) } + call sfree (sp) +end + + +# IP_GETB -- Get a byte from the given offset. + +short procedure ip_getb (fd, offset) + +int fd +int offset + +int nstat, read() +short val +char buf[2] + +begin + call ip_lseek (fd, offset) + nstat = read (fd, buf, 2) + + if (mod(offset,2) == 0) + call bytmov (buf, 2, buf, 1, 2) + call chrupk (buf, 1, buf, 1, 2) + + if (DEBUG) { call eprintf ("ip_getb: %d\n"); call pargs(buf[1]) } + if (buf[1] < 0) + val = buf[1] + 256 + else + val = buf[1] + return (val) +end + + +# IP_GETU -- Get a unsigned short integer from the given offset. + +int procedure ip_getu (fd, offset) + +int fd +int offset + +int val +short ip_gets() + +begin + val = ip_gets (fd, offset) + if (val < 0) + val = val + 65536 + return (val) +end + +# IP_GET[silrd] -- Get a value of <type> from the given offset. + + + +short procedure ip_gets (fd, offset) + +int fd +int offset + +int nstat, read() +short val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_SHORT * SZB_CHAR) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargs(val) } + return (val) +end + + +int procedure ip_geti (fd, offset) + +int fd +int offset + +int nstat, read() +int val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_INT32 * SZB_CHAR) + if (SZ_INT != SZ_INT32) + call iupk32 (val, val, 1) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargi(val) } + return (val) +end + + +long procedure ip_getl (fd, offset) + +int fd +int offset + +int nstat, read() +long val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_INT32 * SZB_CHAR) + if (SZ_INT != SZ_INT32) + call iupk32 (val, val, 1) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargl(val) } + return (val) +end + + +real procedure ip_getr (fd, offset) + +int fd +int offset + +int nstat, read() +real val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_REAL * SZB_CHAR) + call ieeupkr (val) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargr(val) } + return (val) +end + + +double procedure ip_getd (fd, offset) + +int fd +int offset + +int nstat, read() +double val + +begin + call ip_lseek (fd, offset) + nstat = read (fd, val, SZ_DOUBLE * SZB_CHAR) + call ieeupkd (val) + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call pargd(val) } + return (val) +end + + +# IP_GETN -- Get a native floating point number from the given offset. + +real procedure ip_getn (fd, offset) + +int fd +int offset + +int nstat, read() +real rval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, rval, SZ_REAL) + + if (DEBUG) { call eprintf ("ip_getn: %g\n"); call pargr(rval) } + return (rval) +end + + +# IP_GETN8 -- Get a native double precision floating point number from the +# given offset. + +double procedure ip_getn8 (fd, offset) + +int fd +int offset + +int nstat, read() +double dval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, dval, SZ_DOUBLE) + + if (DEBUG) { call eprintf ("ip_getn8: %g\n"); call pargd(dval) } + return (dval) +end + + +# IP_AGETB -- Get an array of bytes from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetb (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +pointer sp, buf +int fp, nval, nstat +int ip_lnote(), read() + +begin + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + nval = len + else + nval = len + 1 + + call smark (sp) + call salloc (buf, nval, TY_CHAR) + + if (ptr == NULL) + call malloc (ptr, nval * SZB_CHAR, TY_CHAR) + nstat = read (fd, Memc[buf], nval / SZB_CHAR + 1) + + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, nval) + call achtbc (Memc[buf], Memc[ptr], len) + + call sfree (sp) +end + + +# IP_AGETU -- Get an array of <type> from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetu (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +begin + call ip_agets (fd, ptr, len) + call achtsu (Mems[ptr], Mems[ptr], len) +end + + +# IP_AGET[silrd] -- Get an array of <type> from the file. The data pointer is +# allocated if necessary and contains the data on output. + + +procedure ip_agets (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_SHORT) + nstat = read (fd, Mems[ptr], len * SZ_SHORT) +end + + +procedure ip_ageti (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_INT) + nstat = read (fd, Memi[ptr], len * SZ_INT32) + if (SZ_INT != SZ_INT32) + call iupk32 (Memi[ptr], Memi[ptr], len) +end + + +procedure ip_agetl (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_LONG) + nstat = read (fd, Meml[ptr], len * SZ_INT32) + if (SZ_INT != SZ_INT32) + call iupk32 (Meml[ptr], Meml[ptr], len) +end + + +procedure ip_agetr (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_REAL) + nstat = read (fd, Memr[ptr], len * SZ_REAL) + call ieevupkr (Memr[ptr], Memr[ptr], len) +end + + +procedure ip_agetd (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_DOUBLE) + nstat = read (fd, Memd[ptr], len * SZ_DOUBLE) + call ieevupkd (Memd[ptr], Memd[ptr], len) +end + + + +# IP_AGETN -- Get an array of native floats from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetn (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_REAL) + nstat = read (fd, Memr[ptr], len * SZ_REAL) +end + + +# IP_AGETN8 -- Get an array of native doubles from the file. The data pointer +# is allocated if necessary and contains the data on output. + +procedure ip_agetn8 (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_DOUBLE) + nstat = read (fd, Memd[ptr], len * SZ_DOUBLE) +end + + +# ----------------------------------------------------------------- +# ------------------ UTILITY FILE I/O FUNCTIONS ------------------- +# ----------------------------------------------------------------- + + +define BLKSIZE 1024 + +# IP_LINE -- Return the offset of the start of the given line number. + +int procedure ip_line (fd, line) + +int fd #i input file descriptor +int line #i line number to search + +pointer sp, cbuf, buf +int nl, offset, i, nread, fsize + +int read(), fstati() + +define done_ 99 +define err_ 98 + +begin + if (line == 1) { + return (1) + } else { + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + # Rewind file descriptor + call ip_lseek (fd, BOF) + nl = 1 + offset = 1 + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + do i = 1, BLKSIZE { + if (Memc[cbuf+i-1] == '\n') { + nl = nl + 1 + offset = offset + 1 + if (nl == line) + goto done_ + } else + offset = offset + 1 + if (offset >= fsize) + goto err_ + } + } +err_ call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_line: '%s'\n"); call pargi(offset) } + call sfree (sp) + call ip_lseek (fd, offset) + return (offset) + } +end + + +# IP_LOCATE -- Return the offset of the start of the given pattern. + +int procedure ip_locate (fd, offset, pattern) + +int fd #i input file descriptor +int offset #i offset to begin search +char pattern[ARB] #i pattern to locate + +pointer sp, cbuf, buf +int fsize, nread, patlen, cur_offset, loc + +int fstati(), read(), strsearch(), strlen() + +define done_ 99 + +begin + # Rewind file descriptor + call ip_lseek (fd, offset) + cur_offset = offset + + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + if (DEBUG) { call eprintf("ip_loc: offset %d\n"); call pargi(offset)} + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + patlen = strlen (pattern) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + loc = strsearch (Memc[cbuf], pattern) + if (loc != 0) { + cur_offset = cur_offset + loc - 1 - patlen + goto done_ + } else { + # Allow some overlap in case the pattern broke over the blocks. + cur_offset = cur_offset + BLKSIZE - 2 * patlen + call ip_lseek (fd, cur_offset) + if (cur_offset + BLKSIZE > fsize) + nread = fsize - cur_offset + 1 + } + } + call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_loc: %d\n"); call pargi(cur_offset)} + call sfree (sp) + call ip_lseek (fd, offset) + return (cur_offset) +end + + +# IP_LSEEK -- Set the file position as a byte offset. + +procedure ip_lseek (fd, offset) + +int fd #i file descriptor +int offset #i requested offset + +long cur_offset, where, fsize +int fstati() +common /fiocom/ cur_offset + +begin + if (offset == BOF || offset == ERR) { + cur_offset = 1 + call seek (fd, BOF) + } else { + fsize = fstati (fd, F_FILESIZE) * SZB_CHAR + cur_offset = min (fsize, offset) + where = min (fsize, (offset/SZB_CHAR+mod(offset,2))) + call seek (fd, where) + } +end + + +# IP_LNOTE -- Note the file position as a byte offset. + +int procedure ip_lnote (fd) + +int fd #i file descriptor (unused) + +long cur_offset +common /fiocom/ cur_offset + +begin + return (cur_offset) +end + + +# IP_LSKIP -- Bump the file position by a byte offset. + +procedure ip_lskip (fd, skip) + +int fd #i file descriptor +int skip + +long cur_offset +common /fiocom/ cur_offset + +begin + call ip_lseek (fd, cur_offset+skip) +end diff --git a/pkg/dataio/import/generic/ipobands.x b/pkg/dataio/import/generic/ipobands.x new file mode 100644 index 00000000..65c6c1c4 --- /dev/null +++ b/pkg/dataio/import/generic/ipobands.x @@ -0,0 +1,375 @@ +include <error.h> +include <mach.h> +include <evvexpr.h> +include <fset.h> +include "../import.h" +include "../ipfcn.h" + +define DEBUG false +define VDEBUG false + + +# IP_GETOP -- Called by evvexpr to get an operand. + +procedure ip_getop (ip, opname, o) + +pointer ip #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype +pointer sp, buf +pointer op + +int fstati(), ip_ptype(), strlen(), strncmp() +bool streq() + +begin + # First see if it's one of the special file operands. + if (opname[1] == '$') { + if (strncmp(opname, "$FSIZE", 3) == 0) { + O_LEN(o) = 0 + O_TYPE(o) = TY_INT + O_VALI(o) = fstati (IP_FD(ip), F_FILESIZE) * SZB_CHAR + } else if (strncmp(opname, "$FNAME", 3) == 0) { + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + call fstats (IP_FD(ip), F_FILENAME, Memc[buf], SZ_FNAME) + + O_TYPE(o) = TY_CHAR + O_LEN(o) = strlen (Memc[buf]) + 1 + call malloc (O_VALP(o), O_LEN(o), TY_CHAR) + call strcpy (Memc[buf], O_VALC(o), i) + call sfree (sp) + } + + return + } + + nops = IP_NPIXT(ip) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = PTYPE(ip,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG) { + call eprintf ("getop: opname=%s tag=%s found=%d ") + call pargstr(opname) ; call pargstr(Memc[IO_TAG(op)]) + call pargi(found) + if (found == YES) call zzi_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + optype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + + case TY_INT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_INT + call malloc (O_VALP(o), IO_NPIX(op), TY_INT) + call amovi (Memi[IO_DATA(op)], Memi[O_VALP(o)], IO_NPIX(op)) + + case TY_LONG: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_LONG + call malloc (O_VALP(o), IO_NPIX(op), TY_LONG) + call amovl (Meml[IO_DATA(op)], Meml[O_VALP(o)], IO_NPIX(op)) + + case TY_REAL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), IO_NPIX(op), TY_REAL) + call amovr (Memr[IO_DATA(op)], Memr[O_VALP(o)], IO_NPIX(op)) + + case TY_DOUBLE: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_DOUBLE + call malloc (O_VALP(o), IO_NPIX(op), TY_DOUBLE) + call amovd (Memd[IO_DATA(op)], Memd[O_VALP(o)], IO_NPIX(op)) + + } + + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call sfree (sp) + call error (1, Memc[buf]) + } +end + + +# IP_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ip_evaluate (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ip_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_obfcn), ip, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# IP_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ip_obfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray, color, cmap +int i, len, v_nargs, func + +int or(), strdic() +bool strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case FLIPX, FLIPY: + v_nargs = 1 + case RED, GREEN, BLUE: + v_nargs = 1 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zzi_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + + case TY_INT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memi[r+i] + + G_COEFF * Memi[g+i] + + B_COEFF * Memi[b+i] + } + + case TY_LONG: + do i = 0, len { + Memr[gray+i] = R_COEFF * Meml[r+i] + + G_COEFF * Meml[g+i] + + B_COEFF * Meml[b+i] + } + + case TY_REAL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memr[r+i] + + G_COEFF * Memr[g+i] + + B_COEFF * Memr[b+i] + } + + case TY_DOUBLE: + do i = 0, len { + Memr[gray+i] = R_COEFF * Memd[r+i] + + G_COEFF * Memd[g+i] + + B_COEFF * Memd[b+i] + } + + } + + case RED: + # Get the red colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + r = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Mems[r+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Memi[r+i]+1) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Meml[r+i]+1) + + } + + case GREEN: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + g = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,Mems[g+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,char(Memi[g+i]+1)) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,char(Meml[g+i]+1)) + + } + + case BLUE: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + b = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,Mems[b+i]+1) + + case TY_INT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,char(Memi[b+i]+1)) + + case TY_LONG: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,char(Meml[b+i]+1)) + + } + + case FLIPX: + # Set flag to reverse pixel order on output. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_X) + goto setop_ + + case FLIPY: + # Set flag to write image from bottom to top. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + + # Copy argument operand descriptor to 'o' +setop_ switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), O_LEN(args[1]), TY_SHORT) + call amovs (Mems[O_VALP(ARGS[1])], Mems[O_VALP(o)], O_LEN(o)) + + case TY_INT: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_INT + call malloc (O_VALP(o), O_LEN(args[1]), TY_INT) + call amovi (Memi[O_VALP(args[1])], Memi[O_VALP(o)], O_LEN(o)) + + case TY_LONG: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_LONG + call malloc (O_VALP(o), O_LEN(args[1]), TY_LONG) + call amovl (Meml[O_VALP(args[1])], Meml[O_VALP(o)], O_LEN(o)) + + case TY_REAL: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), O_LEN(args[1]), TY_REAL) + call amovr (Memr[O_VALP(args[1])], Memr[O_VALP(o)], O_LEN(o)) + + case TY_DOUBLE: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_DOUBLE + call malloc (O_VALP(o), O_LEN(args[1]), TY_DOUBLE) + call amovd (Memd[O_VALP(args[1])], Memd[O_VALP(o)], O_LEN(o)) + + } + + } + + if (DEBUG) { call zzi_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/import/generic/ipproc.x b/pkg/dataio/import/generic/ipproc.x new file mode 100644 index 00000000..def48b1c --- /dev/null +++ b/pkg/dataio/import/generic/ipproc.x @@ -0,0 +1,921 @@ +include <mach.h> +include <imhdr.h> +include <evvexpr.h> +include "../import.h" + +define DEBUG false + + +# IP_PRBAND -- Process a band interleaved file. + +procedure ip_prband (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix +int optype, nbytes_pix, percent +int cur_offset, band_offset, line_offset + +int ip_ptype() +long ip_lnote() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + # Compute the offset between the same pixel in different bands. This + # is the area of the image plus any image padding, computed as a + # byte offset. + optype = ip_ptype (IO_TYPE(PTYPE(ip,1)),IO_NBYTES(PTYPE(ip,1))) + switch (optype) { + case TY_UBYTE: nbytes_pix = 1 + case TY_USHORT, TY_SHORT: nbytes_pix = SZB_CHAR * SZ_SHORT + case TY_INT: nbytes_pix = SZB_CHAR * SZ_INT32 + case TY_LONG: nbytes_pix = SZB_CHAR * SZ_LONG + case TY_REAL: nbytes_pix = SZB_CHAR * SZ_REAL + case TY_DOUBLE: nbytes_pix = SZB_CHAR * SZ_DOUBLE + } + band_offset = (IP_AXLEN(ip,1) * (IP_AXLEN(ip,2)-1)) + + ((IP_LSKIP(ip) + IP_LPAD(ip)) * (IP_AXLEN(ip,2)-1)) + + IP_BSKIP(ip) + band_offset = (band_offset * nbytes_pix) #+ 1 + + if (DEBUG) { + call eprintf ("ip_prband: band_offset=%d curpos=%d\n") + call pargi(band_offset) ; call pargi(ip_lnote(fd)) + call zzi_prstruct ("ip_prband", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + # Skip pixels at front of line + line_offset = ip_lnote (fd) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, 1, npix, cmap) + + # Skip pixels at end of line. + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + cur_offset = ip_lnote (fd) + + # Loop over each of the remaining pixtypes. + do j = 2, IP_NPIXT(ip) { + # Seek to offset of next band (i.e. line_offset + band_offset). + call ip_lskip (fd, band_offset) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + call ip_rdline (ip, fd, j, npix, cmap) # read pixels in the line + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + + # Restore file pointer to cur_offset. + call ip_lseek (fd, cur_offset) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRLINE -- Process a line interleaved file. + +procedure ip_prline (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix, percent + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { + call eprintf ("ip_prline:\n") + call zzi_prstruct ("ip_prline", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + + do j = 1, IP_NPIXT(ip) { + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, j, npix, cmap) + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRPIX -- Process a pixel interleaved file. + +procedure ip_prpix (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +pointer op, data +int i, swap, optype, nlines +int percent, npix, totpix + +int and(), ip_ptype() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { call eprintf ("ip_prpix: ") } + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Allocate the pixtype data pointers. + npix = IP_AXLEN(ip,1) + nlines = IP_NPIXT(ip) + do i = 1, nlines { + op = PTYPE(ip,i) + optype = ip_ptype (IO_TYPE(op),IO_NBYTES(op)) + IO_NPIX(op) = npix + if (IO_DATA(op) == NULL) + if (optype == TY_UBYTE) + call malloc (IO_DATA(op), npix, TY_SHORT) + else + call malloc (IO_DATA(op), npix, optype) + } + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + totpix = npix * IP_NPIXT(ip) + swap = IP_SWAP(ip) + percent = 0 + if (DEBUG) { + call zzi_prstruct ("ip_prpix", ip) + call eprintf ("nl=%d np=%d tp=%d:\n") + call pargi(nlines) ; call pargi(npix) ; call pargi(totpix) + } + do i = 1, nlines { + + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line. + switch (optype) { + case TY_UBYTE: + call ip_agetb (fd, data, totpix) + call ip_lskip (fd, totpix) + # Apply a colormap to the bytes. In general a pixel-interleaved + # file is a 24-bit True Color image, but maybe this is a + # 3-D color index file? + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], totpix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (totpix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_SHORT))) + + + case TY_SHORT: + call ip_agets (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (totpix*(SZ_SHORT*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_SHORT))) + + case TY_INT: + call ip_ageti (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I4) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Memi[data], Memi[data], totpix) + call bswap4 (Memi[data], 1, Memi[data], 1, + (totpix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Memi[data], 1, Memi[data], 1, + (totpix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_INT32))) + + case TY_LONG: + call ip_agetl (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I4) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Meml[data], Meml[data], totpix) + call bswap4 (Meml[data], 1, Meml[data], 1, + (totpix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Meml[data], 1, Meml[data], 1, + (totpix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_INT32))) + + case TY_REAL: + call ip_agetr (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Memr[data], 1, Memr[data], 1, + (totpix*(SZ_REAL*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_REAL))) + + case TY_DOUBLE: + call ip_agetd (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Memd[data], 1, Memd[data], 1, + (totpix*(SZ_DOUBLE*SZB_CHAR))) + } + + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_DOUBLE))) + + } + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + + # Separate pixels into different vectors. + call ip_upkpix (ip, data, npix) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + + if (optype == TY_UBYTE) + call mfree (data, TY_SHORT) + else + call mfree (data, optype) + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PROBEXPR -- Process each of the outbands expressions and write the result +# to the output image. + +procedure ip_probexpr (ip, im, npix, line) + +pointer ip #i task struct pointer +pointer im #i output image pointer +int npix #i number of output pixels +int line #i line number + +int i +pointer out, ip_evaluate() + +begin + # Loop over outbands expressions. + do i = 1, IP_NBANDS(ip) { + # Evaluate outbands expression. + out = ip_evaluate (ip, O_EXPR(ip,i)) + + # Write bands to output image + if (IP_OUTPUT(ip) != IP_NONE) + call ip_wrline (ip, im, out, npix, line, i) + + call evvfree (out) + } +end + + +# IP_RDLINE -- Read a line of pixels from the binary file. + +procedure ip_rdline (ip, fd, pnum, npix, cmap) + +pointer ip #i task struct pointer +int fd #i input file descriptor +int pnum #i pixtype number +int npix #i number of pixels to read +pointer cmap #i colormap pointer + +pointer op, data +int swap, ptype + +int and(), ip_ptype() + +begin + # Read pixels in the line and save as operand. + op = PTYPE(ip,pnum) + ptype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + data = IO_DATA(op) + swap = IP_SWAP(ip) + IO_NPIX(op) = npix + + switch (ptype) { + case TY_UBYTE: + call ip_agetb (fd, data, npix) + call ip_lskip (fd, npix) + # Apply a colormap to the bytes. If the colormap is non-null we + # assume the bytes are color indices into a colormap. + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], npix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (npix * (SZB_CHAR * SZ_SHORT))) + + case TY_SHORT: + call ip_agets (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_SHORT*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_SHORT)) + + case TY_INT: + call ip_ageti (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Memi[data], Memi[data], npix) + call bswap4 (Memi[data], 1, Memi[data], 1, + (npix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Memi[data], 1, Memi[data], 1, + (npix*(SZ_INT*SZB_CHAR))) + } + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_INT32)) + + case TY_LONG: + call ip_agetl (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Meml[data], Meml[data], npix) + call bswap4 (Meml[data], 1, Meml[data], 1, + (npix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Meml[data], 1, Meml[data], 1, + (npix*(SZ_LONG*SZB_CHAR))) + } + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_INT32)) + + case TY_REAL: + call ip_agetr (fd, data, npix) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Memr[data], 1, Memr[data], 1, + (npix*(SZ_REAL*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_REAL)) + + case TY_DOUBLE: + call ip_agetd (fd, data, npix) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Memd[data], 1, Memd[data], 1, + (npix*(SZ_DOUBLE*SZB_CHAR))) + } + + call ip_lskip (fd, npix * (SZB_CHAR * SZ_DOUBLE)) + + } + IO_DATA(op) = data +end + + +# IP_WRLINE -- Write a line of pixels to the output image. We handle image +# flipping here to avoid possibly doing it several times while the outbands +# expression is being evaluated. + +procedure ip_wrline (ip, im, out, npix, line, band) + +pointer ip #i task struct pointer +pointer im #i output image pointer +pointer out #i output operand pointer +int npix #i number of pixels to read +int line #i image line number +int band #i image band number + +int i, lnum, type +int nldone, blnum +pointer sp, dptr, data, optr +bool lastline + +int and() +pointer imps3s(), imps3i(), imps3l(), imps3r(), imps3d() +pointer ip_chtype() + +data blnum /0/ +data nldone /1/ +data lastline /false/ + +begin + call smark (sp) + + # The first thing we do is change the datatype of the operand to + # match the output pixel type. + if (IP_OUTTYPE(ip) != NULL) { + if (IP_OUTTYPE(ip) == O_TYPE(out)) + optr = O_VALP(out) + else + optr = ip_chtype (out, IP_OUTTYPE(ip)) + } + type = IP_OUTTYPE(ip) + + # See if we're flipping image in Y, and adjust the line number. + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + lnum = IP_AXLEN(ip,2) - line + 1 + if (band == 1) + blnum = IP_SZBUF(ip) - mod (line-1, IP_SZBUF(ip)) + lastline = (lnum == 1) + } else { + lnum = line + if (band == 1) + blnum = blnum + 1 + lastline = (lnum == IP_AXLEN(ip,2)) + } + + # See if we're flipping image in x, and reverse the pixels. + if (and(IP_FLIP(ip),FLIP_X) == FLIP_X) { + call salloc (dptr, npix, type) + do i = 1, npix { + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[dptr+i-1] = Mems[optr+(npix-i)] + + case TY_INT: + Memi[dptr+i-1] = Memi[optr+(npix-i)] + + case TY_LONG: + Meml[dptr+i-1] = Meml[optr+(npix-i)] + + case TY_REAL: + Memr[dptr+i-1] = Memr[optr+(npix-i)] + + case TY_DOUBLE: + Memd[dptr+i-1] = Memd[optr+(npix-i)] + + } + } + } else + dptr = optr + + # Make sure the image pixtype is set. + if (IM_PIXTYPE(im) == NULL) + IM_PIXTYPE(im) = type + + # Allocate the buffer pointer if needed. + if (BUFFER(ip,band) == NULL) + call calloc (BUFFER(ip,band), npix*IP_SZBUF(ip), IP_OUTTYPE(ip)) + + if (nldone < IP_SZBUF(ip) && !lastline) { + # Copy the image line to the buffer + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + + case TY_INT: + call amovi (Memi[dptr], Memi[data+((blnum-1)*npix)], npix) + + case TY_LONG: + call amovl (Meml[dptr], Meml[data+((blnum-1)*npix)], npix) + + case TY_REAL: + call amovr (Memr[dptr], Memr[data+((blnum-1)*npix)], npix) + + case TY_DOUBLE: + call amovd (Memd[dptr], Memd[data+((blnum-1)*npix)], npix) + + } + if (band == IP_NBANDS(ip)) + nldone = nldone + 1 + + } else { + # Write the buffer to the image as a section. + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3s (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovs (Mems[BUFFER(ip,band)+(blnum-1)*npix], + Mems[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3s (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovs (Mems[BUFFER(ip,band)], Mems[data], npix*blnum) + } + + case TY_INT: + call amovi (Memi[dptr], Memi[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3i (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovi (Memi[BUFFER(ip,band)+(blnum-1)*npix], + Memi[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3i (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovi (Memi[BUFFER(ip,band)], Memi[data], + npix*blnum) + } + + case TY_LONG: + call amovl (Meml[dptr], Meml[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3l (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovl (Meml[BUFFER(ip,band)+(blnum-1)*npix], + Meml[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3l (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovl (Meml[BUFFER(ip,band)], Meml[data], + npix*blnum) + } + + case TY_REAL: + call amovr (Memr[dptr], Memr[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3r (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovr (Memr[BUFFER(ip,band)+(blnum-1)*npix], + Memr[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3r (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovr (Memr[BUFFER(ip,band)], Memr[data], + npix*blnum) + } + + case TY_DOUBLE: + call amovd (Memd[dptr], Memd[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3d (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovd (Memd[BUFFER(ip,band)+(blnum-1)*npix], + Memd[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3d (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovd (Memd[BUFFER(ip,band)], Memd[data], + npix*blnum) + } + + } + if (band == IP_NBANDS(ip)) { + nldone = 1 + blnum = 0 + } + } + + if (IP_OUTTYPE(ip) != O_TYPE(out)) + call mfree (optr, type) + call sfree (sp) +end + + +# IP_UPKPIX -- Unpack a line of pixel-interleaved pixels to the separate +# pixtype operand arrays. + +procedure ip_upkpix (ip, ptr, npix) + +pointer ip #i task struct pointer +pointer ptr #i pointer to pixels +int npix #i number of pixels in line + +pointer op[IM_MAXDIM] +int i, j, np, optype[IM_MAXDIM] + +int ip_ptype() + +begin + np = IP_NPIXT(ip) + do j = 1, np { + op[j] = PTYPE(ip,j) + optype[j] = ip_ptype (IO_TYPE(op[j]),IO_NBYTES(op[j])) + } + + do j = 1, np { + + do i = 0, npix-1 { + switch (optype[j]) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[IO_DATA(op[j])+i] = Mems[ptr+(i*np+j)-1] + + case TY_INT: + Memi[IO_DATA(op[j])+i] = Memi[ptr+(i*np+j)-1] + + case TY_LONG: + Meml[IO_DATA(op[j])+i] = Meml[ptr+(i*np+j)-1] + + case TY_REAL: + Memr[IO_DATA(op[j])+i] = Memr[ptr+(i*np+j)-1] + + case TY_DOUBLE: + Memd[IO_DATA(op[j])+i] = Memd[ptr+(i*np+j)-1] + + } + } + } +end + + +# IP_FIX_PIXTYPE -- Create the pixtype operands for 3-D band or line- +# interleaved files. These weren't allocated at first since the pixtype +# parameter or database field was atomic. + +procedure ip_fix_pixtype (ip) + +pointer ip #i task struct pointer + +pointer op, op1 +int i, nnp + +begin + if (DEBUG) { + call eprintf ("fix_pixtype: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # See if there's anything to be fixed. + if (IP_NDIM(ip) < 3 || IP_NDIM(ip) < IP_NPIXT(ip)) + return + if (BAND_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_NDIM(ip))) + return + if (LINE_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_INTERLEAVE(ip))) + return + + if (LINE_INTERLEAVED(ip)) + nnp = IP_INTERLEAVE(ip) + else + #nnp = IP_NDIM(ip) + nnp = IP_AXLEN(ip,3) + + # Make the new pixtype operands. + op1 = PTYPE(ip,1) + do i = 2, nnp { + call ip_alloc_operand (PTYPE(ip,i)) + op = PTYPE(ip,i) + IO_TYPE(op) = IO_TYPE(op1) + IO_NBYTES(op) = IO_NBYTES(op1) + call sprintf (OP_TAG(op), SZ_TAG, "b%d") + call pargi (i) + } + IP_NPIXT(ip) = nnp + + if (DEBUG) { call zzi_prstruct ("fix_pixtype", ip) } +end + + +# IP_FIX_OUTBANDS -- Create the outbands operands if none were specified in +# the parameter file. + +procedure ip_fix_outbands (ip) + +pointer ip #i task struct pointer + +pointer sp, buf +pointer im +int i, nbands + +define SZ_OBSTR 2500 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + if (DEBUG) { + call eprintf ("fix_outbands: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # Free up the existing outbands operands. + nbands = IP_NBANDS(ip) + do i = 1, nbands + call ip_free_outbands (OBANDS(ip,i)) + + # Create an outbands parameter string according to the tags in the + # pixtype structure. This way we preserve any user-defined tags on + # output. + nbands = IP_NPIXT(ip) + call aclrc (Memc[buf], SZ_FNAME) + do i = 1, nbands { + call ip_alloc_outbands (OBANDS(ip,i)) + call aclrc (Memc[buf], SZ_FNAME) + call sprintf (Memc[buf], SZ_FNAME, "b%d") + call pargi (i) + call strcpy (Memc[buf], O_EXPR(ip,i), SZ_EXPR) + + # Load the operand struct. + call strcpy (Memc[buf], OP_TAG(O_OP(ip,i)), SZ_EXPR) + } + IP_NBANDS(ip) = nbands + + # Fix the output image dimensions. + im = IP_IM(ip) + IM_LEN(im,3) = IP_AXLEN(ip,3) + if (IP_NBANDS(ip) > 1) + IM_NDIM(im) = 3 + else + IM_NDIM(im) = IP_NDIM(ip) + + call sfree (sp) + + if (DEBUG) { call zzi_prstruct ("fix_outbands", ip) } +end + + +# IP_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. + +pointer procedure ip_chtype (op, type) + +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # Change the pixel type. + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + default: + call error (0, "Invalid output type requested.") + } + + out = coerce (out, TY_CHAR, type) + return (out) +end + + +define NTYPES 6 +define NBITPIX 4 + +# IP_PTYPE -- For a given pixtype parameter return the corresponding IRAF +# data type. + +int procedure ip_ptype (type, nbytes) + +int type #i pixel type +int nbytes #i number of bytes + +int i, pt, pb, ptype +int tindex[NTYPES], bindex[NBITPIX], ttbl[NTYPES*NBITPIX] + +data tindex /PT_BYTE, PT_UINT, PT_INT, PT_IEEE, PT_NATIVE, PT_SKIP/ +data bindex /1, 2, 4, 8/ + +data (ttbl(i), i= 1, 4) /TY_UBYTE, TY_USHORT, TY_INT, 0/ # B +data (ttbl(i), i= 5, 8) /TY_UBYTE, TY_USHORT, 0, 0/ # U +data (ttbl(i), i= 9,12) /TY_UBYTE, TY_SHORT, TY_INT, 0/ # I +data (ttbl(i), i=13,16) / 0, 0, TY_REAL, TY_DOUBLE/ # R +data (ttbl(i), i=17,20) / 0, 0, TY_REAL, TY_DOUBLE/ # N +data (ttbl(i), i=21,24) /TY_UBYTE, TY_USHORT, TY_REAL, TY_DOUBLE/ # X + +begin + if (type == 0 || nbytes == 0) # uninitialized values + return (0) + + pt = NTYPES + do i = 1, NTYPES { + if (tindex[i] == type) + pt = i + } + pb = NBITPIX + do i = 1, NBITPIX { + if (bindex[i] == nbytes) + pb = i + } + + ptype = ttbl[(pt-1)*NBITPIX+pb] + if (ptype == 0) + call error (0, "Invalid pixtype specified.") + else + return (ptype) +end + + +# IP_PSTAT - Print information about the progress we're making. + +procedure ip_pstat (ip, row, percent) + +pointer ip #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / IP_AXLEN(ip,2) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/import/generic/mkpkg b/pkg/dataio/import/generic/mkpkg new file mode 100644 index 00000000..9e8721db --- /dev/null +++ b/pkg/dataio/import/generic/mkpkg @@ -0,0 +1,15 @@ +# Compile the generic sources. + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + ipdb.x ../import.h ../ipfcn.h \ + <error.h> <evvexpr.h> <imhdr.h> <mach.h> + ipfio.x ../import.h <fset.h> <mach.h> + ipobands.x ../import.h ../ipfcn.h <error.h> <evvexpr.h> \ + <fset.h> <mach.h> + ipproc.x ../import.h <evvexpr.h> <imhdr.h> <mach.h> + ; diff --git a/pkg/dataio/import/images.dat b/pkg/dataio/import/images.dat new file mode 100644 index 00000000..dd8123ce --- /dev/null +++ b/pkg/dataio/import/images.dat @@ -0,0 +1,433 @@ +# IMAGES.DAT -- Database of known formats recognized by the IMPORT task. +# +# Each record of the database is of the form: +# +# <format_name>: +# <alias>: +# <alias>: +# keyword = <expr> +# keyword = <expr> +# ...and so on +# +# A database record begins with the format name at the beginning of a line. +# Whitespace at the beginning of a line is considered the continuation of a +# previous line. Comments may be inserted in the database using the normal '#' +# character, the remainder of the line is considered a comment. Blank lines +# and comments are ignored, a record ends at the next line with a format name +# at the beginning of the line. +# +# The format_name field is a string identifying each entry in the +# database, an alias may also be given to identify the same field if known +# by another name. Supported keywords include: +# +# image_id - A boolean expression identifying the image type, either +# using a literal string or one of the provided functions +# id_string - Verbose name of file format +# bswap - Is file byte-swapped? (See Below) +# dims - A whitespace/comma delimited string of image dimension +# pixtype - Pixel type, size [and tag], may be a composite +# interleave - Describes how pixels are stored +# hskip - # of bytes of header info to skip +# tskip - # of bytes of trailing info to skip at end of file +# bskip - # of bytes of info to skip between image bands +# lskip - # of bytes of info to skip at the front of each line +# lpad - # of bytes of info to skip at the end of each line +# yflip - Image is flipped relative to normal IRAF orientation +# comment - (Multiple) informational comment string to be printed, +# e.g. to warn the user about the pixel ordering. +# error - A condition that would cause a file read error, returns +# a string with the error message, otherwise NULL +# +# Expressions include not only functions supported by the system expression +# evaluator but also special functions particular to the IMPORT task. The +# user is referred to the IMPORT help page for more details on the database +# functions. +# +# Expressions may also contain *previously defined* database fields, so for +# instance the 'hskip' keyword can be computed in an expression using the +# value of the 'pixtype' keyword. Additionally, several special operands are +# also supported and may be used in expressions: +# +# $FSIZE - the size in bytes of the binary file +# $FNAME - the name of the binary file + + + +avs: # AVS X image file +mbfx: +mbfavs: +x: + image_id = ($FSIZE - (geti4(1) * geti4(5) * 4) == 8) + id_string = "AVS X Image Format file" + dims = (str(geti4(1)) // "," // str(geti4(5))) // ",4" + pixtype = "x1,b1,b1,b1" + hskip = 8 + yflip = 1 + comment = "Note: The first band of this image is an alpha channel." + + +clementine: # CLEMENTINE mission image +pds3: + image_id = (getstr(1,23) == "PDS_VERSION_ID = PDS3") + id_string = "CLEMENTINE 1 PDS3 image data file" + pixtype = "b1" + hskip = int(locate(1,"OBJECT = IMAGE\r\n")+16) + bskip = int(locate(hskip,"LINE_SAMPLES")) + lskip = int(locate(hskip,"LINES")) +# dims = ((str(ctoi((locate(hskip,"LINE_SAMPLES")+17)))) // "," // +# (str(ctoi((locate(hskip,"LINES")+17)))) ) + dims = ((str(ctoi((locate(bskip,"=")+1)))) // "," // + (str(ctoi((locate(lskip,"=")+1)))) ) + hskip = (ctoi(locate(1,"^IMAGE ")+18)) + bskip = 0 + lskip = 0 + yflip = 0 + + +export: # EXPORT task output format + image_id = (getstr(1,15) == "format = EXPORT") + id_string = "IRAF EXPORT file (with header)" + bswap = (getstr(locate(1,"bswap")+9,locate(1,"bswap")+11) == "no") + hskip = ctoi(locate(1,"hdrsize =")+10) + pixtype = (getstr(locate(1,"datatype = '")+12,2)) + dims = ((ctoi(locate(1,"nbands =")+8) > 1) ? + (str(ctoi(locate(1,"ncols = ")+8)) // "," // + str(ctoi(locate(1,"nrows = ")+8)) // "," // + str(ctoi(locate(1,"nbands = ")+9))) + : (str(ctoi(locate(1,"ncols = ")+8)) // "," // + str(ctoi(locate(1,"nrows = ")+8)))) + interleave = ctoi(locate(1,"interleave =")+13) + + +fits: # Uhh, use RFITS for this + bswap = parameter ("bswap") + image_id = (getstr(1,9) == "SIMPLE =") + id_string = "FITS Format image" + hskip = ( int (locate(1,"END ") / 2800) ) * 2880 + pixtype = ( str (ctoi((locate(1,"BITPIX")+10))) ) + pixtype = ((pixtype == "8" ? "b1" : + (pixtype == "16" ? "i2" : + (pixtype == "32" ? "i4" : + (pixtype == "-32" ? "r4" : + (pixtype == "-64" ? "r8" : "0")))))) + dims = ((ctoi(locate(1,"NAXIS ")+10) == 3) ? + (str(ctoi(locate(1,"NAXIS1")+10)) // "," // + str(ctoi(locate(1,"NAXIS2")+10)) // "," // + str(ctoi(locate(1,"NAXIS3")+10))) + : (str(ctoi(locate(1,"NAXIS1")+10)) // "," // + str(ctoi(locate(1,"NAXIS2")+10)))) + + +gif: # CompuServe's GIF format +giff: + image_id = ( (getstr(1,6) == "GIF87a") || (getstr(1,6) == "GIF89a") ) + id_string = "CompuServe GIF Format File" + dims = (str((getb(7)+(256*getb(8)))) //","// str((getb(9)+(256*getb(10))))) + pixtype = "u1" + hskip = 22 + yflip = 1 + comment = "Note: Colormap information will automatically be applied." + + +oif: # An IRAF OIF pixel file +imh: +iraf: + bswap = (geti2(1) == 26880 && # bswap("impix" in SPP chars) + geti2(3) == 27904 && + geti2(5) == 28672 && + geti2(7) == 26880 && + geti2(9) == 30720) + image_id = (geti2(1) == 105 && # "impix" in SPP chars + geti2(3) == 109 && + geti2(5) == 112 && + geti2(7) == 105 && + geti2(9) == 120) + id_string = "IRAF OIF image pixel file" + dims = ((geti2(23) == 3) ? + (str(geti2(27)) //","// str(geti2(31)) //","// str(geti2(35))) + : (str(geti2(27)) //","// str(geti2(31))) ) + pixtype = ((geti2(17) == 3 ? "i2" : + (geti2(17) == 4 ? "i4" : + (geti2(17) == 5 ? "i4" : + (geti2(17) == 6 ? "n4" : + (geti2(17) == 7 ? "n8" : ""))))) ) + hskip = 1024 + lpad = (geti2(55) - geti2(27)) + lpad = (lpad * ((geti2(17) == 3 ? (2) : + (geti2(17) == 4 ? (4) : + (geti2(17) == 5 ? (4) : + (geti2(17) == 6 ? (4) : + (geti2(17) == 7 ? (8) : (1))))))) ) + error = (geti2(23) > 3) ? "Maximum of 3 dimensions supported." : "okay" + error = ((geti2(17) > 7) || (geti2(17) < 3)) ? + "Image data type not supported." : "okay" + + +mcidas: # Unidata McIDAS file + image_id = (geti4(5) == 4) + id_string = "McIDAS" + dims = (str(geti4(37)) // "," // str(geti4(33))) + pixtype = "b1" + hskip = geti4(133) + lskip = geti4(57) + yflip = 1 + + +miff: # ImageMagick MIFF format +mif: + image_id = (locate(1,"id=ImageMagick") < locate (1,":\n")) + id_string = "ImageMagick MIFF format file" + hskip = ((locate(1,":\n") + 1) + (ctoi(locate(1,"colors=")+7) * 3) + 1) + dims = (str(ctoi(locate(1,"columns=")+8)) // "," // + str(ctoi(locate(1,"rows=")+5)) ) + yflip = 1 + pixtype = (getstr(locate(1,"class=")+6,6) == "Direct" ? "b1,b1,b1" : + ((ctoi(locate(1,"colors=")+7) > 256) ? "b2" : "b1")) + error = locate(1,"compression") > 1 ? + "Compressed files not supported" : "okay" + error = ctoi(locate(1,"colors=")+7) > 256 ? + "Too many entries in colormap" : "okay" + comment = "Note: Colormaps will not be applied to image." + + +pgm: # PBMPlus PGM format +rpgm: + image_id = (getstr(1,2) == "P5" || getstr(1,2) == "P2") + id_string = "PBMPlus PGM format file" + pixtype = "b1" + hskip = ((str(getstr(line(2),1)) != "#") ? # see if there's a comment + (int(line(4) - 1)) + : (int(line(5) - 1)) ) + dims = ((str(getstr(line(2),1)) != "#") ? + (str(ctoi(line(2))) // "," // str(ctoi(locate(line(2)," ")))) + : (str(ctoi(line(3))) // "," // str(ctoi(locate(line(3)," ")))) ) + yflip = 1 + error = getstr(1,2) == "5P" ? "File is byte-swapped" : "okay" + error = getstr(1,2) == "P2" ? "Only raw PGM files are supported." : "okay" + + +ppm: # PBMPlus PPM format +pnm: +rppm: + image_id = (getstr(1,2) == "P6" || getstr(1,2) == "P3") + id_string = "PBMPlus PPM format file" + pixtype = "b1,b1,b1" + hskip = ((str(getstr(line(2),1)) != "#") ? # see if there's a comment + (int(line(4) - 1)) + : (int(line(5) - 1)) ) + dims = ((str(getstr(line(2),1)) != "#") ? + (str(ctoi(line(2))) // "," // str(ctoi(locate(line(2)," ")))) + : (str(ctoi(line(3))) // "," // str(ctoi(locate(line(3)," ")))) ) + dims = dims // ",3" + yflip = 1 + error = getstr(1,2) == "6P" ? "File is byte-swapped" : "okay" + error = getstr(1,2) == "P3" ? "Only raw PGM files are supported." : "okay" + + +rgb: # SGI RGB format image +iris: +sgi: + bswap = (getu(1) == bswap(0732b)) + image_id = (getu(1) == 0732b) + id_string = "SGI RGB Image file" + dims = ((geti2(5) == 3) ? + (str(geti2(7)) // "," // str(geti2(9)) // "," // str(geti2(11))) + : (str(geti2(7)) // "," // str(geti2(9))) ) + pixtype = "b1" + hskip = 512 + interleave = 0 + error = (geti2(3) == 3) ? "Colormap files not supported" : "okay" + error = ((geti2(3) != 0) && (geti2(3) != 1)) ? + "Format of RGB file not supported" : "okay" + error = (geti2(3) == 257) ? "RLE compressed files not supported" : "okay" + + +sunras: # Sun rasterfile +ras: + bswap = (geti4(1) == bswap(59a66a95x)) + image_id = (geti4(1) == 59a66a95x || bswap) + id_string = "Sun Rasterfile" + dims = (str(geti4(5)) // "," // str(geti4(9)) // + ((geti4(13) > 8) ? ("," // str(3)) : " ") ) + pixtype = ((geti4(13) == 8 ? "b1" : + (geti4(13) == 24 ? "b1,b1,b1" : + (geti4(13) == 32 ? "x1,b1,b1,b1" : "x1,b1,b1,b1") )) ) + interleave = 0 + hskip = (32 + geti4(29)) + yflip = 1 + comment = "Note: Colormaps will automatically be applied to 8-bit images." + error = geti4(13) == 1 ? "1-bit rasters not supported." : "okay" + + +iff: # Sun TAAC Image File Format +taac: +vff: +suniff: + image_id = (getstr(1,4) == "ncaa") + id_string = "Sun TAAC Image File Format" + dims = (str(ctoi(locate(1,"size=")+5)) // "," // + str(ctoi(locate((locate(1,"size=")+5)," "))) ) + dims = ((ctoi((locate(1,"bands=")+6)) == 3) ? (dims // ",3") : dims ) + hskip = $FSIZE - (ctoi(locate(1,"size=")+5) * + ctoi(locate((locate(1,"size=")+5)," ")) * + ctoi((locate(1,"bands=")+6)) ) + pixtype = ((ctoi((locate(1,"bands=")+6)) == 3) ? "b1,b1,b1" : "b1" ) + yflip = 1 + comment = "Note: Colormaps will not be applied to 8-bit images." + + +vicar: # VICAR format file + bswap = ( msb_host() && (getstr((locate(1,"INTFMT=")+8),3) == "LOW") ) + image_id = (getstr(1,8) == "LBLSIZE=") + id_string = "VICAR format image data file" + hskip = (ctoi((locate(1,"LBLSIZE=")+8)) + + (ctoi((locate(1,"NLB=")+4)) * ctoi((locate(1,"RECSIZE=")+8)))) + lskip = (ctoi((locate(1,"NBB=")+4))) + interleave = (((getstr((locate(1,"ORG=")+5),3))) == "BSQ" ? 0 : + ((getstr((locate(1,"ORG=")+5),3)) == "BIL" ? + ctoi(locate(1,"NB=")+3) : 999) ) + pixtype = (getstr((locate(1,"FORMAT=")+8),4)) + pixtype = ((pixtype == "BYTE" ? "b1" : + (pixtype == "HALF" ? "i2" : + (pixtype == "FULL" ? "i4" : + (pixtype == "REAL" ? "r4" : + (pixtype == "DOUB" ? "r8" : "0")))))) + pixtype = (((interleave) != 999) ? pixtype : + ((ctoi(locate(1,"DIM=")+5) == 2) ? + pixtype // "," // pixtype : + ((ctoi(locate(1,"DIM=")+5) == 3) ? + pixtype // "," // pixtype // "," // pixtype : + (pixtype) )) ) + dims = (((ctoi(locate(1,"DIM=")+4)==3) && (ctoi(locate(1,"N3=")+3)!=1)) ? + (str(ctoi(locate(1,"N1=")+3)) // "," // + str(ctoi(locate(1,"N2=")+3)) // "," // + str(ctoi(locate(1,"N3=")+3))) + : (str(ctoi(locate(1,"N1=")+3)) // "," // + str(ctoi(locate(1,"N2=")+3)))) + yflip = 1 + error = ((getstr((locate(1,"TYPE=")+6),5) != "IMAGE") ? + "Not a VICAR image file." : "okay") + error = ((getstr((locate(1,"FORMAT=")+8),4) == "COMP") ? + "Complex image data not supported" : "okay") + + +x10: # X10 Window Dump file +x10wd: + image_id = (geti4(5) == 6) + id_string = "X10 Window Dump file" + hskip = ( geti4(1) + (10 * geti2(39)) ) + pixtype = "b1" + dims = (str(geti4(21)) // "," // str(geti4(25))) + comment = "Note: Colormaps will not be applied to image." + + +xwd: # X11 Window Dump file +x11: +x11wd: + #bswap = ( msb_host() && (geti4(29) == 0) ) + image_id = (geti4(5) == 7) + id_string = "X11 Window Dump file" + dims = (str(geti4(17)) // "," // str(geti4(21))) + dims = ( (geti4(45) == 24) ? str (dims // ",3") : dims ) # add dims + dims = ( (geti4(45) == 32) ? str (dims // ",4") : dims ) # add dims + hskip = ( geti4(1) + (12 * geti4(73)) ) + # On a 64-bit machine the colormap struct is 16 bytes long instead of + # 12, see if we have one of these files and pad the header. + hskip = ( ((geti4(17)*geti4(21)*(geti4(45)/8)) + hskip) < ($FSIZE-1024) ? + (hskip + (4*geti4(73))) : hskip) + lpad = ( geti4(49) - (geti4(17) * (geti4(45) / 8)) ) + pixtype = ( (geti4(45) == 8) ? "b1" : + (geti4(45) == 24) ? "b1,b1,b1" : + (geti4(45) == 32) ? "x1,b1,b1,b1" : "x1,b1,b1,b1" ) + yflip = 1 + + + +######################################################################### +# # +# The following database entries are not supported for conversion but # +# are provided for file identification purposes. # +# # +######################################################################### + + +cmuwmraster: # CMU Window Manager Raster + bswap = (geti4(1) == bswap(00F10040BBx)) + image_id = (geti4(1) == 00F10040BBx || bswap) + id_string = "CMU Window manager Raster file (ID only)" + dims = (str(geti4(5)) // "," // str(geti4(9)) // "," // str(geti2(11))) + error = (1 == 1) ? "CMU raster supported for file identification only." : + "okay" + + +fbm: # Fuzzy Bitmap Format file + image_id = (getstr(1,7) == "%bitmap") + id_string = "Fuzzy Bitmap Format file (ID only)" + dims = (str(ctoi(getstr(17,8))) // "," // str(ctoi(getstr(9,8)))) + error = (1 == 1) ? "FBM supported for file identification only." : + "okay" + + +hdf: # NCSA Hierarchical Data File +df: +ncsa: + bswap = ( lsb_host() ) + image_id = (geti4(1) == 0e031301x) + id_string = "NCSA Hierarchical Data File (ID only)" + dims = (str(geti2(822)) // "," // str(geti2(826))) + error = (1 == 1) ? "NCSA HDF supported for file identification only." : + "okay" + +msp: # Microsoft Paint Bitmap + bswap = (geti2(1) == bswap(01800x) || geti2(1) == bswap(0694Cx)) + image_id = ((geti2(1) == 01800x && geti2(3) == 04D6Ex) || + (geti2(1) == 0694Cx && geti2(3) == 0536Ex)) + id_string = "Microsoft Paint Bitmap (ID only)" + dims = (str(geti2(5)) // "," // str(geti2(7))) + error = (1 == 1) ? "MSP supported for file identification only." : + "okay" + +pcx: # PC Paintbrush File Format +dcx: +pcc: + image_id = (getb(1) == 010x) + id_string = "PC Paintbrush File (ID only)" + dims = (str(geti2(9) - geti2(5) + 1) // "," // + str(geti2(11) - geti2(7) + 1)) + error = (1 == 1) ? "PC Paintbrush supported for file identification only." : + "okay" + +pic: # Pictor PC Paint +clp: + bswap = (geti2(1) == bswap(01234x)) + image_id = (geti2(1) == 01234x) + id_string = "Pictor PC Paint bitmap (ID only)" + dims = (str(geti2(3)) // "," // str(geti2(5))) + error = (1 == 1) ? "PC Paint supported for file identification only." : + "okay" + +ps: # Postscript file +postscript: + image_id = (getstr(1,2) == "%!") + id_string = "Postscript file (ID only)" + error = (1 == 1) ? "PS supported for file identification only." : + "okay" + + +rle: # Utah Raster Toolkit file +utah: + image_id = (getb(1) == 52x || getb(1) == 00CCx) + id_string = "Utah Raster Toolkit Format file (ID only)" + error = (1 == 1) ? "RLE supported for file identification only." : + "okay" + + +tif: # TIFF format file +tiff: + bswap = (geti2(1) == bswap(4949x) || geti2(1) == bswap(4D4Dx)) + image_id = ((geti2(1) == 4D4Dx && geti2(3) == 002Ax) || + (geti2(1) == 4949x && geti2(3) == 2A00x)) + id_string = "TIFF Format file (ID only)" + error = (1 == 1) ? "TIFF supported for file identification only." : + "okay" + diff --git a/pkg/dataio/import/import.h b/pkg/dataio/import/import.h new file mode 100644 index 00000000..6d80020a --- /dev/null +++ b/pkg/dataio/import/import.h @@ -0,0 +1,132 @@ +# IMPORT.H - Data structure definition file for the IMPORT task. + +define SZ_IMPSTRUCT 40 # size of the import structure +define SZ_EXPR (20*SZ_LINE) # max size of an expression +define SZ_COMMENT 1024 # size of a database format comment +define LEN_UA 20000 # minimum user header length +define MAX_OPERANDS 1024 + +# Input format parameters. +define IP_INTERLEAVE Memi[$1] # type of data interleaving +define IP_HSKIP Memi[$1+1] # bytes to skip before data +define IP_TSKIP Memi[$1+2] # bytes to skip after data +define IP_BSKIP Memi[$1+3] # bytes between image bands +define IP_LSKIP Memi[$1+4] # bytes to skip at front of line +define IP_LPAD Memi[$1+5] # bytes to skip at end of line +define IP_SWAP Memi[$1+6] # type of byte swapping +define IP_NPIXT Memi[$1+7] # number of pixtypes +define IP_PIXTYPE Memi[$1+8] # pixtype ptr to operands +define IP_NDIM Memi[$1+9] # number of input axes +define IP_AXLEN Memi[($1+10)+$2-1] # input axis dimension + +# Output parameters. +define IP_OUTPUT Memi[$1+20] # type of output generated +define IP_OUTTYPE Memi[$1+21] # output pixel type +define IP_NBANDS Memi[$1+22] # no. of outbands expr string +define IP_OUTBANDS Memi[$1+23] # outbands expr string (ptr) +define IP_IMHEADER Memi[$1+24] # file w/ header info (ptr) +define IP_VERBOSE Memi[$1+25] # verbose output flag + +define IP_FORMAT Memi[$1+26] # format param +define IP_BLTIN Memi[$1+27] # format is a 'builtin' +define IP_FCODE Memi[$1+28] # builtin format code +define IP_FSYM Memi[$1+29] # symtab pointer to db record +define IP_IM Memi[$1+30] # output image pointer +define IP_FD Memi[$1+31] # binary file pointer +define IP_OFFSET Memi[$1+32] # binary file offset +define IP_FLIP Memi[$1+33] # output image orientation flag +define IP_COMPTR Memi[$1+34] # comment block pointer + +define IP_BUFPTR Memi[$1+35] # array of image buffers (ptr) +define IP_NPTRS Memi[$1+36] # number of image buffer +define IP_SZBUF Memi[$1+37] # size of image buffer (lines) + +define IP_CMAP Memi[$1+38] # image colormap (ptr) +define IP_USE_CMAP Memi[$1+39] # use the image colormap? + +# Useful Macros +define PTYPE Memi[IP_PIXTYPE($1)+$2-1] +define OBANDS Memi[IP_OUTBANDS($1)+$2-1] +define COMMENT Memc[IP_COMPTR($1)] +define BUFFER Memi[IP_BUFPTR($1)+$2-1] + + +#----------------------------------------------------------------------------- + +# Outbands structure +define LEN_OUTBANDS 2 +define OB_EXPR Memi[$1] # expression string +define OB_OP Memi[$1+1] # operand struct pointer +define O_EXPR Memc[OB_EXPR(OBANDS($1,$2))] +define O_OP OB_OP(OBANDS($1,$2)) + +# Operand structure +define SZ_TAG 15 +define LEN_OPERAND 6 +define IO_TAG Memi[$1] # operand tag name +define IO_TYPE Memi[$1+1] # operand type +define IO_NBYTES Memi[$1+2] # number of bytes +define IO_NPIX Memi[$1+3] # number of pixels +define IO_DATA Memi[$1+4] # line of pixels +define OP_TAG Memc[IO_TAG($1)] + + +# Format type flags +define IP_NONE 1 # format derived from task params +define IP_SENSE 2 # format divined from database +define IP_NAME 3 # format derived from database +define IP_BUILTIN 4 # format derived from database + +# Output type flags +define IP_IMAGE 5 # generate an output image +define IP_LIST 6 # list pixels (according to 'outbands') +define IP_INFO 7 # print info about image format + +# Byte swapping flags +define S_NONE 000B # swap nothing +define S_ALL 001B # swap everything +define S_I2 002B # swap short ints +define S_I4 004B # swap long ints +define SWAP_STR "|no|none|yes|i2|i4|" + +# Image flipping flags +define FLIP_NONE 000B # don't flip the image +define FLIP_X 001B # flip image in X +define FLIP_Y 002B # flip image in Y + +# Pixtype pixel types +define PT_BYTE 1 # byte data (no conversion) +define PT_UINT 2 # unsigned integer +define PT_INT 3 # signed integer +define PT_IEEE 4 # ieee floating point +define PT_NATIVE 5 # native floating point +define PT_SKIP 6 # skip + +# Default task parameters. +define DEF_SWAP S_NONE +define DEF_INTERLEAVE 0 +define DEF_HSKIP 0 +define DEF_TSKIP 0 +define DEF_BSKIP 0 +define DEF_LSKIP 0 +define DEF_LPAD 0 + +# Useful macros. +define BAND_INTERLEAVED ((IP_NPIXT($1)==1)&&(IP_INTERLEAVE($1)==0)) +define LINE_INTERLEAVED ((IP_NPIXT($1)==1)&&(IP_INTERLEAVE($1)>1)) +define PIXEL_INTERLEAVED ((IP_NPIXT($1)>1)&&(IP_INTERLEAVE(ip)==0)) + +# NTSC grayscale coefficients. +define R_COEFF 0.299 +define G_COEFF 0.587 +define B_COEFF 0.114 + +# Colormap definitions. +define CMAP_SIZE 256 # Output colormap length +define CMAP_MAX 255 # Maximum map value +define CMAP Memc[$1+($2*CMAP_SIZE)+$3-1] + +define IP_RED 0 +define IP_GREEN 1 +define IP_BLUE 2 + diff --git a/pkg/dataio/import/ipbuiltin.x b/pkg/dataio/import/ipbuiltin.x new file mode 100644 index 00000000..e95719be --- /dev/null +++ b/pkg/dataio/import/ipbuiltin.x @@ -0,0 +1,91 @@ +include "import.h" + + +# Define the builtin format names. We also define the aliases in case the +# user specifies one of these instead, the 'sensed' format name is the +# proper name. + +define IP_BUILTINS "|gif|giff\ + |sunras|ras\ + |xwd|x11|" + +define IP_GIF 1 # CompuServe GIF format +define IP_GIFF 2 # CompuServe GIF format +define IP_SUNRAS 3 # Sun Rasterfile +define IP_RAS 4 # Sun Rasterfile +define IP_XWD 5 # X11 Window Dump +define IP_X11 6 # X11 Window Dump + + + +# IP_PRBUILTIN -- Process a 'builtin' format. + +procedure ip_prbuiltin (ip, fname) + +pointer ip #i task struct pointer +char fname[ARB] #i file name + + +begin + # Branch off to the particular format. + switch (IP_FCODE(ip)) { + case IP_GIF, IP_GIFF: + call ip_gif (ip, fname, NO, NO) + case IP_SUNRAS, IP_RAS: + call ip_ras (ip, fname, NO, NO) + case IP_XWD, IP_X11: + call ip_xwd (ip, fname, NO, NO) + default: + return + } +end + + +# IP_BLTIN_INFO -- Process a 'builtin' format file information request. These +# are done separately because in a builtin we can print information such as +# colormap information, compression schemes, etc. + +procedure ip_bltin_info (ip, fname, verbose) + +pointer ip #i task struct pointer +char fname[ARB] #i file name +int verbose #i verbosity flag + +begin + # Branch off to the particular format. + switch (IP_FCODE(ip)) { + case IP_GIF, IP_GIFF: + call ip_gif (ip, fname, YES, verbose) + case IP_SUNRAS, IP_RAS: + call ip_ras (ip, fname, YES, verbose) + case IP_XWD, IP_X11: + call ip_xwd (ip, fname, YES, verbose) + default: + return + } +end + + +# IP_IS_BUILTIN -- See if this is a 'builtin' format. + +int procedure ip_is_builtin (format) + +char format[ARB] #i format to check + +int btoi(), strdic() + +begin + return (btoi(strdic(format,format,SZ_FNAME,IP_BUILTINS) != 0)) +end + + +# IP_FCODE -- Get the format code for a builtin format. + +int procedure ip_fcode (format) + +char format[ARB] #i format to check +int strdic() + +begin + return (strdic (format, format, SZ_FNAME, IP_BUILTINS)) +end diff --git a/pkg/dataio/import/ipdb.gx b/pkg/dataio/import/ipdb.gx new file mode 100644 index 00000000..9e4cb5c3 --- /dev/null +++ b/pkg/dataio/import/ipdb.gx @@ -0,0 +1,766 @@ +include <evvexpr.h> +include <error.h> +include <mach.h> +include <imhdr.h> +include "../import.h" +include "../ipfcn.h" + +define DEBUG false + + +# IP_EVAL_DBREC -- For each of the keywords defined in the database record, +# evaluate the expression and load the task structure. + +procedure ip_eval_dbrec (ip) + +pointer ip #i task struct pointer + +int ival +pointer sp, dims, pixtype, err +pointer np, stp, sym + +pointer stname(), sthead(), stnext +int or(), ip_dbgeti() +bool streq() + +errchk ip_dbgeti() + +begin + call smark (sp) + call salloc (dims, SZ_EXPR, TY_CHAR) + call salloc (pixtype, SZ_EXPR, TY_CHAR) + call salloc (err, SZ_EXPR, TY_CHAR) + call aclrc (Memc[dims], SZ_EXPR) + call aclrc (Memc[pixtype], SZ_EXPR) + call aclrc (Memc[err], SZ_EXPR) + + # Load the defaults. + call ip_load_defaults (ip) + + # First thing we do is get the byte swap flag so the remaining + # fields will be interpreted correctly. + ifnoerr (ival = ip_dbgeti (ip, "bswap")) + IP_SWAP(ip) = ival + + # Next, we handle 'interleave', 'dims' and 'pixtype' as a special case + # since for band- and line-interleaved files we may need to fix up the + # pixtype pointers. + ifnoerr (ival = ip_dbgeti (ip, "interleave")) + IP_INTERLEAVE(ip) = ival + + ifnoerr (call ip_dbstr (ip, "dims", Memc[dims], SZ_EXPR)) + call ip_do_dims (ip, Memc[dims]) + + ifnoerr (call ip_dbstr (ip, "pixtype", Memc[pixtype], SZ_EXPR)) { + if (Memc[pixtype] == '"') + call fdb_strip_quote (Memc[pixtype], Memc[pixtype], SZ_EXPR) + call ip_do_pixtype (ip, Memc[pixtype]) + } + + # Loop over every symbol in the table. + stp = IP_FSYM(ip) + for (sym=sthead(stp); sym != NULL; sym=stnext(stp,sym)) { + np = stname (stp, sym) + + if (streq(Memc[np],"format") || # ignored or found already + streq(Memc[np],"alias") || + streq(Memc[np],"image_id") || + streq(Memc[np],"interleave") || + streq(Memc[np],"dims") || + streq(Memc[np],"pixtype") || + streq(Memc[np],"id_string") || + streq(Memc[np],"bswap")) { + next + } else if (streq(Memc[np],"hskip")) { + IP_HSKIP(ip) = ip_dbgeti (ip, "hskip") + } else if (streq(Memc[np],"tskip")) { + IP_TSKIP(ip) = ip_dbgeti (ip, "tskip") + } else if (streq(Memc[np],"bskip")) { + IP_BSKIP(ip) = ip_dbgeti (ip, "bskip") + } else if (streq(Memc[np],"lskip")) { + IP_LSKIP(ip) = ip_dbgeti (ip, "lskip") + } else if (streq(Memc[np],"lpad")) { + IP_LPAD(ip) = ip_dbgeti (ip, "lpad") + } else if (streq(Memc[np],"yflip")) { + if (ip_dbgeti (ip, "yflip") == YES) + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + } else if (streq(Memc[np],"error")) { + if (IP_OUTPUT(ip) != IP_INFO) + call ip_do_error (ip, Memc[P2C(sym)]) + } else if (streq(Memc[np],"comment")) { + call fdb_strip_quote (Memc[P2C(sym)], Memc[P2C(sym)], SZ_LINE) + call ip_do_comment (ip, Memc[P2C(sym)]) + } else { + call eprintf ("Warning: Unknown database keyword '%s'.\n") + call pargstr (Memc[np]) + } + } + + if (DEBUG) { call zzi_prstruct ("eval dbrec:", ip) } + call sfree (sp) +end + + +# IP_LOAD_DEFAULTS -- Load the default input parameters to the task structure. + +procedure ip_load_defaults (ip) + +pointer ip #i task struct pointer + +begin + IP_SWAP(ip) = DEF_SWAP # type of byte swapping + IP_INTERLEAVE(ip) = DEF_INTERLEAVE # type of data interleaving + IP_HSKIP(ip) = DEF_HSKIP # bytes to skip before data + IP_TSKIP(ip) = DEF_TSKIP # bytes to skip after data + IP_BSKIP(ip) = DEF_BSKIP # bytes between image bands + IP_LSKIP(ip) = DEF_LSKIP # bytes to skip at front of + IP_LPAD(ip) = DEF_LPAD # bytes to skip at end of + + # zero image dimensions + for (IP_NDIM(ip)=IM_MAXDIM; IP_NDIM(ip) > 0; IP_NDIM(ip)=IP_NDIM(ip)-1) + IP_AXLEN(ip,IP_NDIM(ip)) = 0 +end + + +# IP_DBFCN -- Called by evvexpr to execute format database special functions. + +procedure ip_dbfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf, outstr +int fd, func, v_nargs +int i, len, nchar, ival, cur_offset, swap +char ch +short sval +real rval +double dval + +short ip_getb(), ip_gets() +int strdic(), ip_line(), ip_locate(), ip_getu() +int ctoi(), ctol(), ctor(), ctod(), ctocc(), ctowrd() +int and(), strlen(), clgeti() +long ip_getl() +real ip_getr(), ip_getn() +double ip_getd(), ip_getn8() +bool strne(), streq() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + call aclrc (Memc[buf], SZ_LINE) + call aclrc (Memc[outstr], SZ_LINE) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, DB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case CTOCC, CTOD, CTOI, CTOL, CTOR, CTOWRD: + v_nargs = -1 + + case GETSTR: + v_nargs = -1 + case GETB, GETU, GETI, GETI2, GETI4, GETR, GETR4, GETR8, + GETN, GETN4, GETN8: + v_nargs = 1 + + case LOCATE: + v_nargs = -1 + case LINE, SKIP: + v_nargs = 1 + + case BSWAP: + v_nargs = 1 + case PARAMETER, DEFAULT: + v_nargs = 1 + case SUBSTR: + v_nargs = 3 + case STRIDX: + v_nargs = 2 + case LSB_HOST, MSB_HOST: + v_nargs = 0 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + fd = IP_FD(ip) + swap = IP_SWAP(ip) + cur_offset = IP_OFFSET(ip) + + if (DEBUG) { + call eprintf ("cur_offset=%d nargs=%d func=%s swap=%d\n") + call pargi(cur_offset) ; call pargi(nargs) + call pargstr(fcn) ; call pargi (swap) + do i = 1, nargs + call zzi_pevop (args[i]) + call eprintf ("init op => ") ; call zzi_pevop(o) + + } + + # Evaluate the function. + switch (func) { + case CTOCC: # run the fmtio equivalents of the argument + if (nargs == 1) + ch = ip_getb (fd, O_VALI(args[1])) + else + ch = ip_getb (fd, cur_offset) + len = ctocc (ch, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len) + cur_offset = cur_offset + 1 + call ip_lseek (fd, cur_offset) + + case CTOWRD: + if (nargs == 1) + call ip_gstr (fd, O_VALI(args[1]), SZ_FNAME, Memc[outstr]) + else + call ip_gstr (fd, cur_offset, SZ_FNAME, Memc[outstr]) + nchar = ctowrd (Memc[outstr], i, Memc[outstr], SZ_FNAME) + 1 + call ip_initop (o, nchar, TY_CHAR) + call aclrc (O_VALC(o), nchar) + call amovc (Memc[outstr], O_VALC(o), nchar) + cur_offset = cur_offset + nchar + 1 + call ip_lseek (fd, cur_offset) + + case CTOI: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctoi (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_INT + + case CTOL: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctol (Memc[outstr], i, ival) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_LONG + + case CTOR: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctor (Memc[outstr], i, rval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_REAL + + case CTOD: + i = 1 + if (nargs == 1) { + call ip_gstr (fd, O_VALI(args[i]), SZ_FNAME, Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = cur_offset + nchar - 1 + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + nchar = ctod (Memc[outstr], i, dval) + cur_offset = O_VALI(args[1]) + nchar - 1 + } + call ip_lseek (fd, cur_offset) + O_TYPE(o) = TY_DOUBLE + + case GETSTR: + if (nargs == 1) { + call ip_gstr (fd, cur_offset, O_VALI(args[1]), Memc[outstr]) + cur_offset = cur_offset + O_VALI(args[1]) + } else if (nargs == 2) { + call ip_gstr (fd, O_VALI(args[1]), O_VALI(args[2]),Memc[outstr]) + cur_offset = O_VALI(args[1]) + O_VALI(args[2]) - 1 + } + if (strlen(Memc[outstr]) == 0) { + len = strlen ("ERR") + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call strcpy ("ERR", O_VALC(o), len-1) + } else { + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call aclrc (O_VALC(o), len) + call amovc (Memc[outstr], O_VALC(o), len-1) + } + + case GETB: + if (nargs == 0) { + sval = ip_getb (fd, cur_offset) + cur_offset = cur_offset + SZB_CHAR + } else { + sval = ip_getb (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + SZB_CHAR + } + ival = sval + O_TYPE(o) = TY_INT + + case GETU: + if (nargs == 0) { + sval = short (ip_getu (fd, cur_offset)) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = short (ip_getu (fd, O_VALI(args[1]))) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI, GETI2: + if (nargs == 0) { + sval = ip_gets (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_SHORT) + } else { + sval = ip_gets (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_SHORT) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) + call bswap2 (sval, 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + ival = sval + O_TYPE(o) = TY_INT + + case GETI4: + if (nargs == 0) { + ival = ip_getl (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_LONG) + } else { + ival = ip_getl (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_LONG) + } + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) + call bswap4 (ival, 1, ival, 1, (SZ_INT32*SZB_CHAR)) + O_TYPE(o) = TY_INT + + case GETR, GETR4: + if (nargs == 0) { + rval = ip_getr (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getr (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETR8: + if (nargs == 0) { + dval = ip_getd (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getd (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case GETN, GETN4: + if (nargs == 0) { + rval = ip_getn (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_REAL) + } else { + rval = ip_getn (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_REAL) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap4 (rval, 1, rval, 1, (SZ_REAL*SZB_CHAR)) + O_TYPE(o) = TY_REAL + + case GETN8: + if (nargs == 0) { + dval = ip_getn8 (fd, cur_offset) + cur_offset = cur_offset + (SZB_CHAR * SZ_DOUBLE) + } else { + dval = ip_getn8 (fd, O_VALI(args[1])) + cur_offset = O_VALI(args[1]) + (SZB_CHAR * SZ_DOUBLE) + } + if (and(swap, S_ALL) == S_ALL) # handle byte-swapping + call bswap8 (dval, 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + O_TYPE(o) = TY_DOUBLE + + case LOCATE: # locate the pattern in the file + if (nargs == 1) + ival = ip_locate (fd, cur_offset, O_VALC(args[1])) + else if (nargs == 2) + ival = ip_locate (fd, O_VALI(args[1]), O_VALC(args[2])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case LINE: # locate the line no. in the file + ival = ip_line (fd, O_VALI(args[1])) + if (ival == ERR) + ival = 1 + O_TYPE(o) = TY_INT + cur_offset = ival + + case SKIP: # skip a certain number of bytes + ival = O_VALI(args[1]) + O_TYPE(o) = TY_INT + cur_offset = cur_offset + ival + + case BSWAP: # byte-swap argument + O_TYPE(o) = O_TYPE(args[1]) + switch (O_TYPE(args[1])) { + case TY_SHORT: + call bswap2 (O_VALS(args[1]), 1, sval, 1, (SZ_SHORT*SZB_CHAR)) + case TY_INT: + call bswap4 (O_VALI(args[1]), 1, ival, 1, (SZ_INT32*SZB_CHAR)) + case TY_LONG: + call bswap4 (O_VALL(args[1]), 1, ival, 1, (SZ_LONG*SZB_CHAR)) + case TY_REAL: + call bswap4 (O_VALR(args[1]), 1, rval, 1, (SZ_REAL*SZB_CHAR)) + case TY_DOUBLE: + call bswap8 (O_VALD(args[1]), 1, dval, 1, (SZ_DOUBLE*SZB_CHAR)) + } + + case PARAMETER: # return current task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call clgstr ("dims", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call clgstr ("pixtype", Memc[outstr], SZ_FNAME) + len = strlen (Memc[outstr]) + 1 + call ip_initop (o, len, TY_CHAR) + call strcpy (Memc[outstr], O_VALC(o), len) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = clgeti ("interleave") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + call clgstr ("bswap", Memc[outstr], SZ_FNAME) + if (strne("no",Memc[outstr]) && strne("none",Memc[outstr])) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = clgeti ("hskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = clgeti ("tskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = clgeti ("bskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = clgeti ("lskip") + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = clgeti ("lpad") + O_TYPE(o) = TY_INT + } + + case DEFAULT: # return default task parameter value + if (streq(O_VALC(args[1]),"dims")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"pixtype")) { + call ip_initop (o, 1, TY_CHAR) + call strcpy ("", O_VALC(o), 1) + } else if (streq(O_VALC(args[1]),"interleave")) { + ival = DEF_INTERLEAVE + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bswap")) { + ival = DEF_SWAP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"hskip")) { + ival = DEF_HSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"tskip")) { + ival = DEF_TSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"bskip")) { + ival = DEF_BSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lskip")) { + ival = DEF_LSKIP + O_TYPE(o) = TY_INT + } else if (streq(O_VALC(args[1]),"lpad")) { + ival = DEF_LPAD + O_TYPE(o) = TY_INT + } + + case LSB_HOST: # host is an LSB byte ordered machine + if (BYTE_SWAP2 == YES) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case MSB_HOST: # host is an MSB byte ordered machine + if (BYTE_SWAP2 == NO) + ival = YES + else + ival = NO + O_TYPE(o) = TY_BOOL + + case SUBSTR: # return a substring of the argument + + case STRIDX: # return offset of a char w/in str + + } + + # Write result to output operand. + O_LEN(o) = 0 + switch (O_TYPE(o)) { + case TY_USHORT, TY_SHORT: + O_VALS(o) = sval + case TY_INT, TY_BOOL: + O_VALI(o) = ival + case TY_LONG: + O_VALL(o) = ival + case TY_REAL: + O_VALR(o) = rval + case TY_DOUBLE: + O_VALD(o) = dval + } + + if (DEBUG) { call eprintf("ip_dbfcn: ") ; call zzi_pevop (o) } + + IP_OFFSET(ip) = cur_offset + call sfree (sp) +end + + +# IP_DBSTR -- Get a string valued expression from the database. + +procedure ip_dbstr (ip, param, outstr, maxch) + +pointer ip #i task struct pointer +char param[ARB] #i parameter to evaluate +char outstr[ARB] #o result string +int maxch #i max length of string + +pointer sp, expr, o + +int locpr(), strlen() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + call aclrc (Memc[expr], SZ_EXPR) + + # Get the requested parameter. + call aclrc (outstr, SZ_EXPR) + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "FDBGET: Format parameter not found") + + if (DEBUG) { + call eprintf("ip_dbstr: expr='%s' len=%d ");call pargstr(Memc[expr]) + call pargi(strlen(Memc[expr])) + } + + # Evaluate the expression. + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) != TY_CHAR) + call error (0, "ip_dbstr: Expression must be a string valued") + else + call amovc (O_VALC(o), outstr, (min(strlen(O_VALC(o)),maxch))) + } then + call erract (EA_WARN) + + if (DEBUG) { call eprintf ("outstr=:%s:\n") ; call pargstr (outstr) } + + call evvfree (o) + call sfree (sp) +end + +$for (ir) + +$if (datatype == i) +# IP_DBGETI -- Get integer valued format parameter from the database. +$else +# IP_DBGETR -- Get real valued format parameter from the database. +$endif + +PIXEL procedure ip_dbget$t (ip, param) + +pointer ip #i task struct pointer +char param[ARB] #i requested parameter + +PIXEL val +pointer sp, expr, o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +errchk evvexpr + +begin + call smark (sp) + call salloc (expr, SZ_EXPR, TY_CHAR) + + # Get the requested parameter. + call fdbgstr (IP_FSYM(ip), param, Memc[expr], SZ_EXPR) + if (Memc[expr] == EOS) + call error (1, "IP_DBGET: Format parameter not found") + + # Evaluate the expression. + if (DEBUG) { + call eprintf ("ip_dbget: expr='%s'\n") + call pargstr (Memc[expr]) + call flush (STDERR) + } + iferr { + o = evvexpr (Memc[expr], locpr(ip_getop), ip, + locpr(ip_dbfcn), ip, EV_RNGCHK) + if (O_TYPE(o) == TY_BOOL) { + val = O_VALI(o) + $if (datatype == i) + } else if (O_TYPE(o) != TY_PIXEL && O_TYPE(o) != TY_SHORT) { + call error (0, "Expression must be an integer") + $else + } else if (O_TYPE(o) != TY_PIXEL) { + call error (0, "Expression must be a real") + $endif + } else + val = O_VAL$T(o) + + if (DEBUG) { + call eprintf ("ip_dbget: val=%d type=%d ecpr=:%s:\n") + call parg$t (val) + call pargi (O_TYPE(o)) + call pargstr (Memc[expr]) + call flush (STDERR) + } + } then + call erract (EA_WARN) + + call evvfree (o) + call sfree (sp) + return (val) +end +$endfor + +# IP_DO_ERROR -- Process the error parameter. + +procedure ip_do_error (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i error string + +pointer o + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_dbfcn() +bool strne() +errchk evvexpr + +begin + if (DEBUG) {call eprintf ("error expr: '%s' ") ; call pargstr (expr)} + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_dbfcn), ip, + EV_RNGCHK) + + if (DEBUG) { call eprintf("-> '%s'\n") ; call pargstr(O_VALC(o)) } + + if (O_TYPE(o) != TY_CHAR) + call error (2, "do_error: Expression must be a string valued") + else { + if (strne("okay",O_VALC(o))) + call error (2, O_VALC(o)) + } + call evvfree (o) + + } then + if (IP_OUTPUT(ip) != IP_INFO) + call erract (EA_FATAL) +end + + +# IP_DO_COMMENT - Process a comment line in the format database. + +procedure ip_do_comment (ip, comstr) + +pointer ip #i task struct pointer +char comstr[ARB] #i comment to add + +pointer sp, buf + +begin + # Copy the comment line to the comment block. + if (IP_COMPTR(ip) == NULL) + call calloc (IP_COMPTR(ip), SZ_COMMENT, TY_CHAR) + + if (COMMENT(ip) == '\0') { + call strcpy ("\t", COMMENT(ip), SZ_LINE) + call strcat (comstr, COMMENT(ip), SZ_LINE) + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + Memc[buf] = '\0' + call strcpy ("\t", Memc[buf], SZ_LINE) + call strcat (comstr, Memc[buf], SZ_LINE) + call strcat ("\n", Memc[buf], SZ_LINE) + call strcat (COMMENT(ip), Memc[buf], SZ_COMMENT) + + call strcpy (Memc[buf], COMMENT(ip), SZ_COMMENT) + + call sfree (sp) + } +end + + +# IP_INITOP - Initialize an operand pointer to the requested values + +procedure ip_initop (o, len, type) + +pointer o #u operand pointer +int len #i length of array +int type #i data type of operand + +begin + O_LEN(o) = len + O_TYPE(o) = type + if (len > 1) + call calloc (O_VALP(o), len, type) +end diff --git a/pkg/dataio/import/ipfcn.h b/pkg/dataio/import/ipfcn.h new file mode 100644 index 00000000..090c040e --- /dev/null +++ b/pkg/dataio/import/ipfcn.h @@ -0,0 +1,57 @@ +# IPFCN.H - Include file for the special functions supported by the IMPORT task. + +# Format database functions. +define DB_FUNCTIONS "|ctocc|ctod|ctoi|ctol|ctor|ctowrd|\ + |getstr|getb|getu|geti|geti2|geti4|\ + |getr|getr4|getr8|getn|getn4|getn8|\ + |locate|line|skip|bswap|parameter|default|\ + |lsb_host|msb_host|substr|stridx|" + +define CTOCC 1 # Convert character to printable char constant +define CTOD 2 # Convert string to double precision real +define CTOI 3 # Convert string to integer +define CTOL 4 # Convert string to long +define CTOR 5 # Convert string to single precision real +define CTOWRD 6 # Return 1st white-space delimited word from str +# newline +define GETSTR 8 # Get a string at offset +define GETB 9 # Get a byte at offset +define GETU 10 # Get an unsigned short int at offset +define GETI 11 # Get a signed int at offset +define GETI2 12 # Get a signed int at offset +define GETI4 13 # Get a long signed int at offset +# newline +define GETR 15 # Get an IEEE fp number at offset +define GETR4 16 # Get an IEEE fp number at offset +define GETR8 17 # Get an IEEE double precision number at offset +define GETN 18 # Get a native fp number at offset +define GETN4 19 # Get a native fp number at offset +define GETN8 20 # Get a native double precision number at offset +# newline +define LOCATE 22 # Compute an offset +define LINE 23 # Offset of line N +define SKIP 24 # Move offset N-bytes +define BSWAP 25 # Byte swap the argument +define PARAMETER 26 # Return current task parameter +define DEFAULT 27 # Return default task parameter +# newline +define LSB_HOST 29 # Host is LSB byte ordered machine +define MSB_HOST 30 # Host is MSB byte ordered machine +define SUBSTR 31 # Return a substring of the argument +define STRIDX 32 # Return occurance of a char within a string + + +# Outbands expression functions. +define OB_FUNCTIONS "|gray|grey|flipx|flipy|\ + |red|green|blue|" + +define GRAY 1 # Convert to NTSC grayscale +define GREY 2 # Convert to NTSC grayscale (alias) +define FLIPX 3 # Flip image in X +define FLIPY 4 # Flip image in Y +# newline +define RED 6 # Get red component of colormap image +define GREEN 7 # Get green component of colormap image +define BLUE 8 # Get blue component of colormap image + + diff --git a/pkg/dataio/import/ipfio.gx b/pkg/dataio/import/ipfio.gx new file mode 100644 index 00000000..61147ea2 --- /dev/null +++ b/pkg/dataio/import/ipfio.gx @@ -0,0 +1,443 @@ +include <mach.h> +include <fset.h> +include "../import.h" + +define DEBUG false + + +# IP_GSTR -- Get a string of the specifed length from the given offset. + +procedure ip_gstr (fd, offset, len, outstr) + +int fd +int offset +int len +char outstr[ARB] + +int nstat, read() +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, len+2, TY_CHAR) + call aclrc (Memc[buf], len+2) + call aclrc (outstr, len+2) + + call ip_lseek (fd, offset) + nstat = read (fd, Memc[buf], len) + + if (mod(offset,2) == 0 && offset > 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, len) + call chrupk (Memc[buf], 1, outstr, 1, len) + + if (DEBUG) { call eprintf ("ip_gstr: :%s: len=%d\n"); + call pargstr(outstr) ; call pargi (len) } + call sfree (sp) +end + + +# IP_GETB -- Get a byte from the given offset. + +short procedure ip_getb (fd, offset) + +int fd +int offset + +int nstat, read() +short val +char buf[2] + +begin + call ip_lseek (fd, offset) + nstat = read (fd, buf, 2) + + if (mod(offset,2) == 0) + call bytmov (buf, 2, buf, 1, 2) + call chrupk (buf, 1, buf, 1, 2) + + if (DEBUG) { call eprintf ("ip_getb: %d\n"); call pargs(buf[1]) } + if (buf[1] < 0) + val = buf[1] + 256 + else + val = buf[1] + return (val) +end + + +# IP_GETU -- Get a unsigned short integer from the given offset. + +int procedure ip_getu (fd, offset) + +int fd +int offset + +int val +short ip_gets() + +begin + val = ip_gets (fd, offset) + if (val < 0) + val = val + 65536 + return (val) +end + +# IP_GET[silrd] -- Get a value of <type> from the given offset. + +$for (silrd) + +PIXEL procedure ip_get$t (fd, offset) + +int fd +int offset + +int nstat, read() +PIXEL val + +begin + call ip_lseek (fd, offset) + $if (datatype == il) + nstat = read (fd, val, SZ_INT32 * SZB_CHAR) + if (SZ_INT != SZ_INT32) + call iupk32 (val, val, 1) + $else + nstat = read (fd, val, SZ_PIXEL * SZB_CHAR) + $endif + $if (datatype == rd) + call ieeupk$t (val) + $endif + + if (DEBUG) { call eprintf ("ip_get: %g\n"); call parg$t(val) } + return (val) +end +$endfor + +# IP_GETN -- Get a native floating point number from the given offset. + +real procedure ip_getn (fd, offset) + +int fd +int offset + +int nstat, read() +real rval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, rval, SZ_REAL) + + if (DEBUG) { call eprintf ("ip_getn: %g\n"); call pargr(rval) } + return (rval) +end + + +# IP_GETN8 -- Get a native double precision floating point number from the +# given offset. + +double procedure ip_getn8 (fd, offset) + +int fd +int offset + +int nstat, read() +double dval + +begin + call ip_lseek (fd, offset) + nstat = read (fd, dval, SZ_DOUBLE) + + if (DEBUG) { call eprintf ("ip_getn8: %g\n"); call pargd(dval) } + return (dval) +end + + +# IP_AGETB -- Get an array of bytes from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetb (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +pointer sp, buf +int fp, nval, nstat +int ip_lnote(), read() + +begin + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + nval = len + else + nval = len + 1 + + call smark (sp) + call salloc (buf, nval, TY_CHAR) + + if (ptr == NULL) + call malloc (ptr, nval * SZB_CHAR, TY_CHAR) + nstat = read (fd, Memc[buf], nval / SZB_CHAR + 1) + + fp = ip_lnote(fd) + if (mod(fp,2) == 0 && fp != 1) + call bytmov (Memc[buf], 2, Memc[buf], 1, nval) + call achtbc (Memc[buf], Memc[ptr], len) + + call sfree (sp) +end + + +# IP_AGETU -- Get an array of <type> from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetu (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +begin + call ip_agets (fd, ptr, len) + call achtsu (Mems[ptr], Mems[ptr], len) +end + + +# IP_AGET[silrd] -- Get an array of <type> from the file. The data pointer is +# allocated if necessary and contains the data on output. + +$for (silrd) +procedure ip_aget$t (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_PIXEL) + $if (datatype == il) + nstat = read (fd, Mem$t[ptr], len * SZ_INT32) + if (SZ_INT != SZ_INT32) + call iupk32 (Mem$t[ptr], Mem$t[ptr], len) + $else + nstat = read (fd, Mem$t[ptr], len * SZ_PIXEL) + $endif + $if (datatype == rd) + call ieevupk$t (Mem$t[ptr], Mem$t[ptr], len) + $endif +end + +$endfor + +# IP_AGETN -- Get an array of native floats from the file. The data pointer is +# allocated if necessary and contains the data on output. + +procedure ip_agetn (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_REAL) + nstat = read (fd, Memr[ptr], len * SZ_REAL) +end + + +# IP_AGETN8 -- Get an array of native doubles from the file. The data pointer +# is allocated if necessary and contains the data on output. + +procedure ip_agetn8 (fd, ptr, len) + +int fd #i file descriptor +pointer ptr #i data pointer +int len #i length of array + +int nstat +int read() + +begin + if (ptr == NULL) + call malloc (ptr, len, TY_DOUBLE) + nstat = read (fd, Memd[ptr], len * SZ_DOUBLE) +end + + +# ----------------------------------------------------------------- +# ------------------ UTILITY FILE I/O FUNCTIONS ------------------- +# ----------------------------------------------------------------- + + +define BLKSIZE 1024 + +# IP_LINE -- Return the offset of the start of the given line number. + +int procedure ip_line (fd, line) + +int fd #i input file descriptor +int line #i line number to search + +pointer sp, cbuf, buf +int nl, offset, i, nread, fsize + +int read(), fstati() + +define done_ 99 +define err_ 98 + +begin + if (line == 1) { + return (1) + } else { + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + # Rewind file descriptor + call ip_lseek (fd, BOF) + nl = 1 + offset = 1 + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + do i = 1, BLKSIZE { + if (Memc[cbuf+i-1] == '\n') { + nl = nl + 1 + offset = offset + 1 + if (nl == line) + goto done_ + } else + offset = offset + 1 + if (offset >= fsize) + goto err_ + } + } +err_ call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_line: '%s'\n"); call pargi(offset) } + call sfree (sp) + call ip_lseek (fd, offset) + return (offset) + } +end + + +# IP_LOCATE -- Return the offset of the start of the given pattern. + +int procedure ip_locate (fd, offset, pattern) + +int fd #i input file descriptor +int offset #i offset to begin search +char pattern[ARB] #i pattern to locate + +pointer sp, cbuf, buf +int fsize, nread, patlen, cur_offset, loc + +int fstati(), read(), strsearch(), strlen() + +define done_ 99 + +begin + # Rewind file descriptor + call ip_lseek (fd, offset) + cur_offset = offset + + call smark (sp) + call salloc (buf, BLKSIZE, TY_CHAR) + call salloc (cbuf, BLKSIZE, TY_CHAR) + + if (DEBUG) { call eprintf("ip_loc: offset %d\n"); call pargi(offset)} + + nread = BLKSIZE / SZB_CHAR + fsize = fstati (fd, F_FILESIZE) + patlen = strlen (pattern) + while (read (fd, Memc[buf], nread) != EOF) { + # Convert it to spp chars. + call ip_lskip (fd, nread) + call chrupk (Memc[buf], 1, Memc[cbuf], 1, BLKSIZE) + loc = strsearch (Memc[cbuf], pattern) + if (loc != 0) { + cur_offset = cur_offset + loc - 1 - patlen + goto done_ + } else { + # Allow some overlap in case the pattern broke over the blocks. + cur_offset = cur_offset + BLKSIZE - 2 * patlen + call ip_lseek (fd, cur_offset) + if (cur_offset + BLKSIZE > fsize) + nread = fsize - cur_offset + 1 + } + } + call sfree (sp) + call ip_lseek (fd, BOF) + return (ERR) + +done_ if (DEBUG) { call eprintf("ip_loc: %d\n"); call pargi(cur_offset)} + call sfree (sp) + call ip_lseek (fd, offset) + return (cur_offset) +end + + +# IP_LSEEK -- Set the file position as a byte offset. + +procedure ip_lseek (fd, offset) + +int fd #i file descriptor +int offset #i requested offset + +long cur_offset, where, fsize +int fstati() +common /fiocom/ cur_offset + +begin + if (offset == BOF || offset == ERR) { + cur_offset = 1 + call seek (fd, BOF) + } else { + fsize = fstati (fd, F_FILESIZE) * SZB_CHAR + cur_offset = min (fsize, offset) + where = min (fsize, (offset/SZB_CHAR+mod(offset,2))) + call seek (fd, where) + } +end + + +# IP_LNOTE -- Note the file position as a byte offset. + +int procedure ip_lnote (fd) + +int fd #i file descriptor (unused) + +long cur_offset +common /fiocom/ cur_offset + +begin + return (cur_offset) +end + + +# IP_LSKIP -- Bump the file position by a byte offset. + +procedure ip_lskip (fd, skip) + +int fd #i file descriptor +int skip + +long cur_offset +common /fiocom/ cur_offset + +begin + call ip_lseek (fd, cur_offset+skip) +end diff --git a/pkg/dataio/import/ipinfo.x b/pkg/dataio/import/ipinfo.x new file mode 100644 index 00000000..3ded4a2d --- /dev/null +++ b/pkg/dataio/import/ipinfo.x @@ -0,0 +1,256 @@ +include "import.h" + + +# IP_INFO -- Print information about the binary file. + +procedure ip_info (ip, fname, verbose) + +pointer ip #i task struct pointer +char fname[ARB] #i binary file name +int verbose #i verbose output? + +pointer sp, buf +pointer fmt +int fdb +int locpr(), fdb_opendb() + +pointer fdb_scan_records() +extern ip_getop(), ip_dbfcn() + +begin + if (IP_BLTIN(ip) == YES) { + call ip_bltin_info (ip, fname, verbose) + + } else if (IP_FORMAT(ip) == IP_NONE) { + call ip_prinfo (ip, "User Specified Format", fname, verbose) + + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + if (IP_FSYM(ip) == NULL) { + fdb = fdb_opendb () + fmt = fdb_scan_records (fdb, "image_id", + locpr(ip_getop), ip, locpr(ip_dbfcn), ip) + call fdbgstr (fmt, "id_string", Memc[buf], SZ_LINE) + call fdb_strip_quote (Memc[buf], Memc[buf], SZ_EXPR) + call ip_prinfo (ip, Memc[buf], fname, verbose) + call fdb_close (fmt) + call fdb_closedb (fdb) + } else { + call fdbgstr (IP_FSYM(ip), "id_string", Memc[buf], SZ_LINE) + call fdb_strip_quote (Memc[buf], Memc[buf], SZ_EXPR) + call ip_prinfo (ip, Memc[buf], fname, verbose) + } + + call sfree (sp) + } +end + + +# IP_PRINFO -- Print information about the binary file. + +procedure ip_prinfo (ip, format, fname, verbose) + +pointer ip #i task struct pointer +char format #i format name +char fname[ARB] #i binary file name +int verbose #i verbose output? + +int i +bool itob() + +define done_ 99 + +begin + #call printf ("Input file:\n\t") + if (verbose == NO) { + call printf ("%s: %20t") + call pargstr (fname) + do i = 1, IP_NDIM(ip) { + call printf ("%d ") + call pargi (IP_AXLEN(ip,i)) + if (i < IP_NDIM(ip)) + call printf ("x ") + } + call printf (" \t%s\n") + call pargstr (format) + + # Print out the format comment if any. +# if (IP_COMPTR(ip) != NULL) { +# if (COMMENT(ip) != '\0') { +# call printf ("%s\n") +# call pargstr (COMMENT(ip)) +# } +# call strcpy ("\0", COMMENT(ip), SZ_LINE) +# } + return + } + + # Print a more verbose description. + call printf ("%s: %20t%s\n") + call pargstr (fname) + call pargstr (format) + + # Print out the format comment if any. + if (IP_COMPTR(ip) != NULL) { + if (COMMENT(ip) != '\0') { + call printf ("%s\n") + call pargstr (COMMENT(ip)) + } + call strcpy ("\0", COMMENT(ip), SZ_LINE) + } + + # Print the image size. + if (IP_NDIM(ip) > 0) { + call printf ("%20tResolution:%38t") + do i = 1, IP_NDIM(ip) { + call printf ("%d ") + call pargi (IP_AXLEN(ip,i)) + if (i < IP_NDIM(ip)) + call printf ("x ") + } + call printf ("\n") + } + + # Print other information. + if (PTYPE(ip,1) != NULL) { + call printf ("%20tPixel type: %38t%d-bit ") + call pargi (8 * IO_NBYTES(PTYPE(ip,1))) + switch (IO_TYPE(PTYPE(ip,1))) { + case PT_UINT: + call printf ("unsigned integer\n") + case PT_INT: + call printf ("signed integer\n") + case PT_IEEE: + call printf ("IEEE floating point\n") + case PT_NATIVE: + call printf ("native floating point\n") + default: + call printf ("\n") + } + } + + call printf ("%20tPixel storage: %38t%s\n") + if (BAND_INTERLEAVED(ip)) + call pargstr ("non-interleaved") + else if (LINE_INTERLEAVED(ip)) + call pargstr ("line-interleaved") + else if (PIXEL_INTERLEAVED(ip)) + call pargstr ("pixel-interleaved") + else + call pargstr ("unknown") + call printf ("%20tHeader length: %38t%d bytes\n") + call pargi (IP_HSKIP(ip)) + call printf ("%20tByte swapped: %38t%b\n") + call pargb (itob(IP_SWAP(ip))) +end + + +# IP_OBINFO - Print information about the output image contents. + +procedure ip_obinfo (ip, imname) + +pointer ip #i ip struct pointer +char imname[ARB] #i image name + +int i, nb + +begin + call printf (" Output image:\n") + + if (IP_NBANDS(ip) != ERR) { + nb = IP_NBANDS(ip) + do i = 1, nb { + call printf ("\t%s[*,*,%d]:%30t==> %s %s\n") + call pargstr (imname) + call pargi (i) + call pargstr (O_EXPR(ip,i)) + if (i == 1) + call pargstr (" # outbands expr") + else + call pargstr (" ") + } + } else { + nb = max (IP_AXLEN(ip,3), max (IP_INTERLEAVE(ip), IP_NPIXT(ip))) + do i = 1, nb { + call printf ("\t%s[*,*,%d]:%30t==> %s%d %s\n") + call pargstr (imname) + call pargi (i) + call pargstr ("b") + call pargi (i) + if (i == 1) + call pargstr (" # outbands expr") + else + call pargstr (" ") + } + } + +end + + +# IP_LIST_FORMATS -- List the formats in the database. The DB is scanned +# and the format name for each record found, as well as the verbose ID +# string is printed on the standard output. The file position is left at +# the same place on exit. + +procedure ip_list_formats (fd) + +int fd #i input binary file descriptor + +pointer sp, format, idstr, alias +pointer fmt, ap[5] +int i, nsym, cur_offset + +int note() +pointer stfindall(), fdb_next_rec() + +begin + # Save current file offset. + cur_offset = note (fd) + + call smark (sp) + call salloc (format, SZ_EXPR, TY_CHAR) + call salloc (idstr, SZ_EXPR, TY_CHAR) + call salloc (alias, SZ_LINE, TY_CHAR) + + # Loop through the database records. + call seek (fd, BOF) + fmt = NULL + call printf ("Format%15tAliases%36tFormat Identification\n") + call printf ("------%15t-------%36t---------------------\n") + repeat { + fmt = fdb_next_rec (fd) + if (fmt == NULL) + break + call fdbgstr (fmt, "format", Memc[format], SZ_EXPR) + call fdbgstr (fmt, "id_string", Memc[idstr], SZ_EXPR) + call fdb_strip_quote (Memc[idstr], Memc[idstr], SZ_EXPR) + + # Generate a list of aliases for the format. + call aclrc (Memc[alias], SZ_LINE) + nsym = stfindall (fmt, "alias", ap, 5) + if (nsym >= 1) { + do i = nsym, 1, -1 { + call strcat (Memc[P2C(ap[i])], Memc[alias], SZ_LINE) + if (i > 1) + call strcat (",", Memc[alias], SZ_LINE) + } + } else + Memc[alias] = EOS + + # Print the information + call printf ("%s%15t%.20s%36t%s\n") + call pargstr (Memc[format]) + call pargstr (Memc[alias]) + call pargstr (Memc[idstr]) + + call fdb_close (fmt) + call flush (STDOUT) + } + + # Restore file offset. + call seek (fd, cur_offset) + + call sfree (sp) +end diff --git a/pkg/dataio/import/iplistpix.x b/pkg/dataio/import/iplistpix.x new file mode 100644 index 00000000..3f4a001d --- /dev/null +++ b/pkg/dataio/import/iplistpix.x @@ -0,0 +1,137 @@ +include <imhdr.h> +include <error.h> +include <mwset.h> + +# IP_LISTPIXELS -- Convert image pixels into a text stream, i.e., into a list. +# Each pixel is printed on a separate line, preceded by its coordinates. + +procedure ip_listpix (im) + +char wcs[SZ_FNAME] +double incoords[IM_MAXDIM], outcoords[IM_MAXDIM] +int i, j, npix, ndim, wcsndim, laxis1, fmtstat +int paxno[IM_MAXDIM], laxno[IM_MAXDIM] +long v[IM_MAXDIM], vcoords[IM_MAXDIM] +pointer im, line, mw, ct, fmtptrs[IM_MAXDIM] + +int imgnlr(), mw_stati() +pointer mw_openim(), mw_sctran() + +begin + # Get info from the input image. + ndim = IM_NDIM(im) + npix = IM_LEN(im,1) + + # Get the wcs. + call strcpy ("world", wcs, SZ_FNAME) + ifnoerr (mw = mw_openim (im)) { + # Set up the transformation. + call mw_seti (mw, MW_USEAXMAP, NO) + ct = mw_sctran (mw, "logical", wcs, 0) + wcsndim = mw_stati (mw, MW_NPHYSDIM) + + # Get the physical to logical axis map. + call mw_gaxmap (mw, paxno, laxno, wcsndim) + + # Set the default wcs. + call mw_ssytem (mw, wcs) + + } else { + # Print the error message from the above loop. + call erract (EA_WARN) + + # Set the transform to the identity transform. + mw = NULL + ct = NULL + wcsndim = ndim + + # Set the default physical to logical axis map. + do i = 1, wcsndim + paxno[i] = i + } + + # Initialize the v vectors. + call amovkl (long (1), v, IM_MAXDIM) + call amovkl (long (1), vcoords, IM_MAXDIM) + + # Initialize the coordinates. + laxis1 = 0 + do i = 1, wcsndim { + if (paxno[i] == 0) { + incoords[i] = 1 + } else if (paxno[i] == 1) { + laxis1 = i + incoords[i] = v[1] + } else { + incoords[i] = v[paxno[i]] + } + } + + # Check and correct for the no axis mapping case. + if (laxis1 == 0) { + laxis1 = 1 + do i = 1, wcsndim + paxno[i] = i + } + + # Get the logical to physical axis map for the format strings. + do i = 1, ndim { + laxno[i] = 0 + do j = 1, wcsndim { + if (paxno[j] != i) + next + laxno[i] = j + break + } + } + + # Set the format strings for the logical axes. + fmtstat = EOS + do i = 1, ndim { + call malloc (fmtptrs[i], SZ_FNAME, TY_CHAR) + if (fmtstat != EOF) + call gargwrd (Memc[fmtptrs[i]], SZ_FNAME) + else + Memc[fmtptrs[i]] = EOS + if (laxno[i] == 0) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else if (mw == NULL || ct == NULL) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else iferr (call mw_gwattrs (mw, laxno[i], "format", + Memc[fmtptrs[i]], SZ_FNAME)) + call strcpy ("%0.15g ", Memc[fmtptrs[i]], SZ_FNAME) + else + call strcat (" ", Memc[fmtptrs[i]], SZ_FNAME) + } + + # Print the pixels. + while (imgnlr (im, line, v) != EOF) { + do i = 1, npix { + incoords[laxis1] = i + if (ct == NULL) + call amovd (incoords, outcoords, wcsndim) + else + call mw_ctrand (ct, incoords, outcoords, wcsndim) + do j = 1, ndim { # X, Y, Z, etc. + call printf (Memc[fmtptrs[j]]) + if (laxno[j] == 0) + call pargd (double(vcoords[j])) + else + call pargd (outcoords[laxno[j]]) + } + call printf (" %g\n") # pixel value + call pargr (Memr[line+i-1]) + } + call amovl (v, vcoords, IM_MAXDIM) + do i = 1, wcsndim { + if (paxno[i] == 0) + next + incoords[i] = v[paxno[i]] + } + } + + do i = 1, ndim + call mfree (fmtptrs[i], TY_CHAR) + if (mw != NULL) + call mw_close (mw) +end diff --git a/pkg/dataio/import/ipmkhdr.x b/pkg/dataio/import/ipmkhdr.x new file mode 100644 index 00000000..c8432ed2 --- /dev/null +++ b/pkg/dataio/import/ipmkhdr.x @@ -0,0 +1,63 @@ +include <imhdr.h> +include <ctype.h> +include "import.h" + +define LEN_COMMENT 70 # Maximum comment length +define COMMENT "COMMENT " # Comment key +define IS_FITS (IS_DIGIT($1)||IS_UPPER($1)||($1=='-')||($1=='_')) + +# IP_MKHEADER -- Append or substitute new image header from an image or file. +# Only the legal FITS cards (ignoring leading whitespace) will be copied +# from a file. + +procedure ip_mkheader (im, fname) + +pointer im # IMIO pointer +char fname[ARB] # Image or data file name + +int i, j +pointer ua, fd +pointer sp, str + +int open(), getline(), nowhite() +pointer immap() +errchk open + +begin + if (nowhite (fname, fname, SZ_FNAME) == 0) + return + + ua = IM_USERAREA(im) + ifnoerr (fd = immap (fname, READ_ONLY, LEN_UA)) { + call strcpy (Memc[IM_USERAREA(fd)], Memc[ua], LEN_UA) + call imunmap (fd) + } else { + fd = open (fname, READ_ONLY, TEXT_FILE) + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + Memc[ua] = EOS + while (getline (fd, Memc[str]) != EOF) { + for (i=str; IS_WHITE(Memc[i]); i=i+1) + ; + for (j=i; IS_FITS(Memc[j]); j=j+1) + ; + for (; j<i+8 && Memc[j]==' '; j=j+1) + ; + if (j<i+8 && (Memc[j] != EOS || Memc[j] != '\n')) + next + if (Memc[j] == '=' && Memc[j+1] != ' ') + next + for (; j<i+80 && Memc[j] != EOS; j=j+1) + ; + if (Memc[j-1] != '\n') { + Memc[j] = '\n' + Memc[j+1] = EOS + } + call strcat (Memc[i], Memc[ua], LEN_UA) + } + call sfree (sp) + call close (fd) + } +end diff --git a/pkg/dataio/import/ipobands.gx b/pkg/dataio/import/ipobands.gx new file mode 100644 index 00000000..be568818 --- /dev/null +++ b/pkg/dataio/import/ipobands.gx @@ -0,0 +1,306 @@ +include <error.h> +include <mach.h> +include <evvexpr.h> +include <fset.h> +include "../import.h" +include "../ipfcn.h" + +define DEBUG false +define VDEBUG false + + +# IP_GETOP -- Called by evvexpr to get an operand. + +procedure ip_getop (ip, opname, o) + +pointer ip #i task struct pointer +char opname[ARB] #i operand name to retrieve +pointer o #o output operand pointer + +int i, nops, found, optype +pointer sp, buf +pointer op + +int fstati(), ip_ptype(), strlen(), strncmp() +bool streq() + +begin + # First see if it's one of the special file operands. + if (opname[1] == '$') { + if (strncmp(opname, "$FSIZE", 3) == 0) { + O_LEN(o) = 0 + O_TYPE(o) = TY_INT + O_VALI(o) = fstati (IP_FD(ip), F_FILESIZE) * SZB_CHAR + } else if (strncmp(opname, "$FNAME", 3) == 0) { + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + call fstats (IP_FD(ip), F_FILENAME, Memc[buf], SZ_FNAME) + + O_TYPE(o) = TY_CHAR + O_LEN(o) = strlen (Memc[buf]) + 1 + call malloc (O_VALP(o), O_LEN(o), TY_CHAR) + call strcpy (Memc[buf], O_VALC(o), i) + call sfree (sp) + } + + return + } + + nops = IP_NPIXT(ip) + found = NO + do i = 1, nops { + # Search for operand name which matches requested value. + op = PTYPE(ip,i) + if (streq (Memc[IO_TAG(op)],opname)) { + found = YES + break + } + } + + if (VDEBUG) { + call eprintf ("getop: opname=%s tag=%s found=%d ") + call pargstr(opname) ; call pargstr(Memc[IO_TAG(op)]) + call pargi(found) + if (found == YES) call zzi_prop (op) + } + + if (found == YES) { + # Copy operand descriptor to 'o' + optype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + switch (optype) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), IO_NPIX(op), TY_SHORT) + call amovs (Mems[IO_DATA(op)], Mems[O_VALP(o)], IO_NPIX(op)) + $for (ilrd) + case TY_PIXEL: + O_LEN(o) = IO_NPIX(op) + O_TYPE(o) = TY_PIXEL + call malloc (O_VALP(o), IO_NPIX(op), TY_PIXEL) + call amov$t (Mem$t[IO_DATA(op)], Mem$t[O_VALP(o)], IO_NPIX(op)) + $endfor + } + + } else { + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call sprintf (Memc[buf], SZ_LINE, "Unknown outbands operand `%s'\n") + call pargstr(opname) + call sfree (sp) + call error (1, Memc[buf]) + } +end + + +# IP_EVALUATE -- Evaluate the outbands expression. + +pointer procedure ip_evaluate (ip, expr) + +pointer ip #i task struct pointer +char expr[ARB] #i expression to be evaluated + +pointer o # operand pointer to result + +int locpr() +pointer evvexpr() +extern ip_getop(), ip_obfcn() +errchk evvexpr + +begin + if (DEBUG) { call eprintf("ip_eval: expr='%s'\n") ; call pargstr(expr) } + + # Evaluate the expression. + iferr { + o = evvexpr (expr, locpr(ip_getop), ip, locpr(ip_obfcn), ip, + EV_RNGCHK) + } then + call erract (EA_FATAL) + + return (o) +end + + +# IP_OBFCN -- Called by evvexpr to execute import outbands special functions. + +procedure ip_obfcn (ip, fcn, args, nargs, o) + +pointer ip #i task struct pointer +char fcn[ARB] #i function to be executed +pointer args[ARB] #i argument list +int nargs #i number of arguments +pointer o #o operand pointer + +pointer sp, buf +pointer r, g, b, gray, color, cmap +int i, len, v_nargs, func + +int or(), strdic() +bool strne() + +define setop_ 99 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + # Lookup function in dictionary. + func = strdic (fcn, Memc[buf], SZ_LINE, OB_FUNCTIONS) + if (func > 0 && strne(fcn,Memc[buf])) + func = 0 + + # Abort if the function is not known. + if (func <= 0) + call xev_error1 ("unknown function `%s' called", fcn) + + # Verify the correct number of arguments, negative value means a + # variable number of args, handle it in the evaluation. + switch (func) { + case GRAY, GREY: + v_nargs = 3 + case FLIPX, FLIPY: + v_nargs = 1 + case RED, GREEN, BLUE: + v_nargs = 1 + } + if (v_nargs > 0 && nargs != v_nargs) + call xev_error2 ("function `%s' requires %d arguments", + fcn, v_nargs) + else if (v_nargs < 0 && nargs < abs(v_nargs)) + call xev_error2 ("function `%s' requires at least %d arguments", + fcn, abs(v_nargs)) + + if (DEBUG) { + call eprintf ("obfcn: nargs=%d func=%d\n") + call pargi (nargs) ; call pargi (func) + do i = 1, nargs { call eprintf ("\t") ; call zzi_pevop (args[i]) } + call flush (STDERR) + } + + # Evaluate the function. + switch (func) { + case GRAY, GREY: + # evaluate expression for NTSC grayscale. + r = O_VALP(args[1]) + g = O_VALP(args[2]) + b = O_VALP(args[3]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_REAL + call malloc (O_VALP(o), len+1, TY_REAL) + gray = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mems[r+i] + + G_COEFF * Mems[g+i] + + B_COEFF * Mems[b+i] + } + $for (ilrd) + case TY_PIXEL: + do i = 0, len { + Memr[gray+i] = R_COEFF * Mem$t[r+i] + + G_COEFF * Mem$t[g+i] + + B_COEFF * Mem$t[b+i] + } + $endfor + } + + case RED: + # Get the red colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + r = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Mems[r+i]+1) + $for (il) + case TY_PIXEL: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_RED,Mem$t[r+i]+1) + $endfor + } + + case GREEN: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + g = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,Mems[g+i]+1) + $for (il) + case TY_PIXEL: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_GREEN,char(Mem$t[g+i]+1)) + $endfor + } + + case BLUE: + # Get the blue colormap component of the image. + cmap = IP_CMAP(ip) + if (func <= 0) + call xev_error1 ("No colormap in image for function `%s'", fcn) + b = O_VALP(args[1]) + len = O_LEN(args[1]) - 1 + O_LEN(o) = len + 1 + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), len+1, TY_SHORT) + color = O_VALP(o) + switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,Mems[b+i]+1) + $for (il) + case TY_PIXEL: + do i = 0, len + Mems[color+i] = CMAP(cmap,IP_BLUE,char(Mem$t[b+i]+1)) + $endfor + } + + case FLIPX: + # Set flag to reverse pixel order on output. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_X) + goto setop_ + + case FLIPY: + # Set flag to write image from bottom to top. + IP_FLIP(ip) = or (IP_FLIP(ip), FLIP_Y) + + # Copy argument operand descriptor to 'o' +setop_ switch (O_TYPE(args[1])) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_SHORT + call malloc (O_VALP(o), O_LEN(args[1]), TY_SHORT) + call amovs (Mems[O_VALP(ARGS[1])], Mems[O_VALP(o)], O_LEN(o)) + $for (ilrd) + case TY_PIXEL: + O_LEN(o) = O_LEN(args[1]) + O_TYPE(o) = TY_PIXEL + call malloc (O_VALP(o), O_LEN(args[1]), TY_PIXEL) + call amov$t (Mem$t[O_VALP(args[1])], Mem$t[O_VALP(o)], O_LEN(o)) + $endfor + } + + } + + if (DEBUG) { call zzi_pevop (o) } + + call sfree (sp) +end diff --git a/pkg/dataio/import/ipproc.gx b/pkg/dataio/import/ipproc.gx new file mode 100644 index 00000000..38217a4d --- /dev/null +++ b/pkg/dataio/import/ipproc.gx @@ -0,0 +1,804 @@ +include <mach.h> +include <imhdr.h> +include <evvexpr.h> +include "../import.h" + +define DEBUG false + + +# IP_PRBAND -- Process a band interleaved file. + +procedure ip_prband (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix +int optype, nbytes_pix, percent +int cur_offset, band_offset, line_offset + +int ip_ptype() +long ip_lnote() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + # Compute the offset between the same pixel in different bands. This + # is the area of the image plus any image padding, computed as a + # byte offset. + optype = ip_ptype (IO_TYPE(PTYPE(ip,1)),IO_NBYTES(PTYPE(ip,1))) + switch (optype) { + case TY_UBYTE: nbytes_pix = 1 + case TY_USHORT, TY_SHORT: nbytes_pix = SZB_CHAR * SZ_SHORT + case TY_INT: nbytes_pix = SZB_CHAR * SZ_INT32 + case TY_LONG: nbytes_pix = SZB_CHAR * SZ_LONG + case TY_REAL: nbytes_pix = SZB_CHAR * SZ_REAL + case TY_DOUBLE: nbytes_pix = SZB_CHAR * SZ_DOUBLE + } + band_offset = (IP_AXLEN(ip,1) * (IP_AXLEN(ip,2)-1)) + + ((IP_LSKIP(ip) + IP_LPAD(ip)) * (IP_AXLEN(ip,2)-1)) + + IP_BSKIP(ip) + band_offset = (band_offset * nbytes_pix) #+ 1 + + if (DEBUG) { + call eprintf ("ip_prband: band_offset=%d curpos=%d\n") + call pargi(band_offset) ; call pargi(ip_lnote(fd)) + call zzi_prstruct ("ip_prband", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + # Skip pixels at front of line + line_offset = ip_lnote (fd) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, 1, npix, cmap) + + # Skip pixels at end of line. + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + cur_offset = ip_lnote (fd) + + # Loop over each of the remaining pixtypes. + do j = 2, IP_NPIXT(ip) { + # Seek to offset of next band (i.e. line_offset + band_offset). + call ip_lskip (fd, band_offset) + if (IP_LSKIP(ip) != 0) + call ip_lskip (fd, IP_LSKIP(ip)) + call ip_rdline (ip, fd, j, npix, cmap) # read pixels in the line + if (IP_LPAD(ip) != 0) + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + + # Restore file pointer to cur_offset. + call ip_lseek (fd, cur_offset) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRLINE -- Process a line interleaved file. + +procedure ip_prline (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +int i, j, nlines, npix, percent + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { + call eprintf ("ip_prline:\n") + call zzi_prstruct ("ip_prline", ip) + } + + # Patch up the pixtype param if needed. + call ip_fix_pixtype (ip) + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + npix = IP_AXLEN(ip,1) + percent = 0 + do i = 1, nlines { + + do j = 1, IP_NPIXT(ip) { + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line and save as operand. + call ip_rdline (ip, fd, j, npix, cmap) + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + } + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PRPIX -- Process a pixel interleaved file. + +procedure ip_prpix (ip, fd, im, cmap) + +pointer ip #i task struct pointer +int fd #i inpout file descriptor +pointer im #i output image pointer +pointer cmap #i colormap pointer + +pointer op, data +int i, swap, optype, nlines +int percent, npix, totpix + +int and(), ip_ptype() + +begin + # Rewind the file and skip header pixels. + call ip_lseek (fd, BOF) + call ip_lseek (fd, IP_HSKIP(ip)+1) + + if (DEBUG) { call eprintf ("ip_prpix: ") } + + # See if we need to create any outbands operands if the user didn't. + if (IP_NBANDS(ip) == ERR) + call ip_fix_outbands (ip) + + # Allocate the pixtype data pointers. + npix = IP_AXLEN(ip,1) + nlines = IP_NPIXT(ip) + do i = 1, nlines { + op = PTYPE(ip,i) + optype = ip_ptype (IO_TYPE(op),IO_NBYTES(op)) + IO_NPIX(op) = npix + if (IO_DATA(op) == NULL) + if (optype == TY_UBYTE) + call malloc (IO_DATA(op), npix, TY_SHORT) + else + call malloc (IO_DATA(op), npix, optype) + } + + # Loop over the image lines. + nlines = IP_AXLEN(ip,2) + totpix = npix * IP_NPIXT(ip) + swap = IP_SWAP(ip) + percent = 0 + if (DEBUG) { + call zzi_prstruct ("ip_prpix", ip) + call eprintf ("nl=%d np=%d tp=%d:\n") + call pargi(nlines) ; call pargi(npix) ; call pargi(totpix) + } + do i = 1, nlines { + + # Skip pixels at front of line + call ip_lskip (fd, IP_LSKIP(ip)) + + # Read pixels in the line. + switch (optype) { + case TY_UBYTE: + call ip_agetb (fd, data, totpix) + call ip_lskip (fd, totpix) + # Apply a colormap to the bytes. In general a pixel-interleaved + # file is a 24-bit True Color image, but maybe this is a + # 3-D color index file? + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], totpix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, totpix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (totpix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_SHORT))) + + $for (silrd) + case TY_PIXEL: + call ip_aget$t (fd, data, totpix) + $if (datatype == s) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + $if (datatype == il) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I4) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Mem$t[data], Mem$t[data], totpix) + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_INT*SZB_CHAR))) + } + } + $endif + $if (datatype == r) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + $if (datatype == d) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Mem$t[data], 1, Mem$t[data], 1, + (totpix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + + $if (datatype == il) + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_INT32))) + $else + call ip_lskip (fd, (totpix * (SZB_CHAR * SZ_PIXEL))) + $endif + $endfor + } + + # Skip pixels at end of line. + call ip_lskip (fd, IP_LPAD(ip)) + + # Separate pixels into different vectors. + call ip_upkpix (ip, data, npix) + + # Evaluate and write the outbands expressions. + call ip_probexpr (ip, im, npix, i) + + # Print percent done if being verbose + #if (IP_VERBOSE(ip) == YES) + call ip_pstat (ip, i, percent) + } + + if (optype == TY_UBYTE) + call mfree (data, TY_SHORT) + else + call mfree (data, optype) + do i = 1, IP_NBANDS(ip) + call mfree (BUFFER(ip,i), IM_PIXTYPE(im)) +end + + +# IP_PROBEXPR -- Process each of the outbands expressions and write the result +# to the output image. + +procedure ip_probexpr (ip, im, npix, line) + +pointer ip #i task struct pointer +pointer im #i output image pointer +int npix #i number of output pixels +int line #i line number + +int i +pointer out, ip_evaluate() + +begin + # Loop over outbands expressions. + do i = 1, IP_NBANDS(ip) { + # Evaluate outbands expression. + out = ip_evaluate (ip, O_EXPR(ip,i)) + + # Write bands to output image + if (IP_OUTPUT(ip) != IP_NONE) + call ip_wrline (ip, im, out, npix, line, i) + + call evvfree (out) + } +end + + +# IP_RDLINE -- Read a line of pixels from the binary file. + +procedure ip_rdline (ip, fd, pnum, npix, cmap) + +pointer ip #i task struct pointer +int fd #i input file descriptor +int pnum #i pixtype number +int npix #i number of pixels to read +pointer cmap #i colormap pointer + +pointer op, data +int swap, ptype + +int and(), ip_ptype() + +begin + # Read pixels in the line and save as operand. + op = PTYPE(ip,pnum) + ptype = ip_ptype (IO_TYPE(op), IO_NBYTES(op)) + data = IO_DATA(op) + swap = IP_SWAP(ip) + IO_NPIX(op) = npix + + switch (ptype) { + case TY_UBYTE: + call ip_agetb (fd, data, npix) + call ip_lskip (fd, npix) + # Apply a colormap to the bytes. If the colormap is non-null we + # assume the bytes are color indices into a colormap. + if (cmap != NULL && IP_USE_CMAP(ip) == YES) + call ip_gray_cmap (Memc[data], npix, cmap) + + case TY_USHORT: + call ip_agetu (fd, data, npix) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_SHORT*SZB_CHAR))) + } + call ip_lskip (fd, (npix * (SZB_CHAR * SZ_SHORT))) + $for (silrd) + case TY_PIXEL: + call ip_aget$t (fd, data, npix) + $if (datatype == s) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I2) { + call bswap2 (Mems[data], 1, Mems[data], 1, + (npix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + $if (datatype == il) + if (and(swap, S_ALL) == S_ALL || and(swap, S_I2) == S_I4) { + if (SZ_INT != SZ_INT32) { + call ipak32 (Mem$t[data], Mem$t[data], npix) + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (npix*(SZ_INT32*SZB_CHAR))) + } else { + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (npix*(SZ_PIXEL*SZB_CHAR))) + } + } + $endif + $if (datatype == r) + if (and(swap, S_ALL) == S_ALL) { + call bswap4 (Mem$t[data], 1, Mem$t[data], 1, + (npix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + $if (datatype == d) + if (and(swap, S_ALL) == S_ALL) { + call bswap8 (Mem$t[data], 1, Mem$t[data], 1, + (npix*(SZ_PIXEL*SZB_CHAR))) + } + $endif + + $if (datatype == il) + call ip_lskip (fd, npix * (SZB_CHAR * SZ_INT32)) + $else + call ip_lskip (fd, npix * (SZB_CHAR * SZ_PIXEL)) + $endif + $endfor + } + IO_DATA(op) = data +end + + +# IP_WRLINE -- Write a line of pixels to the output image. We handle image +# flipping here to avoid possibly doing it several times while the outbands +# expression is being evaluated. + +procedure ip_wrline (ip, im, out, npix, line, band) + +pointer ip #i task struct pointer +pointer im #i output image pointer +pointer out #i output operand pointer +int npix #i number of pixels to read +int line #i image line number +int band #i image band number + +int i, lnum, type +int nldone, blnum +pointer sp, dptr, data, optr +bool lastline + +int and() +pointer imps3s(), imps3i(), imps3l(), imps3r(), imps3d() +pointer ip_chtype() + +data blnum /0/ +data nldone /1/ +data lastline /false/ + +begin + call smark (sp) + + # The first thing we do is change the datatype of the operand to + # match the output pixel type. + if (IP_OUTTYPE(ip) != NULL) { + if (IP_OUTTYPE(ip) == O_TYPE(out)) + optr = O_VALP(out) + else + optr = ip_chtype (out, IP_OUTTYPE(ip)) + } + type = IP_OUTTYPE(ip) + + # See if we're flipping image in Y, and adjust the line number. + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + lnum = IP_AXLEN(ip,2) - line + 1 + if (band == 1) + blnum = IP_SZBUF(ip) - mod (line-1, IP_SZBUF(ip)) + lastline = (lnum == 1) + } else { + lnum = line + if (band == 1) + blnum = blnum + 1 + lastline = (lnum == IP_AXLEN(ip,2)) + } + + # See if we're flipping image in x, and reverse the pixels. + if (and(IP_FLIP(ip),FLIP_X) == FLIP_X) { + call salloc (dptr, npix, type) + do i = 1, npix { + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[dptr+i-1] = Mems[optr+(npix-i)] + $for (ilrd) + case TY_PIXEL: + Mem$t[dptr+i-1] = Mem$t[optr+(npix-i)] + $endfor + } + } + } else + dptr = optr + + # Make sure the image pixtype is set. + if (IM_PIXTYPE(im) == NULL) + IM_PIXTYPE(im) = type + + # Allocate the buffer pointer if needed. + if (BUFFER(ip,band) == NULL) + call calloc (BUFFER(ip,band), npix*IP_SZBUF(ip), IP_OUTTYPE(ip)) + + if (nldone < IP_SZBUF(ip) && !lastline) { + # Copy the image line to the buffer + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + $for (ilrd) + case TY_PIXEL: + call amov$t (Mem$t[dptr], Mem$t[data+((blnum-1)*npix)], npix) + $endfor + } + if (band == IP_NBANDS(ip)) + nldone = nldone + 1 + + } else { + # Write the buffer to the image as a section. + data = BUFFER(ip,band) + switch (type) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + call amovs (Mems[dptr], Mems[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3s (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amovs (Mems[BUFFER(ip,band)+(blnum-1)*npix], + Mems[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3s (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amovs (Mems[BUFFER(ip,band)], Mems[data], npix*blnum) + } + $for (ilrd) + case TY_PIXEL: + call amov$t (Mem$t[dptr], Mem$t[data+((blnum-1)*npix)], npix) + if (and(IP_FLIP(ip),FLIP_Y) == FLIP_Y) { + data = imps3$t (im, 1, npix, + max(1,(lnum-IP_SZBUF(ip)+1)+IP_SZBUF(ip)-1), + max(1,lnum+min(nldone,IP_SZBUF(ip))-1), + band, band) + call amov$t (Mem$t[BUFFER(ip,band)+(blnum-1)*npix], + Mem$t[data], npix*(IP_SZBUF(ip)-blnum+1)) + } else { + data = imps3$t (im, 1, npix, + min(IP_AXLEN(ip,2),(lnum-blnum+1)), + min(IP_AXLEN(ip,2),lnum), + band, band) + call amov$t (Mem$t[BUFFER(ip,band)], Mem$t[data], + npix*blnum) + } + $endfor + } + if (band == IP_NBANDS(ip)) { + nldone = 1 + blnum = 0 + } + } + + if (IP_OUTTYPE(ip) != O_TYPE(out)) + call mfree (optr, type) + call sfree (sp) +end + + +# IP_UPKPIX -- Unpack a line of pixel-interleaved pixels to the separate +# pixtype operand arrays. + +procedure ip_upkpix (ip, ptr, npix) + +pointer ip #i task struct pointer +pointer ptr #i pointer to pixels +int npix #i number of pixels in line + +pointer op[IM_MAXDIM] +int i, j, np, optype[IM_MAXDIM] + +int ip_ptype() + +begin + np = IP_NPIXT(ip) + do j = 1, np { + op[j] = PTYPE(ip,j) + optype[j] = ip_ptype (IO_TYPE(op[j]),IO_NBYTES(op[j])) + } + + do j = 1, np { + + do i = 0, npix-1 { + switch (optype[j]) { + case TY_UBYTE, TY_USHORT, TY_SHORT: + Mems[IO_DATA(op[j])+i] = Mems[ptr+(i*np+j)-1] + $for (ilrd) + case TY_PIXEL: + Mem$t[IO_DATA(op[j])+i] = Mem$t[ptr+(i*np+j)-1] + $endfor + } + } + } +end + + +# IP_FIX_PIXTYPE -- Create the pixtype operands for 3-D band or line- +# interleaved files. These weren't allocated at first since the pixtype +# parameter or database field was atomic. + +procedure ip_fix_pixtype (ip) + +pointer ip #i task struct pointer + +pointer op, op1 +int i, nnp + +begin + if (DEBUG) { + call eprintf ("fix_pixtype: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # See if there's anything to be fixed. + if (IP_NDIM(ip) < 3 || IP_NDIM(ip) < IP_NPIXT(ip)) + return + if (BAND_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_NDIM(ip))) + return + if (LINE_INTERLEAVED(ip) && (IP_NPIXT(ip) == IP_INTERLEAVE(ip))) + return + + if (LINE_INTERLEAVED(ip)) + nnp = IP_INTERLEAVE(ip) + else + #nnp = IP_NDIM(ip) + nnp = IP_AXLEN(ip,3) + + # Make the new pixtype operands. + op1 = PTYPE(ip,1) + do i = 2, nnp { + call ip_alloc_operand (PTYPE(ip,i)) + op = PTYPE(ip,i) + IO_TYPE(op) = IO_TYPE(op1) + IO_NBYTES(op) = IO_NBYTES(op1) + call sprintf (OP_TAG(op), SZ_TAG, "b%d") + call pargi (i) + } + IP_NPIXT(ip) = nnp + + if (DEBUG) { call zzi_prstruct ("fix_pixtype", ip) } +end + + +# IP_FIX_OUTBANDS -- Create the outbands operands if none were specified in +# the parameter file. + +procedure ip_fix_outbands (ip) + +pointer ip #i task struct pointer + +pointer sp, buf +pointer im +int i, nbands + +define SZ_OBSTR 2500 + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + if (DEBUG) { + call eprintf ("fix_outbands: npixt=%d ndim=%d inter=%d\n") + call pargi(IP_NPIXT(ip)) ; call pargi(IP_NDIM(ip)) + call pargi(IP_INTERLEAVE(ip)) ; call flush (STDERR) + } + + # Free up the existing outbands operands. + nbands = IP_NBANDS(ip) + do i = 1, nbands + call ip_free_outbands (OBANDS(ip,i)) + + # Create an outbands parameter string according to the tags in the + # pixtype structure. This way we preserve any user-defined tags on + # output. + nbands = IP_NPIXT(ip) + call aclrc (Memc[buf], SZ_FNAME) + do i = 1, nbands { + call ip_alloc_outbands (OBANDS(ip,i)) + call aclrc (Memc[buf], SZ_FNAME) + call sprintf (Memc[buf], SZ_FNAME, "b%d") + call pargi (i) + call strcpy (Memc[buf], O_EXPR(ip,i), SZ_EXPR) + + # Load the operand struct. + call strcpy (Memc[buf], OP_TAG(O_OP(ip,i)), SZ_EXPR) + } + IP_NBANDS(ip) = nbands + + # Fix the output image dimensions. + im = IP_IM(ip) + IM_LEN(im,3) = IP_AXLEN(ip,3) + if (IP_NBANDS(ip) > 1) + IM_NDIM(im) = 3 + else + IM_NDIM(im) = IP_NDIM(ip) + + call sfree (sp) + + if (DEBUG) { call zzi_prstruct ("fix_outbands", ip) } +end + + +# IP_CHTYPE - Change the expression operand vector to the output datatype. +# We allocate and return a pointer to the correct type to the converted +# pixels, this pointer must be freed later on. + +pointer procedure ip_chtype (op, type) + +pointer op #i evvexpr operand pointer +int type #i new type of pointer + +pointer out, coerce() + +begin + # Allocate the pointer and coerce it so the routine works. + if (type == TY_UBYTE || type == TY_CHAR) + call calloc (out, O_LEN(op), TY_CHAR) + else { + call calloc (out, O_LEN(op), type) + out = coerce (out, type, TY_CHAR) + } + + # Change the pixel type. + switch (O_TYPE(op)) { + case TY_CHAR: + call achtc (Memc[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_SHORT: + call achts (Mems[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_INT: + call achti (Memi[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_LONG: + call achtl (Meml[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_REAL: + call achtr (Memr[O_VALP(op)], Memc[out], O_LEN(op), type) + case TY_DOUBLE: + call achtd (Memd[O_VALP(op)], Memc[out], O_LEN(op), type) + default: + call error (0, "Invalid output type requested.") + } + + out = coerce (out, TY_CHAR, type) + return (out) +end + + +define NTYPES 6 +define NBITPIX 4 + +# IP_PTYPE -- For a given pixtype parameter return the corresponding IRAF +# data type. + +int procedure ip_ptype (type, nbytes) + +int type #i pixel type +int nbytes #i number of bytes + +int i, pt, pb, ptype +int tindex[NTYPES], bindex[NBITPIX], ttbl[NTYPES*NBITPIX] + +data tindex /PT_BYTE, PT_UINT, PT_INT, PT_IEEE, PT_NATIVE, PT_SKIP/ +data bindex /1, 2, 4, 8/ + +data (ttbl(i), i= 1, 4) /TY_UBYTE, TY_USHORT, TY_INT, 0/ # B +data (ttbl(i), i= 5, 8) /TY_UBYTE, TY_USHORT, 0, 0/ # U +data (ttbl(i), i= 9,12) /TY_UBYTE, TY_SHORT, TY_INT, 0/ # I +data (ttbl(i), i=13,16) / 0, 0, TY_REAL, TY_DOUBLE/ # R +data (ttbl(i), i=17,20) / 0, 0, TY_REAL, TY_DOUBLE/ # N +data (ttbl(i), i=21,24) /TY_UBYTE, TY_USHORT, TY_REAL, TY_DOUBLE/ # X + +begin + if (type == 0 || nbytes == 0) # uninitialized values + return (0) + + pt = NTYPES + do i = 1, NTYPES { + if (tindex[i] == type) + pt = i + } + pb = NBITPIX + do i = 1, NBITPIX { + if (bindex[i] == nbytes) + pb = i + } + + ptype = ttbl[(pt-1)*NBITPIX+pb] + if (ptype == 0) + call error (0, "Invalid pixtype specified.") + else + return (ptype) +end + + +# IP_PSTAT - Print information about the progress we're making. + +procedure ip_pstat (ip, row, percent) + +pointer ip #i task struct pointer +int row #u current row +int percent #u percent completed + +begin + # Print percent done if being verbose + if (row * 100 / IP_AXLEN(ip,2) >= percent + 10) { + percent = percent + 10 + call eprintf (" Status: %2d%% complete\r") + call pargi (percent) + call flush (STDERR) + } +end diff --git a/pkg/dataio/import/mkpkg b/pkg/dataio/import/mkpkg new file mode 100644 index 00000000..c12f77f6 --- /dev/null +++ b/pkg/dataio/import/mkpkg @@ -0,0 +1,37 @@ +# MKPKG file for the IMPORT task + +$call update +$exit + +update: + $checkout libpkg.a ../ + $update libpkg.a + $checkin libpkg.a ../ + ; + +generic: + $set GEN = "$$generic -k" + + $ifolder (generic/ipdb.x, ipdb.gx) + $(GEN) ipdb.gx -o generic/ipdb.x $endif + $ifolder (generic/ipfio.x, ipfio.gx) + $(GEN) ipfio.gx -o generic/ipfio.x $endif + $ifolder (generic/ipobands.x, ipobands.gx) + $(GEN) ipobands.gx -o generic/ipobands.x $endif + $ifolder (generic/ipproc.x, ipproc.gx) + $(GEN) ipproc.gx -o generic/ipproc.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + @generic + @bltins + + fmtdb.x import.h <ctotok.h> <error.h> <evvexpr.h> <fset.h> + ipbuiltin.x import.h + ipinfo.x import.h + iplistpix.x <imhdr.h> <error.h> <mwset.h> + ipmkhdr.x import.h <ctype.h> <imhdr.h> + t_import.x import.h <ctype.h> <error.h> <evvexpr.h> <imhdr.h> + zzidbg.x import.h <evvexpr.h> + ; diff --git a/pkg/dataio/import/t_import.x b/pkg/dataio/import/t_import.x new file mode 100644 index 00000000..adb37d17 --- /dev/null +++ b/pkg/dataio/import/t_import.x @@ -0,0 +1,768 @@ +include <error.h> +include <ctype.h> +include <evvexpr.h> +include <imhdr.h> +include "import.h" + +define DEBUG false + + +# T_IMPORT -- Convert a generic binary raster file to an IRAF image. The +# binary file is described either from the task parameters, or as an entry +# in a database of known formats. Access to the database is either by +# specifying the format explicitly, or by scanning the database and evaluating +# an expression which identifies the format. Output is either in the form +# of information about the file to be converted, a list of the file's pixels +# or an IRAF image whose bands are computed from a list of expressions. + +procedure t_import () + +pointer ip # task structure pointer +int binfiles # binary files list pointer +pointer imfiles # output image list pointer +int fdb # format database descriptor +int im # image pointer +pointer sp, bfname, imname # local storage +pointer format, output, fmt, idstr + +int clpopni(), clplen(), imtlen() # function definitions +int clgfil(), open() +int locpr(), imtgetim(), fdb_opendb() +int ip_fcode(), ip_is_builtin() +pointer imtopenp(), ip_init(), fdb_scan_records(), immap() + +extern ip_getop(), ip_dbfcn() +errchk clpopni, clgfil, imtopenp, open, immap + +define done_ 99 + +begin + call smark (sp) # local storage + call salloc (bfname, SZ_FNAME, TY_CHAR) + call salloc (imname, SZ_FNAME, TY_CHAR) + call salloc (format, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (fmt, SZ_FNAME, TY_CHAR) + call salloc (idstr, SZ_FNAME, TY_CHAR) + + ip = ip_init () # allocate task struct pointer + + call ieemapr (YES, YES) # enable IEEE NaN mapping + call ieemapd (YES, YES) + + # Get file names and image lists. + binfiles = clpopni ("binfiles") + imfiles = imtopenp ("images") + + # Get the format parameter. + call clgstr ("format", Memc[format], SZ_FNAME) + call ip_do_fmtpar (ip, Memc[format]) + + # Get task output parameters. + call ip_gout_pars (ip) + + # See if the image lists match. If the lists are empty and we're + # asked for info, just dump the database and leave. + if (IP_OUTPUT(ip) != IP_INFO && IP_OUTPUT(ip) != IP_NONE) { + if (clplen(binfiles) != imtlen(imfiles) && imtlen(imfiles) != 0) { + # Clean up and print an error. + call clpcls (binfiles) + call imtclose (imfiles) + call sfree (sp) + call error (1, "Input and output lists not the same length.") + } + } else if (IP_OUTPUT(ip) == IP_INFO) { + if (clplen(binfiles) == 0 && imtlen(imfiles) == 0) { + fdb = fdb_opendb () + call ip_list_formats (fdb) + call fdb_closedb (fdb) + goto done_ + } + } + + while (clgfil (binfiles, Memc[bfname], SZ_FNAME) != EOF) { + iferr (IP_FD(ip) = open (Memc[bfname], READ_ONLY, BINARY_FILE)) { + call eprintf ("Error opening file '%s'.\n") + call pargstr (Memc[bfname]) + break + } + + # Process the outbands parameter. + call ip_reset_outbands (ip) + + if (IP_FORMAT(ip) == IP_SENSE) { + # Scan the database and get symtab pointer to format record. + fdb = fdb_opendb () + call ip_lseek (fdb, BOF) + IP_FSYM(ip) = fdb_scan_records (fdb, "image_id", + locpr(ip_getop), ip, locpr(ip_dbfcn), ip) + if (IP_FSYM(ip) == NULL) { + # Try it byte-swapped. + IP_SWAP(ip) = S_ALL + call ip_lseek (fdb, BOF) + IP_FSYM(ip) = fdb_scan_records (fdb, "image_id", + locpr(ip_getop), ip, locpr(ip_dbfcn), ip) + IP_SWAP(ip) = NULL + + if (IP_FSYM(ip) == NULL) { + if (IP_OUTPUT(ip) == IP_INFO) { + call printf ("%.19s%20tUnrecognized format\n") + call pargstr (Memc[bfname]) + call fdb_closedb (fdb) + next + } else { + call printf ( + "Unrecognized format. Known formats include:\n\n") + call ip_lseek (fdb, BOF) + call ip_list_formats (fdb) + call fdb_closedb (fdb) + break + } + } + } + call fdb_closedb (fdb) + } + + # See if this is a 'builtin' format. + if (IP_FSYM(ip) != NULL) { + call fdbgstr (IP_FSYM(ip), "format", Memc[fmt], SZ_LINE) + call fdbgstr (IP_FSYM(ip), "id_string", Memc[idstr], SZ_LINE) + call fdb_strip_quote (Memc[idstr], Memc[idstr], SZ_LINE) + IP_BLTIN(ip) = ip_is_builtin (Memc[fmt]) + IP_FCODE(ip) = ip_fcode (Memc[fmt]) + } else + IP_BLTIN(ip) = NO + + + if (IP_FORMAT(ip) != IP_NONE) { + # Evaluate database expressions for this binary file. + call ip_eval_dbrec (ip) + } + + if (IP_OUTPUT(ip) == IP_INFO) { + # Just print some information about the file. + call ip_info (ip, Memc[bfname], IP_VERBOSE(ip)) + + } else { + if (IP_OUTPUT(ip) != IP_NONE) { + # Get an output image name. + if (IP_OUTPUT(ip) == IP_IMAGE) { + if (imtgetim (imfiles, Memc[imname], SZ_FNAME) == EOF) + call error (1, "Short image list.") + } else if (IP_OUTPUT(ip) == IP_LIST) { + # Get a temporary image name. + call mktemp ("tmp$imp", Memc[imname], SZ_FNAME) + } + + # Open the output image. + iferr (im = immap(Memc[imname], NEW_IMAGE, 0)) { + call erract (EA_WARN) + next + } + IP_IM(ip) = im + + # Calculate the size of output image and number of bands. + IM_LEN(im,1) = IP_AXLEN(ip,1) + IM_LEN(im,2) = IP_AXLEN(ip,2) + IM_LEN(im,3) = IP_NBANDS(ip) + if (IP_NBANDS(ip) > 1) + IM_NDIM(im) = 3 + else + IM_NDIM(im) = IP_NDIM(ip) + IM_PIXTYPE(im) = IP_OUTTYPE(ip) + } + + if (IP_VERBOSE(ip) == YES && IP_OUTPUT(ip) != IP_LIST) { + # Print chatter about the conversion. + call printf ("%s -> %s\n ") + call pargstr (Memc[bfname]) + call pargstr (Memc[imname]) + call ip_info (ip, Memc[bfname], NO) + call ip_obinfo (ip, Memc[imname]) + call flush (STDOUT) + } + + if (IP_BLTIN(ip) == YES) { + call ip_prbuiltin (ip, Memc[bfname]) + } else { + # This is it, process the binary file. + if (BAND_INTERLEAVED(ip)) + # Input file is band interleaved. + call ip_prband (ip, IP_FD(ip), IP_IM(ip), NULL) + else if (LINE_INTERLEAVED(ip)) + # Input file is line interleaved. + call ip_prline (ip, IP_FD(ip), IP_IM(ip), NULL) + else if (PIXEL_INTERLEAVED(ip)) + # Input file is pixel interleaved. + call ip_prpix (ip, IP_FD(ip), IP_IM(ip), NULL) + else + call error (0, "Unrecognized pixel storage.") + + if (IP_VERBOSE(ip) == YES) { + call eprintf (" Status: Done \n") + call flush (STDERR) + } + } + + + if (IP_IMHEADER(ip) != NULL && IP_OUTPUT(ip) != IP_NONE) + # Copy header info to new image (can contain wcs info) + call ip_mkheader (IP_IM(ip), Memc[IP_IMHEADER(ip)]) + + if (IP_OUTPUT(ip) == IP_LIST) { + # List the image pixels band by band. + call ip_listpix (IP_IM(ip)) + call imdelete (Memc[imname]) + } + + if (IP_IM(ip) != NULL) + call imunmap (IP_IM(ip)) # close the output image + } + + call close (IP_FD(ip)) + if (IP_FORMAT(ip) == IP_SENSE) + call fdb_close (IP_FSYM(ip)) # free format pointer + } + + # Free task structure ptr and clean up. + call fdb_close (IP_FSYM(ip)) +done_ call ip_free (ip) + call clpcls (binfiles) + call imtclose (imfiles) + call sfree (sp) +end + + +# IP_INIT -- Initialize the task structure pointers. + +pointer procedure ip_init () + +pointer ptr + +begin + # Allocate task structure pointer. + iferr (call calloc (ptr, SZ_IMPSTRUCT, TY_STRUCT)) + call error (0, "Error allocating IMPORT task structure.") + + # Allocate the pixtype, outbands, and buffer struct pointers. + call calloc (IP_PIXTYPE(ptr), MAX_OPERANDS, TY_POINTER) + call calloc (IP_OUTBANDS(ptr), MAX_OPERANDS, TY_POINTER) + call calloc (IP_BUFPTR(ptr), MAX_OPERANDS, TY_POINTER) + + # Initialize some parameters + IP_IM(ptr) = NULL + IP_FD(ptr) = NULL + IP_OFFSET(ptr) = 1 + IP_FLIP(ptr) = FLIP_NONE + + return (ptr) +end + + +# IP_FREE -- Free the task structure pointers. + +procedure ip_free (ip) + +pointer ip #i task struct pointer + +int i + +begin + # Free pixtype pointers. + for (i=1; i < IP_NPIXT(ip); i=i+1) + call mfree (PTYPE(ip,i), TY_STRUCT) + call mfree (IP_PIXTYPE(ip), TY_POINTER) + + # Free outbands pointers. + for (i=1; i < MAX_OPERANDS; i=i+1) + call mfree (OBANDS(ip,i), TY_STRUCT) + call mfree (IP_OUTBANDS(ip), TY_POINTER) + + # Free buffer pointers. + call mfree (IP_BUFPTR(ip), TY_POINTER) + + if (IP_COMPTR(ip) != NULL) + call mfree (IP_COMPTR(ip), TY_CHAR) + call mfree (ip, TY_STRUCT) +end + + +# IP_GIN_PARS -- Get the task input file parameters. + +procedure ip_gin_pars (ip) + +pointer ip #i task struct pointer + +pointer sp, dims, bswap, pixtype + +int clgeti() + +begin + call smark (sp) + call salloc (dims, SZ_FNAME, TY_CHAR) + call salloc (bswap, SZ_FNAME, TY_CHAR) + call salloc (pixtype, SZ_FNAME, TY_CHAR) + + # Get the storage parameters. + IP_HSKIP(ip) = clgeti ("hskip") + IP_TSKIP(ip) = clgeti ("tskip") + IP_BSKIP(ip) = clgeti ("bskip") + IP_LSKIP(ip) = clgeti ("lskip") + IP_LPAD(ip) = clgeti ("lpad") + + # Process the dims parameter. + call aclrc (Memc[dims], SZ_FNAME) + call clgstr ("dims", Memc[dims], SZ_FNAME) + call ip_do_dims (ip, Memc[dims]) + + # Process the bswap parameter. + call aclrc (Memc[bswap], SZ_FNAME) + call clgstr ("bswap", Memc[bswap], SZ_FNAME) + call ip_do_bswap (ip, Memc[bswap]) + + # Process the pixtype parameter. + call aclrc (Memc[pixtype], SZ_FNAME) + call clgstr ("pixtype", Memc[pixtype], SZ_FNAME) + call ip_do_pixtype (ip, Memc[pixtype]) + + if (IP_NPIXT(ip) > 1) + IP_INTERLEAVE(ip) = 0 # composite pixtype, ignore interleave + else + IP_INTERLEAVE(ip) = clgeti ("interleave") + + # Do a little sanity checking. + if (IP_NPIXT(ip) > 1 && IP_NDIM(ip) > IP_NPIXT(ip)) + call error (1, + "Image dimensions don't match `pixtype' specification.") + if (IP_NPIXT(ip) == 1 && IP_NDIM(ip) > 2 && (IP_INTERLEAVE(ip) != 0 && + IP_INTERLEAVE(ip) != IP_AXLEN(ip,3))) + call error (1, + "Dimensions don't match `pixtype' and `interleave' params.") + + if (DEBUG) { call zzi_prstruct ("init inpars", ip) } + call sfree (sp) +end + + +# IP_GOUT_PARS -- Get the task output file parameters. + +procedure ip_gout_pars (ip) + +pointer ip #i task struct pointer + +pointer sp, out, otype, obands, imhead +int btoi(), clgeti() +bool clgetb(), streq() + +begin + call smark (sp) + call salloc (out, SZ_FNAME, TY_CHAR) + call salloc (otype, SZ_FNAME, TY_CHAR) + call salloc (obands, SZ_FNAME, TY_CHAR) + call salloc (imhead, SZ_FNAME, TY_CHAR) + + # Get the type of output to do. + call aclrc (Memc[out], SZ_FNAME) + call clgstr ("output", Memc[out], SZ_FNAME) + switch (Memc[out]) { + case 'i': + if (Memc[out+1] == 'n') # info + IP_OUTPUT(ip) = IP_INFO + else if (Memc[out+1] == 'm') # image + IP_OUTPUT(ip) = IP_IMAGE + case 'l': # list + IP_OUTPUT(ip) = IP_LIST + case 'n': # none, no + IP_OUTPUT(ip) = IP_NONE + default: + call error (2, "Unrecognized output type in 'output'.") + } + + # Get the output image type. + call aclrc (Memc[otype], SZ_FNAME) + call clgstr ("outtype", Memc[otype], SZ_FNAME) + switch (Memc[otype]) { + case 'u': + IP_OUTTYPE(ip) = TY_USHORT + case 's': + IP_OUTTYPE(ip) = TY_SHORT + case 'i': + IP_OUTTYPE(ip) = TY_INT + case 'l': + IP_OUTTYPE(ip) = TY_LONG + case 'r': + IP_OUTTYPE(ip) = TY_REAL + case 'd': + IP_OUTTYPE(ip) = TY_DOUBLE + default: + IP_OUTTYPE(ip) = NULL + call error (2, "Unrecognized output image type in 'outtype'.") + } + + # Process the outbands parameter. + #call ip_reset_outbands (ip) + + # Get optional image header info file name. + call aclrc (Memc[imhead], SZ_FNAME) + call clgstr ("imheader", Memc[imhead], SZ_FNAME) + if (streq (Memc[imhead],"")) { + IP_IMHEADER(ip) = NULL + } else { + call calloc (IP_IMHEADER(ip), SZ_FNAME, TY_CHAR) + call strcpy (Memc[imhead], Memc[IP_IMHEADER(ip)], SZ_FNAME) + } + IP_VERBOSE(ip) = btoi (clgetb("verbose")) + IP_SZBUF(ip) = clgeti ("buffer_size") + + if (DEBUG) { call zzi_prstruct ("init outpars", ip) } + call sfree (sp) +end + + +# IP_RESET_OUTBANDS - Initialize the 'outbands' parameter structure to the +# default values. + +procedure ip_reset_outbands (ip) + +pointer ip #i task struct pointer + +pointer sp, obands +int i + +begin + if (IP_OUTPUT(ip) == IP_INFO) + return + + call smark (sp) + call salloc (obands, SZ_FNAME, TY_CHAR) + + do i = 1, IP_NBANDS(ip) + call ip_free_outbands (OBANDS(ip,i)) + + # Process the outbands parameter. + call aclrc (Memc[obands], SZ_FNAME) + call clgstr ("outbands", Memc[obands], SZ_FNAME) + call ip_do_outbands (ip, Memc[obands]) + + call sfree (sp) +end + + +# IP_DO_BSWAP -- Read the byte-swap string an load the ip structure. + +procedure ip_do_bswap (ip, bswap) + +pointer ip #i task struct pointer +char bswap[ARB] #i byte swap string + +char ch, flag[SZ_FNAME] +int sp, i + +int strdic() + +begin + if (DEBUG) { call eprintf("swap='%s'\n");call pargstr (bswap) } + + sp = 1 + IP_SWAP(ip) = NULL + while (bswap[sp] != EOS) { + i = 1 + for (ch=bswap[sp]; ch != EOS && ch != ','; ch=bswap[sp]) { + flag[i] = ch + i = i + 1 + sp = sp + 1 + } + flag[i] = EOS + if (DEBUG) { call eprintf("\tflag='%s'\n");call pargstr (flag) } + + switch (strdic (flag, flag, SZ_FNAME, SWAP_STR)) { + case 1, 2: + IP_SWAP(ip) = or (IP_SWAP(ip), S_NONE) + case 3: + IP_SWAP(ip) = or (IP_SWAP(ip), S_ALL) + case 4: + IP_SWAP(ip) = or (IP_SWAP(ip), S_I2) + case 5: + IP_SWAP(ip) = or (IP_SWAP(ip), S_I4) + default: + break + } + } +end + + +# IP_DO_DIMS -- Parse the 'dims' parameter to get number of axes and dimensions. + +procedure ip_do_dims (ip, dims) + +pointer ip #i task struct pointer +char dims[ARB] #i dimension string + +char ch +int sp, ndim, npix +int ctoi() + +begin + if (DEBUG) { call eprintf("dims='%s'\n");call pargstr (dims) } + + ndim = 0 + for (sp=1; ctoi(dims[1],sp,npix) > 0; ) { + ndim = ndim + 1 + IP_AXLEN(ip,ndim) = npix + for (ch=dims[sp]; IS_WHITE(ch) || ch == ','; ch=dims[sp]) + sp = sp + 1 + } + if (ndim == 1) + IP_AXLEN(ip,2) = 1 + IP_NDIM(ip) = ndim +end + + +# IP_DO_FMTPAR -- Given the format parameter, figure out what to do with it. + +procedure ip_do_fmtpar (ip, format) + +pointer ip #i task struct pointer +char format[ARB] #i format string + +pointer fsym +int fd + +int fdb_opendb() +pointer fdb_get_rec() +bool streq() + +begin + if (DEBUG) { call eprintf("format='%s'\n");call pargstr(format) } + + IP_FSYM(ip) = NULL + if (streq(format,"none")) { + # Get the task input parameters. + IP_FORMAT(ip) = IP_NONE + call ip_gin_pars (ip) + + } else if (streq(format,"sense")) { + # Set a flag and figure it out from the database later. + IP_FORMAT(ip) = IP_SENSE + + } else { + # Get a pointer to a symtab entry for the requested format + IP_FORMAT(ip) = IP_NAME + fd = fdb_opendb () + fsym = fdb_get_rec (fd, format) + call fdb_closedb (fd) + if (fsym == NULL) { + call error (2,"Requested format not found in the database.") + } else + IP_FSYM(ip) = fsym + } +end + + +# IP_DO_PIXTYPE -- Process the pixtype parameter + +procedure ip_do_pixtype (ip, pixtype) + +pointer ip #i task struct pointer +char pixtype[ARB] #i pixtype string + +int i, pp, npix, nbytes +pointer op + +int ctoi() + +begin + if (DEBUG) { call eprintf("pixtype=:%s:\n");call pargstr(pixtype) } + + # Check for a bonehead user. + if (pixtype[2] == EOS || pixtype[2] == ',') { + call error (0, "Invalid `pixtype' parameter: no size given") + } + + pp = 1 + npix = 0 + nbytes = ERR + repeat { + npix = npix + 1 + + call ip_alloc_operand (PTYPE(ip,npix)) + op = PTYPE(ip,npix) + + # Get pixel type. + switch (pixtype[pp]) { + case 'b': + IO_TYPE(op) = PT_BYTE + case 'u': + IO_TYPE(op) = PT_UINT + case 'i': + IO_TYPE(op) = PT_INT + case 'r': + IO_TYPE(op) = PT_IEEE + case 'n': + IO_TYPE(op) = PT_NATIVE + case 'x': + IO_TYPE(op) = PT_SKIP + } + pp = pp + 1 + + # Get the number of bytes. + i = ctoi (pixtype, pp, IO_NBYTES(op)) + + # Force equivalence of 'b1' and 'u1' pixtypes. + if (IO_TYPE(op) == PT_UINT && IO_NBYTES(op) == 1) + IO_TYPE(op) = PT_BYTE + + # Get a tag name or create one. + if (pixtype[pp] == ',' || pixtype[pp] == EOS) { # no tag given + call sprintf (OP_TAG(op), SZ_TAG, "b%d") + call pargi (npix) + if (pixtype[pp] != EOS) + pp = pp + 1 + } else if (pixtype[pp] == ':') { # get the tag + pp = pp + 1 + for (i=1; (pixtype[pp] != ',' && pixtype[pp] != EOS) ; i=i+1) { + Memc[IO_TAG(op)+i-1] = pixtype[pp] + pp = pp + 1 + } + pp = pp + 1 + } + + # Make sure all of the pixtypes are the same datatype. + if (nbytes != ERR) { + if (nbytes != IO_NBYTES(op)) + call error (0, "Pixtypes must all be the same size") + } else + nbytes = IO_NBYTES(op) + + if (DEBUG) { call zzi_prop (op) } + + } until (pixtype[pp] == EOS) + IP_NPIXT(ip) = npix +end + + +# IP_DO_OUTBANDS -- Get the outbands parameter and break it up into a list +# of individual expressions. + +procedure ip_do_outbands (ip, outbands) + +pointer ip #i task struct pointer +char outbands[ARB] #i outbands string + +pointer sp, buf +int i, op, nbands, level + +int strsearch() + +begin + # If there is no outbands parameter specified, warn the user, we'll + # make something up later. + IP_USE_CMAP(ip) = YES + if (outbands[1] == EOS && IP_OUTPUT(ip) != IP_INFO) { + call eprintf ("Warning: No 'outbands' parameter specified: ") + call eprintf ("Converting all pixels.\n") + IP_NBANDS(ip) = ERR + return + } + + call smark (sp) + call salloc (buf, SZ_EXPR, TY_CHAR) + call aclrc (Memc[buf], SZ_EXPR) + + if (DEBUG) { call eprintf("outbands='%s'\n");call pargstr(outbands) } + + op = 1 + nbands = 0 + while (outbands[op] != EOS) { + level = 0 + nbands = nbands + 1 + # Copy expr up to the delimiting comma into a buffer. + call aclrc (Memc[buf], SZ_EXPR) + for (i=0; i < SZ_EXPR; i = i + 1) { + if (outbands[op] == '(') { + level = level + 1 + Memc[buf+i] = outbands[op] + } else if (outbands[op] == ')') { + level = level - 1 + Memc[buf+i] = outbands[op] + } else if ((outbands[op] == ',' && level == 0) || + outbands[op] == EOS) { + Memc[buf+i] = EOS + op = op + 1 + break + } else if (! IS_WHITE(outbands[op])) + Memc[buf+i] = outbands[op] + op = op + 1 + } + + if (Memc[buf] != EOS) { + # Save expression to main outbands structure. + call ip_alloc_outbands (OBANDS(ip,nbands)) + call strcpy (Memc[buf], O_EXPR(ip,nbands), SZ_EXPR) + + if (strsearch(Memc[buf], "red") > 0 || + strsearch(Memc[buf], "green") > 0 || + strsearch(Memc[buf], "blue") > 0) + IP_USE_CMAP(ip) = NO + + # Load the operand struct. + call strcpy (Memc[buf], OP_TAG(O_OP(ip,nbands)), SZ_EXPR) + + if (DEBUG) { call zzi_proband (ip, nbands) } + } + } + IP_NBANDS(ip) = nbands + IP_AXLEN(ip,3) = nbands + + call sfree (sp) +end + + +# IP_ALLOC_OUTBANDS -- Allocate an outbands structure. + +procedure ip_alloc_outbands (op) + +pointer op #i outbands struct pointer + +begin + call calloc (op, LEN_OUTBANDS, TY_STRUCT) + call calloc (OB_EXPR(op), SZ_EXPR, TY_CHAR) + call ip_alloc_operand (OB_OP(op)) +end + + +# IP_FREE_OUTBANDS -- Free an outbands structure. + +procedure ip_free_outbands (op) + +pointer op #i outbands struct pointer + +begin + call ip_free_operand (OB_OP(op)) + call mfree (OB_EXPR(op), TY_CHAR) + call mfree (op, TY_STRUCT) +end + + +# IP_ALLOC_OPERAND -- Allocate an operand structure. + +procedure ip_alloc_operand (op) + +pointer op #i operand struct pointer + +begin + call calloc (op, LEN_OPERAND, TY_STRUCT) + call calloc (IO_TAG(op), SZ_FNAME, TY_CHAR) +end + + +# IP_FREE_OPERAND -- Free an operand structure. + +procedure ip_free_operand (op) + +pointer op #i operand struct pointer + +begin + call mfree (IO_TAG(op), TY_CHAR) + call mfree (op, TY_STRUCT) +end diff --git a/pkg/dataio/import/zzidbg.x b/pkg/dataio/import/zzidbg.x new file mode 100644 index 00000000..25c58778 --- /dev/null +++ b/pkg/dataio/import/zzidbg.x @@ -0,0 +1,145 @@ +include <evvexpr.h> +include "import.h" + +procedure zzi_prstruct (whence, ip) + +char whence[SZ_FNAME] +pointer ip +int i + +begin + call eprintf ("%s:\n") ; call pargstr (whence) + call eprintf ("\tformat=%s interleave=%d bswap=%s\n") + switch (IP_FORMAT(ip)) { + case IP_NONE: call pargstr ("IP_NONE") + case IP_SENSE: call pargstr ("IP_SENSE") + case IP_NAME: call pargstr ("IP_NAME") + case IP_BUILTIN: call pargstr ("IP_BUILTIN") + default: call pargstr ("ERR") + } + call pargi (IP_INTERLEAVE(ip)) + switch(IP_SWAP(ip)) { + case S_NONE: call pargstr ("S_NONE") + case S_ALL: call pargstr ("S_ALL") + case S_I2: call pargstr ("S_I2") + case S_I4: call pargstr ("S_I4") + default: call pargstr ("ERR") + } + call eprintf ("\thskip=%d tskip=%d bskip=%d lskip=%d lpad=%d\n") + call pargi (IP_HSKIP(ip)) + call pargi (IP_TSKIP(ip)) + call pargi (IP_BSKIP(ip)) + call pargi (IP_LSKIP(ip)) + call pargi (IP_LPAD(ip)) + call eprintf ("\tndim=%s dims=(%d,%d,%d,%d,%d,%d,%d)\n") + call pargi (IP_NDIM(ip)) + do i = 1, 7 + call pargi (IP_AXLEN(ip,i)) + + call eprintf ("\toutput=%s outtype=%s imheader='%s' verbose=%d\n") + switch(IP_OUTPUT(ip)) { + case IP_NONE: call pargstr ("IP_NONE") + case IP_IMAGE: call pargstr ("IP_IMAGE") + case IP_LIST: call pargstr ("IP_LIST") + case IP_INFO: call pargstr ("IP_INFO") + default: call pargstr ("ERR") + } + switch(IP_OUTTYPE(ip)) { + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + default: call pargstr ("ERR") + } + if (IP_IMHEADER(ip) == NULL) + call pargstr ("") + else + call pargstr (Memc[IP_IMHEADER(ip)]) + call pargi (IP_VERBOSE(ip)) + call eprintf ("\tpixtype:\n") + do i = 1, IP_NPIXT(ip) { + call eprintf ("\t ") + call zzi_prop (PTYPE(ip,i)) + } + call eprintf ("\toutbands:\n") + do i = 1, IP_NBANDS(IP) { + call eprintf ("\t ") + call zzi_proband (ip, i) + } + call flush (STDERR) +end + + +procedure zzi_proband (ip,band) + +pointer ip +int band + +begin + call eprintf ("ob=%d expr='%s' op->") + call pargi (OBANDS(ip,band)) + call pargstr (O_EXPR(ip,band)) + call zzi_prop (O_OP(ip,band)) +end + + +procedure zzi_prop (o) + +pointer o +char buf[8] +int type, ip_ptype() + +begin + call sprintf (buf, 8, " buirnx") + type = ip_ptype(IO_TYPE(o), IO_NBYTES(o)) + call eprintf ("(o=%d expr='%s' tag='%s' (t='%c' N=%d=>%s) Np=%d %d)\n") + call pargi (o) + call pargstr (Memc[OB_EXPR(o)]) + call pargstr (OP_TAG(o)) + call pargc (buf[IO_TYPE(o)+1]) + call pargi (IO_NBYTES(o)) + switch (type) { + case TY_UBYTE: call pargstr ("TY_UBYTE") + case TY_USHORT: call pargstr ("TY_USHORT") + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + default: call pargstr ("ERR") + } + call pargi (IO_NPIX(o)) + call pargi (IO_DATA(o)) + call flush (STDERR) +end + + +procedure zzi_pevop (o) + +pointer o + +begin + call eprintf ("o=%d type=%d len=%d flags=%d ") + call pargi (o) + call pargi (O_TYPE(o)) + call pargi (O_LEN(o)) + call pargi (O_FLAGS(o)) + switch (O_TYPE(o)) { + case TY_CHAR: + call eprintf ("val='%s'\n") ; call pargstr (O_VALC(o)) + case TY_SHORT: + call eprintf ("val=%d\n") ; call pargs (O_VALS(o)) + case TY_INT: + call eprintf ("val=%d\n") ; call pargi (O_VALI(o)) + case TY_LONG: + call eprintf ("val=%d\n") ; call pargl (O_VALL(o)) + case TY_REAL: + call eprintf ("val=%g\n") ; call pargr (O_VALR(o)) + case TY_DOUBLE: + call eprintf ("val=%g\n") ; call pargd (O_VALD(o)) + default: + call eprintf ("ptr=%d\n") ; call pargi (O_VALP(o)) + } + call flush (STDERR) +end diff --git a/pkg/dataio/imtext/imtext.h b/pkg/dataio/imtext/imtext.h new file mode 100644 index 00000000..76506eda --- /dev/null +++ b/pkg/dataio/imtext/imtext.h @@ -0,0 +1,21 @@ +# Definitions used for conversions between text files and IRAF images. +# Both tasks rtextimage and wtextimage include this file. + +define LEN_WT (2+20+20) + +define IRAFTYPE Memc[P2C($1)] +define FORM Memc[P2C($1+20)] + +define UNSET 0 # Flag for unitialized header values +define INT_FORM 1 # Text file pixels written as integers +define FP_FORM 2 # Text file pixels written as floating point +define CPX_FORM 3 # Text file pixels written as complex + +define COL_VALUE 11 # Starting column for FITS keyword values +define LEN_CARD 80 +define SZ_STRING 20 +define MAX_LENTEXT (2*SZ_LINE) +define NFITS_LINES 10 +define NCARDS_FITS_BLK 36 +define LEN_STRING 18 +define LEN_KEYWORD 8 diff --git a/pkg/dataio/imtext/mkpkg b/pkg/dataio/imtext/mkpkg new file mode 100644 index 00000000..8cabe34c --- /dev/null +++ b/pkg/dataio/imtext/mkpkg @@ -0,0 +1,19 @@ +# The image to text file conversion program WTEXTIMAGE makes the following +# contributions to the dataio package library: + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + putcplx.x <imhdr.h> <mach.h> + putint.x <imhdr.h> <mach.h> <ctype.h> + putreal.x <imhdr.h> <mach.h> + wti_wheader.x imtext.h <imhdr.h> <mach.h> <imio.h> + t_wtextimage.x imtext.h <imhdr.h> <mach.h> <ctype.h> <fset.h> <error.h> + rt_rheader.x imtext.h <imhdr.h> <imio.h> + rt_cvtpix.x imtext.h <imhdr.h> + rt_rwpix.x imtext.h <imhdr.h> <ctype.h> + t_rtextimage.x imtext.h <imhdr.h> <error.h> + ; diff --git a/pkg/dataio/imtext/putcplx.x b/pkg/dataio/imtext/putcplx.x new file mode 100644 index 00000000..df498479 --- /dev/null +++ b/pkg/dataio/imtext/putcplx.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> + +# WTI_PUTCOMPLEX -- Output pixels to a text file in complex floating format. +# Pixels are output in storage order for images of any dimension (leftmost +# subscript varying fastest). We do not bother to implement a different +# datapath for each image pixel datatype because the execution time is +# entirely dominated by the binary to character conversion, and because we +# need type complex pixels for XTOC anyhow. + +procedure wti_putcomplex (im, tx, maxll, decpl, fmtchar, width) + +pointer im # pointer to image file +int tx # file descriptor of output text file +int maxll # maximum length of output text line +int decpl # number of decimal places of precision +int fmtchar # format character (efg) +int width # field width of each number (0=free format) + +char numbuf[MAX_DIGITS] +int npix, ip, j, ndigits, nspaces, maxch +pointer sp, obuf, op, pix, cp +long v[IM_MAXDIM] +int imgnlx(), xtoc() +errchk imgnlx, putline + +begin + call smark (sp) + call salloc (obuf, maxll+1, TY_CHAR) + + call amovkl (long(1), v, IM_MAXDIM) + npix = IM_LEN(im,1) + op = obuf + + while (imgnlx (im, pix, v) != EOF) { + do j = 1, npix { + # Encode the number. + if (width <= 0) + maxch = MAX_DIGITS + else + maxch = width + + ndigits = xtoc (Memx[pix+j-1], numbuf, MAX_DIGITS, + decpl, fmtchar, maxch) + + # Determine the number of spaces needed to right justify the + # field. If the field width is zero the output is free format + # and we always output a single space. + + if (width <= 0) + nspaces = 1 + else + nspaces = width - ndigits + + # Break the output line if insufficient space remains on the + # line. + + if (op-obuf + ndigits + nspaces > maxll) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + op = obuf + } + + # Append sufficient blanks to right justify the number in + # the given field. + do cp = op, op + nspaces - 1 + Memc[cp] = ' ' + op = op + nspaces + + # Append the number to the output line. + do ip = 1, ndigits + Memc[op+ip-1] = numbuf[ip] + op = op + ndigits + } + } + + # Break the last line if there is anything on it. + if (op > obuf) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + } + + call sfree (sp) +end diff --git a/pkg/dataio/imtext/putint.x b/pkg/dataio/imtext/putint.x new file mode 100644 index 00000000..a98d3fb5 --- /dev/null +++ b/pkg/dataio/imtext/putint.x @@ -0,0 +1,160 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include <ctype.h> + +# WTI_PUTINT -- Output pixels to a text file in integer format. Pixels are +# output in storage order for images of any dimension (leftmost subscript +# varying fastest). + +procedure wti_putint (im, tx, maxll, width) + +pointer im # pointer to image file +int tx # file descriptor of output text file +int maxll # maximum length of output text line +int width # field width of each number (0=free format) + +char numbuf[MAX_DIGITS] +int npix, ip, j, ndigits +pointer sp, obuf, op, pix +long v[IM_MAXDIM] +int imgnll(), ltoc() +errchk imgnll, putline + +begin + call smark (sp) + call salloc (obuf, maxll+1, TY_CHAR) + + call amovkl (long(1), v, IM_MAXDIM) + npix = IM_LEN(im,1) + op = obuf + + if (width <= 0) { + # If the encoding is free format call LTOC to encode the number, + # compute the number of spaces required to right justify the + # numeric string in the specified field width, then move the + # spaces and the number into the output line. + + while (imgnll (im, pix, v) != EOF) { + do j = 1, npix { + # Encode the number. + ndigits = ltoc (Meml[pix+j-1], numbuf, MAX_DIGITS) + + # Break output line if insufficient space remains. + if (op-obuf + ndigits + 1 > maxll) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + op = obuf + } + + # Append a blank and the number to the output line. + if (op > obuf) { + Memc[op] = ' ' + op = op + 1 + } + do ip = 1, ndigits + Memc[op+ip-1] = numbuf[ip] + op = op + ndigits + } + } + + } else { + # Fixed format. Encode the integer number from right to left + # in the given field, blank filling at the left. Note that + # fancy formats such as left justify or zero fill are not + # presently supported (and are probably not worth it here). + + while (imgnll (im, pix, v) != EOF) { + do j = 1, npix { + # Break output line if insufficient space remains. + if (op-obuf + width > maxll) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + op = obuf + } + + # Encode the number in the output field. + call wti_encode_l (Meml[pix+j-1], Memc[op], width) + op = op + width + } + } + } + + # Break the last line if there is anything on it. + if (op > obuf) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + } + + call sfree (sp) +end + + +# WTI_ENCODE_L -- Encode a long integer number as a decimal integer, right +# justified with blank fill in the indicated field. Since we know the field +# width in advance we can encode the number from right to left (least +# significant digits first), without having to reverse the digits and copy +# the string as is the case with LTOC. +procedure wti_encode_l (lval, out, w) + +long lval # number to be encoded +char out[w] # output field (NOT EOS DELIMITED) +int w # field width + +bool neg +int op, i +long val, quotient +define overflow_ 91 + +begin + if (IS_INDEFL (lval)) { + if (w < 5) + goto overflow_ + call amovc ("INDEF", out[w-4], 5) + op = w - 5 + + } else { + neg = (lval < 0) + if (neg) + val = -lval + else + val = lval + + # Output digits from right to left. + do i = w, 1, -1 { + quotient = val / 10 + out[i] = TO_DIGIT (val - quotient * 10) + val = quotient + if (val == 0) { + op = i - 1 + break + } + } + + # Add minus sign if negative. + if (neg) { + if (op > 0) + out[op] = '-' + op = op - 1 + } + + # Check for overflow. + if (op < 0 || val > 0) + goto overflow_ + } + + # Blank fill at left. + do i = op, 1, -1 + out[i] = ' ' + + return + +overflow_ + # Number was too large to fit in the given field width. + do i = 1, w + out[i] = '*' +end diff --git a/pkg/dataio/imtext/putreal.x b/pkg/dataio/imtext/putreal.x new file mode 100644 index 00000000..217a45aa --- /dev/null +++ b/pkg/dataio/imtext/putreal.x @@ -0,0 +1,88 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> + +# WTI_PUTREAL -- Output pixels to a text file in a floating point format. +# Pixels are output in storage order for images of any dimension (leftmost +# subscript varying fastest). We do not bother to implement a different +# datapath for each image pixel datatype because the execution time is +# entirely dominated by the binary to character conversion, and because we +# need type double pixels for DTOC anyhow. + +procedure wti_putreal (im, tx, maxll, decpl, fmtchar, width) + +pointer im # pointer to image file +int tx # file descriptor of output text file +int maxll # maximum length of output text line +int decpl # number of decimal places of precision +int fmtchar # type of encoding (efg) +int width # field width of each number (0=free format) + +char numbuf[MAX_DIGITS] +int npix, ip, j, ndigits, nspaces, maxch +pointer sp, obuf, op, pix, cp +long v[IM_MAXDIM] +int imgnld(), dtoc() +errchk imgnld, putline + +begin + call smark (sp) + call salloc (obuf, maxll+1, TY_CHAR) + + call amovkl (long(1), v, IM_MAXDIM) + npix = IM_LEN(im,1) + op = obuf + + while (imgnld (im, pix, v) != EOF) { + do j = 1, npix { + # Encode the number. + if (width <= 0) + maxch = MAX_DIGITS + else + maxch = width + + ndigits = dtoc (Memd[pix+j-1], numbuf, MAX_DIGITS, + decpl, fmtchar, maxch) + + # Determine the number of spaces needed to right justify the + # field. If the field width is zero the output is free format + # and we always output a single space. + + if (width <= 0) + nspaces = 1 + else + nspaces = width - ndigits + + # Break the output line if insufficient space remains on the + # line. + + if (op-obuf + ndigits + nspaces > maxll) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + op = obuf + } + + # Append sufficient blanks to right justify the number in + # the given field. + do cp = op, op + nspaces - 1 + Memc[cp] = ' ' + op = op + nspaces + + # Append the number to the output line. + do ip = 1, ndigits + Memc[op+ip-1] = numbuf[ip] + op = op + ndigits + } + } + + # Break the last line if there is anything on it. + if (op > obuf) { + Memc[op] = '\n' + Memc[op+1] = EOS + call putline (tx, Memc[obuf]) + } + + call sfree (sp) +end diff --git a/pkg/dataio/imtext/rt_cvtpix.x b/pkg/dataio/imtext/rt_cvtpix.x new file mode 100644 index 00000000..170a26d4 --- /dev/null +++ b/pkg/dataio/imtext/rt_cvtpix.x @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "imtext.h" + +# RT_CONVERT_PIXELS -- Called once for each text file to be converted. All +# pixels in the text file are converted to image pixels. + +procedure rt_convert_pixels (tf, im, format, pixels) + +int tf # File descriptor of input text file +pointer im # Pointer to image header +int format # Format of text pixels (integer/floating point) +int pixels # Get pixels from input text file? + +pointer bufptr, sp, word1, pattern +int stat, nlines, npix, i +long v[IM_MAXDIM], start +int impnll(), impnld(), impnlx() +int fscan(), stridxs(), patmatch(), patmake() +long note() + +errchk impnll, impnld, impnlx +errchk rt_get_lineptr, rt_output_line, fscan, seek, amovkl + +begin + # Determine if text file pixels were written with an integer, complex + # or floating point format. This information may have been already + # determined from the header. If not, the first pixel is read + # from text file. If it contains a decimal point, the character E, + # or a + or - sign not in the first position, it is a floating point + # number. Complex numbers are assumed to be written as "(r,i)". + + if (pixels == YES && format == UNSET) { + call smark (sp) + call salloc (word1, SZ_LINE, TY_CHAR) + call salloc (pattern, SZ_LINE, TY_CHAR) + + # Note position so we can return to it + start = note (tf) + + stat = fscan (tf) + call gargwrd (Memc[word1], SZ_LINE) + if (patmake ("[DdEe]", Memc[pattern], SZ_LINE) == ERR) + call error (7, "Error creating format pattern") + + if (stridxs ("(", Memc[word1]) > 0) + format = CPX_FORM + else if (stridxs (".", Memc[word1]) > 0) + format = FP_FORM + else if (patmatch (Memc[word1], Memc[pattern]) > 0) + format = FP_FORM + else if (stridxs ("+", Memc[word1]) > 1) + format = FP_FORM + else if (stridxs ("-", Memc[word1]) > 1) + format = FP_FORM + else + format = INT_FORM + + call sfree (sp) + call seek (tf, start) + } + + # Pixel type may not have been set by this point either... + if (IM_PIXTYPE(im) == UNSET) { + switch (format) { + case FP_FORM: + IM_PIXTYPE(im) = TY_REAL + case INT_FORM: + IM_PIXTYPE(im) = TY_INT + case CPX_FORM: + IM_PIXTYPE(im) = TY_COMPLEX + default: + call error (0, "Unrecognized format type") + } + } + + nlines = 1 + do i = 2, IM_NDIM(im) + nlines = nlines * IM_LEN (im, i) + call amovkl (long(1), v, IM_MAXDIM) + npix = IM_LEN (im, 1) + + # Initialize text buffer + call rt_rinit + + switch (IM_PIXTYPE(im)) { + case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: + do i = 1, nlines { + stat = impnll (im, bufptr, v) + if (pixels == YES) + call rt_output_linel (tf, format, bufptr, npix) + else + call aclrl (Meml[bufptr], npix) + } + case TY_REAL, TY_DOUBLE: + do i = 1, nlines { + stat = impnld (im, bufptr, v) + if (pixels == YES) + call rt_output_lined (tf, format, bufptr, npix) + else + call aclrd (Memd[bufptr], npix) + } + case TY_COMPLEX: + do i = 1, nlines { + stat = impnlx (im, bufptr, v) + if (pixels == YES) + call rt_output_linex (tf, format, bufptr, npix) + else + call aclrx (Memx[bufptr], npix) + } + default: + call error (0, "Image pixel type unset") + } +end diff --git a/pkg/dataio/imtext/rt_rheader.x b/pkg/dataio/imtext/rt_rheader.x new file mode 100644 index 00000000..9c4323bf --- /dev/null +++ b/pkg/dataio/imtext/rt_rheader.x @@ -0,0 +1,170 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include "imtext.h" + +# RT_RHEADER -- read FITS header, saving the image dimension information in +# the image header. The format (integer/floating point) is returned. + +procedure rt_rheader (tf, im, format) + +int tf # File descriptor for input text file +pointer im # Pointer to image header +int format # Format of text file pixels (integer/floating point) + +pointer sp, wt, card +bool streq() +int ncard, fd_user, max_lenuser +int getline(), rt_decode_card(), stridxs(), strlen(), stropen() +errchk getline, rt_decode_card + +begin + call smark (sp) + call salloc (wt, LEN_WT, TY_STRUCT) + call salloc (card, LEN_CARD+1, TY_CHAR) + + Memc[card+LEN_CARD] = '\n' + Memc[card+LEN_CARD+1] = EOS + + # Prepare user area string to be written + max_lenuser = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + fd_user = stropen (Memc[IM_USERAREA(im)], max_lenuser, NEW_FILE) + + ncard = 1 + repeat { + if (getline (tf, Memc[card]) == EOF) + call error (2, "RT_RHEADER: EOF encountered before END card") + + ncard = ncard + 1 + if (rt_decode_card (wt, im, fd_user, Memc[card]) == YES) + break + } + + # Encountered END card; examine a few header keyword values. From + # the FORMAT keyword, determine if the pixel values are written as + # integers, floating point numbers or complex numbers. + + if (strlen (FORM(wt)) > 0) { + if (stridxs ("I", FORM(wt)) > 0) + format = INT_FORM + else if (stridxs ("(", FORM(wt)) > 0) + format = CPX_FORM + else + format = FP_FORM + } else + format = UNSET + + # The image pixel type is set by the IRAFTYPE keyword value. + + if (streq (IRAFTYPE(wt), "SHORT INTEGER")) + IM_PIXTYPE (im) = TY_SHORT + else if (streq (IRAFTYPE(wt), "UNSIGNED SHORT INT")) + IM_PIXTYPE (im) = TY_USHORT + else if (streq (IRAFTYPE(wt), "INTEGER")) + IM_PIXTYPE (im) = TY_INT + else if (streq (IRAFTYPE(wt), "LONG INTEGER")) + IM_PIXTYPE (im) = TY_LONG + else if (streq (IRAFTYPE(wt), "REAL FLOATING")) + IM_PIXTYPE (im) = TY_REAL + else if (streq (IRAFTYPE(wt), "DOUBLE FLOATING")) + IM_PIXTYPE (im) = TY_DOUBLE + else if (streq (IRAFTYPE(wt), "COMPLEX")) + IM_PIXTYPE (im) = TY_COMPLEX + + call close (fd_user) + call sfree (sp) +end + + +# RT_DECODE_CARD -- Decode a FITS format card and return YES when the END +# card is encountered. The decoded value is stored in the image header, +# or in the user area if there is no other place for it. The END card is +# tested only to the first three characters; strictly speaking the END +# card begins with the 8 characters "END ". + +int procedure rt_decode_card (wt, im, fd, card) + +pointer wt # Pointer to wtextimage keyword structure +pointer im # Pointer to image header being written +int fd # File descriptor of user area +char card[ARB] # Card image read from FITS header + +int nchar, ival, i, j, k, ndim + +int strmatch(), ctoi() +errchk rt_get_fits_string, putline, putline + +begin + + i = COL_VALUE + if (strmatch (card, "^END") > 0) + return (YES) + + else if (strmatch (card, "^NAXIS ") > 0) { + nchar = ctoi (card, i, ndim) + if (ndim > 0) + IM_NDIM(im) = ndim + + } else if (strmatch (card, "^NAXIS") > 0) { + k = strmatch (card, "^NAXIS") + nchar = ctoi (card, k, j) + nchar = ctoi (card, i, IM_LEN(im,j)) + + } else if (strmatch (card, "^NDIM ") > 0) + nchar = ctoi (card, i, IM_NDIM(im)) + + else if (strmatch (card, "^LEN") > 0) { + k = strmatch (card, "^LEN") + nchar = ctoi (card, k, j) + nchar = ctoi (card, i, IM_LEN(im,j)) + + } else if (strmatch (card, "^BITPIX ") > 0) { + nchar = ctoi (card, i, ival) + if (ival != 8) + call error (6, "Not 8-bit ASCII characters") + + } else if (strmatch (card, "^FORMAT ") > 0) { + call rt_get_fits_string (card, FORM(wt), SZ_STRING) + } else if (strmatch (card, "^IRAFTYPE") > 0) { + call rt_get_fits_string (card, IRAFTYPE(wt), SZ_STRING) + } else if (strmatch (card, "^OBJECT ") > 0) { + call rt_get_fits_string (card, IM_TITLE(im), SZ_IMTITLE) + } else { + # Putline returns an error if there is no room in the user area + iferr (call putline (fd, card)) { + call eprintf ("Space in user area has been exceeded\n") + return (YES) + } + } + + return (NO) +end + + +# RT_GET_FITS_STRING -- Extract a string from a FITS card and trim trailing +# blanks. The EOS is marked by either ', /, or the end of the card. +# There may be an optional opening ' (FITS standard). + +procedure rt_get_fits_string (card, str, maxchar) + +char card[ARB] # Input card image containing keyword and value +char str[maxchar] # Output string +int maxchar # Maximum number of characters output +int j, istart, nchar + +begin + # Check for opening quote + if (card[COL_VALUE] == '\'') + istart = COL_VALUE + 1 + else + istart = COL_VALUE + + for (j=istart; (j < LEN_CARD) && (card[j] != '\''); j=j+1) + ; + for (j=j-1; (j >= istart) && (card[j] == ' '); j=j-1) + ; + + nchar = min (maxchar, j - istart + 1) + call strcpy (card[istart], str, nchar) +end diff --git a/pkg/dataio/imtext/rt_rwpix.x b/pkg/dataio/imtext/rt_rwpix.x new file mode 100644 index 00000000..a3ba26bf --- /dev/null +++ b/pkg/dataio/imtext/rt_rwpix.x @@ -0,0 +1,271 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <ctype.h> +include "imtext.h" + +# RT_RINIT -- Initialize buffer and buffer pointer for reading text. + +procedure rt_rinit () + +int ip +char text_buf[SZ_LINE] +common /rpix_init/ ip, text_buf + +begin + ip = 1 + text_buf[1] = EOS +end + + +# RT_OUTPUT_LINEL -- Put line of long pixels to image from text file. + +procedure rt_output_linel (tf, format, bufptr, npix) + +int tf # File descriptor for input text file +int format # Format of pixels in text file (integer/ floating) +pointer bufptr # Pointer to image line to be filled +int npix # Number of pixels per image line + +pointer sp, dbl_buf, cplx_buf +errchk rt_ripixels, rt_rfpixels, rt_rcpixels + +begin + call smark (sp) + + switch (format) { + case INT_FORM: + call salloc (dbl_buf, npix, TY_DOUBLE) + call rt_ripixels (tf, Memd[dbl_buf], npix) + call achtdl (Memd[dbl_buf], Meml[bufptr], npix) + case FP_FORM: + call salloc (dbl_buf, npix, TY_DOUBLE) + call rt_rfpixels (tf, Memd[dbl_buf], npix) + call achtdl (Memd[dbl_buf], Meml[bufptr], npix) + case CPX_FORM: + call salloc (cplx_buf, npix, TY_COMPLEX) + call rt_rcpixels (tf, Memx[cplx_buf], npix) + call achtxl (Memx[cplx_buf], Meml[bufptr], npix) + } + + call sfree (sp) +end + + +# RT_OUTPUT_LINED -- Put line of double pixels to image from text file. + +procedure rt_output_lined (tf, format, bufptr, npix) + +int tf # File descriptor for input text file +int format # Format of pixels in text file (integer/ floating) +pointer bufptr # Pointer to image line to be filled +int npix # Number of pixels per image line + +pointer sp, cplx_buf +errchk rt_ripixels, rt_rfpixels, rt_rcpixels + +begin + call smark (sp) + + switch (format) { + case INT_FORM: + call rt_ripixels (tf, Memd[bufptr], npix) + case FP_FORM: + call rt_rfpixels (tf, Memd[bufptr], npix) + case CPX_FORM: + call salloc (cplx_buf, npix, TY_COMPLEX) + call rt_rcpixels (tf, Memx[cplx_buf], npix) + call achtxd (Memx[cplx_buf], Memd[bufptr], npix) + } + + call sfree (sp) +end + + +# RT_OUTPUT_LINEX -- Put line of complex pixels to image from text file. + +procedure rt_output_linex (tf, format, bufptr, npix) + +int tf # File descriptor for input text file +int format # Format of pixels in text file (integer/ floating) +pointer bufptr # Pointer to image line to be filled +int npix # Number of pixels per image line + +pointer sp, dbl_buf +errchk rt_ripixels, rt_rfpixels, rt_rcpixels + +begin + call smark (sp) + + switch (format) { + case INT_FORM: + call salloc (dbl_buf, npix, TY_DOUBLE) + call rt_ripixels (tf, Memd[dbl_buf], npix) + call achtdx (Memd[dbl_buf], Memx[bufptr], npix) + case FP_FORM: + call salloc (dbl_buf, npix, TY_DOUBLE) + call rt_rfpixels (tf, Memd[dbl_buf], npix) + call achtdx (Memd[dbl_buf], Memx[bufptr], npix) + case CPX_FORM: + call rt_rcpixels (tf, Memx[bufptr], npix) + } + + call sfree (sp) +end + + +# RT_RIPIXELS -- read integer pixels free format from text file into a +# type double real buffer. + +procedure rt_ripixels (tf, dbl_out, npix) + +int tf # File descriptor for input text file +double dbl_out[ARB] # Output pixel array +int npix # Number of pixels to output + +bool neg +int i, sum, ip_start, ip +char text_buf[SZ_LINE] +common /rpix_init/ ip, text_buf +int getline() +errchk getline + +begin + # Read values until satisfied + for (i=0; i < npix; ) { + sum = 0 + + # Position to first non white space character + while (IS_WHITE (text_buf[ip])) + ip = ip + 1 + ip_start = ip + + neg = (text_buf[ip] == '-') + if (neg) + ip = ip + 1 + + while (IS_DIGIT (text_buf[ip])) { + sum = sum * 10 + TO_INTEG (text_buf[ip]) + ip = ip + 1 + } + + if (ip == ip_start) { + if (getline (tf, text_buf) == EOF) { + call eprintf ("Premature EOF seen by rt_ripixels\n") + break + } + ip = 1 + + } else { + i = i + 1 + if (neg) + dbl_out[i] = double (-sum) + else + dbl_out[i] = double ( sum) + } + } +end + + +# RT_RFPIXELS -- read floating point pixels free format from text file into a +# double floating point buffer. + +procedure rt_rfpixels (tf, dbl_out, npix) + +int tf # File descriptor for text file +double dbl_out[npix] # Output pixel buffer +int npix # Number of pixels to output + +int i, nchars +double dval +int gctod(), getline() + +int ip +char text_buf[SZ_LINE] +common /rpix_init/ ip, text_buf +errchk gctod, getline + +begin + # Read values until satisfied + for (i=0; i < npix; ) { + nchars = gctod (text_buf, ip, dval) + + if (nchars == 0) { + if (getline (tf, text_buf) == EOF) { + call eprintf ("Premature EOF seen in rt_rfpixels\n") + break + } + ip = 1 + + } else { + i = i + 1 + dbl_out[i] = dval + } + } +end + + +# RT_RCPIXELS -- read complex pixels free format from text file into a +# complex floating point buffer. + +procedure rt_rcpixels (tf, cplx_out, npix) + +int tf # File descriptor for text file +complex cplx_out[npix] # Output pixel buffer +int npix # Number of pixels to output + +int i, nchars +complex xval +int gctox(), getline() + +int ip +char text_buf[SZ_LINE] +common /rpix_init/ ip, text_buf +errchk gctox, getline + +begin + # Read values until satisfied + for (i=0; i < npix; ) { + nchars = gctox (text_buf, ip, xval) + + if (nchars == 0) { + if (getline (tf, text_buf) == EOF) { + call eprintf ("Premature EOF seen in rt_rcpixels\n") + break + } + ip = 1 + + } else { + i = i + 1 + cplx_out[i] = xval + } + } +end + + +# RT_SKIP_LINES -- Skip lines of text file. + +int procedure rt_skip_lines (tf, nskip) + +int tf # File descriptor of text file +int nskip # Number of lines to skip + +pointer sp, buffer +int i +int fscan() + +begin + call smark (sp) + call salloc (buffer, SZ_LINE, TY_CHAR) + + for (i = 1; i <= nskip; i = i + 1) { + if (fscan (tf) == EOF) { + call sfree (sp) + return (EOF) + } else + call gargstr (Memc[buffer], SZ_LINE) + } + + call sfree (sp) + return (OK) +end diff --git a/pkg/dataio/imtext/t_rtextimage.x b/pkg/dataio/imtext/t_rtextimage.x new file mode 100644 index 00000000..603e9134 --- /dev/null +++ b/pkg/dataio/imtext/t_rtextimage.x @@ -0,0 +1,109 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <error.h> +include "imtext.h" + +# T_RTEXTIMAGE -- Read text files into IRAF images. Information +# about the dimensionality of the image (the number of dimensions and the +# length of each dimension) must either be read from a FITS header or supplied +# by the user. + +procedure t_rtextimage () + +char output[SZ_FNAME], text_file[SZ_FNAME], temp[SZ_FNAME] +char out_fname[SZ_FNAME] +pointer im +int header, pixels, nskip, nfiles, ntext, format, data_type, tf, i, input +int fd_dim, junk, ndim, ip + +bool clgetb() +#char clgetc() +pointer immap() +int btoi(), clgeti(), clpopni(), clplen(), clgfil(), get_data_type() +int open(), rt_skip_lines(), clpopnu(), ctoi() + +begin + # Determine the input and output file names + input = clpopni ("input") + call clgstr ("output", output, SZ_FNAME) + + # Get hidden parameters from cl. + # data_type = get_data_type (clgetc ("otype")) + call clgstr ("otype", out_fname, SZ_FNAME) + data_type = get_data_type (out_fname[1]) + header = btoi (clgetb ("header")) + pixels = btoi (clgetb ("pixels")) + if (header == NO) + nskip = clgeti ("nskip") + + # Loop over the input files, generating an output name and processing. + nfiles = clplen (input) + do ntext = 1, nfiles { + if (clgfil (input, text_file, SZ_FNAME) == EOF) + return + tf = open (text_file, READ_ONLY, TEXT_FILE) + if (nfiles > 1) { + call sprintf (out_fname, SZ_FNAME, "%s.%03d") + call pargstr (output) + call pargi (ntext) + } else + call strcpy (output, out_fname, SZ_FNAME) + + im = immap (out_fname, NEW_IMAGE, 0) + + # Initialize those values that could be read from the header. + format = UNSET + IM_NDIM(im) = UNSET + IM_PIXTYPE(im) = UNSET + + if (header == YES) { + iferr (call rt_rheader (tf, im, format)) + call erract (EA_FATAL) + } else if (nskip > 0) { + if (rt_skip_lines (tf, nskip) == EOF) + call error (1, "Unexpected EOF when skipping lines") + } + + # Get data_type of output image. If supplied by user, use parameter + # value over anything read from FITS header. + + if (IM_PIXTYPE(im) == UNSET) { + # Not read from header, use parameter value if supplied. + # Otherwise, wait until pixels are read to set pixel type. + if (data_type == ERR) + IM_PIXTYPE(im) = UNSET + else + IM_PIXTYPE(im) = data_type + } else if (data_type != ERR) + # Available in header, but user has specified value to be used + IM_PIXTYPE(im) = data_type + + # If image dimension information wasn't read from header, the user + # must supply it. + + if (IM_NDIM(im) == UNSET) { + fd_dim = clpopnu ("dim") + ndim = clplen (fd_dim) + do i = 1, ndim { + junk = clgfil (fd_dim, temp, SZ_FNAME) + ip = 1 + junk = ctoi (temp, ip, IM_LEN (im, i)) + } + IM_NDIM(im) = ndim + call clpcls (fd_dim) + } + + # Convert text pixels to image pixels, posting only a warning + # message if an error occurs. Processing continues to the next + # file in the input list. + + iferr (call rt_convert_pixels (tf, im, format, pixels)) + call erract (EA_WARN) + + call imunmap (im) + call close (tf) + } + + call clpcls (input) +end diff --git a/pkg/dataio/imtext/t_wtextimage.x b/pkg/dataio/imtext/t_wtextimage.x new file mode 100644 index 00000000..8860f3d6 --- /dev/null +++ b/pkg/dataio/imtext/t_wtextimage.x @@ -0,0 +1,261 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <ctype.h> +include <fset.h> +include <error.h> +include <mach.h> +include <imhdr.h> +include "imtext.h" + +define SZ_FORMAT 20 + + +# WTEXTIMAGE -- Write a text file from an IRAF image. Image header information +# is written in the "keyword = value / comment" format of FITS. Pixel values +# follow the header. The resulting text file can be read as a FITS image. The +# header cards include "NAXIS = 0", indicating no binary data matrix is written. +# The encoded pixel values can be read as special records following the null +# data matrix. + +procedure t_wtextimage () + +bool header +bool pixels +pointer im +char output[SZ_FNAME], format[SZ_FORMAT], imlist[SZ_LINE] +char image[SZ_FNAME], out_fname[SZ_FNAME] +int maxll, file_num, out, input, nfiles + +pointer immap() +bool clgetb(), strne() +int clgeti(), imtgetim(), open(), imtopen(), fstati(), imtlen() + +begin + # Open template of input image filenames. + call clgstr ("input", imlist, SZ_LINE) + input = imtopen (imlist) + nfiles = imtlen (input) + + # See if STDOUT has been redirected and get output filename. + if (fstati (STDOUT, F_REDIR) == YES) { + # Output has been redirected, set output filename to STDOUT + call strcpy ("STDOUT", output, SZ_FNAME) + } else { + # Get output filename from cl + call clgstr ("output", output, SZ_FNAME) + } + + # Get other parameters from cl. + header = clgetb ("header") + pixels = clgetb ("pixels") + maxll = min (MAX_LENTEXT, clgeti ("maxlinelen")) + if (maxll <= 0) + call error (1, "Illegal maximum line length: must be > 0") + + call clgstr ("format", format, SZ_FORMAT) + call strlwr (format) + + file_num = 0 + + while (imtgetim (input, image, SZ_FNAME) != EOF) { + file_num = file_num + 1 + + # Open image. + iferr (im = immap (image, READ_ONLY, 0)) { + call erract (EA_WARN) + next + } + + if (nfiles > 1 && strne (output, "STDOUT")) { + # Generate unique output file name + call sprintf (out_fname, SZ_FNAME, "%s.%03d") + call pargstr (output) + call pargi (file_num) + } else + call strcpy (output, out_fname, SZ_FNAME) + + # Open output file. + iferr (out = open (out_fname, APPEND, TEXT_FILE)) { + call imunmap (im) + call erract (EA_WARN) + next + } + + iferr (call wti_convert_image (im,image,out,header,pixels, + maxll,format)) + call erract (EA_WARN) + + call imunmap (im) + call close (out) + } + + call imtclose (input) +end + + +# WTI_CONVERT_IMAGE -- called once for each image to be converted. This +# procedure determines the output pixel format and then directs the processing +# depending on user request. + +procedure wti_convert_image (im, image, out, header, pixels, maxll, user_format) + +pointer im # input image +char image[ARB] # image name +int out # output text file descriptor +bool header # convert header information (y/n)? +bool pixels # convert pixels (y/n)? +int maxll # maximum line length of text file +char user_format[ARB] # output format for single pixel entered by user + +int width, decpl, fmtchar +pointer sp, out_format, ftn_format, spp_format, ep +errchk wti_determine_fmt, wti_write_header +errchk wti_putint, wti_putreal, wti_putcomplex + +begin + call smark (sp) + call salloc (out_format, SZ_FORMAT, TY_CHAR) + call salloc (spp_format, SZ_FORMAT, TY_CHAR) + call salloc (ftn_format, SZ_FORMAT, TY_CHAR) + call salloc (ep, SZ_LINE, TY_CHAR) + + # Clear the format variables. + call aclrc (Memc[out_format], SZ_FORMAT) + call aclrc (Memc[spp_format], SZ_FORMAT) + call aclrc (Memc[ftn_format], SZ_FORMAT) + call aclrc (Memc[ep], SZ_LINE) + fmtchar = ' ' + + # Determine the output format. + + if (user_format[1] == EOS) { + # Format has not been set by user. Set appropriate defaults. + switch (IM_PIXTYPE(im)) { + case TY_USHORT: + call strcpy ("6d", Memc[spp_format], SZ_FORMAT) + case TY_SHORT: + call strcpy ("7d", Memc[spp_format], SZ_FORMAT) + case TY_INT: + call strcpy ("12d", Memc[spp_format], SZ_FORMAT) + case TY_LONG: + call strcpy ("12d", Memc[spp_format], SZ_FORMAT) + case TY_REAL: + call strcpy ("14.7g", Memc[spp_format], SZ_FORMAT) + case TY_DOUBLE: + call strcpy ("22.15g", Memc[spp_format], SZ_FORMAT) + case TY_COMPLEX: + call strcpy ("21.7z", Memc[spp_format], SZ_FORMAT) + } + } else + call strcpy (user_format, Memc[spp_format], SZ_FORMAT) + + call wti_determine_fmt (Memc[spp_format], Memc[ftn_format], + decpl, fmtchar, width) + + # Write the header. + if (header) { + if (width > 0) { + if ((maxll / width) < 1) { + call sprintf (Memc[ep], SZ_LINE, + "%s: output maxlinelen=%d is too short for format %s") + call pargstr (image) + call pargi (maxll) + call pargstr (Memc[ftn_format]) + call error (2, Memc[ep]) + } + + call sprintf (Memc[out_format], SZ_FORMAT, "%d%s") + call pargi (maxll / width) + call pargstr (Memc[ftn_format]) + } else + call strcpy ("*", Memc[out_format], SZ_FORMAT) + + call wti_write_header (im, image, out, Memc[out_format]) + } + + # Write out the pixels in text form. + if (pixels) { + switch (fmtchar) { + case 'd': + call wti_putint (im, out, maxll, width) + case 'e', 'f', 'g': + call wti_putreal (im, out, maxll, decpl, fmtchar, width) + case 'z': + call wti_putcomplex (im, out, maxll, decpl, 'e', width) + } + } + + call sfree (sp) +end + + +# WTI_DETERMINE_FMT -- Extract field width from input format string and +# generate a fortran format equivalent to the input spp format. The input +# format may be either a Fortran sytle format or an SPP format. + +procedure wti_determine_fmt (spp_format, ftn_format, decpl, fmtchar, width) + +char spp_format[ARB] # SPP format of each pixel +char ftn_format[ARB] # equivalent Fortran format (output) +int decpl # number of decimal places of precision (output) +int fmtchar # format character (output) +int width # field width (output) + +int ip +bool fortran_format +int ctoi() + +begin + # Parse either an SPP format "W.Dc" or a Fortran format "cW.D" to + # determine the field width, number of decimal places or precision, + # and the format char. If the field width is missing or zero we set + # width=0 to flag that free format output is desired. + + for (ip=1; IS_WHITE (spp_format[ip]); ip=ip+1) + ; + fortran_format = IS_ALPHA (spp_format[ip]) + if (fortran_format) { + if (spp_format[ip] == 'i') + fmtchar = 'd' + ip = ip + 1 + } + + # Extract W and D fields. + if (ctoi (spp_format, ip, width) == 0) + width = 0 + if (spp_format[ip] == '.') { + ip = ip + 1 + if (ctoi (spp_format, ip, decpl) == 0) + decpl = 0 + } else + decpl = 0 + + if (!fortran_format && spp_format[ip] != EOS) { + fmtchar = spp_format[ip] + ip = ip + 1 + } + + if (spp_format[ip] != EOS) + call error (3, "unacceptable numeric format") + + # Construct the FTN version of the spp_format. This will be + # output in the header. + + switch (fmtchar) { + case 'd': + call sprintf (ftn_format, SZ_FORMAT, "I%d") + call pargi (width) + case 'e', 'f', 'g': + call sprintf (ftn_format, SZ_FORMAT, "%c%d.%d") + call pargi (TO_UPPER (fmtchar)) + call pargi (width) + call pargi (decpl) + case 'z': + # Tell Fortran to use a list directed read to read complex data. + call strcpy ("*", ftn_format, SZ_FORMAT) + width = 0 + + default: + call error (4, "Improper format. Must be chosen from [defgz].") + } +end diff --git a/pkg/dataio/imtext/wtextimage.semi b/pkg/dataio/imtext/wtextimage.semi new file mode 100644 index 00000000..4574722a --- /dev/null +++ b/pkg/dataio/imtext/wtextimage.semi @@ -0,0 +1,91 @@ +# Semicode for the IRAF image to text file converter. + +procedure t_wtextimage (input, output) + +begin + input = expand template of input image file names + if (output hasn't been redirected) + get name of output file from cl + + # Get hidden parameters from cl + header = is header to be written? + maxlinelen = max number of characters per line of text + if (format not user specified) + format = NOT_SET + + for (each file name in input) { + im = open image file + generate output file name + text = open text file + call convert_image (im, text, header, maxlinelen, format) + close image file + close text file + } +end + + +# CONVERT_IMAGE -- called once for each image to be converted. Directs +# the processing depending on user request. + +procedure convert_image (im, text, header, maxlinelen, format) + +begin + if (format = NOT_SET) + format = appropriate value for data type of image + + # Calculate number of pixels per line of text + npix_line = maxlinelen / (field width of pixel output format) + output_format = "npix_line.pixel_format" + + if (header is to be written) + call write_header (im, text, output_format, maxlinelen) + + call convert_pixels (im, text, output_format) +end + + +# WRITE_HEADER -- write information from IRAF image header in +# "keyword = value" format, one keyword per line of text. + +procedure convert_header (image, text, output_format, maxlinelen) + +begin + # Write header information to text file + SIMPLE = T + BITPIX = 8 + NAXIS = 0 + ORIGIN = NOAO + IRAF-MAX= IM_MAX + IRAF-MIN= IM_MIN + IRAF-B/P= + IRAFTYPE= + OBJECT = IM_TITLE + NDIM = IM_NDIM + LEN1 = IM_LEN(1) + FILENAME= IM_HDRFILE + FORMAT = output_format + + # Write any information stored in image user area + if (user area contains information) { + COMMENT = "Copying user area" + KEYWORD = copy user area to text file + } + + # Final header line is END + END = last line of header + + Pad with blank lines until multiple of 36 lines is output +end + + +# CONVERT_IMAGE -- write pixel values from IRAF image into text file. The +# pixels are output in "leftmost subscript varying most rapidly" order. + +procedure convert_image (image, text, format) + +begin + get next line of image + for each pixel in line + convert pixel to character + put out line to text file according to format +end diff --git a/pkg/dataio/imtext/wti_wheader.x b/pkg/dataio/imtext/wti_wheader.x new file mode 100644 index 00000000..2cad585d --- /dev/null +++ b/pkg/dataio/imtext/wti_wheader.x @@ -0,0 +1,152 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imio.h> +include <mach.h> +include "imtext.h" + +define NBITS_ASCII 8 +define NDEC_PLACES 7 + + +# WTI_WRITE_HEADER -- write information from IRAF image header to text file in +# FITS "keyword = value / comment" format. One keyword is written per line +# of text. + +procedure wti_write_header (im, image, tx, out_format) + +pointer im # Pointer to image file +char image[ARB] # Image filename +int tx # File descriptor of text file +char out_format[ARB] # Output format for pixel conversion + +int i, nlines, user, op, max_lenuser +pointer sp, root, line, comment +bool streq() +int strlen(), sizeof(), getline(), stropen(), gstrcpy(), stridx() + +errchk addcard_b, addcard_i, addcard_r, addcard_st +errchk wti_iraf_type, streq, strupr, stropen, strclose, getline + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (comment, SZ_LINE, TY_CHAR) + + call addcard_i (tx, "BITPIX", NBITS_ASCII, "8-bit ASCII characters") + call addcard_i (tx, "NAXIS", IM_NDIM(im), "Number of Image Dimensions") + + nlines = NFITS_LINES + + # Construct and output an NAXISn card for each axis + do i = 1, IM_NDIM(im) { + op = gstrcpy ("NAXIS", Memc[root], LEN_KEYWORD) + call sprintf (Memc[root+op], LEN_KEYWORD-op, "%d") + call pargi (i) + call addcard_i (tx, Memc[root], IM_LEN(im,i), "Length of axis") + nlines = nlines + 1 + } + + call addcard_st (tx, "ORIGIN", "NOAO-IRAF: WTEXTIMAGE", "", + strlen("NOAO-IRAF: WTEXTIMAGE")) + + # Add the image MIN and MAX header cards + call strcpy ("Max image pixel", Memc[comment], SZ_LINE) + if (IM_MTIME(im) > IM_LIMTIME(im)) + call strcat (" (out of date)", Memc[comment], SZ_LINE) + call addcard_r (tx, "IRAF-MAX", IM_MAX(im), Memc[comment], + NDEC_PLACES) + + call strcpy ("Min image pixel", Memc[comment], SZ_LINE) + if (IM_MTIME(im) > IM_LIMTIME(im)) + call strcat (" (out of date)", Memc[comment], SZ_LINE) + call addcard_r (tx, "IRAF-MIN", IM_MIN(im), Memc[comment], + NDEC_PLACES) + + # The number of bits per pixel is calculated and output + call addcard_i (tx, "IRAF-B/P", sizeof (IM_PIXTYPE(im)) * + SZB_CHAR * NBITS_BYTE, "Image bits per pixel") + + call wti_iraf_type (IM_PIXTYPE(im), Memc[root]) + call addcard_st (tx, "IRAFTYPE", Memc[root], "Image datatype", + strlen(Memc[root])) + + call strupr (IM_TITLE(im)) + call addcard_st (tx, "OBJECT" , IM_TITLE(im), "", + strlen (IM_TITLE(im))) + + call strupr (image) + call addcard_st (tx, "FILENAME", image, "IRAF filename", + strlen (image)) + nlines = nlines + 1 + + call strcpy ("Text line format", Memc[comment], SZ_LINE) + if (streq (out_format, "*")) + call strcat (" (* = list directed)", Memc[comment], SZ_LINE) + call addcard_st (tx, "FORMAT", out_format, Memc[comment], + LEN_STRING) + nlines = nlines + 1 + + # Write any information stored in image user area + if ((IM_HDRLEN(im) - LEN_IMHDR) > 0) { + max_lenuser = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + user = stropen (Memc[IM_USERAREA(im)], max_lenuser, READ_ONLY) + + while (getline (user, Memc[line]) != EOF) { + call putline (tx, Memc[line]) + nlines = nlines + 1 + } + + # Make sure last line written out included a newline. It won't if + # the user area was truncated when it was read. + if (stridx ("\n", Memc[line]) == 0) + call putline (tx, "\n") + + call close (user) + } + + # Final header line is END (FITS keywords are 8 characters long) + call fprintf (tx, "END%77w\n") + nlines = nlines + 1 + + # Pad output file with blank lines until header block occupies + # a multiple of 36 lines. + + if (nlines != NCARDS_FITS_BLK) { + do i = 1, NCARDS_FITS_BLK - mod(nlines, NCARDS_FITS_BLK) + call fprintf (tx, "%80w\n") + } + + call sfree (sp) +end + + +# WTI_IRAF_TYPE -- Procedure to set the iraf datatype keyword. Permitted strings +# are INTEGER, FLOATING or COMPLEX. + +procedure wti_iraf_type (datatype, type_str) + +int datatype # the IRAF data type +char type_str[ARB] # the output IRAF type string + +begin + switch (datatype) { + case TY_SHORT: + call strcpy ("SHORT INTEGER", type_str, LEN_STRING) + case TY_USHORT: + call strcpy ("UNSIGNED SHORT INT", type_str, LEN_STRING) + case TY_INT: + call strcpy ("INTEGER", type_str, LEN_STRING) + case TY_LONG: + call strcpy ("LONG INTEGER", type_str, LEN_STRING) + case TY_REAL: + call strcpy ("REAL FLOATING", type_str, LEN_STRING) + case TY_DOUBLE: + call strcpy ("DOUBLE FLOATING", type_str, LEN_STRING) + case TY_COMPLEX: + call strcpy ("COMPLEX", type_str, LEN_STRING) + default: + call error (4, "IRAF_TYPE: Unknown IRAF image type.") + } +end diff --git a/pkg/dataio/lib/addcards.x b/pkg/dataio/lib/addcards.x new file mode 100644 index 00000000..42699380 --- /dev/null +++ b/pkg/dataio/lib/addcards.x @@ -0,0 +1,140 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define MAXLEN_STRVAL 65 +define LEN_KEYWORD 8 +define LEN_STRING 18 + +# ADDCARD_R -- Format and append a FITS header card with a real +# keyword value to the input string buffer. + +procedure addcard_r (fd, keyword, value, comment, precision) + +int fd # File descriptor of input string buffer +char keyword[LEN_KEYWORD] # FITS keyword +real value # Value of FITS keyword +char comment[ARB] # Comment string +int precision # Number of decimal places output + + +begin + call fprintf (fd, "%-8.8s= %20.*g / %-45.45s\n") + call pargstr (keyword) + call pargi (precision) + call pargr (value) + call pargstr (comment) +end + + +# ADDCARD_I -- Format and append a FITS header card with an integer +# keyword value to the input string buffer. + +procedure addcard_i (fd, keyword, value, comment) + +int fd # File descriptor of input string buffer +char keyword[LEN_KEYWORD] # FITS keyword +int value # Value of FITS keyword +char comment[ARB] # Comment string + +begin + call fprintf (fd, "%-8.8s= %20d / %-45.45s\n") + call pargstr (keyword) + call pargi (value) + call pargstr (comment) +end + + +# ADDCARD_TIME -- Format and append a FITS header card to the input +# file descriptor. The value is input as a real number; it is output +# in HH:MM:SS.S format with %h. The procedure can be used for RA, DEC +# and ST, UT and HA. + +procedure addcard_time (fd, keyword, value, comment) + +int fd # File descriptor +char keyword[LEN_KEYWORD] # FITS keyword +real value # Value of FITS keyword to be encoded +char comment[ARB] # Comment string + + +begin + call fprintf (fd, "%-8.8s= '%-18.1h' / %-45s\n") + call pargstr (keyword) + call pargr (value) + call pargstr (comment) +end + + +# ADDCARD_ST -- Format and output a FITS header card to the input +# file descriptor. The value is output as a string with the given keyword. +# If the string value is longer than 18 characters, it is output without +# a comment. + +procedure addcard_st (fd, keyword, value, comment, length) + +int fd # File descriptor +char keyword[LEN_KEYWORD] # FITS keyword +char value[SZ_LINE] # String value of FITS keyword to be encoded +char comment[ARB] # Comment string +int length # Length of string value + +begin + if (length <= LEN_STRING) { + call fprintf (fd, "%-8.8s= '%-18.18s' / %-44s\n") + call pargstr (keyword) + call pargstr (value) + call pargstr (comment) + } else { + length = min (length, MAXLEN_STRVAL) + call fprintf (fd, "%-8.8s= '%*.*s' /\n") + call pargstr (keyword) + call pargi (-length) + call pargi (length) + call pargstr (value) + } +end + + +# ADDCARD_B -- Format and output a FITS header card to the input file +# descriptor. The value is output as a boolean with the given keyword. +# Unlike string parameters, booleans are not enclosed in quotes. + +procedure addcard_b (fd, keyword, value, comment) + +int fd # File descriptor +char keyword[LEN_KEYWORD] # FITS keyword +bool value # Boolean parameter (T/F) +char comment[ARB] # Comment string +char truth + +begin + if (value) + truth = 'T' + else + truth = 'F' + + call fprintf (fd, "%-8.8s= %20c / %-45.45s\n") + call pargstr (keyword) + call pargc (truth) + call pargstr (comment) +end + + +# ADDCARD_D -- Format and append a FITS header card with a double +# keyword value to the input string buffer. + +procedure addcard_d (fd, keyword, value, comment, precision) + +int fd # File descriptor of input string buffer +char keyword[LEN_KEYWORD] # FITS keyword +double value # Value of FITS keyword +char comment[ARB] # Comment string +int precision # Number of decimal places output + + +begin + call fprintf (fd, "%-8.8s= %20.*f / %-45.45s\n") + call pargstr (keyword) + call pargi (precision) + call pargd (value) + call pargstr (comment) +end diff --git a/pkg/dataio/lib/getdatatype.x b/pkg/dataio/lib/getdatatype.x new file mode 100644 index 00000000..9502e82f --- /dev/null +++ b/pkg/dataio/lib/getdatatype.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define NTYPES 9 + +# GETDATATYPE -- Convert a character to an IRAF data type + +int procedure getdatatype (ch) + +char ch +int i, type_code[NTYPES] +int stridx() + +string types "bcusilrdx" # Supported data types +data type_code /TY_UBYTE, TY_CHAR, TY_USHORT, TY_SHORT, TY_INT, TY_LONG, + TY_REAL, TY_DOUBLE, TY_COMPLEX/ + +begin + i = stridx (ch, types) + if (i == 0) + return (ERR) + else + return (type_code[stridx(ch,types)]) +end + + +# DTSTRING -- Convert a datatype to a string + +procedure dtstring (datatype, str, maxchar) + +int datatype # IRAF datatype +char str[maxchar] # Output string +int maxchar # Maximum characters in string + +begin + switch (datatype) { + case TY_UBYTE: + call strcpy ("unsigned byte", str, maxchar) + case TY_CHAR: + call strcpy ("character", str, maxchar) + case TY_USHORT: + call strcpy ("unsigned short", str, maxchar) + case TY_SHORT: + call strcpy ("short", str, maxchar) + case TY_INT: + call strcpy ("integer", str, maxchar) + case TY_LONG: + call strcpy ("long", str, maxchar) + case TY_REAL: + call strcpy ("real", str, maxchar) + case TY_DOUBLE: + call strcpy ("double", str, maxchar) + case TY_COMPLEX: + call strcpy ("complex", str, maxchar) + default: + call strcpy ("unknown", str, maxchar) + } +end diff --git a/pkg/dataio/lib/mkpkg b/pkg/dataio/lib/mkpkg new file mode 100644 index 00000000..698997dd --- /dev/null +++ b/pkg/dataio/lib/mkpkg @@ -0,0 +1,12 @@ +# These routines are used by more than one task in the dataio package: + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + addcards.x + #getdatatype.x + #ranges.x <ctype.h> <mach.h> + ; diff --git a/pkg/dataio/lib/ranges.x b/pkg/dataio/lib/ranges.x new file mode 100644 index 00000000..b3812cd1 --- /dev/null +++ b/pkg/dataio/lib/ranges.x @@ -0,0 +1,234 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <ctype.h> + +define FIRST 1 # Default starting range +define LAST MAX_INT # Default ending range +define STEP 1 # Default step + +# DECODE_RANGES -- Parse a string containing a list of integer numbers or +# ranges, delimited by either spaces or commas. Return as output a list +# of ranges defining a list of numbers, and the count of list numbers. +# Range limits must be positive nonnegative integers. ERR is returned as +# the function value if a conversion error occurs. The list of ranges is +# delimited by a single NULL. + +int procedure decode_ranges (range_string, ranges, max_ranges, nvalues) + +char range_string[ARB] # Range string to be decoded +int ranges[3, max_ranges] # Range array +int max_ranges # Maximum number of ranges +int nvalues # The number of values in the ranges + +int ip, nrange, first, last, step, ctoi() + +begin + ip = 1 + nvalues = 0 + + do nrange = 1, max_ranges - 1 { + # Defaults to all positive integers + first = FIRST + last = LAST + step = STEP + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get first limit. + # Must be a number, '-', 'x', or EOS. If not return ERR. + if (range_string[ip] == EOS) { # end of list + if (nrange == 1) { + # Null string defaults + ranges[1, 1] = first + ranges[2, 1] = last + ranges[3, 1] = step + ranges[1, 2] = NULL + nvalues = nvalues + abs (last-first) / step + 1 + return (OK) + } else { + ranges[1, nrange] = NULL + return (OK) + } + } else if (range_string[ip] == '-') + ; + else if (range_string[ip] == 'x') + ; + else if (IS_DIGIT(range_string[ip])) { # ,n.. + if (ctoi (range_string, ip, first) == 0) + return (ERR) + } else + return (ERR) + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get last limit + # Must be '-', or 'x' otherwise last = first. + if (range_string[ip] == 'x') + ; + else if (range_string[ip] == '-') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, last) == 0) + return (ERR) + } else if (range_string[ip] == 'x') + ; + else + return (ERR) + } else + last = first + + # Skip delimiters + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + + # Get step. + # Must be 'x' or assume default step. + if (range_string[ip] == 'x') { + ip = ip + 1 + while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') + ip = ip + 1 + if (range_string[ip] == EOS) + ; + else if (IS_DIGIT(range_string[ip])) { + if (ctoi (range_string, ip, step) == 0) + ; + } else if (range_string[ip] == '-') + ; + else + return (ERR) + } + + # Output the range triple. + ranges[1, nrange] = first + ranges[2, nrange] = last + ranges[3, nrange] = step + nvalues = nvalues + abs (last-first) / step + 1 + } + + return (ERR) # ran out of space +end + + +# GET_NEXT_NUMBER -- Given a list of ranges and the current file number, +# find and return the next file number. Selection is done in such a way +# that list numbers are always returned in monotonically increasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure get_next_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number+1 is anywhere in the list, that is the next number, + # otherwise the next number is the smallest number in the list which + # is greater than number+1. + + number = number + 1 + next_number = MAX_INT + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder + step <= last) + next_number = number - remainder + step + } else if (first > number) + next_number = min (next_number, first) + } + + if (next_number == MAX_INT) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# GET_PREVIOUS_NUMBER -- Given a list of ranges and the current file number, +# find and return the previous file number. Selection is done in such a way +# that list numbers are always returned in monotonically decreasing order, +# regardless of the order in which the ranges are given. Duplicate entries +# are ignored. EOF is returned at the end of the list. + +int procedure get_previous_number (ranges, number) + +int ranges[ARB] # Range array +int number # Both input and output parameter + +int ip, first, last, step, next_number, remainder + +begin + # If number-1 is anywhere in the list, that is the previous number, + # otherwise the previous number is the largest number in the list which + # is less than number-1. + + number = number - 1 + next_number = 0 + + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) { + remainder = mod (number - first, step) + if (remainder == 0) + return (number) + if (number - remainder >= first) + next_number = number - remainder + } else if (last < number) { + remainder = mod (last - first, step) + if (remainder == 0) + next_number = max (next_number, last) + else if (last - remainder >= first) + next_number = max (next_number, last - remainder) + } + } + + if (next_number == 0) + return (EOF) + else { + number = next_number + return (number) + } +end + + +# IS_IN_RANGE -- Test number to see if it is in range. + +bool procedure is_in_range (ranges, number) + +int ranges[ARB] # Range array +int number # Number to be tested against ranges + +int ip, first, last, step + +begin + for (ip=1; ranges[ip] != NULL; ip=ip+3) { + first = min (ranges[ip], ranges[ip+1]) + last = max (ranges[ip], ranges[ip+1]) + step = ranges[ip+2] + if (number >= first && number <= last) + if (mod (number - first, step) == 0) + return (true) + } + + return (false) +end diff --git a/pkg/dataio/mkpkg b/pkg/dataio/mkpkg new file mode 100644 index 00000000..bba288df --- /dev/null +++ b/pkg/dataio/mkpkg @@ -0,0 +1,33 @@ +# Make the DATAIO package + +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $set LIBS = "-lxtools" + $update libpkg.a + $omake x_dataio.x + $link x_dataio.o libpkg.a $(LIBS) -o xx_dataio.e + ; + +install: + $move xx_dataio.e bin$x_dataio.e + ; + +libpkg.a: + @lib + @export + @import + @imtext + @reblock + @fits + @bintext + @mtexamine + @cardimage + @t2d + ; diff --git a/pkg/dataio/mtexamine.par b/pkg/dataio/mtexamine.par new file mode 100644 index 00000000..07269aa1 --- /dev/null +++ b/pkg/dataio/mtexamine.par @@ -0,0 +1,8 @@ +tape_file,s,a,,,,Tape file +file_list,s,h,1-999,,,List of file numbers +dump_records,b,h,no,,,Dump selected records? +rec_list,s,h,1-999,,,List of records to be dumped +byte_chunk,i,h,1,,,Byte chunk +swapbytes,b,h,no,,,Swap bytes? +output_format,s,h,o,,,Dump format (c|d|o|u|x) +mode,s,h,"ql",,, diff --git a/pkg/dataio/mtexamine/mkpkg b/pkg/dataio/mtexamine/mkpkg new file mode 100644 index 00000000..99e96080 --- /dev/null +++ b/pkg/dataio/mtexamine/mkpkg @@ -0,0 +1,10 @@ +# Mtexamine library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_mtexamine.x <error.h> <fset.h> <printf.h> <mach.h> mtexamine.com + ; diff --git a/pkg/dataio/mtexamine/mtexamine.com b/pkg/dataio/mtexamine/mtexamine.com new file mode 100644 index 00000000..46969458 --- /dev/null +++ b/pkg/dataio/mtexamine/mtexamine.com @@ -0,0 +1,6 @@ +int dump_records +int byteswap +int byte_chunk +char output_format + +common /mtexam/ dump_records, byteswap, byte_chunk, output_format diff --git a/pkg/dataio/mtexamine/t_mtexamine.x b/pkg/dataio/mtexamine/t_mtexamine.x new file mode 100644 index 00000000..26f7b2fd --- /dev/null +++ b/pkg/dataio/mtexamine/t_mtexamine.x @@ -0,0 +1,376 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <fset.h> +include <printf.h> +include <mach.h> + +define MAX_RANGES 100 +define LEN_LINE 80 +define TAPE_BYTE 8 +define TWO_TO_EIGHT 256 +define FIELD_INDEX 5 +define NFORMATS 5 + + +# MTEXAMINE -- Examine one or more magtape files, counting the number and size +# of the records in a file, and the number of files on the tape. + +procedure t_mtexamine() + +int nfiles, file_number, ndumps, nrecords +int file_range[2*MAX_RANGES+1], rec_range[2*MAX_RANGES+1] +pointer sp, tape_name, tape_file, file_list, rec_list + +bool clgetb() +char clgetc() +int fstati(), mtfile(), mtneedfileno(), decode_ranges(), get_next_number() +int mt_examine(), mt_get_format(), clgeti(), btoi() +include "mtexamine.com" + +begin + # Allocate working space. + call smark (sp) + call salloc (tape_name, SZ_FNAME, TY_CHAR) + call salloc (tape_file, SZ_FNAME, TY_CHAR) + call salloc (file_list, SZ_LINE, TY_CHAR) + call salloc (rec_list, SZ_LINE, TY_CHAR) + + # Flush STDOUT on a newline only if output is not redirected. + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get input file(s). + call clgstr ("tape_file", Memc[tape_file], SZ_FNAME) + if (mtfile (Memc[tape_file]) == NO) + call strcpy ("1", Memc[file_list], SZ_LINE) + else if (mtneedfileno (Memc[tape_file]) == NO) + call strcpy ("1", Memc[file_list], SZ_LINE) + else + call clgstr ("file_list", Memc[file_list], SZ_LINE) + if (decode_ranges (Memc[file_list],file_range,MAX_RANGES,nfiles) == ERR) + call error (0, "Illegal file number list.") + + # Get dump parameters + dump_records = btoi (clgetb ("dump_records")) + if (dump_records == YES) { + call clgstr ("rec_list", Memc[rec_list], SZ_LINE) + if (decode_ranges (Memc[rec_list], rec_range, MAX_RANGES, + ndumps) == ERR) + call error (0, "Illegal record list.") + byteswap = btoi (clgetb ("swapbytes")) + byte_chunk = clgeti ("byte_chunk") + if (byte_chunk < 1 || byte_chunk > (SZ_LONG * SZB_CHAR)) + call error (0, "Illegal byte chunk size.") + output_format = mt_get_format (clgetc ("output_format")) + if (output_format == ERR) + call error (0, "Illegal format.") + if (byte_chunk != 1 && output_format == FMT_CHAR) + call error (0, "Cannot output integers as chars.") + } + + # Loop over files + file_number = 0 + while (get_next_number (file_range, file_number) != EOF) { + + if (mtfile (Memc[tape_file]) == YES && + mtneedfileno (Memc[tape_file]) == YES) + call mtfname (Memc[tape_file], file_number, Memc[tape_name], + SZ_FNAME) + else + call strcpy (Memc[tape_file], Memc[tape_name], SZ_FNAME) + + iferr { + nrecords = mt_examine (Memc[tape_name], rec_range) + } then { + call eprintf ("Error reading file: %s\n") + call pargstr (Memc[tape_name]) + call erract (EA_WARN) + break + } else if (nrecords == 0) { + call printf ("Tape at EOT\n") + break + } + + } + + call sfree (sp) +end + + +# MT_EXAMINE -- Procedure to examine a tape file. If dump_record is +# no mtexamine gives a summary of the record structure of the file, +# otherwise the specified records are dumped. + +int procedure mt_examine (tape_file, dump_range) + +char tape_file[ARB] # input file name +int dump_range[ARB] # range of records to be dumped + +pointer sp, inbuf, pchar, junk +int in, bufsize, totrecords, nrecords, totbytes, last_recsize, nbadrec +int stat, rec_number, next_dump, recsize, nelems, vals_per_line, field_len +long maxval, max_plusint, twice_max_plusint + +int mtopen(), fstati(), get_next_number(), read(), gltoc() +errchk mtopen, malloc, read, mfree, close +include "mtexamine.com" + +begin + call smark (sp) + call salloc (junk, SZ_FNAME, TY_CHAR) + + in = mtopen (tape_file, READ_ONLY, 0) + bufsize = fstati (in, F_BUFSIZE) + call salloc (pchar, bufsize, TY_CHAR) + + call printf ("File %s:\n") + call pargstr (tape_file) + + totrecords = 0 + nrecords = 0 + totbytes = 0 + nbadrec = 0 + last_recsize = 0 + + # Prepare formatting parameters for dumping records. + if (dump_records == YES) { + call salloc (inbuf, bufsize * SZB_CHAR, TY_LONG) + rec_number = 0 + next_dump = get_next_number (dump_range, rec_number) + maxval = 2 ** (byte_chunk * TAPE_BYTE - 1) - 1 + field_len = gltoc (maxval, Memc[junk], SZ_FNAME, TAPE_BYTE) + 1 + vals_per_line = (LEN_LINE - FIELD_INDEX) / (field_len + 1) + if (output_format == FMT_DECIMAL && byte_chunk > 1 && + byte_chunk < (SZ_LONG * SZB_CHAR)) { + max_plusint = maxval + 1 + twice_max_plusint = 2 * max_plusint + } + } + + # Loop through the records. + repeat { + iferr (stat = read (in, Memc[pchar], bufsize)) { + call fseti (in, F_VALIDATE, last_recsize / SZB_CHAR) + nbadrec = nbadrec + 1 + call printf ("\tRead error on record: %d\n") + call pargi (totrecords + 1) + stat = read (in, Memc[pchar], bufsize) + } + if (stat == EOF) + break + + recsize = fstati (in, F_SZBBLK) + if (dump_records == NO) { + if (nrecords == 0) { + nrecords = 1 + last_recsize = recsize + } else if (recsize == last_recsize) { + nrecords = nrecords + 1 + } else { + call printf ("\t%d %d-byte records\n") + call pargi (nrecords) + call pargi (last_recsize) + nrecords = 1 + last_recsize = recsize + } + } else if (next_dump != EOF && rec_number == totrecords + 1) { + call printf (" Record %d,") + call pargi (totrecords + 1) + call printf (" %d bytes,") + call pargi (recsize) + nelems = recsize / byte_chunk + call printf (" %d elements") + call pargi (nelems) + call mt_bytupkl (Memc[pchar], Meml[inbuf], recsize, byte_chunk, + byteswap) + call mt_dump (Meml[inbuf], nelems, field_len, vals_per_line, + max_plusint, twice_max_plusint) + next_dump = get_next_number (dump_range, rec_number) + } + + totrecords = totrecords + 1 + totbytes = totbytes + recsize + } + + if (nrecords > 0 && dump_records == NO) { + call printf ("\t%d %d-byte records\n") + call pargi (nrecords) + call pargi (last_recsize) + } + + # Print total number of records and bytes + if (dump_records == YES) { + call printf (" Total %d records, %d bytes\n") + call pargi (totrecords) + call pargi (totbytes) + } else { + call printf ("\tTotal %d records, %d bytes") + call pargi (totrecords) + call pargi (totbytes) + if (nbadrec > 0) { + call printf (" [%d bad records]") + call pargi (nbadrec) + } + call printf ("\n") + } + + call close (in) + + call sfree (sp) + return (totrecords) +end + + +# MT_DUMP -- Procedure to format and dump a tape record in chars, shorts or +# longs in char, decimal, octal, unsigned decimal or hexadecimal format. + +procedure mt_dump (buffer, nelems, field_len, vals_per_line, max_plusint, + twice_max_plusint) + +int nelems, field_len, vals_per_line +long buffer[ARB], max_plusint, twice_max_plusint + +int i, nchars +char ch, outstr[SZ_FNAME] +int ctocc() +include "mtexamine.com" + +begin + for (i = 1; i <= nelems; i = i + 1) { + if (mod (i, vals_per_line) == 1) { + call printf ("\n%*d:") + call pargi (FIELD_INDEX) + call pargi (i) + } + if (output_format == FMT_CHAR) { + ch = buffer[i] + nchars = ctocc (ch, outstr, SZ_FNAME) + call printf ("%*s") + call pargi (field_len) + call pargstr (outstr) + } else { + if (output_format == FMT_DECIMAL && byte_chunk > 1 + && byte_chunk < (SZ_LONG * SZB_CHAR)) + call mt_sign_convert (buffer[i], 1, max_plusint, + twice_max_plusint) + call printf ("%**") + call pargi (field_len) + call pargc (output_format) + call pargl (buffer[i]) + } + } + + call printf ("\n") +end + + +# MT_GET_FORMAT -- Procedure to return the appropriate output format. + +int procedure mt_get_format (c) + +char c +int i, format_code[NFORMATS] +int stridx() +string formats "cdoxu" +data format_code /FMT_CHAR, FMT_DECIMAL, FMT_OCTAL, FMT_HEX, FMT_UNSIGNED/ + +begin + i = stridx (c, formats) + if ( i == 0) + return (ERR) + else + return (format_code[i]) +end + + +# MT_BYTUPKL -- Procedure to unpack an array in chunks byte_chunk bytes long +# into a long array with optional byteswapping. + +procedure mt_bytupkl (a, b, nbytes, byte_chunk, byteswap) + +char a[ARB] # input buffer +long b[ARB] # output array +int nbytes # number of bytes +int byte_chunk # number of bytes to be formatted, swapped etc. +int byteswap # swap bytes + +int op, i, j, rem +long sum + +begin + op = 1 + + # Unpack unsigned bytes into a long integer array + call achtbl (a, b, nbytes) + + # Flip bytes if necessary + if (byteswap == YES && byte_chunk > 1) { + for (i = 1; i <= nbytes - byte_chunk + 1; i = i + byte_chunk) + call mt_aflipl (b[i], byte_chunk) + } + + # Convert the bytes into unsigned integers + for (i = 1; i <= nbytes - byte_chunk + 1; i = i + byte_chunk) { + sum = 0 + for (j = 1; j <= byte_chunk; j = j + 1) { + sum = sum + TWO_TO_EIGHT ** (byte_chunk - j) * + b[i + j - 1] + } + b[op] = sum + op = op + 1 + } + + # Convert remaining bytes + rem = nbytes - i + 1 + if (rem > 0) { + if (byteswap == YES && byte_chunk > 1) + call mt_aflipl (b[i], rem) + sum = 0 + for (j = 1; j <= rem; j = j + 1) + sum = sum + TWO_TO_EIGHT ** (rem - j) * + b[i + j - 1] + b[op] = sum + } +end + + +# MT_AFLIPL -- Procedure to flip a long integer array in place. + +procedure mt_aflipl (buf, npix) + +long buf[npix] # array to be flipped +int npix # number of elements in array + +int n_total, n_half, i, j + +begin + n_half = npix / 2 + n_total = npix + 1 + for (i = 1; i <= n_half; i = i + 1) { + j = buf[i] + buf[i] = buf[n_total - i] + buf[n_total - i] = j + } +end + + +# MT_SIGN_CONVERT -- Procedure to convert unsigned long integers in the range +# 0 to twice_max_plusint - 1 to integers in the range - max_plusint +# to max_plusint - 1. + +procedure mt_sign_convert (b, nelems, max_plusint, twice_max_plusint) + +long b[nelems] # array of long integers to be converted +int nelems # number of elements in the array +long max_plusint # 0 <= b[i] <= max_plusint - 1 +long twice_max_plusint # twice max_plusint + +int i + +begin + for (i = 1; i <= nelems; i = i + 1) { + if (b[i] >= max_plusint) + b[i] = b[i] - twice_max_plusint + } +end diff --git a/pkg/dataio/rcardimage.par b/pkg/dataio/rcardimage.par new file mode 100644 index 00000000..98276eed --- /dev/null +++ b/pkg/dataio/rcardimage.par @@ -0,0 +1,14 @@ +mode,s,h,"ql" +cardfile,s,a,,,,"Card image file" +file_list,s,a,,,,"List of tape file numbers" +textfile,s,a,,,,"Output file text file(s)" +card_length,i,h,80,,,"Columns per card" +max_line_length,i,h,161,,161,"Maximum line length" +entab,b,h,yes,,,"Replace blanks with tabs and blanks?" +join,b,a,no,,,"Join oversize lines?" +contn_string,s,a,>>,,,"Continuation line marker" +trim,b,h,yes,,,"Trim trailing whitespace?" +verbose,b,h,yes,,,"Print messages?" +ebcdic,b,h,no,,,"Convert from EBCDIC to ASCII?" +ibm,b,h,no,,,"Translate from IBM(EBCDIC) to ASCII?" +offset,i,h,0,,,Tape file number offset diff --git a/pkg/dataio/reblock.par b/pkg/dataio/reblock.par new file mode 100644 index 00000000..01916973 --- /dev/null +++ b/pkg/dataio/reblock.par @@ -0,0 +1,16 @@ +infiles,s,a,,,,Input file +outfiles,s,a,,,,Output file +file_list,s,a,,,,Tape file list +newtape,b,a,,,,Blank tape? +outblock,i,h,INDEF,,,Size of output block in bytes +inrecord,i,h,INDEF,,,Size of input records in bytes +outrecord,i,h,INDEF,,,Size of output records in btyes +pad_block,b,h,no,,,Pad last block? +padchar,s,h,'0',,,Pad character +skipn,i,h,0,,,Skip n blocks (tape) or records (disk) +copyn,i,h,INDEF,,,Copy n blocks (tape) or records (disk) +byteswap,b,h,no,,,Swap bytes? +wordswap,b,h,no,,,Swap words? +offset,i,h,0,,,Tape file number offset +verbose,b,h,yes,,,Print messages? +mode,s,h,"ql",,, diff --git a/pkg/dataio/reblock/mkpkg b/pkg/dataio/reblock/mkpkg new file mode 100644 index 00000000..5baf1a30 --- /dev/null +++ b/pkg/dataio/reblock/mkpkg @@ -0,0 +1,12 @@ +# Reblock Library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_reblock.x reblock.com reblock.h <fset.h> <error.h> <ctype.h>\ + <mach.h> + reblock_file.x reblock.com reblock.h <fset.h> <error.h> <mach.h> + ; diff --git a/pkg/dataio/reblock/reblock.com b/pkg/dataio/reblock/reblock.com new file mode 100644 index 00000000..35bc652d --- /dev/null +++ b/pkg/dataio/reblock/reblock.com @@ -0,0 +1,21 @@ +# input parameters +int szb_outblock # size of output block in bytes +int szb_inrecord # size of input record in bytes +int szb_outrecord # size of output record in bytes +int nskip # number blocks (tape) or records (disk) to be skipped +int ncopy # number of blocks (tape) or records (disk) to be copied +int padvalue # integer value of padcharacter + +# integer switches +int intape # input tape device +int outtape # output tape device +int reblock # reformat? +int pad_block # pad short blocks +int pad_record # pad records +int trim_record # trim records +int byteswap # swap every other byte +int wordswap # swap every other word + +common /reblock/ szb_outblock, szb_inrecord, szb_outrecord, nskip, ncopy, + padvalue, intape, outtape, reblock, pad_block, pad_record, + trim_record, byteswap, wordswap diff --git a/pkg/dataio/reblock/reblock.h b/pkg/dataio/reblock/reblock.h new file mode 100644 index 00000000..c88d38a8 --- /dev/null +++ b/pkg/dataio/reblock/reblock.h @@ -0,0 +1,7 @@ +# define the output parameters +define BLKS_RD $1[1] +define BLKS_WRT $1[2] +define RECS_RD $1[3] +define RECS_WRT $1[4] +define LEN_OUTPARAM 4 + diff --git a/pkg/dataio/reblock/reblock.hlp b/pkg/dataio/reblock/reblock.hlp new file mode 100644 index 00000000..465314be --- /dev/null +++ b/pkg/dataio/reblock/reblock.hlp @@ -0,0 +1,154 @@ +.help reblock Mar84 dataio +.ih +NAME +reblock -- copy a file on tape or disk with optional reblocking +.ih +USAGE +reblock (infiles, outfiles, file_list) +.ih +PARAMETERS +.ls infiles +File or device name e.g. "mta1600[2]" or "mta800" or "file1". +.le +.ls outfiles +If multiple file to disk is requested, the ouput file names will be generated +by concatenating the tape file number onto the output file name. +.le +.ls file_list +List of tape file numbers or ranges delimited by whitespace or commas, +e.g. "1-3, 5_8". +File_list is requested only if the magtape input device is specified. +Files will be read in ascending order regardless of the ordering of the list. +Reading will terminate silently if EOT is reached, thus a list such as +"1-999" may be used to read all files on the tape. +.le +.ls newtape +If the output device is magtape, newtape specifies whether the tape is +blank or contains data. +Newtape is requested only if no tape file number is specified, e.g. "mta1600". +.le +.ls outblock = INDEF +Size of the output block bytes. +In the default case and for disk output, the output block size is set to the +file i/o disk default buffer size. +.le +.ls inrecord = INDEF, outrecord = INDEF +The sizes of the input and output logical records in bytes. +The default input and output record sizes are set equal to +the input and output block sizes respectively. If inrecord > outrecord, +records are trimmed; if inrecord < outrecord, records are padded; if +inrecord = outrecord, records are simply counted. If only one of inrecord or +outrecord is set, the undefined parameter defaults to the value of the +other. +.le +.ls nskip = 0 +The number of input blocks (tape input) or records (disk input, size inrecord) +to be skipped. +.le +.ls ncopy = INDEF +The number of input blocks (tape input) or records +(disk input, size inrecord) to be copied. Ncopy defaults to a very large number. +.le +.ls byteswap = no +Swap every other byte. +.le +.ls wordswap = no +Swap every other word. +.le +.ls pad_block = no +If pad_block is set, reblock pads trailing blocks until they are outblock +bytes long, otherwise trailing blocks may be short. +.le +.ls padchar = 0 +Single character used to pad blocks or records. +Padchar is only requested if pad_record or pad_block +is set. If padchar equals one of the digits 0 through nine, records and +blocks are padded with the face value of the character, otherwise the +ASCII value is used. +.le +.ls verbose = yes +Print messages about files, blocks copied etc. +.le +.ih +DESCRIPTION + +REBLOCK is a procedure to copy disk or tape resident files to +disk or tape. Multiple tape files or a single disk input file may be specified. +If multiple files are output to disk the output file names will be +generated by concatenating the tape file number onto the output file name. +The user may request magnetic tape output to begin at a specific file on +tape, e.g. mta1600[5] in which case file five will be overwritten if it +exists, or at BOT or EOT. If no file number is specified REBLOCK asks +whether the tape is new or old and begin writing at BOT or EOT as +appropriate. + +Before beginning the copy, the user may request reblock to skip +n (default 0) blocks (tape input) or logical records (disk input). +The user can also specify that +only n (default all) blocks (tape input) or records (disk input) +are to be copied. Before the copy the data may be optionally word-swapped +(default no) and/or byte-swapped (default no). If verbose is specified +(default yes) reblock prints the input and output file names, +the number of blocks read and written and the number of records read and +written. + +Reblock +uses the default buffer sizes supplied by mtio and file i/o to determine the +maximum number of bytes which can be read in a single read call. For tapes +this corresponds to the maximum number of bytes per block permitted by the +device. Mtio will not read more than one block per read call. Therefore the +actual number of bytes read will be less than or equal to the mtio buffer size. +For disk files the default buffer size set by IRAF is a multiple of the +disk block size. If the disk file is smaller than one block +or the last block is partially full, the number of bytes read +will be less than the default buffer size. All magtape and disk reads are +done with the file i/o read procedure and a call to fstati determines the number +of bytes actually read. + +If all the defaults are set, a binary copy is performed. +In tape to tape copies the block and record sizes are preserved, +but the density may +be changed by specifying the appropriate output file name e.g. mta800 or +mta1600. +Reblocking occurs in tape to disk transfers, if records, are trimmed, +padded or counted, or if blocks are padded. +If a disk to tape transfer is requested +the output block size will be the default file i/o buffer size. +The last block in a file may be short. If uniform sized blocks are +desired, pad_block must be set, in which case trailing partially filled +blocks will be padded with padchar. + +Logical records are distinguished from blocks (physical records). +The input and output record sizes default to +the size of the input and output blocks respectively. +Logical records may be shorter or longer than the block sizes. +.ih +EXAMPLES + +Copy a magnetic tape preserving the record sizes but changing +the density from 800 bpi to 1600 bpi. + +.nf + da> reblock mtb800, "mta1600[1]", "1-999" +.fi + +Reblock a magnetic tape changing the block size from 4000 bytes to 8000 +bytes and padding the last block. + +.nf + da> reblock mtb1600, "mta1600[1]", "1-999", outb=8000, padb+ +.fi + +Trim the records of a disk file. + +.nf + da> reblock input, output, inrec=80, outrec=72 +.fi + +Pad the records of a disk file with blanks. + +.nf + da> reblock input, output, inrec=81, outrec=82, padchar=" " +.fi + +.endhelp diff --git a/pkg/dataio/reblock/reblock_file.x b/pkg/dataio/reblock/reblock_file.x new file mode 100644 index 00000000..2801a1b1 --- /dev/null +++ b/pkg/dataio/reblock/reblock_file.x @@ -0,0 +1,416 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <fset.h> +include <mach.h> +include "reblock.h" + +# REB_REBLOCK_FILE -- Copy and optionally reblock files. + +procedure reb_reblock_file (in_fname, out_fname, outparam) + +char in_fname[ARB] # input file name +char out_fname[ARB] # output file name +int outparam[ARB] # output parameters + +char padchar +int in, out, sz_charsin, sz_charsout, mov_nbytes, rem_in, rem_out +int bytes_read, ip, op, i, first_byte, nchars, rec_count, ntrim +long offset +pointer inbuf, outbuf + +int mtopen(), reb_roundup(), read(), reb_skipover(), fstati(), open() +errchk open, mtopen, read, awriteb, awaitb, close, mfree, malloc, flush +errchk reb_write_block, reb_pad_block, reb_pad_record, reb_skipover +include "reblock.com" + +begin + # Open input and output files + in = mtopen (in_fname, READ_ONLY, 0) + out = NULL + + # Allocate space for input buffer. + sz_charsin = fstati (in, F_BUFSIZE) + call malloc (inbuf, sz_charsin, TY_CHAR) + outbuf = NULL + + # Skip over n input blocks (tape) or records (disk). + first_byte = 1 + if (intape == YES) { + for (i=1; i <= nskip; i = i + 1) { + nchars = read (in, Memc[inbuf], sz_charsin) + if (nchars == EOF) + call error (1,"Skipped past EOF on input.") + } + } else { + first_byte = reb_skipover (in, szb_inrecord, nskip) + if (first_byte == EOF) + call error (2, "Skipped past EOF on input.") + } + + # Initialize the input and output block and record counters + BLKS_RD(outparam) = 0 + BLKS_WRT(outparam) = 0 + RECS_RD(outparam) = 0 + RECS_WRT(outparam) = 0 + + # Initalize the record counter. + rec_count = 0 + + # Set of the offset in output file for asyncrhronous i/o. + offset = 1 + + # Loop over the input blocks. + repeat { + + # Read a block and update block counter. + nchars = read (in, Memc[inbuf], sz_charsin) + if (nchars == EOF) + break + bytes_read = nchars * SZB_CHAR + if (mod (fstati (in, F_SZBBLK), SZB_CHAR) != 0) + bytes_read = bytes_read - mod (fstati (in, F_SZBBLK), SZB_CHAR) + BLKS_RD(outparam) = BLKS_RD(outparam) + 1 + + # Align to first byte. + if (rec_count == 0 && first_byte > 1) { + bytes_read = bytes_read - first_byte + 1 + call bytmov (Memc[inbuf],first_byte, Memc[inbuf],1, bytes_read) + } + + # Open the output file. This has been moved from the beginning + # of the routine to avoid a magtape problem. + # driver problem. + if (BLKS_RD(outparam) == 1) { + if (outtape == NO) + out = open (out_fname, NEW_FILE, BINARY_FILE) + else + out = mtopen (out_fname, WRITE_ONLY, 0) + } + + # Binary copy. + if (reblock == NO) { + + RECS_RD(outparam) = BLKS_RD(outparam) + call reb_write_block (out, Memc[inbuf], bytes_read, offset, + byteswap, wordswap) + BLKS_WRT(outparam) = BLKS_WRT(outparam) + 1 + RECS_WRT(outparam) = BLKS_WRT(outparam) + + # Reblock. + } else { + + # Initialize reblocking parameters after first read. + if (BLKS_RD(outparam) == 1) { + + # Initialize block and record sizes + if (IS_INDEFI(szb_inrecord)) + szb_inrecord = sz_charsin * SZB_CHAR + if (IS_INDEFI(szb_outblock)) + szb_outblock = fstati (out, F_BUFSIZE) * SZB_CHAR + if (IS_INDEFI(szb_outrecord)) + szb_outrecord = szb_outblock + + # Set pad character. + if (pad_record == YES || pad_block == YES) { + padchar = char (padvalue) + call chrpak (padchar, 1, padchar, 1, 1) + } + + # Allocate space for the output buffer. + sz_charsout = reb_roundup (szb_outblock, SZB_CHAR) / + SZB_CHAR + call malloc (outbuf, sz_charsout, TY_CHAR) + + # Intialize the record remainder counters + rem_in = szb_inrecord + rem_out = szb_outrecord + + # Initialize input and output buffer pointers + ip = 1 + op = 1 + } + + # Loop over the input buffer. + repeat { + + # Calculate the number of bytes to be moved. + mov_nbytes = min (bytes_read - ip + 1, + rem_in, rem_out, szb_outblock - op + 1) + call bytmov (Memc[inbuf], ip, Memc[outbuf], op, mov_nbytes) + + # Update the remainders + rem_in = rem_in - mov_nbytes + if (rem_in == 0) + rem_in = szb_inrecord + rem_out = rem_out - mov_nbytes + if (rem_out == 0) + rem_out = szb_outrecord + + # Update the input and output buffer pointers. + ip = ip + mov_nbytes + op = op + mov_nbytes + + # Pad records. + if (pad_record == YES && rem_in == szb_inrecord) { + + # Do the padding. + if (mov_nbytes != 0) { + RECS_RD(outparam) = RECS_RD(outparam) + 1 + call reb_pad_record (Memc[outbuf], op, rem_out, + szb_outblock, szb_outrecord, padchar) + } else if (rem_out < szb_outrecord) + call reb_pad_record (Memc[outbuf], op, rem_out, + szb_outblock, szb_outrecord, padchar) + + # Increment the output record counter. + if (rem_out == szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + else if (rem_out < szb_outrecord) + rem_in = 0 + } + + # If the output buffer is exhausted, output block of data. + if (op > szb_outblock) { + call reb_write_block (out, Memc[outbuf], szb_outblock, + offset, byteswap, wordswap) + BLKS_WRT(outparam) = BLKS_WRT(outparam) + 1 + op = 1 + } + + # Trim records. + if (trim_record == YES && rem_out == szb_outrecord) { + + # Do the trimming. + if (mov_nbytes != 0) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + ntrim = min (rem_in, bytes_read - ip + 1) + ip = ip + ntrim + rem_in = rem_in - ntrim + if (rem_in == 0) + rem_in = szb_inrecord + + # Increment the record counter. + if (rem_in == szb_inrecord) + RECS_RD(outparam) = RECS_RD(outparam) + 1 + else if (rem_in < szb_inrecord) + rem_out = 0 + } + + # Count the records. + if (pad_record == NO && trim_record == NO) { + if (szb_inrecord == sz_charsin * SZB_CHAR) + RECS_RD(outparam) = BLKS_RD(outparam) + else if (rem_in == szb_inrecord) + RECS_RD(outparam) = RECS_RD(outparam) + 1 + if (rem_out == szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + } + + # Quit if ncopy records has been reached. + if (intape == NO && RECS_RD(outparam) == ncopy) + break + + } until (ip > bytes_read) + + # Reset the input buffer pointer + ip = 1 + } + + # Update the record counter. + if (intape == YES) + rec_count = BLKS_RD(outparam) + else + rec_count = RECS_RD(outparam) + + } until (rec_count >= ncopy) + + # Output remainder of data + if (reblock == YES) { + + # Pad last record if short. + if (pad_record == YES) { + if (rem_in < szb_inrecord) + RECS_RD(outparam) = RECS_RD(outparam) + 1 + if (rem_out < szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + while (rem_out < szb_outrecord) { + call reb_pad_record (Memc[outbuf], op, rem_out, + szb_outblock, szb_outrecord, padchar) + if (op > szb_outblock) { + call reb_write_block (out, Memc[outbuf], szb_outblock, + offset, byteswap, wordswap) + BLKS_WRT(outparam) = BLKS_WRT(outparam) + 1 + op = 1 + } + } + } + + # Pad last block if short. + if (pad_block == YES && op > 1) + call reb_pad_block (Memc[outbuf], op, rem_out, outparam, + szb_outblock, szb_outrecord, padchar) + + # Write last block + if (op > 1) { + call reb_write_block (out, Memc[outbuf], op - 1, offset, + byteswap, wordswap) + op = 1 + BLKS_WRT(outparam) = BLKS_WRT(outparam) + 1 + if (pad_record == YES && rem_out < szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + else if (rem_out < szb_outrecord) + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + } + + } + + call mfree (inbuf, TY_CHAR) + if (outbuf != NULL) + call mfree (outbuf, TY_CHAR) + call close (in) + if (out != NULL) + call close (out) +end + + +# REB_PAD_RECORD -- Procedure for padding records. + +procedure reb_pad_record (buffer, op, rem_out, szb_outblock, szb_outrecord, + padchar) + +char buffer[ARB], padchar +int szb_outblock, szb_outrecord, op, rem_out +int i, junk + +begin + junk = rem_out + for (i = 1; i <= junk && op <= szb_outblock; i = i + 1) { + call bytmov (padchar, 1, buffer, op, 1) + op = op + 1 + rem_out = rem_out - 1 + } + + if (rem_out == 0) + rem_out = szb_outrecord +end + + +# REB_PAD_BLOCK -- Procedure to pad the last block so that all output blocks +# will have the same size. + +procedure reb_pad_block (buffer, op, rem_out, outparam, szb_outblock, + szb_outrecord, padchar) + +char buffer[ARB] # data to be padded +int op # pointer to first element for padding +int rem_out # number of remaining bytes to be padded in a record +int outparam[ARB] # output parameters, number of records, blocks written +int szb_outblock # size in bytes of output block +int szb_outrecord # size in bytes of an output record +char padchar # character used for padding + +int i, junk + +begin + junk = szb_outblock - op + 1 + for (i = 1; i <= junk; i = i + 1) { + call bytmov (padchar, 1, buffer, op, 1) + op = op + 1 + rem_out = rem_out - 1 + if (rem_out == 0) { + rem_out = szb_outrecord + RECS_WRT(outparam) = RECS_WRT(outparam) + 1 + } + } +end + + +# REB_WRITE_BLOCK -- Procedure to write blocks using the asynchronous read +# and write functions in file i/o. Writing must occur on block boundaries. + +procedure reb_write_block (fd, buffer, nbytes, offset, byteswap, wordswap) + +int fd # output file descriptor +char buffer[ARB] # data to be output +int nbytes # number of bytes of data +long offset # offset in chars in output file for writing +int byteswap # swap every other byte before output +int wordswap # swap every other word before output + +int nbread +int awaitb() +errchk awriteb, awaitb + +begin + if (byteswap == YES) + call bswap2 (buffer, 1, buffer, 1, nbytes) + if (wordswap == YES) + call bswap4 (buffer, 1, buffer, 1, nbytes) + call awriteb (fd, buffer, nbytes, offset) + nbread = awaitb (fd) + if (nbread == ERR) + call error (3, "Error writing block data") + else + offset = offset + nbread +end + + +# REB_SKIPOVER -- Procedure to find the first byte containing data given the +# input block size and the number of input blocks to be skipped. + +int procedure reb_skipover (fd, szb_inblock, nskip) + +int fd # file descriptor +int szb_inblock # size of an input block +int nskip # number of blocks to skip + +int first_byte +long szb_skip, szb_physkip, skip_diff, sz_charoff, loff +long fstatl() +int reb_roundup() +errchk fstatl, seek + +begin + szb_skip = long (szb_inblock) * long (nskip) + szb_physkip = reb_roundup (szb_skip, SZB_CHAR) + skip_diff = szb_physkip - szb_skip + + if (skip_diff == 0) { + sz_charoff = (szb_physkip / SZB_CHAR) + 1 + first_byte = 1 + } else { + sz_charoff = (szb_physkip / SZB_CHAR) - 1 + first_byte = int (szb_skip - (SZB_CHAR * sz_charoff) + 1) + } + + loff = long (sz_charoff) + + if (loff > fstatl (fd, F_FILESIZE)) { + call seek (fd, EOF) + return (EOF) + } else { + call seek (fd, loff) + return (first_byte) + } +end + + +# REB_ROUNDUP -- Procedure to round a number to the next highest number +# divisible by base. + +int procedure reb_roundup (number, base) + +int number # number to be rounded upwards +int base # base for rounding + +int value + +begin + if (mod(number, base) == 0) + return (number) + else { + value = (number/base + 1) * base + return (value) + } +end diff --git a/pkg/dataio/reblock/structure.hlp b/pkg/dataio/reblock/structure.hlp new file mode 100644 index 00000000..1a7c5221 --- /dev/null +++ b/pkg/dataio/reblock/structure.hlp @@ -0,0 +1,50 @@ +.help gcopy "Program Structure" +.sh +Program Structure +.nf +t_bincopy() +# Returns when file list is finished or EOT reached. + + read_file (in_fname, out_fname, outparam) + Returns when an EOF is encountered on read. + + skipover (fd, szb_outblock, nskip) + # Returns the offset of the first data byte in the first char + # to contain data of interest or EOF + + record_pad (szb_outblock, szb_outrecord, padchar, buffer, op, rem_out) + + block_pad (szb_outblock, szb_outrecord, padchar, buffer, op, rem_out, + outparam) +.fi +.sh +BINCOPY Structure Summary +.ls t_bincopy +The main program gets the input and output filenames, creates a list of +files to be processed and gets the program parameters. +For each file in the input list READFILE is called, +and the input and output file names, blocks read and written and records read +and written are printed. +The program terminates when the input file list is exhausted or EOT is reached. +.ls read_file +READ_FILE opens the input and output devices, allocates space for the input +and output buffers and copies the data optionally skipping data +and byteswapping and/or wordswapping the data. +The routine terminates when an EOF is encountered on a read. +READ_FILE calls SKIPOVER to find the first data byte of interest and +RECORD_PAD and BLOCK_PAD to pad records and blocks respectively. +.ls skipover +SKIPOVER seeks to the first char containing data of interest and calculates +the offset in that char of the first byte of interest. Returns the offset +or EOF if the requested position is past EOF. +.le +.ls record_pad +Record_pad pads input records of szb_inrecord bytes long to output records +szb_outrecord long. +.le +.ls block_pad +Pads short blocks to size szb_outblock. +.le +.le +.le +.endhelp diff --git a/pkg/dataio/reblock/t_reblock.x b/pkg/dataio/reblock/t_reblock.x new file mode 100644 index 00000000..09c86a9a --- /dev/null +++ b/pkg/dataio/reblock/t_reblock.x @@ -0,0 +1,214 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <fset.h> +include <error.h> +include <ctype.h> +include <mach.h> +include "reblock.h" + +define MAX_RANGES 100 +define SZ_PADCHAR 10 + +# T_REBLOCK -- Procedure to copy binary files optionally changing the blocking +# factor. Further documentation in reblock.hlp. + +procedure t_reblock () + +char infiles[SZ_FNAME] # list of input files +char file_list[SZ_LINE] # list of tape file numbers +char outfiles[SZ_FNAME] # list of output files +char padchar[SZ_PADCHAR] # character for padding blocks and records +bool verbose # print messages ? + +char in_fname[SZ_FNAME], out_fname[SZ_FNAME], cval +int inlist, outlist, len_inlist, len_outlist, file_number, file_cnt +int range[2 * MAX_RANGES + 1] +int outparam[LEN_OUTPARAM], offset, ip + +bool clgetb() +int fstati(), mtfile(), mtneedfileno(), fntopnb(), fntlenb(), fntgfnb() +int decode_ranges(), btoi(), clgeti(), get_next_number(), cctoc() +include "reblock.com" + +begin + # Flush on a newline if the output is not redirected. + if (fstati (STDOUT, F_REDIR) == NO) + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get the input and output file(s). + call clgstr ("infiles", infiles, SZ_FNAME) + call clgstr ("outfiles", outfiles, SZ_FNAME) + + # Get the input file names. + if (mtfile (infiles) == YES) { + inlist = NULL + intape = YES + if (mtneedfileno (infiles) == YES) + call clgstr ("file_list", file_list, SZ_LINE) + else + call strcpy ("1", file_list, SZ_LINE) + } else { + inlist = fntopnb (infiles, NO) + len_inlist = fntlenb (inlist) + intape = NO + if (len_inlist > 0) { + call sprintf (file_list, SZ_LINE, "1-%d") + call pargi (len_inlist) + } else + call strcpy ("0", file_list, SZ_LINE) + } + + # Decode the tape file number list. + if (decode_ranges (file_list, range, MAX_RANGES, len_inlist) == ERR) + call error (0, "Illegal file number list.") + offset = clgeti ("offset") + + # Get the output file names. + if (mtfile (outfiles) == YES) { + outlist = NULL + len_outlist = len_inlist + outtape = YES + if (mtneedfileno (outfiles) == YES) { + if (! clgetb ("newtape")) + call mtfname (outfiles, EOT, out_fname, SZ_FNAME) + else + call mtfname (outfiles, 1, out_fname, SZ_FNAME) + } else + call strcpy (outfiles, out_fname, SZ_FNAME) + } else { + outlist = fntopnb (outfiles, NO) + len_outlist = fntlenb (outlist) + outtape = NO + } + if ((len_inlist > 1) && (len_outlist != 1) && + (len_outlist != len_inlist)) + call error (0, + "The number of input and output files is not equal") + + # Get the block and record sizes. + szb_outblock = clgeti ("outblock") + if (outtape == NO) + szb_outblock = INDEFI + szb_inrecord = clgeti ("inrecord") + szb_outrecord = clgeti ("outrecord") + if (IS_INDEFI(szb_inrecord) && !IS_INDEFI(szb_outrecord)) + szb_inrecord = szb_outrecord + if (IS_INDEFI(szb_outrecord) && !IS_INDEFI(szb_inrecord)) + szb_outrecord = szb_inrecord + + # Get the pad and trim parameters. + pad_block = btoi (clgetb ("pad_block")) + if (szb_inrecord < szb_outrecord) + pad_record = YES + else + pad_record = NO + if (szb_inrecord > szb_outrecord) + trim_record = YES + else + trim_record = NO + if (pad_block == YES || pad_record == YES) { + call clgstr ("padchar", padchar, SZ_PADCHAR) + ip = 1 + if (cctoc (padchar, ip, cval) <= 0) + cval = ' ' + if (IS_DIGIT (cval)) + padvalue = TO_INTEG (cval) + else + padvalue = cval + } + + # Tape to disk always requires reblocking. + if (intape == YES && outtape == NO) + reblock = YES + else if (pad_record == YES || pad_block == YES || trim_record == YES) + reblock = YES + else if (!IS_INDEFI(szb_outblock) || !IS_INDEFI(szb_inrecord) || + !IS_INDEFI(szb_outrecord)) + reblock = YES + else + reblock = NO + + # Get remaining parameters. + nskip = max (0, clgeti ("skipn")) + ncopy = clgeti ("copyn") + if (IS_INDEFI(ncopy)) + ncopy = MAX_INT + byteswap = btoi (clgetb ("byteswap")) + wordswap = btoi (clgetb ("wordswap")) + verbose = clgetb ("verbose") + + # Loop through the files + file_cnt = 1 + file_number = 0 + while (get_next_number (range, file_number) != EOF) { + + # Construct the input file name. + if (intape == YES) { + if (mtneedfileno (infiles) == YES) + call mtfname (infiles, file_number, in_fname, SZ_FNAME) + else + call strcpy (infiles, in_fname, SZ_FNAME) + } else if (fntgfnb (inlist, in_fname, SZ_FNAME) != EOF) + ; + + # Construct the output file name. + if (outtape == NO) { + if (len_inlist > 1 && len_outlist == 1) { + call sprintf (out_fname[1], SZ_FNAME, "%s%03d") + call pargstr (outfiles) + if (intape == YES) + call pargi (file_number + offset) + else + call pargi (file_cnt) + } else if (fntgfnb (outlist, out_fname, SZ_FNAME) != EOF) + ; + } else if (file_cnt == 2) + call mtfname (out_fname, EOT, out_fname, SZ_FNAME) + + iferr { + + if (verbose) { + call printf ("File: %s -> %s: ") + call pargstr (in_fname) + call pargstr (out_fname) + } + + call reb_reblock_file (in_fname, out_fname, outparam) + + if (verbose) { + if (intape == YES) + call printf ("[skip %d blks] ") + else + call printf ("[skip %d recs] ") + call pargi (nskip) + call printf ("blks r/w %d/%d ") + call pargi (BLKS_RD(outparam)) + call pargi (BLKS_WRT(outparam)) + if (reblock == YES) { + call printf ("recs r/w %d/%d\n") + call pargi (RECS_RD(outparam)) + call pargi (RECS_WRT(outparam)) + } else + call printf ("\n") + } + + } then { + call flush (STDOUT) + call eprintf ("Cannot read file %s\n") + call pargstr (in_fname) + } else if (BLKS_RD(outparam) == 0) { + if (verbose) { + call printf ("Empty file: %s\n") + call pargstr (in_fname) + } + break + } else { + file_cnt = file_cnt + 1 + } + } + + if (inlist != NULL) + call fntclsb (inlist) + if (outlist != NULL) + call fntclsb (outlist) +end diff --git a/pkg/dataio/rfits.par b/pkg/dataio/rfits.par new file mode 100644 index 00000000..6ea66586 --- /dev/null +++ b/pkg/dataio/rfits.par @@ -0,0 +1,12 @@ +fits_file,f,a,"mta",,,"FITS data source" +file_list,s,a,"",,,"File/extensions list" +iraf_file,f,a,"",,,"IRAF filename" +make_image,b,h,yes,,,"Create an IRAF image?" +long_header,b,h,no,,,"Print FITS header cards?" +short_header,b,h,yes,,,"Print short header?" +datatype,s,h,"",,,"IRAF data type" +blank,r,h,0.,,,"Blank value" +scale,b,h,yes,,,"Scale the data?" +oldirafname,b,h,no,,,"Use old IRAF name in place of iraf_file?" +offset,i,h,0,,,"Tape file offset" +mode,s,h,"ql",,, diff --git a/pkg/dataio/rtextimage.par b/pkg/dataio/rtextimage.par new file mode 100644 index 00000000..86614e90 --- /dev/null +++ b/pkg/dataio/rtextimage.par @@ -0,0 +1,9 @@ +# Parameter file for t_rtextimage, text file to IRAF image converter + +input,f,a,,,,Input text file +output,f,a,,,,Output image file +otype,s,h,"",,,Pixel type on output +header,b,h,yes,,,Read FITS header preceding pixels? +pixels,b,h,yes,,,Read pixels? +nskip,i,h,0,,,Number of lines to skip +dim,s,h,,,,Image dimension string diff --git a/pkg/dataio/t2d.par b/pkg/dataio/t2d.par new file mode 100644 index 00000000..a50cbbd5 --- /dev/null +++ b/pkg/dataio/t2d.par @@ -0,0 +1,5 @@ +input,s,a,,,,Input file descriptor +ofroot,s,a,,,,Output file root name +files,s,a,,,,List of files +verbose,b,h,yes,,,Print out progress reports +errignore,b,h,yes,,,Assume an error record is zero bytes long diff --git a/pkg/dataio/t2d/mkpkg b/pkg/dataio/t2d/mkpkg new file mode 100644 index 00000000..32b680dd --- /dev/null +++ b/pkg/dataio/t2d/mkpkg @@ -0,0 +1,10 @@ +# T2d contributions to Dataio Library + +$checkout libpkg.a ../ +$update libpkg.a +$checkin libpkg.a ../ +$exit + +libpkg.a: + t_t2d.x <fset.h> <error.h> <mach.h> + ; diff --git a/pkg/dataio/t2d/t_t2d.x b/pkg/dataio/t2d/t_t2d.x new file mode 100644 index 00000000..f21fe4da --- /dev/null +++ b/pkg/dataio/t2d/t_t2d.x @@ -0,0 +1,280 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <error.h> +include <fset.h> +include <mach.h> + +define OBUF_PAD 35536 +define SZ_OBUF 100000 +define SWAP {temp=$1;$1=$2;$2=temp} +define MAX_RANGES 200 + +# T2D -- This is an asynchronous tape to disk copy routine. +# T2d sets up a large output buffer (many blocks long) and reads from +# the input device directly into this output buffer, keeping track of where in +# the output buffer it is. When it reaches a predetermined point in the output +# buffer, it writes an integral number of blocks to the output device, moves +# the leftover input data to the beginning of the alternate buffer and +# continues reading. (until EOF, then it writes out whatever is left). +# The user specifies which files on tape he or she wants and a root name +# for the output file names. + +procedure t_t2d() + +char input[SZ_FNAME] +char files[SZ_LINE] +char ofroot[SZ_FNAME] # Root file name, output files. + +char tapename[SZ_FNAME] +char dfilename[SZ_FNAME] # Disk file name. +int filerange[2 * MAX_RANGES + 1] +int nfiles, filenumber, numrecords +bool verbose +bool errignore + +int mtfile(), strlen(), decode_ranges(), mtneedfileno() +int get_next_number(), tape2disk() +bool clgetb() + +begin + call fseti (STDOUT, F_FLUSHNL, YES) + + # Get input file(s). + call clgstr ("input", input, SZ_FNAME) + if (mtfile(input) == NO || mtneedfileno(input) == NO) + call strcpy ("1", files, SZ_LINE) + else + call clgstr ("files", files, SZ_LINE) + + if (decode_ranges (files, filerange, MAX_RANGES, nfiles) == ERR) + call error (0, "Illegal file number list.") + + # Get root output filename, the verbose flag, and the error-ignore flag. + call clgstr ("ofroot", ofroot, SZ_FNAME) + verbose = clgetb ("verbose") + errignore = clgetb ("errignore") + filenumber = 0 + + if (mtfile(input) == YES && mtneedfileno(input) == YES) { + # Loop over files + while (get_next_number (filerange, filenumber) != EOF) { + + # Assemble the appropriate tape file name. + call mtfname (input, filenumber, tapename, SZ_FNAME) + + # Assemble the appropriate disk file name. + call strcpy (ofroot, dfilename, SZ_FNAME) + call sprintf (dfilename[strlen(ofroot) + 1], SZ_FNAME, "%03d") + call pargi (filenumber) + + # Print out the tape file we are trying to read. + if (verbose) { + call printf ("%s ") + call pargstr (tapename) + call flush (STDOUT) + } + + + # Do the tape to disk transfer. + iferr { + numrecords = tape2disk (tapename, dfilename, errignore) + } then { + call eprintf ("Error reading file: %s\n") + call pargstr (tapename) + call erract (EA_WARN) + next + } else if (numrecords == 0) { + call deletefg (dfilename, YES, YES) + if (verbose) + call printf ("Tape at EOT\n") + break + } else if (verbose){ + call printf (" wrote `%s'\n") + call pargstr(dfilename) + } + + } # End while. + + } else { + + # Print out the tape file we are trying to read. + if (verbose) { + call printf ("%s ") + call pargstr(input) + call flush (STDOUT) + } + + # Do the tape to disk transfer. + iferr { + numrecords = tape2disk (input, ofroot, errignore) + } then { + call eprintf ("Error reading file: %s\n") + call pargstr (input) + call erract (EA_WARN) + } else if (numrecords == 0) { + call deletefg (input, YES, YES) + if (verbose) + call printf ("Tape at EOT\n") + } else if (verbose){ + call printf (" wrote `%s'\n") + call pargstr(ofroot) + } + } +end + + +# TAPE2DISK -- This is the actual tape to disk copy routine. + +int procedure tape2disk (infile, outfile, errignore) + +char infile[SZ_FNAME] +char outfile[SZ_FNAME] +bool errignore + +bool inblock +int blksize, mxbufszo, numblks, cutoff, obufsize, temp, numrecords +int inblksize, innumblks, toread, mxbufszi +long ooffset +int nchars, stat, in, out, lastnchars +pointer op, otop, bufa, bufb + +int fstati(), mtopen(), open(), await() + +begin + # Open the input and output files. + in = mtopen (infile, READ_ONLY, 0) + out = open (outfile, NEW_FILE, BINARY_FILE) + + # Find out how big the blocks are on the output device. Calculate + # an output buffer size which is an integral number of blocks long + # and is long enough to permit many input reads per output write. + # Here, I use the maximum output buffer size. + + blksize = fstati (out, F_BLKSIZE) # Outputfile block size + mxbufszo = fstati (out, F_MAXBUFSIZE) # Maximum output buffer size + mxbufszi = fstati (in, F_MAXBUFSIZE) # Maximum in buffer size + if (mxbufszo <= 0) # if no max, set a max + mxbufszo = SZ_OBUF + if (mxbufszi <= 0) # if no max, set a max + mxbufszi = OBUF_PAD + numblks = mxbufszo / blksize # No. blocks in 'out' buffer + + # Find out if the input device is blocked and if it is, the block + # size. + inblksize = fstati (in, F_BLKSIZE) # Inputfile block size + inblock = true + if (inblksize == 0) + inblock = false + + # Put an extra OBUF_PAD chars in the output buffer to allow for + # overruns on the last input read before we do an output write. + + cutoff = numblks * blksize + obufsize = cutoff + OBUF_PAD + + call malloc (bufa, obufsize, TY_CHAR) # Allocate output buffer. + call malloc (bufb, obufsize, TY_CHAR) # Other output buffer + op = bufa # Movable pointer inside buffer + otop = bufa + cutoff # Point to full position (top) + + ooffset = 1 # Output offset. + nchars = 0 # Number of chars. + numrecords = 0 # Number of records read. + lastnchars = 0 + + # Main Loop. + repeat { + # A series of reads of the input file are required to fill the + # output buffer. + + if (inblock) { + innumblks = (cutoff - (op - bufa)) / inblksize + toread = (innumblks+1) * inblksize + + call aread (in, Memc[op], toread, 1) + nchars = await (in) + if (nchars <= 0) { + if (nchars == ERR) { + # report read error + call eprintf ("error on read\n") + call flush (STDERR) + + # If errignore, do not move pointer, else, + # assume data. + if (!errignore) + nchars = toread + } + # If we found the EOF + if (nchars == 0) { + cutoff = op - bufa + } + } else if (nchars < toread) { + numrecords = numrecords + 1 + cutoff = op - bufa + nchars + nchars = 0 + } else { + numrecords = numrecords + 1 + op = op + nchars + } + + } else { + + repeat { + call aread (in, Memc[op], mxbufszi, 1) + nchars = await (in) + + if (nchars <= 0) { + if (nchars == ERR) { + # report read error + call eprintf ("error on read\n") + call flush (STDERR) + + # If errignore, do not move pointer, else, + # assume data. + if (!errignore) + nchars = lastnchars + } + # If we found the EOF + if (nchars == 0) { + cutoff = op - bufa + break + } + } + + if (nchars > 0) { + numrecords = numrecords + 1 + lastnchars = nchars + op = op + nchars + } + + } until (op >= otop) + } # end of 'if (inblock)' + + # Wait for last write to finish and initiate next write. + stat = await (out) + if (stat == ERR) + call eprintf ("error on write\n") + call awrite (out, Memc[bufa], cutoff, ooffset) + ooffset = ooffset + cutoff # Update the output offset. + + # Copy leftover buffer elements into the bottom of other buffer. + if ((op - otop) > 0) + call amovc (Memc[otop], Memc[bufb], op - otop) + op = bufb + (op - otop) + + # Swap buffers + SWAP (bufa, bufb) + otop = bufa + cutoff + } until (nchars == 0) # all done + + stat = await (out) # wait for final write to finish. + if (stat == ERR) + call eprintf ("error on write\n") + + call close (in) + call close (out) + call mfree (bufa, TY_CHAR) + call mfree (bufb, TY_CHAR) + + return (numrecords) +end diff --git a/pkg/dataio/txtbin.par b/pkg/dataio/txtbin.par new file mode 100644 index 00000000..09e9bf97 --- /dev/null +++ b/pkg/dataio/txtbin.par @@ -0,0 +1,4 @@ +mode,s,h,"ql",,, +text_file,s,a,,,,Input file name(s) +binary_file,s,a,,,,Output file name(s) +verbose,b,h,yes,,,Print messages? diff --git a/pkg/dataio/wcardimage.par b/pkg/dataio/wcardimage.par new file mode 100644 index 00000000..610a867d --- /dev/null +++ b/pkg/dataio/wcardimage.par @@ -0,0 +1,11 @@ +mode,s,h,"ql",,, +textfile,s,a,,,,"Text file(s)" +cardfile,s,a,,,,"Card image file(s)" +new_tape,b,a,,,,"Blank tape?" +contn_string,s,h,>>,,,"Marker for oversize lines" +verbose,b,h,yes,,,"Print messages of actions performed?" +detab,b,h,yes,,,"Detab string and replace with blanks?" +card_length,i,h,80,,,"Columns per card" +cards_per_blk,i,h,50,,,"Card images per block" +ebcdic,b,h,no,,,"Convert from ASCII to EBCDIC?" +ibm,b,h,no,,,"Convert from ASCII to IBM(EBCDIC)?" diff --git a/pkg/dataio/wfits.par b/pkg/dataio/wfits.par new file mode 100644 index 00000000..eb48586b --- /dev/null +++ b/pkg/dataio/wfits.par @@ -0,0 +1,18 @@ +# WFITS parameters + +iraf_files,s,a,,,,IRAF images +fits_files,f,a,,,,FITS filename(s) +newtape,b,a,,,,Blank tape? +fextn,s,h,"fits",,,Extension to append to output disk FITS filename(s) +extensions,b,h,no,,,Write all images to a single FITS file ? +global_hdr,b,h,yes,,,Prepend a global header to the FITS extensions file ? +make_image,b,h,yes,,,Create a FITS image file? +long_header,b,h,no,,,Print FITS header cards? +short_header,b,h,yes,,,Print short header? +bitpix,i,h,0,,,FITS bits per pixel +blocking_factor,i,h,0,0,10,FITS tape blocking factor +scale,b,h,yes,,,Scale data? +autoscale,b,h,yes,,,Auto_scaling? +bscale,r,a,1.0,,,FITS bscale +bzero,r,a,0.0,,,FITS bzero +mode,s,h,ql,,, diff --git a/pkg/dataio/wtextimage.par b/pkg/dataio/wtextimage.par new file mode 100644 index 00000000..276a9728 --- /dev/null +++ b/pkg/dataio/wtextimage.par @@ -0,0 +1,8 @@ +# Parameter file for t_wtextimage, IRAF image to text file converter + +input,f,a,,,,Input image file +output,f,a,,,,Output text file +header,b,h,yes,,,Print header information? +pixels,b,h,yes,,,Print pixel values? +format,s,h,"",,,Pixel format <w.d[defgz]> +maxlinelen,i,h,80,1,322,Maximum line length output diff --git a/pkg/dataio/x_dataio.x b/pkg/dataio/x_dataio.x new file mode 100644 index 00000000..598c1e6e --- /dev/null +++ b/pkg/dataio/x_dataio.x @@ -0,0 +1,17 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Dataio package. + +task rcardimage = t_rcardimage, + wcardimage = t_wcardimage, + mtexamine = t_mtexamine, + txtbin = t_txtbin, + bintxt = t_bintxt, + rtextimage = t_rtextimage, + wtextimage = t_wtextimage, + reblock = t_reblock, + rfits = t_rfits, + wfits = t_wfits, + t2d = t_t2d, + import = t_import, + export = t_export |