aboutsummaryrefslogtreecommitdiff
path: root/pkg/images/tv/imexamine/iesimexam.x
diff options
context:
space:
mode:
Diffstat (limited to 'pkg/images/tv/imexamine/iesimexam.x')
-rw-r--r--pkg/images/tv/imexamine/iesimexam.x492
1 files changed, 492 insertions, 0 deletions
diff --git a/pkg/images/tv/imexamine/iesimexam.x b/pkg/images/tv/imexamine/iesimexam.x
new file mode 100644
index 00000000..292364ee
--- /dev/null
+++ b/pkg/images/tv/imexamine/iesimexam.x
@@ -0,0 +1,492 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <error.h>
+include <imhdr.h>
+include <gset.h>
+include <mach.h>
+include "imexam.h"
+
+define CSIZE 24
+
+
+# IE_SIMEXAM -- Draw a perspective view of a surface. The altitude
+# and azimuth of the viewing angle are variable.
+
+procedure ie_simexam (gp, mode, ie, x, y)
+
+pointer gp # GIO pointer
+int mode # Mode
+pointer ie # IMEXAM pointer
+real x, y # Center
+
+real angh, angv # Orientation of surface (degrees)
+real floor, ceiling # Range limits
+
+int wkid
+int x1, x2, y1, y2, nx, ny, npts
+pointer pp, sp, title, str, sdata, work, im, data, ie_gimage(), ie_gdata()
+
+bool clgpsetb()
+int clgpseti()
+real clgpsetr()
+pointer clopset()
+
+int first
+real vpx1, vpx2, vpy1, vpy2
+common /frstfg/ first
+common /noaovp/ vpx1, vpx2, vpy1, vpy2
+
+begin
+ iferr (im = ie_gimage (ie, NO)) {
+ call erract (EA_WARN)
+ return
+ }
+
+ pp = IE_PP(ie)
+ if (pp != NULL)
+ call clcpset (pp)
+ pp = clopset ("simexam")
+ IE_PP(ie) = pp
+
+ nx = clgpseti (pp, "ncolumns")
+ ny = clgpseti (pp, "nlines")
+ angh = clgpsetr (pp, "angh")
+ angv = clgpsetr (pp, "angv")
+ floor = clgpsetr (pp, "floor")
+ ceiling = clgpsetr (pp, "ceiling")
+
+ if (!IS_INDEF(x))
+ IE_X1(ie) = x
+ if (!IS_INDEF(y))
+ IE_Y1(ie) = y
+
+ x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5
+ x2 = IE_X1(ie) + nx / 2 + 0.5
+ y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5
+ y2 = IE_Y1(ie) + ny / 2 + 0.5
+ iferr (data = ie_gdata (im, x1, x2, y1, y2)) {
+ call erract (EA_WARN)
+ return
+ }
+
+ nx = x2 - x1 + 1
+ ny = y2 - y1 + 1
+ npts = nx * ny
+
+ call smark (sp)
+
+ # Take floor and ceiling if enabled (nonzero).
+ if (IS_INDEF (floor) && IS_INDEF (ceiling))
+ sdata = data
+ else {
+ call salloc (sdata, npts, TY_REAL)
+ call amovr (Memr[data], Memr[sdata], npts)
+ if (!IS_INDEF (floor) && !IS_INDEF (ceiling)) {
+ floor = min (floor, ceiling)
+ ceiling = max (floor, ceiling)
+ }
+ }
+ iferr (call ie_surf_limits (Memr[sdata], npts, floor, ceiling)) {
+ call sfree (sp)
+ call erract (EA_WARN)
+ return
+ }
+
+ if (mode != APPEND) {
+ call gclear (gp)
+
+ # Set the viewport.
+ call gsview (gp, 0.1, 0.9, 0.1, 0.9)
+
+ call salloc (title, IE_SZTITLE, TY_CHAR)
+ call salloc (str, SZ_LINE, TY_CHAR)
+
+ if (clgpsetb (pp, "banner")) {
+ call sysid (Memc[str], SZ_LINE)
+ call sprintf (Memc[title], IE_SZTITLE,
+ "%s\n%s: Surface plot of [%d:%d,%d:%d]\n%s")
+ call pargstr (Memc[str])
+ call pargstr (IE_IMNAME(ie))
+ call pargi (x1)
+ call pargi (x2)
+ call pargi (y1)
+ call pargi (y2)
+ call pargstr (IM_TITLE(im))
+ } else
+ Memc[title] = EOS
+
+ call clgpset (pp, "title", Memc[str], SZ_LINE)
+ if (Memc[str] != EOS) {
+ call strcat ("\n", Memc[title], IE_SZTITLE)
+ call strcat (Memc[str], Memc[title], IE_SZTITLE)
+ }
+
+ call gseti (gp, G_DRAWAXES, NO)
+ call glabax (gp, Memc[title], "", "")
+ }
+
+ # Open graphics device and make plot.
+ call gopks (STDERR)
+ wkid = 1
+ call gopwk (wkid, 6, gp)
+ call gacwk (wkid)
+
+ first = 1
+ call srfabd()
+ call ggview (gp, vpx1, vpx2, vpy1, vpy2)
+ call set (vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1)
+ call salloc (work, 2 * (2*nx*ny+nx+ny), TY_REAL)
+ call ezsrfc (Memr[sdata], nx, ny, angh, angv, Memr[work])
+
+ if (mode != APPEND) {
+ if (clgpsetb (pp, "axes")) {
+ call gswind (gp, real (x1), real (x2), real (y1), real (y2))
+ call gseti (gp, G_CLIP, NO)
+ call ie_perimeter (gp, Memr[sdata], nx, ny, angh, angv)
+ }
+ }
+
+ call gdawk (wkid)
+ call gclks ()
+ call sfree (sp)
+end
+
+
+# IE_PERIMETER -- draw and label axes around the surface plot.
+
+procedure ie_perimeter (gp, z, ncols, nlines, angh, angv)
+
+pointer gp # Graphics pointer
+int ncols # Number of image columns
+int nlines # Number of image lines
+real z[ncols, nlines] # Array of intensity values
+real angh # Angle of horizontal inclination
+real angv # Angle of vertical inclination
+
+pointer sp, x_val, y_val, kvec
+char tlabel[10]
+real xmin, ymin, delta, fact1, flo, hi, xcen, ycen
+real x1_perim, x2_perim, y1_perim, y2_perim, z1, z2
+real wc1, wc2, wl1, wl2, del
+int i, j, junk
+int itoc()
+data fact1 /2.0/
+real vpx1, vpx2, vpy1, vpy2
+common /noaovp/ vpx1, vpx2, vpy1, vpy2
+
+begin
+ call smark (sp)
+ call salloc (x_val, ncols + 2, TY_REAL)
+ call salloc (y_val, nlines + 2, TY_REAL)
+ call salloc (kvec, max (ncols, nlines) + 2, TY_REAL)
+
+ # Get window coordinates set up in calling procedure.
+ call ggwind (gp, wc1, wc2, wl1, wl2)
+
+ # Set up window, viewport for output. The coordinates returned
+ # from trn32s are in the range [1-1024].
+ call set (vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1)
+
+ # Find range of z for determining perspective
+ flo = MAX_REAL
+ hi = -flo
+ do j = 1, nlines {
+ call alimr (z[1,j], ncols, z1, z2)
+ flo = min (flo, z1)
+ hi = max (hi, z2)
+ }
+
+ # Set up linear endpoints and spacing as used in surface.
+
+ delta = (hi-flo) / (max (ncols,nlines) -1.) * fact1
+ xmin = -(real (ncols/2) * delta + real (mod (ncols+1, 2)) * delta)
+ ymin = -(real (nlines/2) * delta + real (mod (nlines+1, 2)) * delta)
+ del = 2.0 * delta
+
+ # The perimeter is separated from the surface plot by the
+ # width of delta.
+
+ x1_perim = xmin - delta
+ y1_perim = ymin - delta
+ x2_perim = xmin + (real (ncols) * delta)
+ y2_perim = ymin + (real (nlines) * delta)
+ # Set up linear arrays over full perimeter range
+ do i = 1, ncols + 2
+ Memr[x_val+i-1] = x1_perim + (i-1) * delta
+ do i = 1, nlines + 2
+ Memr[y_val+i-1] = y1_perim + (i-1) * delta
+
+ # Draw and label axes and tick marks.
+ # It is important that frame has not been called after calling srface.
+ # First to draw the perimeter. Which axes get drawn depends on the
+ # values of angh and angv. Get angles in the range [-180, 180].
+
+ if (angh > 180.)
+ angh = angh - 360.
+ else if (angh < -180.)
+ angh = angh + 360.
+
+ if (angv > 180.)
+ angv = angv - 360.
+ else if (angv < -180.)
+ angv = angv + 360.
+
+ # Calculate positions for the axis labels
+ xcen = 0.5 * (x1_perim + x2_perim)
+ ycen = 0.5 * (y1_perim + y2_perim)
+
+ if (angh >= 0) {
+ if (angv >= 0) {
+ # Case 1: xy rotation positive, looking down from above mid Z
+
+ # First draw x axis
+ call amovkr (y2_perim, Memr[kvec], ncols + 2)
+ call ie_draw_axis (Memr[x_val+1], Memr[kvec], flo, ncols + 1)
+ call ie_label_axis (xcen, y2_perim+del, flo, "X-AXIS", -1, -2)
+ call ie_draw_ticksx (Memr[x_val+1], y2_perim, y2_perim+delta,
+ flo, ncols)
+ junk = itoc (int (wc1), tlabel, 10)
+ call ie_label_axis (xmin, y2_perim+del, flo, tlabel, -1, -2)
+ junk = itoc (int (wc2), tlabel, 10)
+ call ie_label_axis (Memr[x_val+ncols], y2_perim+del, flo,
+ tlabel, -1, -2)
+
+ # Now draw y axis
+ call amovkr (x2_perim, Memr[kvec], nlines + 2)
+ call ie_draw_axis (Memr[kvec], Memr[y_val+1], flo, nlines + 1)
+ call ie_label_axis (x2_perim+del, ycen, flo, "Y-AXIS", 2, -1)
+ call ie_draw_ticksy (x2_perim, x2_perim+delta, Memr[y_val+1],
+ flo, nlines)
+ junk = itoc (int (wl1), tlabel, 10)
+ call ie_label_axis (x2_perim+del, ymin, flo, tlabel, 2, -1)
+ junk = itoc (int (wl2), tlabel, 10)
+ call ie_label_axis (x2_perim+del, Memr[y_val+nlines], flo,
+ tlabel, 2, -1)
+ } else {
+ # Case 2: xy rotation positive, looking up from below mid Z
+ # First draw x axis
+ call amovkr (y1_perim, Memr[kvec], ncols + 2)
+ call ie_draw_axis (Memr[x_val], Memr[kvec], flo, ncols + 1)
+ call ie_label_axis (xcen, y1_perim-del, flo, "X-AXIS", -1, 2)
+ call ie_draw_ticksx (Memr[x_val+1], y1_perim, y1_perim-delta,
+ flo, ncols)
+ junk = itoc (int (wc1), tlabel, 10)
+ call ie_label_axis (xmin, y1_perim-del, flo, tlabel, -1, 2)
+ junk = itoc (int (wc2), tlabel, 10)
+ call ie_label_axis (Memr[x_val+ncols], y1_perim-del, flo,
+ tlabel, -1, 2)
+
+ # Now draw y axis
+ call amovkr (x1_perim, Memr[kvec], nlines + 2)
+ call ie_draw_axis (Memr[kvec], Memr[y_val], flo, nlines + 1)
+ call ie_label_axis (x1_perim-del, ycen, flo, "Y-AXIS", 2, 1)
+ call ie_draw_ticksy (x1_perim, x1_perim-delta, Memr[y_val+1],
+ flo, nlines)
+ junk = itoc (int (wl1), tlabel, 10)
+ call ie_label_axis (x1_perim-del, ymin, flo, tlabel, 2, 1)
+ junk = itoc (int (wl2), tlabel, 10)
+ call ie_label_axis (x1_perim-del, Memr[y_val+nlines], flo,
+ tlabel, 2, 1)
+ }
+ }
+
+ if (angh < 0) {
+ if (angv > 0) {
+ # Case 3: xy rotation negative, looking down from above mid Z
+ # (default). First draw x axis
+ call amovkr (y1_perim, Memr[kvec], ncols + 2)
+ call ie_draw_axis (Memr[x_val+1], Memr[kvec], flo, ncols + 1)
+ call ie_label_axis (xcen, y1_perim-del, flo, "X-AXIS", 1, 2)
+ call ie_draw_ticksx (Memr[x_val+1], y1_perim, y1_perim-delta,
+ flo, ncols)
+ junk = itoc (int (wc1), tlabel, 10)
+ call ie_label_axis (xmin, y1_perim-del, flo, tlabel, 1, 2)
+ junk = itoc (int (wc2), tlabel, 10)
+ call ie_label_axis (Memr[x_val+ncols], y1_perim-del, flo,
+ tlabel, 1, 2)
+
+ # Now draw y axis
+ call amovkr (x2_perim, Memr[kvec], nlines + 2)
+ call ie_draw_axis (Memr[kvec], Memr[y_val], flo, nlines + 1)
+ call ie_label_axis (x2_perim+del, ycen, flo, "Y-AXIS", 2, -1)
+ call ie_draw_ticksy (x2_perim, x2_perim+delta, Memr[y_val+1],
+ flo, nlines)
+ junk = itoc (int (wl1), tlabel, 10)
+ call ie_label_axis (x2_perim+del, ymin, flo, tlabel, 2, -1)
+ junk = itoc (int (wl2), tlabel, 10)
+ call ie_label_axis (x2_perim+del, Memr[y_val+nlines], flo,
+ tlabel, 2, -1)
+ } else {
+ # Case 4: xy rotation negative, looking up from below mid Z
+ # First draw x axis
+ call amovkr (y2_perim, Memr[kvec], ncols + 2)
+ call ie_draw_axis (Memr[x_val], Memr[kvec], flo, ncols + 1)
+ call ie_label_axis (xcen, y2_perim+del, flo, "X-AXIS", 1, -2)
+ call ie_draw_ticksx (Memr[x_val+1], y2_perim, y2_perim+delta,
+ flo, ncols)
+ junk = itoc (int (wc1), tlabel, 10)
+ call ie_label_axis (xmin, y2_perim+del, flo, tlabel, 1, -2)
+ junk = itoc (int (wc2), tlabel, 10)
+ call ie_label_axis (Memr[x_val+ncols], y2_perim+del, flo,
+ tlabel, 1, -2)
+
+ # Now draw y axis
+ call amovkr (x1_perim, Memr[kvec], nlines + 2)
+ call ie_draw_axis (Memr[kvec], Memr[y_val+1], flo, nlines + 1)
+ call ie_label_axis (x1_perim-del, ycen, flo, "Y-AXIS", 2, 1)
+ call ie_draw_ticksy (x1_perim, x1_perim-delta, Memr[y_val+1],
+ flo, nlines)
+ junk = itoc (int (wl1), tlabel, 10)
+ call ie_label_axis (x1_perim-del, ymin, flo, tlabel, 2, 1)
+ junk = itoc (int (wl2), tlabel, 10)
+ call ie_label_axis (x1_perim-del, Memr[y_val+nlines], flo,
+ tlabel, 2, 1)
+ }
+ }
+
+ # Flush plotit buffer before returning
+ call plotit (0, 0, 2)
+ call sfree (sp)
+end
+
+
+# ??
+
+procedure ie_draw_axis (xvals, yvals, zval, nvals)
+
+int nvals
+real xvals[nvals]
+real yvals[nvals]
+real zval
+pointer sp, xt, yt
+int i
+real dum
+
+begin
+ call smark (sp)
+ call salloc (xt, nvals, TY_REAL)
+ call salloc (yt, nvals, TY_REAL)
+
+ do i = 1, nvals
+ call trn32s (xvals[i], yvals[i], zval, Memr[xt+i-1], Memr[yt+i-1],
+ dum, 1)
+
+ call gpl (nvals, Memr[xt], Memr[yt])
+ call sfree (sp)
+end
+
+
+# ??
+
+procedure ie_label_axis (xval, yval, zval, sppstr, path, up)
+
+real xval
+real yval
+real zval
+char sppstr[SZ_LINE]
+int path
+int up
+
+int nchars
+int strlen()
+% character*64 fstr
+
+begin
+ nchars = strlen (sppstr)
+
+% call f77pak (sppstr, fstr, 64)
+ call pwrzs (xval, yval, zval, fstr, nchars, CSIZE, path, up, 0)
+end
+
+
+# ??
+
+procedure ie_draw_ticksx (x, y1, y2, zval, nvals)
+
+int nvals
+real x[nvals]
+real y1, y2
+real zval
+
+int i
+real tkx[2], tky[2], dum
+
+begin
+ do i = 1, nvals {
+ call trn32s (x[i], y1, zval, tkx[1], tky[1], dum, 1)
+ call trn32s (x[i], y2, zval, tkx[2], tky[2], dum, 1)
+ call gpl (2, tkx[1], tky[1])
+ }
+end
+
+
+# ??
+
+procedure ie_draw_ticksy (x1, x2, y, zval, nvals)
+
+int nvals
+real x1, x2
+real y[nvals]
+real zval
+
+int i
+real tkx[2], tky[2], dum
+
+begin
+ do i = 1, nvals {
+ call trn32s (x1, y[i], zval, tkx[1], tky[1], dum, 1)
+ call trn32s (x2, y[i], zval, tkx[2], tky[2], dum, 1)
+ call gpl (2, tkx[1], tky[1])
+ }
+end
+
+
+# IE_SURF_LIMITS -- Apply the floor and ceiling constraints to the subraster.
+# If either value is exactly zero, it is not applied.
+
+procedure ie_surf_limits (ras, m, floor, ceiling)
+
+real ras[m]
+int m
+real floor, ceiling
+real val1_1 # value at ras[1]
+int k
+bool const_val # true if data are constant
+bool bad_floor # true if no value is above floor
+bool bad_ceiling # true if no value is below ceiling
+
+begin
+ const_val = true # initial values
+ bad_floor = true
+ bad_ceiling = true
+ val1_1 = ras[1]
+
+ do k = 1, m
+ if (ras[k] != val1_1) {
+ const_val = false
+ break
+ }
+ if (!IS_INDEF(floor)) {
+ do k = 1, m {
+ if (ras[k] <= floor)
+ ras[k] = floor
+ else
+ bad_floor = false
+ }
+ }
+ if (!IS_INDEF(ceiling)) {
+ do k = 1, m {
+ if (ras[k] >= ceiling)
+ ras[k] = ceiling
+ else
+ bad_ceiling = false
+ }
+ }
+
+ if (bad_floor && !IS_INDEF(floor))
+ call error (1, "entire image is below (or at) specified floor")
+ if (bad_ceiling && !IS_INDEF(ceiling))
+ call error (1, "entire image is above (or at) specified ceiling")
+ if (const_val)
+ call error (1, "all data values are the same; can't plot it")
+end
generated by cgit (git 2.34.1) at 2025-09-20 07:41:15 -0400