Initial commit

1 files changed, 563 insertions, 0 deletions

diff --git a/vendor/x11iraf/guidemo/imbrowse.x b/vendor/x11iraf/guidemo/imbrowse.x
new file mode 100644
index 00000000..10110af0
--- /dev/null
+++ b/vendor/x11iraf/guidemo/imbrowse.x
@@ -0,0 +1,563 @@
+include <error.h>
+include <diropen.h>
+include <ctype.h>
+include	<finfo.h>
+include <imhdr.h>
+include <imio.h>
+include <gset.h>
+include <gim.h>
+
+define	SZ_BIGBUF	16384
+define	USER_AREA	Memc[($1+IMU-1)*SZ_STRUCT + 1]
+define	SAMPLE_SIZE	600
+define	NCOLORS		200
+define	MAX_INTENSITY	255
+define	SWATH		32
+
+
+# IMBROWSE -- Image browser GUI demo task.
+
+procedure t_imbrowse()
+
+pointer	gp
+real	x, y
+int	wcs, key, ip, op
+char	directory[SZ_PATHNAME]
+char	buf[SZ_LINE], cmd[SZ_FNAME], args[SZ_LINE]
+char	device[SZ_FNAME], uifname[SZ_PATHNAME], template[SZ_LINE]
+char	section[SZ_LINE], strval[SZ_LINE], curdir[SZ_PATHNAME]
+
+bool	streq()
+pointer	gopenui()
+int	clgcur(), clgeti()
+int	imb_isdirectory()
+
+begin
+	# Get the start directory.
+	if (clgeti ("$nargs") > 0) {
+	    call clgstr ("directory", directory, SZ_PATHNAME)
+	    if (imb_isdirectory (directory, curdir, SZ_PATHNAME) > 0)
+		call strcpy (curdir, directory, SZ_PATHNAME)
+	    else
+		directory[1] = EOS
+	} else
+	    directory[1] = EOS
+
+	call clgstr ("device", device, SZ_FNAME)
+	call clgstr ("uifname", uifname, SZ_FNAME)
+	call clgstr ("template", template, SZ_LINE)
+	call clgstr ("section", section, SZ_LINE)
+
+	gp = gopenui (device, NEW_FILE, uifname, STDGRAPH)
+	call gmsg (gp, "template", template)
+	call gmsg (gp, "section", section)
+
+	call fpathname (directory, curdir, SZ_PATHNAME)
+	call imb_setdir (gp, curdir, ".", template)
+
+	while (clgcur ("coords", x, y, wcs, key, strval, SZ_LINE) != EOF) {
+	    switch (key) {
+	    case 'q', 'Q':
+		break
+
+	    case ':':
+		for (ip=1;  IS_WHITE(strval[ip]);  ip=ip+1)
+		    ;
+		op = 1
+		while (strval[ip] != EOS && !IS_WHITE(strval[ip])) {
+		    cmd[op] = strval[ip]
+		    op = op + 1
+		    ip = ip + 1
+		}
+		cmd[op] = EOS
+		for (  ;  IS_WHITE(strval[ip]);  ip=ip+1)
+		    ;
+		call strcpy (strval[ip], args, SZ_LINE)
+
+		if (streq (cmd, "chdir")) {
+		    call imb_setdir (gp, curdir, args, template)
+
+		} else if (streq (cmd, "template")) {
+		    call strcpy (args, template, SZ_LINE)
+		    call imb_setdir (gp, curdir, ".", template)
+
+		} else if (streq (cmd, "section")) {
+		    call strcpy (args, section, SZ_LINE)
+
+		} else if (streq (cmd, "header")) {
+		    call imb_pheader (gp, curdir, args, section)
+
+		} else if (streq (cmd, "display")) {
+		    call imb_display (gp, curdir, args, section)
+
+		} else {
+		    call sprintf (buf, SZ_LINE, "unrecognized command: `%s'\n")
+			call pargstr (strval)
+		    call gmsg (gp, "errormsg", buf)
+		}
+
+	    default:
+		call sprintf (buf, SZ_LINE,
+		    "unrecognized cursor command: key=%c strval=`%s'\n")
+		    call pargi (key)
+		    call pargstr (strval)
+		call gmsg (gp, "errormsg", buf)
+	    }
+	}
+
+	call gclose (gp)
+end
+
+
+# IMB_SETDIR -- Set the current directory.
+
+procedure imb_setdir (gp, curdir, newdir, template)
+
+pointer	gp			#I graphics descriptor
+char	curdir[ARB]		#I current directory
+char	newdir[ARB]		#I new directory or subdirectory
+char	template[ARB]		#I filename template
+
+pointer	s_op, f_op, pt
+int	fd, errcode, nchars
+pointer	sp, lbuf, fname, subdirs, files, dirpath, ftemp
+
+pointer	pt_compile()
+int	errget(), gstrcpy(), imb_isdirectory(), imb_issubdir()
+int	diropen(), nowhite(), getline(), access(), pt_match()
+errchk	fchdir, fpathname, gmsg, diropen, getline, access, pt_compile
+define	error_ 91
+
+begin
+	call smark (sp)
+	call salloc (lbuf, SZ_LINE, TY_CHAR)
+	call salloc (fname, SZ_PATHNAME, TY_CHAR)
+	call salloc (ftemp, SZ_PATHNAME, TY_CHAR)
+	call salloc (subdirs, SZ_COMMAND, TY_CHAR)
+	call salloc (files, SZ_BIGBUF, TY_CHAR)
+	call salloc (dirpath, SZ_PATHNAME, TY_CHAR)
+
+	s_op = subdirs
+	f_op = files
+
+	# We should check for buffer overflow and realloc if it occurs, but
+	# we omit this at present in this demo program.
+
+	iferr {
+	    # Get pathname of new directory.
+	    if (imb_issubdir (curdir, newdir) == YES) {
+		call strcpy (curdir, Memc[fname], SZ_PATHNAME)
+		call zfsubd (Memc[fname], SZ_PATHNAME, newdir, nchars)
+	    } else if (imb_isdirectory(newdir,Memc[dirpath],SZ_PATHNAME) > 0) {
+		call fpathname (Memc[dirpath], Memc[fname], SZ_PATHNAME)
+	    } else
+		call fpathname (newdir, Memc[fname], SZ_PATHNAME)
+
+	    # Read the directory and construct a list of subdirectories and
+	    # a list of files matching the given template.
+
+	    fd = diropen (Memc[fname], PASS_HIDDEN_FILES)
+	    call strcpy (Memc[fname], curdir, SZ_PATHNAME)
+	    call gmsg (gp, "directory", Memc[fname])
+	    pt = pt_compile (template)
+
+	    s_op = s_op + gstrcpy ("/\n", Memc[s_op], ARB)
+	    while (getline (fd, Memc[lbuf]) != EOF) {
+		if (nowhite (Memc[lbuf], Memc[ftemp], SZ_PATHNAME) <= 0)
+		    next
+		call imb_mkfname (Memc[ftemp], curdir, Memc[fname], SZ_PATHNAME)
+		if (access (Memc[fname], 0, DIRECTORY_FILE) == YES)
+		    s_op = s_op + gstrcpy (Memc[lbuf], Memc[s_op], ARB)
+		if (pt_match (pt, Memc[fname]) == YES)
+		    f_op = f_op + gstrcpy (Memc[lbuf], Memc[f_op], ARB)
+	    }
+
+	    call pt_free (pt)
+	    call close (fd)
+	} then
+	    goto error_
+
+	Memc[s_op] = EOS
+	Memc[f_op] = EOS
+
+	call gmsg (gp, "subdirs", Memc[subdirs])
+	call gmsg (gp, "files", Memc[files])
+
+	call sfree (sp)
+	return
+error_
+	errcode = errget (Memc[lbuf], SZ_LINE)
+	call gmsg (gp, "errormsg", Memc[lbuf])
+	call sfree (sp)
+end
+
+
+# IMB_PHEADER -- Print an image header.
+
+procedure imb_pheader (gp, curdir, image, section)
+
+pointer	gp			#I graphics descriptor
+char	curdir[ARB]		#I directory
+char	image[ARB]		#I image name
+char	section[ARB]		#I image section
+
+int	in, min_lenuserarea
+pointer	sp, lbuf, hbuf, ip, op, im, fname
+int	stropen(), getline(), gstrcpy()
+pointer	immap()
+
+begin
+        call smark (sp)
+        call salloc (lbuf, SZ_LINE, TY_CHAR)
+        call salloc (fname, SZ_PATHNAME, TY_CHAR)
+
+	call imb_mkfname (image, curdir, Memc[fname], SZ_PATHNAME)
+	iferr (im = immap (Memc[fname], READ_ONLY, 0)) {
+	    call sprintf (Memc[lbuf], SZ_LINE, "cannot open image `%s'")
+		call pargstr (image)
+	    call gmsg (gp, "errormsg", Memc[lbuf])
+	    call sfree (sp)
+	    return
+	}
+
+	call salloc (hbuf, IM_HDRLEN(im), TY_CHAR)
+	op = hbuf
+
+        # 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)
+
+        # 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
+            Memc[ip] = '\n'
+            Memc[ip+1] = EOS
+
+	    op = op + gstrcpy (Memc[lbuf], Memc[op], ARB)
+        }
+
+	call gmsg (gp, "image_title", IM_TITLE(im))
+	call gmsg (gp, "header", Memc[hbuf])
+
+        call close (in)
+	call imunmap (im)
+        call sfree (sp)
+end
+
+
+# IMB_DISPLAY -- Display an image.
+
+procedure imb_display (gp, curdir, image, section)
+
+pointer	gp			#I graphics descriptor
+char	curdir[ARB]		#I directory
+char	image[ARB]		#I image name
+char	section[ARB]		#I image section
+
+int	ncols, nrows, i, v
+real	contrast, z1, z2, dz1, dz2
+int	r[NCOLORS], g[NCOLORS], b[NCOLORS]
+int	nsample_lines, len_stdline, j1, j2, npix
+pointer	sp, im, fname, lbuf, in, out, pkras
+
+int	clgeti()
+real	clgetr()
+pointer	immap(), imgs2r()
+errchk	gseti, gswind, clgeti, clgetr, zscale, malloc, imgs2r
+errchk	gim_createraster, gim_setmapping, gim_writecolormap, gim_writepixels
+
+begin
+        call smark (sp)
+        call salloc (lbuf, SZ_LINE, TY_CHAR)
+        call salloc (fname, SZ_PATHNAME, TY_CHAR)
+
+	call imb_mkfname (image, curdir, Memc[fname], SZ_PATHNAME)
+	call strcat (section, Memc[fname], SZ_PATHNAME)
+
+	iferr (im = immap (Memc[fname], READ_ONLY, 0)) {
+	    call sprintf (Memc[lbuf], SZ_LINE, "cannot open image `%s%s'")
+		call pargstr (image)
+		call pargstr (section)
+	    call gmsg (gp, "errormsg", Memc[lbuf])
+	    call sfree (sp)
+	    return
+	}
+
+	ncols = IM_LEN(im,1)
+	nrows = IM_LEN(im,2)
+
+	call gmsg (gp, "image_title", IM_TITLE(im))
+
+	# Create raster to hold image.
+	call gim_createraster (gp, 1, 0, ncols, nrows, 8)
+
+	# Associate a WCS with raster 1.
+	call gseti (gp, G_RASTER, 1)
+	call gswind (gp, 0.5, real(ncols) + 0.5, 0.5, real(nrows) + 0.5)
+
+	# Set the primary raster to screen mapping.
+	call gim_setmapping (gp, 1, 0,
+	    1,  CT_PIXEL, 0.0, 0.0, real(ncols), real(nrows),
+	    0,  CT_NDC,   0.0, 0.0, 1.0, 1.0)
+
+	# Write colormap.
+	do i = 1, NCOLORS {
+	    v = MAX_INTENSITY * (real((i - 1)) / (NCOLORS - 1))
+	    r[i] = v;  g[i] = v;  b[i] = v
+	}
+	call gim_writecolormap (gp, 0, LAST_COLOR+1, NCOLORS, r, g, b)
+	call gim_writecolormap (gp, 1, LAST_COLOR+1, NCOLORS, r, g, b)
+
+	contrast = clgetr ("contrast")
+	nsample_lines = clgeti ("nsample_lines")
+	len_stdline = SAMPLE_SIZE / nsample_lines
+	call zscale (im, z1, z2, contrast, SAMPLE_SIZE, len_stdline)
+
+	dz1 = LAST_COLOR + 1
+	dz2 = dz1 + NCOLORS - 1
+	call malloc (out, ncols * SWATH, TY_REAL)
+	call malloc (pkras, ncols * SWATH, TY_CHAR)
+	
+	do j1 = 1, nrows, SWATH {
+	    j2 = min (j1 + SWATH - 1, nrows)
+	    npix = (j2 - j1 + 1) * ncols
+	    in = imgs2r (im, 1, ncols, j1, j2)
+	    call amapr (Memr[in], Memr[out], npix, z1, z2, dz1, dz2)
+	    call achtrb (Memr[out], Memc[pkras], npix)
+	    call gim_writepixels (gp, 1,
+		Memc[pkras], 8, 0, j1-1, ncols, j2-j1+1)
+	}
+
+	call mfree (out, TY_REAL)
+	call mfree (pkras, TY_CHAR)
+	call imunmap (im)
+        call sfree (sp)
+end
+
+
+# IMB_MKFNAME -- Construct a filename given a directory name and the file
+# name.
+
+procedure imb_mkfname (file, directory, fname, maxch)
+
+char	file[ARB]		#I input filename
+char	directory[ARB]		#I directory file resides in
+char	fname[ARB]		#O path to file
+int	maxch			#I max chars out
+
+begin
+	call fdirname (directory, fname, maxch)
+	call strcat (file, fname, maxch)
+end
+
+
+# IMB_ISDIRECTORY -- Test whether the named file is a directory.  Check first 
+# to see if it is a subdirectory of the current directory; otherwise look in
+# the environment to see if it is a logical directory.  If VFN is a directory,
+# return the OS pathname of the directory in pathname, and the number of
+# chars in the pathname as the function value.  Otherwise return 0.
+
+int procedure imb_isdirectory (vfn, pathname, maxch)
+
+char	vfn[ARB]		# name to be tested
+char	pathname[ARB]		# receives path of directory
+int	maxch			# max chars out
+
+bool	isdir
+pointer	sp, fname, op
+int	ip, fd, nchars, ch
+long	file_info[LEN_FINFO]
+int	finfo(), diropen(), gstrcpy(), strlen()
+bool	streq()
+
+begin
+	call smark (sp)
+	call salloc (fname, SZ_PATHNAME, TY_CHAR)
+
+	# Copy the VFN string, minus any whitespace on either end.
+	op = fname
+	for (ip=1;  vfn[ip] != EOS;  ip=ip+1) {
+	    ch = vfn[ip]
+	    if (!IS_WHITE (ch)) {
+		Memc[op] = ch
+		op = op + 1
+	    }
+	}
+	Memc[op] = EOS
+
+	isdir = false
+	if (streq (vfn, ".") || streq (vfn, "..")) {
+	    isdir = true
+
+	} else if (finfo (Memc[fname], file_info) != ERR) {
+	    isdir = (FI_TYPE(file_info) == FI_DIRECTORY)
+
+	    if (isdir) {
+		call fdirname (Memc[fname], pathname, maxch)
+		nchars = strlen (pathname)
+	    }
+
+	} else {
+	    # If we get here, either VFN is a logical directory (with the
+	    # $ omitted), or it is the name of a new file.
+
+	    Memc[op] = '$'
+	    Memc[op+1] = EOS
+	    ifnoerr (fd = diropen (Memc[fname], 0)) {
+		call close (fd)
+		isdir = true
+	    }
+
+	    nchars = gstrcpy (Memc[fname], pathname, maxch)
+	}
+
+	call sfree (sp)
+	if (isdir)
+	    return (nchars)
+	else {
+	    pathname[1] = EOS
+	    return (0)
+	}
+end
+
+
+# IMB_ISSUBDIR -- Test whether the named file is a subdirectory of the 
+# current directory.
+
+int procedure imb_issubdir (curdir, newdir)
+
+char	curdir[ARB]		# current directory
+char	newdir[ARB]		# subdir name to be tested
+
+bool	subdir
+pointer	sp, fname
+int	root, extn, nchars
+long	file_info[LEN_FINFO]
+int	finfo(), btoi()
+bool	streq()
+
+begin
+	call smark (sp)
+	call salloc (fname, SZ_PATHNAME, TY_CHAR)
+
+	subdir = false
+	if (streq (newdir, ".") || streq (newdir, "..")) {
+	    subdir = true
+
+	} else {
+	    call zfnbrk (newdir, root, extn)
+	    if (root == 1) {
+		call strcpy (curdir, Memc[fname], SZ_PATHNAME)
+		call zfsubd (Memc[fname], SZ_PATHNAME, newdir, nchars)
+		if (finfo (Memc[fname], file_info) != ERR)
+		    subdir = (FI_TYPE(file_info) == FI_DIRECTORY)
+	    }
+	}
+
+	call sfree (sp)
+	return (btoi (subdir))
+end
+
+
+# Pattern template matching utility.
+# --------------------------------------
+define	MAX_PATTERNS	64
+define	SZ_PATBUF	SZ_LINE
+
+define	LEN_PATDES	(10 + MAX_PATTERNS * SZ_PATBUF)
+define	PT_NPATTERNS	Memi[$1]
+define	PT_PATBUF	Memi[$1+10+(($2)-1)*SZ_PATBUF]
+
+# PT_COMPILE -- Compile a pattern template into the pattern descriptor.
+# A pattern template is a comma delimited list of patterns, e.g., "*.x,*.y".
+
+pointer procedure pt_compile (template)
+
+char	template[ARB]			#I pattern template
+
+pointer	sp, pattern, pt, op
+int	junk, npatterns, ip, pch, ch
+int	patmake()
+errchk	calloc
+
+begin
+	call smark (sp)
+	call salloc (pattern, SZ_LINE, TY_CHAR)
+
+	call calloc (pt, LEN_PATDES, TY_STRUCT)
+	npatterns = 0
+
+	for (ip=1;  template[ip] == ',' || IS_WHITE (template[ip]);  ip=ip+1)
+	    ;
+
+	while (template[ip] != EOS) {
+	    # Get the next pattern.
+	    op = pattern
+	    Memc[op] = '^';  op = op + 1
+
+	    pch = 0
+	    ch = template[ip]
+
+	    while (ch != EOS && ch != ',' && !IS_WHITE(ch)) {
+		if (ch == '*' && pch != ']') {
+		    Memc[op] = '?'
+		    op = op + 1
+		}
+		Memc[op] = ch
+		op = op + 1
+		ip = ip + 1
+		pch = ch
+		ch = template[ip]
+	    }
+
+	    Memc[op] = '$';  op = op + 1
+	    Memc[op] = EOS
+
+	    # Encode the pattern.
+	    npatterns = npatterns + 1
+	    junk = patmake (Memc[pattern], PT_PATBUF(pt,npatterns), SZ_PATBUF)
+
+	    while (template[ip] == ',' || IS_WHITE (template[ip]))
+		ip = ip + 1
+	}
+
+	PT_NPATTERNS(pt) = npatterns
+	call sfree (sp)
+	return (pt)
+end
+
+
+# PT_MATCH -- Test a string to see if it matches one of the patterns in the
+# compiled pattern template.
+
+int procedure pt_match (pt, str)
+
+pointer	pt			#I pattern template descriptor
+char	str[ARB]		#I string to be matched against template
+
+int	i
+int	patmatch()
+
+begin
+	for (i=1;  i <= PT_NPATTERNS(pt);  i=i+1)
+	    if (patmatch (str, PT_PATBUF(pt,i)) > 0)
+		return (YES)
+
+	return (NO)
+end
+
+
+# PT_FREE -- Free a pattern template descriptor.
+
+procedure pt_free (pt)
+
+pointer	pt			#I pattern template descriptor
+
+begin
+	call mfree (pt, TY_STRUCT)
+end