1 files changed, 430 insertions, 0 deletions
diff --git a/noao/digiphot/photcal/mkimsets/t_imgroup.x b/noao/digiphot/photcal/mkimsets/t_imgroup.x
new file mode 100644
index 00000000..fd560cff
--- /dev/null
+++ b/noao/digiphot/photcal/mkimsets/t_imgroup.x
@@ -0,0 +1,430 @@
+include <fset.h>
+include <ctotok.h>
+
+define	IMG_DEFSZSET	15
+define	IMG_DEFSZNAME	79
+
+# Reformat a file containing a list of images into an image set file using
+# a set definition field and a list of permitted set definition values.
+# The input image list is assumed to have the image name in column 1 and the
+# value of the set definition field in column 2. All the rest of the columns
+# are ignored.  The image set definition field is checked against the list
+# of permitted set defintion field values and the image is rejected if the
+# two do not match. The number of permitted values defines the size of each
+# set.
+
+procedure t_imgroup ()
+
+pointer	imlist			# pointer to the input image list
+pointer	imsetlist		# pointer to the output image set
+pointer	setvals			# pointer to the permitted list of set values
+int	rename 			# prompt the user for image set names
+
+int	in, out, nvalues
+pointer	sp, valnames
+bool	clgetb()
+int	btoi(), open(), ph_listset()
+
+begin
+	call fseti (STDOUT, F_FLUSHNL, YES)
+
+	# Allocate working space.
+	call smark (sp)
+	call salloc (imlist, SZ_FNAME, TY_CHAR)
+	call salloc (imsetlist, SZ_FNAME, TY_CHAR)
+	call salloc (setvals, SZ_FNAME, TY_CHAR)
+
+	# Get the parameters.
+	call clgstr ("imlist", Memc[imlist], SZ_FNAME)
+	call clgstr ("imsetlist", Memc[imsetlist], SZ_FNAME)
+	call clgstr ("setvalues", Memc[setvals], SZ_FNAME)
+	rename = btoi (clgetb ("rename"))
+
+	# Open the input and output files.
+	in = open (Memc[imlist], READ_ONLY, TEXT_FILE)
+	out = open (Memc[imsetlist], NEW_FILE, TEXT_FILE)
+
+	# Group the sets.
+	valnames = NULL
+	nvalues = ph_listset (Memc[setvals], valnames, IMG_DEFSZNAME,
+	    IMG_DEFSZSET)
+	if (nvalues > 0)
+	    call ph_group (in, out, Memc[setvals], Memc[valnames],
+		    IMG_DEFSZNAME, nvalues, rename)
+	else
+	    call eprintf (
+	        "<Error>: The list of permitted set values is empty\n")
+
+	# Close files.
+	call close (in)
+	call close (out)
+
+	if (valnames != NULL)
+	    call mfree (valnames, TY_CHAR)
+	call sfree (sp)
+end
+
+
+# PH_LISTSET -- Extract the individual set defintion values.
+
+int procedure ph_listset (setvals, values, max_lvalue, def_nvalues)
+
+char	setvals[ARB]	        # the list of set values
+pointer	values			# pointer to the array of extracted names
+int	max_lvalue		# maximum length of a value
+int	def_nvalues		# the default number of set values
+
+int	ip, tp, op, token, nc, bufsize, vptr
+pointer	sp, temp
+int	ctowrd(), ctotok(), strlen()
+
+begin
+	# Allocate working space.
+	call smark (sp)
+	call salloc (temp, SZ_LINE, TY_CHAR)
+	bufsize = def_nvalues
+	call malloc (values, (max_lvalue + 1) * bufsize, TY_CHAR)
+
+	# Decode the individual values.
+	nc = 0
+	ip = 1
+	vptr = values
+	while (setvals[ip] != EOS) {
+
+	    # Extract whitespace separated strings.
+	    if (ctowrd (setvals, ip, Memc[temp], SZ_LINE) <= 0)
+		break
+
+	    # Initialize token extraction.
+	    tp = 1
+	    op = 1
+
+	    # Check the extracted string for imbedded punctuation.
+	    # Only commas and semi-colons are recognized.
+
+	    while (Memc[temp+tp-1] != EOS) {
+	        token = ctotok (Memc[temp], tp, Memc[vptr+op-1], max_lvalue)
+                if (Memc[vptr+op-1] == EOS)
+                    next
+		if (token == TOK_UNKNOWN || token == TOK_CHARCON)
+		    next
+		if ((token == TOK_PUNCTUATION) && (Memc[vptr+op-1] == ',' ||
+		    Memc[vptr+op-1] == ';')) {
+		    Memc[vptr+op-1] = EOS
+		    nc = nc + 1
+		    op = 1
+		} else
+		    op = op + strlen (Memc[vptr+op-1])
+		vptr = values + nc * (max_lvalue + 1)
+	        if (nc < def_nvalues)
+		    next
+	        bufsize = bufsize + def_nvalues
+	        call realloc (values, (max_lvalue + 1) * bufsize, TY_CHAR)
+	    }
+
+	    if (op > 1)
+	        nc = nc + 1
+	    vptr = values + nc * (max_lvalue + 1)
+	    if (nc < def_nvalues)
+		next
+	    bufsize = bufsize + def_nvalues
+	    call realloc (values, (max_lvalue + 1) * bufsize, TY_CHAR)
+	}
+
+	call sfree (sp)
+
+	# Return the number of values successfully decoded.
+	call realloc (values, (max_lvalue + 1) * nc, TY_CHAR)
+	return (nc)
+end
+
+
+# PH_GROUP -- Group the data into sets.
+
+procedure ph_group (in, out, filters, values, max_lvalue, nvalues, rename)
+
+int	in			# the input file descriptor
+int	out			# the output file descriptor
+char	filters[ARB]		# the filter set
+char	values[max_lvalue,ARB]	# list of permitted set values
+int	max_lvalue		# maximum length of a set value
+int	nvalues			# the number of permitted values
+int	rename			# prompt for the image set names
+
+int	i, numindex, ns, nsets, op, num
+pointer	sp, image, setval, name, tname, index, record
+int	fscan(), nscan(), ph_member(), gstrcpy()
+
+begin
+	# Allocate working space.
+	call smark (sp)
+	call salloc (image, SZ_FNAME, TY_CHAR)
+	call salloc (setval, SZ_LINE, TY_CHAR)
+	call salloc (tname, SZ_FNAME, TY_CHAR)
+	call salloc (name, SZ_FNAME, TY_CHAR)
+	call salloc (index, nvalues, TY_INT)
+	call salloc (record, SZ_LINE, TY_CHAR)
+
+	# Issue explanatory message.
+	if (rename == YES) {
+	    call printf ("\n")
+	    call printf ("Enter/Confirm Names for Each Image Set\n")
+	    call printf ("\n")
+	}
+
+	# Initialize.
+	ns = 0
+	nsets = 0
+	op = 1
+	call amovki (0, Memi[index], nvalues)
+
+	# Read the input file.
+	while (fscan (in) != EOF) {
+
+	    # Get the image name and set definition from columns 1 and 2.
+	    call gargwrd (Memc[image], SZ_FNAME)
+	    call gargwrd (Memc[setval], SZ_LINE)
+	    if (nscan() < 1)
+		next
+	    if (Memc[image] == '#')
+		next
+	    if (nscan() < 2)
+		Memc[setval] = EOS
+
+	    # Check for set membership.
+	    if ((nvalues == 1) && (values[1,1] == EOS))
+		num = 1
+	    else {
+	        num = ph_member (Memc[setval], values, max_lvalue, nvalues)
+	        if (num == 0) {
+		    call eprintf ("<Warning>: Image %s filter id %s ")
+			call pargstr (Memc[image])
+			call pargstr (Memc[setval])
+		    call eprintf (
+		        " does not belong to the filter set %s\n")
+			call pargstr (filters)
+		    next
+		}
+	    }
+
+	    # Check to see if a particular slot is already filled.
+	    # Terminate the set if a duplicate set member is found.
+
+	    numindex = Memi[index+num-1]
+	    if (numindex != 0) {
+		call eprintf ("<Warning> Set %d image %s has the same ")
+		    call pargi (nsets + 1)
+		    call pargstr (Memc[image])
+		call eprintf ("filter id %s as image %s\n")
+		    call pargstr (Memc[setval])
+		    call pargstr (Memc[record+numindex-1])
+		do i = 1, nvalues {
+		    if (Memi[index+i-1] != 0)
+			next
+		    Memi[index+i-1] = op
+		    op = op + gstrcpy ("INDEF", Memc[record+op-1],
+		        SZ_LINE - op + 1) + 1
+		    ns = ns + 1
+		}
+	    } else {
+		Memi[index+num-1] = op
+	        ns = ns + 1
+		op = op + gstrcpy (Memc[image], Memc[record+op-1],
+		    SZ_LINE - op + 1) + 1
+	    }
+
+	    # Write out the new set and begin working on the next set.
+	    if (ns == nvalues) {
+
+		nsets = nsets + 1
+
+		# Get the set name.
+		call sprintf (Memc[tname], SZ_LINE, "OBS%d")
+		    call pargi (nsets)
+		if (rename == YES) {
+	            call ph_swrite (STDOUT, Memc[tname], Memc[record],
+		        Memi[index], nvalues)
+		    call ph_rname (Memc[tname], Memc[name], SZ_LINE)
+		} else
+		    call strcpy (Memc[tname], Memc[name], SZ_LINE)
+
+		# Write out the new set.
+		call ph_swrite (out, Memc[name], Memc[record], Memi[index], 
+		    nvalues)
+
+		# Reinitialize.
+		ns = 0
+		op = 1
+		call amovki (0, Memi[index], nvalues)
+	    }
+
+	    if (numindex != 0) {
+		Memi[index+num-1] = op
+	        ns = ns + 1
+		op = op + gstrcpy (Memc[image], Memc[record+op-1],
+		    SZ_LINE - op + 1) + 1
+	    }
+	}
+
+	# Write out the last record to the output file.
+	if (ns > 0) {
+
+	    # Fill in the missing values.
+	    do i = 1, nvalues {
+		if (Memi[index+i-1] != 0)
+		    next
+		Memi[index+i-1] = op
+		op = op + gstrcpy ("INDEF", Memc[record+op-1],
+		    SZ_LINE - op + 1) + 1
+	    }
+
+	    nsets = nsets + 1
+
+	    # Prompt for the image set name.
+	    call sprintf (Memc[tname], SZ_LINE, "OBS%d")
+		call pargi (nsets)
+	    if (rename == YES) {
+	        call ph_swrite (STDOUT, Memc[tname], Memc[record], Memi[index],
+	            nvalues)
+		call ph_rname (Memc[tname], Memc[name], SZ_LINE)
+	    } else
+		call strcpy (Memc[tname], Memc[name], SZ_LINE)
+
+	    # Write the record.
+	    call ph_swrite (out, Memc[name], Memc[record], Memi[index],
+	        nvalues)
+	}
+
+	# Warn the user if the set is empty.
+	if (nsets <= 0)
+	    call eprintf ("\n<Warning> The image set file is empty\n\n")
+	else
+	    call eprintf ("\n")
+
+	call sfree (sp)
+end
+
+
+# PH_MEMBER -- Test whether the string belongs to a permitted list
+# of values.
+
+int procedure ph_member (setval, values, max_lvalue, nvalues)
+
+char	setval[ARB]		# the set value
+char	values[max_lvalue,ARB]	# the permitted list of possible set values
+int	max_lvalue		# maximum length of the set value
+int	nvalues			# the number of set values
+
+int	nc, i
+bool	streq()
+
+begin
+	nc = 0
+	do i = 1, nvalues {
+	    if (streq (setval, values[1,i]))
+		nc = i
+	}
+
+	return (nc)
+end
+
+
+# PH_SWRITE -- Write out the finshed set to a file.
+
+procedure ph_swrite (out, name, record, index, nvalues)
+
+int	out		# output file descriptor
+char	name[ARB]	# the name of the output field
+char	record[ARB]	# the name of the output record
+int	index[ARB]	# array of indices
+int	nvalues		# number of values
+
+pointer	sp, str
+int	i
+
+begin
+	call smark (sp)
+	call salloc (str, SZ_FNAME, TY_CHAR)
+
+	call fprintf (out, "%s :")
+	    call pargstr (name)
+
+	do i = 1, nvalues {
+	    call ph_imroot (record[index[i]], Memc[str], SZ_FNAME)
+	    call fprintf (out, "  %s")
+		#call pargstr (record[index[i]])
+		call pargstr (Memc[str])
+	}
+
+	call fprintf (out, "\n")
+
+	call sfree (sp)
+end
+
+
+# PH_RNAME -- Prompt the user for a field name.
+
+procedure ph_rname (tname, name, max_lname)
+
+char	tname[ARB]		# temporary input name
+char	name[ARB]		# the final output name
+int	max_lname		# the maximum length of the name
+
+int	scan()
+
+begin
+	# Issue a prompt to the user
+	call printf ("\tEnter new name for field %s (name, <CR>=ok): ")
+	    call pargstr (tname)
+	call flush (STDOUT)
+
+	# Get the new value
+	if (scan () == EOF)
+	    name[1] = EOS
+	else
+	    call gargwrd (name, max_lname)
+	if (name[1] == EOS)
+	    call strcpy (tname, name, max_lname)
+
+	call printf ("\n")
+end
+
+
+# PH_IMROOT -- Fetch the root image name minus the directory specification
+# and the section notation.
+
+procedure ph_imroot (image, root, maxch)
+
+char    image[ARB]              # image specification
+char    root[ARB]               # output root name
+int     maxch                   # maximum number of characters
+
+pointer sp, imroot, kernel, section, str
+int     clindex, clsize, nchars
+int     fnldir()
+
+begin
+        call smark (sp)
+        call salloc (imroot, SZ_PATHNAME, TY_CHAR)
+        call salloc (kernel, SZ_FNAME, TY_CHAR)
+        call salloc (section, SZ_FNAME, TY_CHAR)
+        call salloc (str, SZ_PATHNAME, TY_CHAR)
+
+        call imparse (image, Memc[imroot], SZ_PATHNAME, Memc[kernel], SZ_FNAME,
+            Memc[section], SZ_FNAME, clindex, clsize)
+        nchars = fnldir (Memc[imroot], Memc[str], SZ_PATHNAME)
+	if (clindex >= 0) {
+            call sprintf (root, maxch, "%s[%d]%s%s")
+                call pargstr (Memc[imroot+nchars])
+		call pargi (clindex)
+                call pargstr (Memc[kernel])
+                call pargstr (Memc[section])
+	} else {
+            call sprintf (root, maxch, "%s%s%s")
+                call pargstr (Memc[imroot+nchars])
+                call pargstr (Memc[kernel])
+                call pargstr (Memc[section])
+	}
+
+        call sfree (sp)
+end