#=================================================================  gpxtest.icn



############################################################################
#
#	File:     gpxtest.icn
#
#	Subject:  Program to test graphics procedures
#
#	Author:   Gregg M. Townsend
#
#	Date:     September 26, 1995
#
############################################################################
#
#  This program exercises a wide variety of graphics operations.  Several
#  independent output tests are run in square cells within a window.  The
#  resulting image can be compared with a standard image to determine its
#  correctness.  
#
#  The "Dialog" button brings up an interactive dialog box test; the
#  "Quit" button exits the program.
#
#  Some variations among systems are expected in the areas of fonts,
#  attribute values, and availability of mutable colors.  The first test,
#  involving window resizing, produces results that do not exactly fit the
#  grid pattern of the other tests; that is also expected.
#
#  This program is designed for a color display, but it also works on
#  monochrome systems.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links: button, dsetup, evmux, graphics
#
############################################################################

#====== link button
#====== link dsetup
#====== link evmux
#====== link graphics


$define CELL 80				# size of one test "cell"
$define HALF (CELL / 2)			# half a cell
$define GAP 10				# gap between cells

$define NWIDE 6				# number of cells across
$define NHIGH 4 			# number of cells down

$define WIDTH (NWIDE * (CELL + GAP))	# total width
$define HEIGHT (NHIGH * (CELL + GAP))	# total height

$define ABET "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz"


global cx, cy				# current cell indices


##############################  Overall control  ##############################


procedure main(args)
   local x, y

   # Start with a medium window; shrink, test defaults, grow.
   Window("size=300,300", args)

   # The following sequence *should* have no permanent effect
   WAttrib("drawop=xor", "fillstyle=masked", "pattern=checkers", "linewidth=5")
   DrawCircle(CELL / 2, CELL / 2, CELL / 3)
   EraseArea()
   WAttrib("drawop=copy", "fillstyle=solid", "linewidth=1")

   # Shrink the window, test defaults, grow to final size.
   deftest()
   WAttrib("size=" || WIDTH || "," || HEIGHT)
   WAttrib("width=" || WIDTH)			# should be no-op
   WAttrib("size=" || WIDTH || "," || HEIGHT)	# should be no-op

   # Make a simple background.
   if WAttrib("depth") > 1 then
      Fg("35000,35000,65000")
   every y := (3 * CELL / 2) to (2 * HEIGHT) by 7 do
      DrawLine(0, y, 2 * y, 0)
   Fg("#000")

   # Run a series of tests confined to small, square cells.
   cx := cy := 0			# current cell (already filled)
   cell(simple)
   cell(lines)
   cell(rects)
   cell(star)
   cell(pretzel)
   cell(spiral)
   cell(arcs)
   cell(copying)
   cell(rings)
   cell(fontvars)
   cell(stdfonts)
   cell(stdpats)
   cell(patts)
   cell(attribs)
   cell(gamma)
   cell(balls)
   cell(slices)
   cell(details)
   cell(rainbow)
   cell(whale)
   cell(cheshire)

   # Use the final cell area for Dialog and Quit buttons.
   buttonrow(&window, WIDTH - CELL - GAP/2, HEIGHT - GAP / 2, CELL, 2 * GAP,
      0, - 3 * GAP, "Quit", argless, exit, "Dialog", argless, dltest)
   quitsensor(&window)
   sensor(&window, 'Dd', argless, dltest)
   evmux(&window)
end


## cell(proc) -- run a test in the next available cell
#
#  Proc is called with a private graphics context assigned to &window.
#  Clipping set to cell boundaries and the origin is at the center.

procedure cell(proc)
   local x, y, stdwin

   if (cx +:= 1) >= NWIDE then {
      cx := 0
      cy +:= 1
      }
   x := integer((cx + .5) * (CELL + GAP))
   y := integer((cy + .5) * (CELL + GAP))

   stdwin := &window
   &window := Clone("dx=" || x, "dy=" || y, "bg=white")
   ClearOutline(-HALF - 1, -HALF - 1, CELL + 1, CELL + 1)
   Clip(-HALF, -HALF, CELL, CELL)
   proc()
   Uncouple(&window)
   &window := stdwin
end


##############################  Cell Tests  ##############################


## arcs() -- draw a series of arcs forming a tight spiral
#
#  Tests DrawCircle with angle limits.

procedure arcs()
   local r, a, d

   r := 2
   a := 0
   d := &pi / 10
   while r < HALF do {
      DrawCircle(0, 0, r, a, d)
      r +:= 1
      a +:= d
      d +:= &pi / 40
      }
end


## attribs() -- test WAttrib().
#
#  For each of several attributes we should be able to inquire the current
#  setting, set it to that value, and get it back again.  If that works,
#  display some system-dependent attributes in the cell window.

procedure attribs()
   local alist, afail, n, a, f, cw, ch, cl, v1, v2

   alist := [
      "fg", "bg", "reverse", "drawop", "gamma", "font", "leading", 
      "linewidth", "linestyle", "fillstyle", "pattern",
      "clipx", "clipy", "clipw", "cliph", "dx", "dy",
      "label", "pos", "posx", "posy", "size", "height", "width", "canvas",
      "resize", "echo", "cursor", "x", "y", "row", "col", "pointer",
      "pointerx", "pointery", "pointerrow", "pointercol", 
      ]
   afail := []

   every a := \!alist do {
      v1 := WAttrib(a)		| { put(afail, a); next }
      WAttrib(a || "=" || v1)	| { put(afail, a || "=" || v1); next }
      v2 := WAttrib(a)		| { put(afail, a); next }
      v1 == v2		| { put(afail, a || ": " || v1 || "/" || v2); next }
      }

   Translate(-HALF, -HALF)
   GotoRC(1, 1)

   if *afail > 0 then {
      Font("sans,bold,10")
      WWrite("FAILED:")
      every WWrite("  ", !afail)
      every write(&errout, "WAttrib() failure: ", !afail)
      fail
      }

   f := WAttrib("font") | "[FAILED]"
   cw := WAttrib("fwidth") | "[FAILED]"
   ch := WAttrib("fheight") | "[FAILED]"
   cl := WAttrib("leading") | "[FAILED]"
   Font("sans,10")
   WWrite("display=", WAttrib("display") | "[FAILED]")
   WWrite("  (", WAttrib("displaywidth") | "????", "x", 
      WAttrib("displayheight") | "????", "x", WAttrib("depth") | "??", ")") 
   every a := "gamma" | "pointer" do
      WWrite(a, "=", WAttrib(a) | "[FAILED]")
   WWrite("std font=", f)
   WWrite("  (", cw, "x", ch, ", +", cl, ")")
end


## balls() -- draw a grid of spheres
#
#  Tests DrawImage using g16 palette.

procedure balls()
   every DrawImage(-HALF + 2 to HALF by 20, -HALF + 2 to HALF by 20, 
      " 16 , g16 , FFFFB98788AEFFFF_
      FFD865554446AFFF FD856886544339FF E8579BA9643323AF_
      A569DECA7433215E 7569CDB86433211A 5579AA9643222108_
      4456776533221007 4444443332210007 4333333222100008_
      533322221100000A 822222111000003D D41111100000019F_
      FA200000000018EF FFA4000000028EFF FFFD9532248BFFFF")
end


## cheshire() -- cheshire cat display
#
#  Tests mutable colors, WDelay, various drawing operations.

procedure cheshire()
   local face, eyes, grin, i, g

   if (face := NewColor("white")) & 
   (eyes := NewColor("black")) & (grin := NewColor("black")) then {
      Fg("gray")
      FillRectangle(-HALF, -HALF)
      Fg(face)
      FillArc(-HALF, .3 * CELL, CELL, -HALF)
      FillPolygon(0, 0, -.35 * CELL, -.35 * CELL, -.35 * CELL, 0)
      FillPolygon(0, 0, .35 * CELL, -.35 * CELL, .35 * CELL, 0)
      Fg(eyes)
      WAttrib("linewidth=2")
      DrawCircle(-.18 * CELL, -.0 * CELL, 3, , , .18 * CELL, -.0 * CELL, 3)
      Fg(grin)
      DrawCircle(0, -HALF, .7 * CELL, &pi / 3, &pi / 3)
      WDelay(500)
      every i := 0 to 30 by 2 do {
         WDelay(100)
         g := i * 65535 / 60
         Color(eyes, g || "," || g || "," || g)
         g := 65535 - g
         Color(face, g || "," || g || "," || g)
         }
      every i := 0 to 26 by 2 do {
         WDelay(100)
         g := i * 65535 / 60
         Color(grin, g || "," || g || "," || g)
         }
      }
   else {
      Translate(-HALF + 4, -HALF)
      GotoRC(1, 1)
      WWrite("this test\nrequires\nmutable\ncolors")
      }
end


## copying() -- test CopyArea
#
#  Tests hidden canvas, overlapping copies, and generation
#  of background color for missing source pixels.

procedure copying()
   local win, o, w, h

   win := WOpen("canvas=hidden", "size=" || CELL || "," || CELL) | {
      GotoRC(1, 1)
      WWrite("Can't get\nhidden\ncanvas")
      fail
      }
   every DrawCircle(win, HALF, HALF, HALF - 2 to sqrt(2) * HALF by 3)

   o := 5		# offset for copy
   w := CELL / 4	# width of square to be copied
   h := w / 2		# half of that, for centering
   Bg(win, "black")

   CopyArea(win, -o, -o, w, w, 0, 0)
   CopyArea(win, HALF - h, -o, w, w, HALF - h, 0)
   CopyArea(win, CELL + o, -o, -w, w, CELL - w, 0)

   CopyArea(win, -o, HALF - h, w, w, 0, HALF - h)
   CopyArea(win, CELL + o, HALF - h, -w, w, CELL - w, HALF - h)

   CopyArea(win, -o, CELL + o, w, -w, 0, CELL - w)
   CopyArea(win, HALF - h, CELL + o, w, -w, HALF - h, CELL - w)
   CopyArea(win, CELL + o, CELL + o, -w, -w, CELL - w, CELL - w)

   CopyArea(win, o, o, w, w, HALF - w, HALF - w)
   CopyArea(win, CELL - o, o, -w, w, HALF, HALF - w)
   CopyArea(win, o, CELL - o, w, -w, HALF - w, HALF)
   CopyArea(win, CELL - o, CELL - o, -w, -w, HALF, HALF)

   CopyArea(win, &window, , , , , -HALF, -HALF)
   close(win)
end


## deftest() -- test defaults
#
#  Tests x/y/w/h defaulting by adjusting the window size several times.
#  Also exercises "drawop=reverse" incidentally.
#
#  This test must be run first.  It uses the entire window and leaves
#  results in the first cell.

procedure deftest()
   WAttrib("drawop=reverse")
   WAttrib("size=" || CELL || "," || CELL / 2)
   FillArc()
   FillArc(, , CELL / 4)
   FillArc(3 * CELL / 4)
   WAttrib("height=" || CELL)
   DrawArc(, CELL / 2)
   WAttrib("drawop=copy")
end


## details() -- test drawing details
#
#  Tests some of the details of filling and stroking.

procedure details()
   Shade("light gray")
   FillRectangle()

   WAttrib("linewidth=7", "fg=white")
   DrawLine(10, 10, 10, 25, 30, 25, 20, 10)
   WAttrib("linewidth=1", "fg=black")
   DrawLine(10, 10, 10, 25, 30, 25, 20, 10)

   Fg("white")
   DrawRectangle(-5, -5, -25, -30)
   Fg("black")
   DrawArc(-5, -5, -25, -30)

   Fg("white")
   FillArc(5, -5, 24, -30)
   Fg("black")
   DrawArc(5, -5, 24, -30)

   Shade("light gray")
   FillCircle(17, -17, 6)
   Fg("Black")
   DrawCircle(17, -17, 6)

   Fg("white")
   FillPolygon(-5,20, -17,23, -20,35, -23,23, -35,20, -23,17, -20,5, -17,17)
   Fg("black")
   DrawPolygon(-5,20, -17,23, -20,35, -23,23, -35,20, -23,17, -20,5, -17,17)
end


## fontvars() -- test font variations
#
#  Tests various font characteristics combined with standard font names.
#  Also exercises Shade, GoToXY, WWrites.

procedure fontvars()
   Translate(-HALF + 4, -HALF)
   Shade("gray")
   FillRectangle(-4)
   Shade("black")
   GotoXY(0, 0)
   WWrites("\nFonts...")
   WWrites("\n", if Font("mono,12") then ABET else "no mono 12")
   WWrites("\n", if Font("serif,italic") then ABET else "no SF ital")
   WWrites("\n", if Font("sans,bold,18") then ABET else "no SN B 18")
   WWrites("\n", if Font("fixed") then ABET else "no fixed!") 
end


## gamma() -- test gamma correction
#
#  Draws 50%-gray bars with various values of the gamma attribute, beginning
#  with the system default.  Incidentally tests some font attributes.

procedure gamma()
   local g

   GotoXY(0, -HALF + WAttrib("leading"))
   every g := &null | 1.0 | 1.6 | 2.5 | 4.0 | 6.2 do {
      Shade("gray")
      WAttrib("gamma=" || \g)
      FillRectangle(-4, WAttrib("y"), -HALF, -WAttrib("fheight"))
      Shade("black")
      WWrite(WAttrib("gamma"))
      }
end


## lines() -- test line drawing
#
#  Tests proper drawing and joining of lines of various widths.  There
#  once were problems here in Icon, and there still are in some X servers.

procedure lines()
   local i, y
   y := -HALF - 6
   every WAttrib("linewidth=" || (0 to 4)) do
      tline(-HALF + 10, y +:= 15)
end

procedure tline(x, y)
   DrawLine(x + 1, y, x + 3, y)
   DrawLine(x - 1, y, x - 3, y)
   DrawLine(x, y + 1, x, y + 3)
   DrawLine(x, y - 1, x, y - 3)
   x +:= 15
   DrawLine(x - 3, y - 3, x + 3, y - 3)
   DrawLine(x + 3, y - 3, x + 3, y + 3)
   DrawLine(x + 3, y + 3, x - 3, y + 3)
   DrawLine(x - 3, y + 3, x - 3, y - 3)
   x +:= 15
   DrawLine(x - 3, y - 3, x + 3, y + 3)
   DrawLine(x - 3, y + 3, x + 3, y - 3)
   x +:= 15
   DrawLine(x, y - 4, x + 4, y)
   DrawLine(x + 4, y, x, y + 4)
   DrawLine(x, y + 4, x - 4, y)
   DrawLine(x - 4, y, x, y - 4)
   x +:= 15
   DrawRectangle(x - 4, y - 4, 8, 8)
end


## patts() -- test custom patterns
#
#  Tests custom patterns in hex and decimal forms; tests fillstyle=masked.

procedure patts()
   local i, j, s, x, y

   WAttrib("linewidth=4")
   DrawCircle(0, 0, 0.38 * CELL)	# circle should persist after patts
   WAttrib("linewidth=1")

   WAttrib("fillstyle=masked")
   s := ["8,#01552B552B552BFF", "8,#020E070420E07040",
      "8,31,14,68,224,241,224,68,14", "8,#2020FF020202FF20", "4,#5A5A",
      "8,#0ABBA0BE82BAAAEA", "8,#E3773E383E77E383", "8,#4545C71154547C11",
      "8,#FF7F3F1F0F070301"]

   every i := 0 to 2 do
      every j := 0 to 2 do {
         WAttrib("pattern=" || s[3 * i + j + 1])
         x := -HALF + j * CELL / 3
         y := -HALF + i * CELL / 3
         FillRectangle(x, y, CELL / 3, CELL / 3)
         }
end


## pretzel() -- draw a pretzel
#
#  Tests DrawCurve.

procedure pretzel()
   WAttrib("linewidth=3")
   DrawCurve(20, -20, -5, 0, 20, 20, 35, 0, 0,
      -20, -35, 0, -20, 20, 5, 0, -20, -20)
end


## rainbow() -- draw a rainbow
#
#  Tests several color naming variations.

procedure rainbow()
   local r, c, l

   Shade("moderate blue-cyan")
   FillRectangle()
   WAttrib("fillstyle=solid")
   r := 20
   l := ["pink", "pale orange", "light yellow", "pale green", "very light blue",
         "light bluish violet", " pale violet"]
   WAttrib("linewidth=3")
   every Fg(!l) do
      DrawCircle(0, 20, r +:= 3, 0, -&pi)
end


## rects() -- draw rectangles
#
#  Tests rectangles specified with positive & negative width & height.

procedure rects()
   local r, a

   WAttrib("drawop=reverse")
   r := HALF
   every a := 1 to 19 by 2 do
      DrawRectangle(0, 0, r * cos(0.33 * a), r * sin(0.33 * a))
end 


## rings() -- draw a pile of rings
#
#  Tests linewidth and DrawCircle in combination.

procedure rings()
   local x, y
   Translate(-HALF, -HALF)
   FillRectangle()
   every 1 to 15 do {
      x := ?CELL
      y := ?CELL
      WAttrib("fg=black", "linewidth=5")
      DrawCircle(x, y, 30)		# draw ring in black
      WAttrib("fg=white", "linewidth=3")
      DrawCircle(x, y, 30)		# color with white band
      }
end


## simple() -- an easy first test
#
#  Tests DrawString, DrawCircle, FillRectangle, EraseArea, linestyles.

procedure simple()
   DrawCircle(0, 0, CELL / 3)
   DrawString(-HALF + 4, -HALF + 12, "hello,")
   DrawString(-HALF + 4, -HALF + 25, "world")
   FillRectangle(0, 0)
   EraseArea(10, 4, CELL / 5, CELL / 3)
   WAttrib("linestyle=dashed")
   DrawLine(HALF - 3, HALF, HALF - 3, -HALF)
   WAttrib("linestyle=striped")
   DrawLine(HALF - 6, HALF, HALF - 6, -HALF)
end


## slices() -- draw a pie with different-colored slices
#
#  Tests RandomColor, Shade, FillArc.

procedure slices()
   local n, a, da, ov

   n := 10
   da := 2 * &pi / n			# change in angle
   a := -&pi / 2 - da			# current angle
   ov := &pi / 1000			# small overlap

   FillRectangle(-HALF, -HALF)
   every 1 to n do {
      Shade(RandomColor())
      FillArc(-HALF, -CELL / 3, CELL, 2 * CELL / 3, a +:= da, da + ov)
      }
end


## spiral() -- draw a spiral, one point at a time
#
#  Tests DrawPoint.

procedure spiral()
   local r, a, d

   r := 3			# initial radius
   a := 0			# initial start angle
   while r < HALF do {
      DrawPoint(r * cos(a), r * sin(a))
      d := 1.0 / r
      a +:= d
      r +:= 2 * d
      }
end


## star() -- draw a five-pointed star.
#
#  Tests FillPolygon and the even-odd winding rule.

procedure star()
   FillPolygon(-40, -10, 40, -10, -25, 40, 0, -40, 25, 40)
end



## stdfonts() -- test standard fonts
#
#  Shows the default font (the header line), standard fonts, and "fixed".

procedure stdfonts()
   Translate(-HALF + 4, -HALF)
   Shade("gray")
   FillRectangle(-4)
   Shade("black")
   GotoRC(1, 1)
   WWrite(if Font("mono") then "mono" else "no mono!") 
   WWrite(if Font("typewriter") then "typewriter" else "no typewriter!") 
   WWrite(if Font("sans") then "sans" else "no sans!") 
   WWrite(if Font("serif") then "serif" else "no serif!") 
   WWrite(if Font("fixed") then "fixed" else "no fixed!") 
end


## stdpats() -- test standard patterns
#
#  Tests standard pattern names; tests fillstyle=textured.

procedure stdpats()
   local i, j, s, x, y

   WAttrib("fillstyle=textured")
   s := [
      "black", "verydark", "darkgray", "gray", "lightgray", "verylight",
      "white", "vertical", "diagonal", "horizontal", "grid", "trellis",
      "checkers", "grains", "scales", "waves"]
   every i := 0 to 3 do
      every j := 0 to 3 do {
         WAttrib("pattern=" || s[4 * i + j + 1])
         x := -HALF + j * CELL / 4
         y := -HALF + i * CELL / 4
         FillRectangle(x, y)	# depends on opacity of patterns to work
         }
end


## whale() -- draw a whale
#
#  Tests transparent and regular images, Capture, Zoom.

procedure whale()
   local s

   Fg("moderate greenish cyan")
   FillRectangle()
   Translate(-HALF, -HALF)

   DrawImage(3, 3, "32, c1, _
      ~~~~~~~~~~~~000~~~~~~00~~~~~~~00_
      ~~~~~~~~~~~0JJJ00~~~~0J00~~~00J0_
      ~~~~~~~000000JJJJ0~~~0J0J000J0J0_
      ~~~~~000iiiii000JJ0~~0JJJ0J0JJi0_
      ~~~~06660ii000ii00J0~~00JJJJJ00~_
      ~~~066000i06600iii00~~~~0iii0~~~_
      ~~0066000i06000iiii0~~~~~0i0~~~~_
      ~~0i0000iii000iiiiii0~~~~0i0~~~~_
      ~0iiiiiiiiiiiiiiiiiii0~~0ii0~~~~_
      ~00000iii0000iiiiiiiii00iiii0~~~_
      0AAAAA000AAAA00iiiiiiiiiiiii0~~~_
      0AAAAAAAAAAAAAA0iiiiiiiiiiii0~~~_
      ~0000AAAAA0000AA0iiiiiiiiiiii0~~_
      ~06060000060600AA0iiiiiiiiiii0~~_
      ~060606060606000A0iiiii00iiii0~~_
      ~~0~006060000000AA0iiiiiJ0iii0~~_
      ~~~~~~00000000000A0iiii0JJ0ii0~~_
      ~~~~~~00000000000A0iiiiJ0J0ii0~~_
      ~~~0~~00000000000A0iii0JJ00i0~~~_
      ~~060000000000000A0i0JJ0JJ0i0~~~_
      ~~06060600000600AA0ii0JJ00ii0~~~_
      ~00006060606060AA0iiii000ii0~~~~_
      0AAA0000060600AAA0iiiiiiiii0~~~~_
      0AAAAAAAA000AAAA0iiiiiiiiii0~~~~_
      ~000AAAAAAAAAAA0iiiiiiiiii0~~~~~_
      ~~0i0000AAAAA00iiiiiiiiiii0~~~~~_
      ~~0iiiii00000iiiiiiiiiiii0~~~~~~_
      ~~~0iiiiiiiiiiiiiiiiiiii0~~~~~~~_
      ~~~~0iiiiiiiiiiiiiiiii00~~~~~~~~_
      ~~~~~00iiiiiiiiiiiii00~~~~~~~~~~_
      ~~~~~~~000iiiiiii000~~~~~~~~~~~~_
      ~~~~~~~~~~0000000~~~~~~~~~~~~~~~")

   s := Capture(, 0, 0, 36, 36)
   DrawImage(0, 40, s)

   Zoom(0, 0, 36, 36, 40, 20, 72, 72)
end


##############################  Dialog test  ##############################


## dltest() -- dialog test
#
#  Present a dialog box with "Validate" and "Cancel" buttons.
#  For "Validate", check all values, and repeat dialog if incorrect.
#  For "Cancel", return immediately.

procedure dltest()
   while dlog() ~== "Cancel" do {
      if dialog_value["button"] ~=== 1 then
         { Notice("The button was not left dark."); next }
      if dialog_value["xbox"] ~=== 1 then
         { Notice("The checkbox was not checked."); next }
      if dialog_value["slider"] < 0.8 then
         { Notice("The slider was not set."); next }
      if map(dialog_value["text"]) ~== "icon" then
         { Notice("The text did not say `Icon'"); next }
      Notice("All values were correct.")
      return
      }
end


#===<<vib:begin>>===	modify using vib; do not remove this marker line
procedure dlog(win, deftbl)
static dstate
initial dstate := dsetup(win,
   ["dlog:Sizer::1:0,0,370,220:",],
   ["button:Button:regular:1:291,21,56,21:button",],
   ["cancel:Button:regular::198,174,100,30:Cancel",],
   ["label1:Label:::20,25,252,13:Click this button and leave it dark:",],
   ["label2:Label:::20,55,105,13:Check this box:",],
   ["label3:Label:::20,85,238,13:Move this slider to the far right:",],
   ["rule:Line:::20,157,350,157:",],
   ["slider:Slider:h::273,86,76,15:0.0,1.0,0.5",],
   ["text:Text::6:20,115,214,17:Enter the word `Icon': \\=here",],
   ["validate:Button:regular:-1:75,174,100,30:Validate",],
   ["xbox:Button:xbox:1:131,54,16,16:",],
   )
return dpopup(win, deftbl, dstate)
end
#===<<vib:end>>===	end of section maintained by vib



#=============================================  $include vdefns.icn



############################################################################
#
#	File:     vdefns.icn
#
#	Subject:  Definitions for visual interface
#
#	Author:   Gregg M. Townsend
#
#	Date:     July 10, 1995
#
###########################################################################
#
#  Requires:  Version 9.0 of Icon
#
############################################################################

# Fixed font width, in pixels, assumed by VIB

$define VFWidth 7

# Geometry rules for sliders and scrollbars

$define VSlider_MinAspect 3
$define VSlider_MinWidth 10
$define VSlider_DefWidth 15
$define VSlider_DefLength 60


# Background color, chosen to look good on 4-bit MSWin systems

$define VBackground "gray-white"



#=============================================  $include keysyms.icn



############################################################################
#
#	File:     keysyms.icn
#
#	Subject:  Definitions for event key symbols
#
#	Author:   Ralph E. Griswold and Gregg M. Townsend
#
#	Date:     October 19, 1994
#
###########################################################################
#
#  Requires:  Version 9.0 of Icon
#
############################################################################

$define Key_Compose		65312
$define Key_Do			65383
$define Key_Down		65364
$define Key_End			65367
$define Key_F1			65470
$define Key_F2			65471
$define Key_F3			65472
$define Key_F4			65473
$define Key_F5			65474
$define Key_F6			65475
$define Key_F7			65476
$define Key_F8			65477
$define Key_F9			65478
$define Key_F10			65479
$define Key_F11			65480
$define Key_F12			65481
$define Key_F13			65482
$define Key_F14			65483
$define Key_F15			65484
$define Key_F16			65485
$define Key_F17			65486
$define Key_F18			65487
$define Key_F19			65488
$define Key_F20			65489
$define Key_Find		65384
$define Key_Help		65386
$define Key_Home		65360
$define Key_Insert		65379
$define Key_KP_Down		65433
$define Key_KP_Left		65430
$define Key_KP_Right		65432
$define Key_KP_Up		65431
$define Key_L1			65480  # clash with f11
$define Key_L2			65481  # clash with f12
$define Key_L3			65482
$define Key_L4			65483
$define Key_L5			65484
$define Key_L6			65485
$define Key_L7			65486
$define Key_L8			65487
$define Key_L9			65488
$define Key_L10			65489
$define Key_Left		65361
$define Key_PF1			65425
$define Key_PF2			65426
$define Key_PF3			65427
$define Key_PF4			65428
$define Key_Pause		65299
$define Key_PgDn		65366
$define Key_PgUp		65365
$define Key_PrSc		65377
$define Key_R1			65490
$define Key_R2			65491
$define Key_R3			65492
$define Key_R4			65493
$define Key_R5			65494
$define Key_R6			65495
$define Key_R7			65496
$define Key_R8			65497
$define Key_R9			65498
$define Key_R10			65499
$define Key_R11			65500
$define Key_R12			65501
$define Key_R13			65502
$define Key_R14			65503
$define Key_R15			65504
$define Key_Right		65363
$define Key_ScrollLock		65300
$define Key_Select		65376
$define Key_Up			65362



#=============================================  /home/gmt/ipl/gprocs/button.icn



############################################################################
#
#	File:     button.icn
#
#	Subject:  Procedures for pushbutton sensors
#
#	Author:   Gregg M. Townsend
#
#	Date:     November 14, 1994
#
############################################################################
#
#   These procedures implement pushbuttons using the X-window event
#   multiplexor, evmux.
#
#   It is assumed that buttons do not overlap, and that fg, bg, and font
#   do not change beyond the initial call.  These restrictions can be
#   accommodated if necessary by using a window clone.
#
#   button(win, label, proc, arg, x, y, w, h)
#
#	establishes a button of size (w,h) at (x,y) and returns a handle.
#	"label" is displayed as the text of the button.
#	When the button is pushed, proc(win, arg) is called.
#
#	If proc is null, the label is drawn with no surrounding box, and
#	the button is not sensitive to mouse events.  This can be used to
#	insert a label in a row of buttons.
#
#   buttonlabel(handle, label)
#
#	changes the label on a button.
#
#   buttonrow(win,x,y,w,h,dx,dy, label,proc,arg, label,proc,arg, ...)
#
#	establishes a row (or column) of buttons and returns a list of handles.
#	Every button has size (w,h) and is offset from its predecessor by
#	(dx,dy).
#
#	(x,y) give the "anchor point" for the button row, which is a corner
#	of the first button.  x specifies the left edge of that button unless
#	dx is negative, in which case it specifies the right edge.  Similarly,
#	y is the top edge, or the bottom if dy is negative.
#
#	One button is created for each argument triple of label,proc,arg.
#	An extra null argument is accepted to allow regularity in coding as
#	shown in the example below.
#
#	If all three items of the triple are null, a half-button-sized
#	gap is inserted instead of a button.
#
#   Example:
#
#	Draw a pushbutton at (x,y) of size (w,h);
#	then change its label from "Slow" to "Reluctant"
#	When the button is pushed, call setspeed (win, -3).
#
# 		b := button (win, "Slow", setspeed, -3, x, y, w, h)
#   		buttonlabel (b, "Reluctant")
#
#	Make a set of buttons extending to the left from (490,10)
#
#		blist := buttonrow(win, 490, 10, 50, 20, -60, 0,
#		    "fast", setspeed, +3,
#		    "med", setspeed, 0,
#		    "slow", setspeed, -3,
#		    )
#
############################################################################
#
#  Links: evmux, graphics
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################

#====== link evmux
#====== link graphics

$define BORDER 2	# border width

record Button_Rec(win, label, proc, arg, x, y, w, h)

procedure button(win, label, proc, arg, x, y, w, h)
   local r

   r := Button_Rec(win, label, proc, arg, x, y, w, h)
   buttonlabel(r, label)
   if \proc then {
      BevelRectangle(win, x, y, w, h, BORDER)
      sensor(win, &lpress, Exec_Button, r, x, y, w, h)
      }
   return r
end

procedure buttonrow(win, x, y, w, h, dx, dy, args[])
   local hlist, label, proc, arg

   if dx < 0 then x -:= w
   if dy < 0 then y -:= h
   hlist := []
   repeat {
      label := get(args) | break
      proc := get(args) | break
      arg := get(args) | break
      if label === proc === arg === &null then {
         x +:= dx / 2
         y +:= dy / 2
         }
      else {
         put(hlist, button(win, label, proc, arg, x, y, w, h))
         x +:= dx
         y +:= dy
         }
      }
   return hlist
end

procedure buttonlabel(r, s)
   r.label := s
   if /r.proc then
      EraseArea(r.win, r.x, r.y, r.w, r.h)	# borderless button
   else
      EraseArea(r.win, r.x+BORDER, r.y+BORDER, r.w-2*BORDER, r.h-2*BORDER)
   CenterString(r.win, r.x + r.w/2, r.y + r.h/2, r.label)
   return
end

procedure Exec_Button(win, r, x, y)
   local e, b, t

   WAttrib(win, "drawop=reverse")
   FillRectangle(win, r.x + BORDER, r.y + BORDER, r.w - 2*BORDER, r.h -2*BORDER)
   BevelRectangle(win, r.x, r.y, r.w, r.h, b := -BORDER)

   while e := Event(win) do {
      x := &x
      y := &y
      case e of {
         &ldrag: {			# drag
            t := (if ontarget(r, x, y) then -BORDER else BORDER)
            if b ~===:= t then {
               BevelRectangle(win, r.x, r.y, r.w, r.h, b)
               FillRectangle(win,
                  r.x + BORDER, r.y + BORDER, r.w - 2*BORDER, r.h - 2*BORDER)
               }
            }
         &lrelease: {			# release leftbutton
            if b < 0 then {
               BevelRectangle(win, r.x, r.y, r.w, r.h, BORDER)
               FillRectangle(win,
                  r.x + BORDER, r.y + BORDER, r.w - 2*BORDER, r.h - 2*BORDER)
               WAttrib(win, "drawop=copy")
               r.proc(win, r.arg)
               }
            else
               WAttrib(win, "drawop=copy")
            return
            }
         }
      }
end



#=============================================  /home/gmt/ipl/gprocs/dsetup.icn



###########################################################################
#
#	File:     dsetup.icn
#
#	Subject:  Procedures for creating dialog boxes
#
#	Author:   Gregg M. Townsend and Ralph E. Griswold
#
#	Date:     September 22, 1995
#
###########################################################################
#
#  dsetup(win, wlist) initializes a set of widgets according to
#  a list of specifications created by the terface editor VIB.
#
#  win can be an existing window, or null.
#
#  wlist is a list of specifications; the first must be the Sizer and
#  the last may be null.  Each specification is itself a list consisting
#  of a specification string, a callback routine, and an optional list
#  of additional specifications.  Specification strings vary by vidget
#  type, but the general form is "ID:type:style:n:x,y,w,h:label".
#
#  dsetup() returns a table of values from the dialog, indexed by ID.
#
###########################################################################
#
#  Includes:  vdefns
#
###########################################################################
#
#  Links:  dialog, xio, xutils,
#          vidgets, vslider, vmenu, vscroll, vtext, vbuttons, vradio
#          vdialog
#
###########################################################################

#====== $include "vdefns.icn"

#====== link dialog
#====== link vdialog
#====== link vidgets
#====== link vslider
#====== link vmenu
#====== link vscroll
#====== link vtext
#====== link vbuttons
#====== link vradio
#====== link vsetup

record DL_rec(var, typ, sty, num, x, y, w, h, lbl, cbk, etc)
record DL_state(dialog, list, deflabel)

global did_list, did_label

## dsetup(win, wlist) -- set up vidgets and return table of handles
#
#  wlist is a list of vidget specs as constructed by vib (or uix).

procedure dsetup(win, wlist[])
   local r, dialog, obj, num, wspec, alist

   if type(win) ~== "window" then
      win := &window

   win := Clone(win, "fg=black", "linewidth=1", "linestyle=solid",
      "fillstyle=solid", "drawop=copy")	# clone window with standard attribs
   VSetFont(win)			# set standard VIB font
   if ColorValue(Bg(win)) == ("65535,65535,65535" | "0,0,0") then
      Bg(win, VBackground)		# change black or white bg to gray-white

   while /wlist[-1] do			# ignore trailing null elements
      pull(wlist)
   wspec := get(wlist)			# first spec gives wdow size

   r := DL_crack(wspec) | stop("dsetup: bad spec")

   did_list := []
   did_label := &null

   dialog := Vdialog(win, 0, 0)		# create dialog frame
   dialog.id := r.var
   VInsert(dialog, Vmessage(win, ""),	# set dialog box dimensions
      r.x + r.w - 1, r.y + r.h - WAttrib(win, "fheight") - 1)

   every r := DL_crack(!sort(wlist), &null) do {
      DL_obj(win, dialog, r)			# insert other vidgets
      }

   VFormat(dialog)				# create the dialog

   return DL_state(dialog, did_list, did_label)	# return state for dpopup()

end

procedure dpopup(win, dftbl, dstate)
   local did_list, init_list, i

   if type(win) ~== "window" then {
      win :=: dftbl
      }

   /dftbl := table()
   did_list := dstate.list

   init_list := list(*did_list)
   every i := 1 to *did_list do
      init_list[i] := \dftbl[did_list[i]]

   dialog_value := VOpenDialog(dstate.dialog, , dstate.dialog.id,
      init_list, dstate.deflabel)

   every i := 1 to *did_list do
      dftbl[did_list[i]] := dialog_value[i]

   dialog_value := dftbl

   return dialog_button

end

## DL_crack(wspec, cbk) -- extract elements of spec and put into record
#
#  cbk is a default callback to use if the spec doesn't supply one.

procedure DL_crack(wspec, cbk)
   local r, f

   r := DL_rec()
   (get(wspec) | fail) ? { 
      r.var := tab(upto(':')) | fail;  move(1)
      r.typ := tab(upto(':')) | fail;  move(1)
      r.sty := tab(upto(':')) | fail;  move(1)
      r.num := tab(upto(':')) | fail;  move(1)
      r.x := tab(upto(',')) | fail;  move(1)
      r.y := tab(upto(',')) | fail;  move(1)
      r.w := tab(upto(',')) | fail;  move(1)
      r.h := tab(upto(':')) | fail;  move(1)
      r.lbl := tab(0)
      }
   get(wspec)		# skip callback field
   r.cbk := cbk		# always use parameter
   r.etc := get(wspec)
   return r
end


## DL_obj(win, dialog, r) -- create vidget depending on type

procedure DL_obj(win, dialog, r)
   local obj, gc, style, lo, hi, iv, args

   case r.typ of {
      "Label" | "Message": {
         obj := Vmessage(win, r.lbl)
         VInsert(dialog, obj, r.x, r.y, r.w, r.h)
         }
      "Line": {
         obj := Vline(win, r.x, r.y, r.w, r.h)
         VInsert(dialog, obj, r.x, r.y, 1, 1) 
         }
#     "Rect": {
#        gc := Clone(win)
#        if r.num == "" | r.num = 0 then
#           r.num := &null
#        obj := Vpane(gc, r.cbk, r.var, r.num)
#        VInsert(dialog, obj, r.x, r.y, r.w, r.h)
#        }
      "Rect":  &null
      "Check": {
         obj := Vcheckbox(win, r.cbk, r.var, r.w)
         VInsert(dialog, obj, r.x, r.y, r.w, r.h)
         }
      "Button": {
         style := case r.sty of {
            "regular":	V_RECT
            "regularno":V_RECT_NO
            "check":	V_CHECK
            "checkno":	V_CHECK_NO
            "circle":	V_CIRCLE
            "circleno":	V_CIRCLE_NO
            "diamond":	V_DIAMOND
            "diamondno":V_DIAMOND_NO
            "xbox":	V_XBOX
            "xboxno":	V_XBOX_NO
            default:	V_RECT
            }
         if r.num == "1" then {		# toggle
            put(did_list, r.var)
            obj := Vtoggle(win, r.lbl, r.cbk, r.var, style, r.w, r.h)
            VRegister(dialog, obj, r.x, r.y)
            }
         else {				# dismiss
            obj := Vbutton(win, r.lbl, dialog_cb, V_OK, style, r.w, r.h)
            VInsert(dialog, obj, r.x, r.y)
            if r.num == "-1" then
               did_label := r.lbl
            }
         }
      "Choice": {
         obj := Vradio_buttons(win, r.etc, r.cbk, r.var, V_DIAMOND_NO)
         put(did_list, r.var)
         VRegister(dialog, obj, r.x, r.y)
         }
      "Slider" | "Scrollbar" : {
         r.lbl ? {
            lo := numeric(tab(upto(',')))
            move(1)
            hi := numeric(tab(upto(',')))
            move(1)
            iv := numeric(tab(0))
            }
         if r.num == "" then
            r.num := &null
         obj := case (r.sty || r.typ) of {
            "hSlider":
               Vhoriz_slider(win, r.cbk, r.var, r.w, r.h, lo, hi, iv, r.num)
            "vSlider":
               Vvert_slider(win, r.cbk, r.var, r.h, r.w, hi, lo, iv, r.num)
            "hScrollbar":
               Vhoriz_scrollbar(win, r.cbk, r.var, r.w, r.h, lo, hi, , , r.num) 
            "vScrollbar":
               Vvert_scrollbar(win, r.cbk, r.var, r.h, r.w, hi, lo, , , r.num)
            }
         put(did_list, r.var)
         VRegister(dialog, obj, r.x, r.y)
         }
      "Text": {
         obj := Vtext(win, r.lbl, r.cbk, r.var, r.num)
         put(did_list, r.var)
         VRegister(dialog, obj, r.x, r.y)
         }
#     "Menu": {
#        obj := Vmenu_bar(win, r.lbl, DL_submenu(win, r.etc, r.cbk))
#        VInsert(dialog, obj, r.x, r.y)
#        }
      "Menu":  &null
      default: {
         stop("dsetup: unrecognized object: ", r.typ)
         fail
         }
   }
   return obj
end



## DL_submenu(win, lst, cbk) -- create submenu vidget

procedure DL_submenu(win, lst, cbk)
   local a, c, lbl

   a := [win]
   while *lst > 0 do {
      put(a, get(lst))
      if type(lst[1]) == "list" then
         put(a, DL_submenu(win, get(lst), cbk))
      else
         put(a, cbk)
      }
   return Vsub_menu ! a
end



## dproto(proc, font, w, h) -- protoype a dialog box procedure built by vib
#
#  n.b. "font" is now ignored, although it was once significant.

procedure dproto(proc, font, w, h)
   local win, s, l

   w <:= 150
   h <:= 100
   win := Window([], "canvas=hidden")
   VSetFont(win)
   repeat {
      if write(image(proc), " returned ", image(proc(win))) then {
         l := sort(dialog_value, 3)
         while write("   dialog_value[\"", get(l), "\"] = ", image(get(l)))
         }
      else
         write(image(proc), " failed")
      if TextDialog(win,"Test prototype",,,,["Again","Quit"]) == "Quit" then
         break
      }
   WClose(win)
end



#==============================================  /home/gmt/ipl/gprocs/evmux.icn



############################################################################
#
#	File:     evmux.icn
#
#	Subject:  Procedures for window event multiplexor
#
#	Author:   Gregg M. Townsend
#
#	Date:     July 11, 1995
#
############################################################################
#
#   These procedures help organize event-driven X-windows programs.
#   They are configured by registering *sensors*, which respond to
#   X events that occur when the mouse cursor is within a particular
#   region.  When a sensor fires, it calls a user procedure that was
#   registered when the sensor was created.
#
#   These routines interpret window events and respond by calling user code:
#	sensor() registers the events of interest
#	evhandle() reads and responds to the next event
#	evmux() loops forever, handling events
#
#   Two other little routines help build event-driven programs:
#	quitsensor() registers a standardized response to ^C, DEL, etc.
#	argless() responds by calling any proc with no arguments, e.g. exit().
#
#
#   sensor(win, ev, proc, arg, x, y, w, h) -- register an event responder.
#
#	registers *proc* as the procedure to be called when the event[s]
#	*ev* occur within the given bounds inside window *win* and returns
#	a handle.  The default bounds encompass the entire window.
#
#	The event set *ev* can be either:
#	    -- a cset or string specifying particular keypresses of interest
#	    -- one of the event keywords (&lpress, &rdrag, &resize, etc.)
#
#	When a matching event occurs, proc(win, arg, x, y, e) is called.  proc,
#	win, and arg are as recorded from the sensor call.  x and y give the
#	current mouse position and e the event; for a keypress, this is the
#	character.
#
#	No event generates more than one procedure call.
#	In the case of conflicting entries, the later registrant wins.
#
#	delsensor(win, x) deletes sensor x from the specified window.
#	If x is null, all sensors are deleted.
#
#
#   evmux(win) -- loop forever, calling event handlers as appropriate.
#   evhandle(win) -- wait for the next event, and handle it.
#
#	evmux(win) is an infinite loop that calls user routines in response
#	to window events.  It is for programs that don't need to do other
#	work while waiting for window input.
#
#	evhandle(win) processes one event and then returns to its caller,
#	allowing external loop control.  evhandle returns the outcome of
#	the handler proc, or fails if there is no handler for the event.
#
#   quitsensor(win, wait) -- standardized "quit" sensor
#
#	quitsensor() registers a sensor that calls exit() when either
#	"q" or "Q" is typed in the window.
#
#	If wait is non-null, quitsensor does not return but just waits for
#	the signal (useful in non-interactive display programs).
#
#
#   argless(win, proc) -- call proc with no arguments.
#
#	Useful for registering argless procedures as in quitsensor() above.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################

record EvMux_Rec(ev, proc, arg, x, y, w, h)
global EvMux_Windows


## sensor(win, ev, proc, arg, x, y, w, h) -- register an event responder.

procedure sensor(win, ev, proc, arg, x, y, w, h)
   local evlist, r, e

   /EvMux_Windows := table()
   /EvMux_Windows[win] := list()
   evlist := EvMux_Windows[win]

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   if type(ev) == ("cset" | "string") then
      ev := cset(ev)
   else
      ev := cset(evchar(ev)) | stop("invalid event specification: ", image(ev))
   push(evlist, r := EvMux_Rec(ev, proc, arg, x, y, w, h))
   return r
end


## delsensor(win, x) -- delete sensor x, or all sensors, from window.

procedure delsensor(win, x)
   local t

   t := \EvMux_Windows[win] | fail

   if /x then {
      delete(EvMux_Windows, win)	# delete whole set of sensors
      return
      }

   if not (x === !t) then
      fail				# not registered in this window

   # Sensor is registered for this window.  Disable it.
   x.ev := ''

   # Remove disabled sensors from list, if possible.
   while *t[1].ev = 0 do
      pop(t)
   while *t[-1].ev = 0 do
      pull(t)

   # If nothing is left on list, delete from table.
   if *t = 0 then
      delete(EvMux_Windows, win)
   return
end


##   evchar(e) -- map mouse event to character code.
#
#  Internally, *all* events are single-character strings, and mouse & resizing
#  events are mapped into characters that are never returned as keypress events.

procedure evchar(s)
   return case s of {
      &lpress:    "\237"	# mouse button 1 down
      &mpress:    "\236"	# mouse button 2 down
      &rpress:    "\235"	# mouse button 3 down
      &lrelease:  "\234"	# mouse button 1 up
      &mrelease:  "\233"	# mouse button 2 up
      &rrelease:  "\232"	# mouse button 3 up
      &ldrag:     "\231"	# mouse button 1 is dragging
      &mdrag:     "\230"	# mouse button 2 is dragging
      &rdrag:     "\227"	# mouse button 3 is dragging
      &resize:    "\226"	# window has resized
   }
   fail
end


## evmux(win) -- loop forever, calling event handlers as appropriate.
## evhandle(win) -- wait for the next event, and handle it.
#		    produce result of the handler proc; fail if nobody handles.

procedure evmux(win)
   repeat
      evhandle(win)
end

procedure evhandle(win)
   local x, y, ev, e, r, t

   t := (\EvMux_Windows)[win] | stop("no events registered for window")
   ev := Event(win)
   x := &x
   y := &y

   # convert event code to single character
   if type(ev) == "integer" then
      e := evchar(ev) | ""
   else
      e := ev

   # find and call the first (most recent) matching handler
   # (just a simple serial search)
   every r := !t do
      if any(r.ev, e) & ontarget(r, x, y) then
         return r.proc(win, r.arg, x, y, ev)
   fail
end


## ontarget(r, x, y) -- check if an event is within bounds
#
#  checks that (x, y) are within the bounds of (r.x, r.y, r.w, r.h).

procedure ontarget(r, x, y)
   return (x -:= r.x) >= 0 & x < r.w & (y -:= r.y) >= 0 & y < r.h
end


## quitsensor(win, wait) -- standardized "quit" sensor

procedure quitsensor(win, wait)
   sensor(win, 'qQ', argless, exit)
   if \wait then evmux(win)
   return
end


## argless(win, proc) -- call proc with no arguments.

procedure argless(win, proc)
   return proc()
end



#===========================================  /home/gmt/ipl/gprocs/graphics.icn



############################################################################
#
#	File:     graphics.icn
#
#	Subject:  Procedures for graphics
#
#	Author:   Gregg M. Townsend
#
#	Date:     November 14, 1994
#
############################################################################
#
#  Links to core subset of graphics procedures.
#
############################################################################

#====== link bevel
#====== link color
#====== link dialog
#====== link enqueue
#====== link gpxop
#====== link gpxlib
#====== link vidgets	# basic set needed by Dialog() and Vset()
#====== link window
#====== link wopen



#=============================================  /home/gmt/ipl/gprocs/dialog.icn



############################################################################
#
#	File:     dialog.icn
#
#	Subject:  Procedures for dialogs
#
#	Author:   Ralph E. Griswold and Gregg M. Townsend
#
#	Date:     August 23, 1995
#
############################################################################
#
#  This file contains several procedures for posting dialog boxes:
#
#  Notice(win, captions) -- notice dialog (a simple text dialog)
#  TextDialog(win, captions, labels, defaults...) -- text dialog
#  ToggleDialog(win, captions, labels, defaults...) -- toggle dialog
#  SelectDialog(win, captions, labels, defaults...) -- selection dialog
#  SaveDialog(win, caption, filename, len) -- save file dialog
#  OpenDialog(win, caption, filename, len) -- open file dialog
#  ColorDialog(win, captions, refcolor, callback, id) -- color dialog
#
#  In all cases, the first or only caption is used as a dialog box ID,
#  used to remember the dialog box location when it is closed.  A later
#  posting using the same ID places the new box at the same location.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links:  graphics, vbuttons, vdialog, vradio, vslider, vidgets
#
############################################################################

#====== link graphics
#====== link vbuttons
#====== link vdialog
#====== link vradio
#====== link vslider
#====== link vidgets

global dialog_button
global dialog_value

$define ButtonWidth	 50	# minimum button width
$define ButtonHeight	 30	# button height
$define FieldWidth	 10	# default field width
$define OpenWidth	 50	# default field width for Open/SaveDialog

$define XOff		  0	# offset for text vidgets
$define XOffButton	 85	# initial x offset for buttons
$define XOffIncr	 15	# space between buttons

procedure Dialog(win, captions, labels, defaults, widths, buttons, index)
   Dialog := TextDialog
   return Dialog(win, captions, labels, defaults, widths, buttons, index)
end

procedure TextDialog(			#: text dialog
   win, captions, labels, defaults, widths, buttons, index
   )
   local maxl, lead, pad, default_button, i, maxw, cwidth, id, label_width
   local button, maxb, dialog, x, y, button_space, default_width, box_id

   if type(win) ~== "window" then {
      win :=: captions :=: labels :=: defaults :=: widths :=: buttons :=: index
      win := &window
      }

   /captions := []
   /labels := []
   /defaults := []
   /widths := []
   /buttons := ["Okay", "Cancel"]
   /index := 1

   if type(captions) ~== "list" then captions := [captions]
   if type(labels) ~== "list" then labels := ([\labels] | [])
   if type(defaults) ~== "list" then defaults := ([\defaults] | [])
   if type(widths) ~== "list" then widths := ([\widths] | [default_width])
   if type(buttons) ~== "list" then buttons := [buttons]

   default_button := buttons[index] 		# null if out of bounds
   default_width := widths[-1] | FieldWidth

   maxl := 0
   every maxl <:= *(labels | defaults | widths)
   until *labels = maxl do put(labels, labels[-1] | "")
   until *defaults = maxl do put(defaults, defaults[-1] | "")
   until *widths = maxl do put(widths, widths[-1] | 10) 

   id := 0

   label_width := 0
   every label_width <:= TextWidth(win, !labels)
   if label_width > 0 then label_width +:= 15

   maxb := 0
   every maxb <:= TextWidth(win, !buttons)
   maxb +:= 10
   maxb <:= ButtonWidth

   lead := WAttrib(win, "leading")
   pad := 2 * lead
   cwidth := WAttrib(win, "fwidth")

   dialog := Vdialog(win, pad, pad)

   maxw := 0
   every maxw <:= TextWidth(win, !captions)

   y := -lead

   every VInsert(dialog, Vmessage(win, !captions), 0, y +:= lead)
   every i := 1 to maxl do {
      y +:= pad
      if *labels[i] > 0 then
         VInsert(dialog, Vmessage(win, labels[i]), 0, y)
      VRegister(dialog, Vtext(win, "", , id +:= 1,
         widths[i]), label_width, y)
      maxw <:= label_width + widths[i] * cwidth
      }

   y +:= (3 * pad) / 2

   button_space := maxb * *buttons + XOffIncr * (*buttons - 1)
   maxw <:= button_space

   x := ((maxw - button_space) / 2)

   every button := !buttons do {
      VInsert(dialog, Vbutton(win, button, dialog_cb, V_OK, , maxb,
         ButtonHeight), x, y)
      x +:= maxb + XOffIncr
      }

   VFormat(dialog)

   box_id := captions[1] | "TextDialog"
   dialog_value := VOpenDialog(dialog, , box_id, defaults, default_button)

   return dialog_button

end

procedure ToggleDialog(			#: toggle dialog
   win, captions, labels, defaults, buttons, index
   )
   local maxl, lead, pad, default_button, i, maxw, cwidth, id, label_width
   local button, maxb, dialog, x, y, button_space, default_width, box_id

   if type(win) ~== "window" then {
      win :=: captions :=: labels :=: defaults :=:  buttons :=: index
      win := &window
      }

   /captions := []
   /labels := []
   /defaults := []
   /buttons := ["Okay", "Cancel"]
   /index := 1

   if type(captions) ~== "list" then captions := [captions]
   if type(labels) ~== "list" then labels := ([\labels] | [])
   if type(defaults) ~== "list" then defaults := ([\defaults] | [])
   if type(buttons) ~== "list" then buttons := [buttons]

   default_button := buttons[index] 		# null if out of bounds

   maxl := 0
   every maxl <:= *labels
   until *labels = maxl do put(labels, labels[-1] | "")
   until *defaults = maxl do put(defaults, defaults[-1] | &null)

   id := 0

   label_width := 0
   every label_width <:= TextWidth(win, !labels)
   if label_width > 0 then label_width +:= 30

   maxb := 0
   every maxb <:= TextWidth(win, !buttons)
   maxb +:= 10
   maxb <:= ButtonWidth

   lead := WAttrib(win, "leading")
   pad := 2 * lead
   cwidth := WAttrib(win, "fwidth")

   dialog := Vdialog(win, pad, pad)

   maxw := 0
   every maxw <:= TextWidth(win, !captions)

   y := -lead

   every VInsert(dialog, Vmessage(win, !captions), 0, y +:= lead)
   every i := 1 to maxl do {
      y +:= pad
      VRegister(dialog, Vtoggle(win, labels[i], , id +:= 1, V_CHECK_NO, label_width),
         0, y)
      maxw <:= label_width
      }

   y +:= (3 * pad) / 2

   button_space := maxb * *buttons + XOffIncr * (*buttons - 1)
   maxw <:= button_space

   x := ((maxw - button_space) / 2)

   every button := !buttons do {
      VInsert(dialog, Vbutton(win, button, dialog_cb, V_OK, , maxb,
         ButtonHeight), x, y)
      x +:= maxb + XOffIncr
      }

   VFormat(dialog)

   box_id := captions[1] | "ToggleDialog"
   dialog_value := VOpenDialog(dialog, , box_id, defaults, default_button)

   return dialog_button

end

procedure SelectDialog( 		#: selection dialog
   win, captions, labels, deflt, buttons, index
   ) 
   local maxl, lead, pad, default_button, i, maxw, cwidth, label_width
   local button, maxb, dialog, x, y, button_space, box_id

   if type(win) ~== "window" then {
      win :=: captions :=: labels :=: deflt :=: buttons :=: index
      win := &window
      }

   /captions := []
   /labels := []
   /buttons := ["Okay", "Cancel"]
   /index := 1

   if type(captions) ~== "list" then captions := [captions]
   if type(labels) ~== "list" then labels := ([\labels] | [])
   if type(buttons) ~== "list" then buttons := [buttons]

   default_button := buttons[index] 		# null if out of bounds

   maxl := 0
   every maxl <:= *labels
   until *labels = maxl do put(labels, labels[-1] | "")

   label_width := 0
   every label_width <:= TextWidth(win, !labels)
   if label_width > 0 then label_width +:= 15

   maxb := 0
   every maxb <:= TextWidth(win, !buttons)
   maxb +:= 10
   maxb <:= ButtonWidth

   lead := WAttrib(win, "leading")
   pad := 2 * lead
   cwidth := WAttrib(win, "fwidth")

   dialog := Vdialog(win, pad, pad)

   maxw := 0
   every maxw <:= TextWidth(win, !captions)

   y := -lead

   every VInsert(dialog, Vmessage(win, !captions), 0, y +:= lead)
   y +:= 2 * lead
   VRegister(dialog, Vvert_radio_buttons(win, labels, , 1, V_DIAMOND_NO), 0, y)

   y +:= integer(0.83 * (pad * (*labels - 1)) + 1.5 * pad)

   button_space := maxb * *buttons + XOffIncr * (*buttons - 1)
   maxw <:= button_space

   x := ((maxw - button_space) / 2)

   every button := !buttons do {
      VInsert(dialog, Vbutton(win, button, dialog_cb, V_OK, , maxb,
         ButtonHeight), x, y)
      x +:= maxb + XOffIncr
      }

   VFormat(dialog)

   box_id := captions[1] | "ToggleDialog"
   dialog_value := VOpenDialog(dialog, , box_id, [deflt], default_button)[1]

   return dialog_button

end

procedure Notice(captions[])		#: notice dialog
   local win

   if type(captions[1]) == "window" then
      win := get(captions)
   else
      win := &window

   TextDialog(win, captions, , , , "Okay")

   dialog_value := &null

   return dialog_button

end

procedure SaveDialog(win, caption, filename, len)	#: save dialog

   if type(win) ~== "window" then
      return SaveDialog((\&window | runerr(140)), win, caption, filename)

   /caption := "Save:"
   /filename := ""
   /len := OpenWidth

   TextDialog(win, caption, , filename, len, ["Yes", "No", "Cancel"])

   dialog_value := dialog_value[1]

   return dialog_button

end

procedure OpenDialog(win, caption, filename, len)	#: open dialog

   if type(win) ~== "window" then
      return OpenDialog((\&window | runerr(140)), win, caption, filename)

   /caption := "Open:"
   /filename := ""
   /len := OpenWidth

   TextDialog(win, caption, , filename, len)

   dialog_value := dialog_value[1]

   return dialog_button

end

procedure dialog_cb(vidget, s)

   dialog_button := vidget.s

   return

end

#  ColorDialog(win, captions, color, callback, id) -- display color dialog
#
#  captions	list of dialog box captions; default is ["Select color:"]
#  color	reference color setting; none displayed if not supplied
#  callback	procedure to call when the setting is changed
#  id		arbitrary value passed to callback
#
#  ColorDialog displays a dialog window with R/G/B and H/S/V sliders for
#  color selection.  When the "Okay" or "Cancel" button is pressed,
#  ColorDialog returns the button name, with the ColorValue of the final
#  settings stored in the global variable dialog_value.
#
#  If a callback procedure is specified, callback(id, k) is called whenever
#  the settings are changed;  k is the ColorValue of the settings.

record cdl_rec(rect, orgcolor, refcolor, mutable, callback, id,
   r, g, b, h, s, v, rv, gv, bv, hv, sv, vv)

global cdl_data			# data for current color dialog

$define PickerWidth	300	# overall color picker width
$define SliderHeight	200	# height of a slider
$define SliderWidth	 15	# width of one slider
$define SliderPad	  5	# distance between sliders

procedure ColorDialog(win, captions, refcolor, callback, id)	#: color dialog
   local x1, x2, dx, y, bw, lead, pad, dialog, box_id

   if type(win) ~== "window" then
      return ColorDialog((\&window|runerr(140)), win,captions,refcolor,callback)

   /captions := "Select color:"
   if type(captions) ~== "list" then captions := [captions]

   cdl_data := cdl_rec()
   cdl_data.callback := callback
   cdl_data.id := id
   cdl_data.refcolor := refcolor
   cdl_data.orgcolor := ColorValue(win, \refcolor | Fg(win) | "gray")

   cdl_data.orgcolor ? {
      cdl_data.r := integer(tab(many(&digits)))
      move(1)
      cdl_data.g := integer(tab(many(&digits)))
      move(1)
      cdl_data.b := integer(tab(many(&digits)))
      }
   HSV(cdl_data.orgcolor) ? {
      cdl_data.h := integer(tab(many(&digits)))
      move(1)
      cdl_data.s := integer(tab(many(&digits)))
      move(1)
      cdl_data.v := integer(tab(many(&digits)))
      }

   lead := WAttrib(win, "leading")
   pad := 2 * lead

   y := -lead

   dialog := Vdialog(win, pad, pad, cdl_init)
   every VInsert(dialog, Vmessage(win, !captions), 0, y +:= lead)

   dx := SliderWidth + SliderPad
   x1 := 0 - dx
   x2 := PickerWidth + SliderPad
   y +:= pad

   cdl_data.rv := cdl_slider(dialog, "r", x1 +:= dx, y, 0, 65535, cdl_data.r)
   cdl_data.gv := cdl_slider(dialog, "g", x1 +:= dx, y, 0, 65535, cdl_data.g)
   cdl_data.bv := cdl_slider(dialog, "b", x1 +:= dx, y, 0, 65535, cdl_data.b)
   cdl_data.vv := cdl_slider(dialog, "v", x2 -:= dx, y, 0, 100, cdl_data.v)
   cdl_data.sv := cdl_slider(dialog, "s", x2 -:= dx, y, 0, 100, cdl_data.s)
   cdl_data.hv := cdl_slider(dialog, "h", x2 -:= dx, y, 0, 360, cdl_data.h)

   x1 +:= dx + SliderPad
   x2 -:= 2 * SliderPad
   cdl_data.rect := Vpane(win, , , "sunken",
      x2 - x1, SliderHeight - 3 * lead - SliderPad)
   VInsert(dialog, cdl_data.rect, x1, y)

   y +:= SliderHeight + pad
   bw := TextWidth(win, "Cancel") + 10
   VInsert(dialog, Vbutton(win, "Okay", cdl_exit, V_OK, ,
      bw, ButtonHeight), PickerWidth / 2 - bw - 10, y)
   VInsert(dialog, Vbutton(win, "Cancel", cdl_exit, V_OK, ,
      bw, ButtonHeight), PickerWidth / 2 + 10, y)

   VFormat(dialog)
   box_id := captions[1] | "ColorDialog"
   VOpenDialog(dialog, , box_id, , "Okay")

   dialog_value := cdl_data.r || "," || cdl_data.g || "," || cdl_data.b
   return dialog_button

end

procedure cdl_slider(dialog, id, x, y, low, high, init) 	# place a slider
   local v

   v := Vvert_slider(dialog.win, cdl_setval, id,
      SliderHeight, SliderWidth, low, high, init)
   VInsert(dialog, v, x, y)
   return v
end

procedure cdl_init()			# initialize non-vidget part of dialog
   local c, r

   r := cdl_data.rect
   if cdl_data.mutable := NewColor(cdl_data.rect.win, cdl_data.orgcolor) then {
      c := Fg(r.win)
      Fg(r.win, cdl_data.mutable)
      FillRectangle(r.win, r.ux, r.uy, r.uw, r.uh)
      if Fg(r.win, \cdl_data.refcolor) then
         FillRectangle(r.win, r.ux, r.uy + r.uh, r.uw, -r.uh / 8)
      Fg(r.win, c)
      }
   else
      CenterString(r.win, r.ux + r.uw / 2, r.uy + r.uh / 2, "Cannot show color")
   cdl_sethsv()
   return
end

procedure cdl_exit(vidget, s)		# save position and button name on exit
   dialog_button := vidget.s
   FreeColor(cdl_data.rect.win, \cdl_data.mutable)
   return
end

procedure cdl_setval(v, x)		# set value in response to slider motion
   static recurse

   if /recurse then {			# if not a recursive call
      recurse := 1			# note to prevent recursion
      case v.id of {
         "r":  { cdl_data.r := x; cdl_sethsv(); }
         "g":  { cdl_data.g := x; cdl_sethsv(); }
         "b":  { cdl_data.b := x; cdl_sethsv(); }
         "h":  { cdl_data.h := x; cdl_setrgb(); }
         "s":  { cdl_data.s := x; cdl_setrgb(); }
         "v":  { cdl_data.v := x; cdl_setrgb(); }
         }
      recurse := &null
      }
   return
end

procedure cdl_sethsv()			# set h/s/v values from r/g/b
   local c

   HSV(c := cdl_data.r || "," || cdl_data.g || "," || cdl_data.b) ? {
      VSetState(cdl_data.hv, cdl_data.h := integer(tab(many(&digits))))
      move(1)
      VSetState(cdl_data.sv, cdl_data.s := integer(tab(many(&digits))))
      move(1)
      VSetState(cdl_data.vv, cdl_data.v := integer(tab(many(&digits))))
      }
   cdl_setcolor(c)
   return
end

procedure cdl_setrgb()			# set r/g/b values from h/s/v
   local c

   (c := HSVValue(cdl_data.h || "/" || cdl_data.s || "/" || cdl_data.v)) ? {
      VSetState(cdl_data.rv, cdl_data.r := integer(tab(many(&digits))))
      move(1)
      VSetState(cdl_data.gv, cdl_data.g := integer(tab(many(&digits))))
      move(1)
      VSetState(cdl_data.bv, cdl_data.b := integer(tab(many(&digits))))
      }
   cdl_setcolor(c)
   return
end

procedure cdl_setcolor(c)		# display new color and invoke callback
   local win, x1, x2, y, dy

   win := cdl_data.rect.win
   Color(win, \cdl_data.mutable, c)		# set the mutable color

   x1 := cdl_data.rect.ax
   x2 := x1 + cdl_data.rect.aw
   y := cdl_data.rect.ay + cdl_data.rect.ah + SliderPad
   dy := WAttrib(win, "leading")

   EraseArea(win, x1, y, x2 - x1, 3 * dy)	# erase and redraw text area
   y +:= WAttrib(win, "ascent")
   x2 -:= TextWidth(win, "h: 360")

   DrawString(win, x1, y, "r: " || right(cdl_data.r, 5))
   DrawString(win, x2, y, "h: " || right(cdl_data.h, 3))
   y +:= dy
   DrawString(win, x1, y, "g: " || right(cdl_data.g, 5))
   DrawString(win, x2, y, "s: " || right(cdl_data.s, 3))
   y +:= dy
   DrawString(win, x1, y, "b: " || right(cdl_data.b, 5))
   DrawString(win, x2, y, "v: " || right(cdl_data.v, 3))

   (\cdl_data.callback)(cdl_data.id, c)		# invoke user callback, if any
   return
end

#   Popup(x, y, w, h, proc, args...) creates a subwindow of the specified
#   size, calls proc(args), and awaits its success or failure.  Then, the
#   overlaid area is restored and the result of proc is produced.  &window,
#   as seen by proc, is a new binding of win in which dx, dy, and clipping
#   have been set.  The usable area begins at (0,0);  its size is
#   (WAttrib(win, "clipw"), WAttrib(win, "cliph")).  Defaults are:
#   	x, y	positioned to center the subwindow
#	w, h	250, 150
#	proc	Event
#  Popup(win, x, y, w, h, proc, args[])

$define BorderWidth 4
$define ShadowWidth 4

procedure Popup(args[])
   local win, x, y, w, h, xx, yy, ww, hh, dx, dy, s, proc, retv, ampwin, save

   # Get parameters.
   PushWin(args)
   win := get(args)
   x := get(args);		integer(x) | runerr(101, \x)
   y := get(args);		integer(y) | runerr(101, \y)
   w := \get(args) | 250; 	integer(w) | runerr(101, w)
   h := \get(args) | 150; 	integer(h) | runerr(101, h)
   proc := \get(args) | Event

   # Handle defaults
   dx := WAttrib(win, "dx")
   dy := WAttrib(win, "dy")
   /x := (WAttrib(win, "width") - w) / 2 - dx	# center the subwindow
   /y := (WAttrib(win, "height") - h) / 2 - dy
   w >:= WAttrib(win, "width")			# limit to size of full win
   h >:= WAttrib(win, "height")

   # Adjust subwindow configuration parameters.
   xx := x - BorderWidth
   yy := y - BorderWidth
   ww := w + 2 * BorderWidth + ShadowWidth
   hh := h + 2 * BorderWidth + ShadowWidth

   # Save original window contents.
   save := ScratchCanvas(ww, hh) | stop("can't get ScratchCanvas in Popup")
   CopyArea(win, save, xx, yy, ww, hh)

   # Save &window and create subwindow.
   ampwin := &window
   &window := Clone(win) | stop("can't Clone in Popup")
   WAttrib("drawop=copy", "fillstyle=solid", "linestyle=solid", "linewidth=1",
      "dx=" || (dx + x), "dy=" || (dy + y))
   DrawRectangle(-BorderWidth, -BorderWidth, ww-ShadowWidth-1, hh-ShadowWidth-1)
   BevelRectangle(-BorderWidth + 1, -BorderWidth + 1,
      ww - ShadowWidth - 2, hh - ShadowWidth - 2, BorderWidth)
   FillRectangle(-BorderWidth + ShadowWidth, h + BorderWidth,
      ww - ShadowWidth, ShadowWidth)
   FillRectangle(w + BorderWidth, -BorderWidth + ShadowWidth,
      ShadowWidth, hh - ShadowWidth) 
   Clip(0, 0, w, h)
   EraseArea()

   # Flush any previously entered events on the window
   while *Pending(win) > 0 do
      Event(win)

   # Call proc; save result, if any, or use args as flag if none.
   retv := (proc ! args) | args

   # Restore window and return result.  Use &window to ensure drawop=copy.
   Clip(-BorderWidth, -BorderWidth, ww, hh)
   CopyArea(save, &window, 0, 0, ww, hh, -BorderWidth, -BorderWidth)
   EraseArea(save)
   &window := ampwin
   return args ~=== retv
end



#============================================  /home/gmt/ipl/gprocs/vdialog.icn



############################################################################
#
#	File:     vdialog.icn
#
#	Subject:  Procedures for dialog boxes
#
#	Author:   Jon Lipp
#
#	Date:     July 10, 1995
#
############################################################################
#
#  Vidgets defined in this file:
#
#	Vdialog
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links:  vbuttons, vtext
#
############################################################################

#====== link vbuttons
#====== link vtext

record DL_pos_rec(x,y)		# dialog position record

############################################################################
#  Vdialog - allows a pop-up menu_frame to be associated with a button.
#
#  Open the dialogue, let the user edit fields, one entry per field.
#  returns a list containing the values of the fields.
#
############################################################################
record Vdialog_frame_rec(win, padx, pady, callback, aw, ah, lookup,
   draw, id, ax, ay, uid, F, P,  V)

procedure Vdialog(params[])
   local self
   static procs

   initial {
      procs := Vstd(event_Vframe, draw_Vframe, 1,
                   resize_Vframe, inrange_Vpane, init_Vdialog,
                   couplerset_Vpane, insert_Vdialog, remove_Vframe,
                   lookup_Vframe, set_abs_Vframe)
      if /V_OK then VInit()
   }

   self := Vdialog_frame_rec ! params[1:5|0]
   Vwin_check(self.win, "Vdialog()")
   if (\self.padx, not numeric(self.padx) ) then
      _Vbomb("invalid padx parameter to Vdialog()")
   if (\self.pady, not numeric(self.pady) ) then
      _Vbomb("invalid pady parameter to Vdialog()")

   self.uid := Vget_uid()
   self.V := procs
   self.F := Vstd_dialog(open_dialog_Vdialog, register_Vdialog,
             format_Vdialog, unregister_Vdialog)
   self.P := Vstd_pos()
   self.V.init(self)
   return self
end

procedure open_dialog_Vdialog(self, x, y, values, def_str)
local i, c, e, newfocus, tid, rv, now, val
local entry, r, def, sel, v, args, parent, posn
static xytable
initial xytable := table()

## Check ID and determine x and y values.
   if \x then {
      if WAttrib(self.win, "canvas") == ("normal" | "maximal") then  {
	 x +:= WAttrib(self.win, "posx")
	 y +:= WAttrib(self.win, "posy")
	 }
      }
   else if \y then {
      /xytable[y] := DL_pos_rec()
      posn := xytable[y]
      x := posn.x
      y := posn.y
      }

   if WAttrib(self.win,"canvas") == ("normal" | "maximal") then  {
      /x := WAttrib(self.win,"posx") + (WAttrib(self.win,"width")-self.aw) / 2
      /y := WAttrib(self.win,"posy") + (WAttrib(self.win,"height")-self.ah) / 2
      /x <:= 20
      /y <:= 10
      }

## Sort text entry list.
   self.F.text_entries := sort(self.F.text_entries)
   every i := 1 to *self.F.text_entries do
      self.F.text_lu[self.F.text_entries[i]] := i

## Build arg list and open window
   args := []
   put(args, "size=" || self.aw || "," || self.ah)
   put(args, "pos=" || \x || "," || \y)
   put(args, "display=" || WAttrib(self.win, "display"))
   put(args, "label=" || ("" ~== WAttrib(self.win, "label")))
   put(args, "font=" || WAttrib(self.win, "font"))
   if (c := Fg(self.win))[1] ~== "-" then
      put(args, "fg=" || c)
   if (c := Bg(self.win))[1] ~== "-" then
      put(args, "bg=" || c)
   parent := self.win
   if not (self.win := WOpen ! args) then {
      write(&errout, "can't open window for dialog")
      write(&errout, "window arguments:")
      every writes(&errout, " ", !args | "\n")
      stop()
      }

   every v := !self.draw do {
      v.win := self.win
      if type(v) == ("Vradio_frame_rec" | "Vscrollbar_frame_rec") then
         every (!v.draw).win := self.win
      }
   self.V.resize(self, 0, 0, self.aw, self.ah)

## Make a sorted list of self.F.entries
   sel := sort(self.F.entries, 1)
## set values of fields to value list, or default if entry is &null
   every i := 1 to *sel do {
      entry := sel[i][2]
      val := values[i] | &null
      (\entry).V.set_value(entry, val)
      }
   self.F.focus := &null
   self.V.draw(self)

## Find default button according to def_str.
   if \def_str then
      every i := !self.lookup do
         if def_str == \i["s"] then {
            def := i
            BevelRectangle(def.win, def.ax-5, def.ay-5, def.aw+10, def.ah+10,-2)
            break
            }

   self.F.focus := self.F.entries[self.F.text_entries[1]]
   newfocus := \self.F.focus | \sel[1][2] | &null
   (\self.F.focus).T.block(self.F.focus)

## Call the user initialization callback, if any.
   (\self.callback)(self)

   repeat {
      e := Event(self.win)
      if e === "\r" then {
         if \def then {
            e := &lpress
            &x := def.ax + 1
            &y := def.ay + 1
            Enqueue(def.win, &lrelease, def.ax + 1, def.ay + 1)
         }
         else next
      }
      if integer(e) < 0 then {
         newfocus := self.V.lookup(self, &x, &y) | self.F.focus
         if ((\newfocus).id) ~=== ((\self.F.focus).id) then
            switch_focus_Vdialog(self, newfocus)
      }
      r := (\newfocus).V.event(newfocus, e, &x, &y) | &null
      case r of {
         V_NEXT: { 	#move to next entry
            now := self.F.text_lu[self.F.focus.id]
            tid := ((*self.F.text_entries >= now + 1) | 1)
            switch_focus_Vdialog(self, self.F.entries[self.F.text_entries[tid]])
            }
         V_PREVIOUS: {	#move to previous entry
            now := self.F.text_lu[self.F.focus.id]
            tid := ((1 <= now - 1) | *self.F.text_entries)
            switch_focus_Vdialog(self, self.F.entries[self.F.text_entries[tid]])
            }
         V_OK: {	# done, quit with changes
            rv := []
            every e := !sel do put(rv, e[2].data)
            break
            }
         V_CANCEL: { 	# cancel changes, quit.
            break
            }
      }
      newfocus := self.F.focus
   } # end repeat

## close temporary window after saving its location for next time
   (\posn).x := WAttrib(self.win, "posx")
   (\posn).y := WAttrib(self.win, "posy")
   WClose(self.win)

## restore window fields
   self.win := parent
   every v := !self.draw do {
      v.win := self.win
      if type(v) == ("Vradio_frame_rec" | "Vscrollbar_frame_rec") then
         every (!v.draw).win := self.win
      }

## flush pending events that may have accumulated on the parent window
   while *Pending(self.win) > 0 do
      Event(self.win)

##  For Vtext vidgies, tell them to turn off their cursors.
   every tid := !self.F.text_entries do
      \(self.F.entries[tid]).T.CursorOn := &null

   return \rv
end

procedure switch_focus_Vdialog(self, newfocus)
   if (newfocus.id === !self.F.text_entries) then {
      self.F.focus.T.unblock(self.F.focus)
#      self.F.focus.T.erase_cursor(self.F.focus)
      newfocus.T.block(newfocus)
      self.F.focus := newfocus
      }
end

procedure insert_Vdialog(self, vidget, x, y)
   if /self | /vidget | /x | /y then
      _Vbomb("incomplete or &null parameters to VInsert() for dialogs")
   pad_and_send_Vdialog(self, vidget, x, y)
end

procedure register_Vdialog(self, vidget, x, y)
   if /self | /vidget | /x | /y then
      _Vbomb("incomplete or &null parameters to VRegister()")
   self.F.entries[vidget.id] := vidget
   if type(vidget) ? find("text") then
      put(self.F.text_entries, vidget.id)
   pad_and_send_Vdialog(self, vidget, x, y)
end

procedure unregister_Vdialog(self, kid)
local new, i

   if (kid.id === !self.F.text_entries) then {
      new := []
      every i := !self.F.text_entries do if kid.id ~=== i then put(new, i)
      self.F.text_entries := new
      }
   delete(self.F.entries, kid.id)
   every i := 1 to *self.F.text_entries do
      self.F.text_lu[self.F.text_entries[i]] := i
   self.V.remove(self, kid, 1)
end

procedure pad_and_send_Vdialog(self, vidget, x, y)

   if (x|y) < 0 | type(x|y) == "real" then
      _Vbomb("must VRegister() or VInsert() a vidget to a dialog with absolute coordinates")
   insert_Vframe(self, vidget, x+self.padx, y+self.pady)
end

procedure format_Vdialog(self)
   self.V.resize(self, 0, 0,
                 Vmin_frame_width(self)+self.padx-1,
                 Vmin_frame_height(self)+self.pady-1)
end

procedure init_Vdialog(self)
   init_Vframe(self)
   /self.padx := 20
   /self.pady := 20
   self.F.entries := table()
   self.F.text_entries := []
   self.F.text_lu := table()
end



#============================================  /home/gmt/ipl/gprocs/vidgets.icn



############################################################################
#
#	File:     vidgets.icn
#
#	Subject:  Procedures for vidgets
#
#	Author:   Jon Lipp
#
#	Date:     November 14, 1994
#
############################################################################
#
#  Links to basic vidget files needed to use the library.
#
############################################################################

#====== link graphics
#====== link vcoupler
#====== link vframe
#====== link viface
#====== link vpane
#====== link vstd



#============================================  /home/gmt/ipl/gprocs/vslider.icn



############################################################################
#
#	File:     vslider.icn
#
#	Subject:  Procedures for sliders
#
#	Author:   Jon Lipp and Gregg M. Townsend
#
#	Date:     March 23, 1995
#
############################################################################
#
#  Vidgets defined in this file:
#	Vvslider
#	Vhslider
#
#  Utility procedures in this file:
#	Vvert_slider()
#	Vhoriz_slider()
#
############################################################################
#
#  Includes: vdefns.icn
#
############################################################################
#
#  Links:  vidgets
#
############################################################################

#====== link vidgets

#====== $include "vdefns.icn"

record Vslider_rec (win, callback, id, aw, ah, discont,
   ax, ay, data, pad, ws, cv_range, rev, pos, uid, drawn, P, V)

############################################################################
# Vvslider
############################################################################

procedure procs_Vvslider()
   static procs
   initial procs := Vstd(event_Vvslider, draw_Vvslider, outline_Vslider,
                        resize_Vvslider, inrange_Vpane, init_Vvslider,
                        couplerset_Vvslider,,,,,set_value_Vvslider)
   return procs
end

procedure Vvslider(params[])
   local self

   self := Vslider_rec ! params[1:7|0]
   Vwin_check(self.win, "Vvert_slider()")
   if (\self.aw, not numeric(self.aw) ) then
      _Vbomb("invalid width parameter to Vvert_slider()")
   if (\self.ah, not numeric(self.ah) ) then
      _Vbomb("invalid length parameter to Vvert_slider()")
   
   self.uid := Vget_uid()
   self.V := procs_Vvslider()
   self.P := Vstd_pos()

   self.V.init(self)
   return self
end

procedure draw_Vvslider(s)
local val

   s.drawn := 1
   s.V.outline(s)
   val := (s.callback.value - s.callback.min) * s.ws / s.cv_range
   if \s.rev then
      val := s.ws - val + s.pad
   else
      val +:= s.pad
   s.pos := val
   draw_Vvslider_bar(s)
end

procedure event_Vvslider(s, e)
local value

   if \s.callback.locked then fail
   if e === (&lpress|&mpress|&rpress) then
      until e === (&lrelease|&mrelease|&rrelease) do {
         value := ((&y - s.ay - s.pad) / s.ws) * s.cv_range
         if \s.rev then
            s.callback.V.set(s.callback, s, s.callback.max - value, s.discont)
         else
            s.callback.V.set(s.callback, s, s.callback.min + value, s.discont)
         s.data := s.callback.value
         update_Vvslider(s, 1)
         e := Event(s.win)
         }
   else
      fail				# not our event
   if \s.discont then
      s.callback.V.set(s.callback, s, s.callback.value)
   update_Vvslider(s)
   return s.callback.value
end

procedure update_Vvslider(s, active)
local val

   val := (s.callback.value - s.callback.min) * s.ws / s.cv_range
   if \s.rev then
      val := s.ws - val + s.pad
   else
      val +:= s.pad
   s.pos := val
   draw_Vvslider_bar(s, active)
   return s.callback.value
end

procedure draw_Vvslider_bar(s, active)
local ww, d

   ww := s.aw - 4
   EraseArea(s.win, s.ax + 2, s.ay + 2, ww, s.ah - 4)
   if \active then {
      d := -1
      FillRectangle(s.win, s.ax + 4, s.ay + s.pos - ww + 2, ww - 4, 2 * ww - 4)
      }
   else
      d := 1
   BevelRectangle(s.win, s.ax + 2, s.ay + s.pos - ww, ww, 2 * ww, d)
   BevelRectangle(s.win, s.ax + 3, s.ay + s.pos, ww - 2, 1 - ww, d)
   BevelRectangle(s.win, s.ax + 3, s.ay + s.pos, ww - 2, ww - 1, d)
end

procedure set_value_Vvslider(s, value)
   couplerset_Vvslider(s, , value)
   return
end

procedure couplerset_Vvslider(s, caller, value)

   value := numeric(value) | s.callback.min
   if s.callback.value === value then fail
   s.callback.V.set(s.callback, caller, value)
   s.data := s.callback.value
   if \s.drawn then
      update_Vvslider(s)
end

procedure init_Vvslider(s)

   /s.aw := VSlider_DefWidth
   /s.ah := VSlider_DefLength
   s.aw <:= VSlider_MinWidth
   s.ah <:= VSlider_MinAspect * s.aw
   if /s.callback | type(s.callback) == "procedure" then
      _Vbomb("Vvslider requires a coupler variable callback")
   s.pad := s.aw - 2
   s.ws := real(s.ah - 2 * s.pad)
   s.cv_range := s.callback.max - s.callback.min
   init_Vpane(s)
end

procedure resize_Vvslider(s, x, y, w, h)

   resize_Vidget(s, x, y, w, h)
   if s.aw > s.ah then {
      s.V := procs_Vhslider()
      return s.V.resize(s, x, y, w, h)
      }
   s.pad := s.aw - 2
   s.ws := real(s.ah - 2 * s.pad)
   s.cv_range := s.callback.max - s.callback.min
end


############################################################################
# Vhslider 
############################################################################

procedure procs_Vhslider()
   static procs

   initial procs := Vstd(event_Vhslider, draw_Vhslider, outline_Vslider,
                        resize_Vhslider, inrange_Vpane, init_Vhslider,
                        couplerset_Vhslider,,,,,set_value_Vhslider)
   return procs
end

procedure Vhslider(params[])
   local self

   self := Vslider_rec ! params[1:7|0]
   self.aw :=: self.ah
   Vwin_check(self.win, "Vhoriz_slider()")
   if (\self.ah, not numeric(self.ah) ) then
      _Vbomb("invalid width parameter to Vhoriz_slider()")
   if (\self.aw, not numeric(self.aw) ) then
      _Vbomb("invalid length parameter to Vhoriz_slider()")

   self.uid := Vget_uid()
   self.V := procs_Vhslider()
   self.P := Vstd_pos()

   self.V.init(self)
   return self
end

procedure draw_Vhslider(s)
local val

   s.drawn := 1
   s.V.outline(s)
   val := (s.callback.value - s.callback.min) * s.ws / s.cv_range
   if \s.rev then
      val := s.ws - val + s.pad
   else
      val +:= s.pad
   s.pos := val
   draw_Vhslider_bar(s)
end

procedure event_Vhslider(s, e)
local value

   if \s.callback.locked then fail
   if e === (&lpress|&mpress|&rpress) then
      until e === (&lrelease|&mrelease|&rrelease) do {
         value := ((&x - s.ax - s.pad) / s.ws) * s.cv_range
         if \s.rev then
            s.callback.V.set(s.callback, s, s.callback.max - value, s.discont)
         else
            s.callback.V.set(s.callback, s, s.callback.min + value, s.discont)
         s.data := s.callback.value
         update_Vhslider(s, 1)
         e := Event(s.win)
         }
   else
      fail				# not our event
   if \s.discont then
      s.callback.V.set(s.callback, s, s.callback.value)
   update_Vhslider(s)
   return s.callback.value
end

procedure update_Vhslider(s, active)
local val

   val := (s.callback.value - s.callback.min) * s.ws / s.cv_range
   if \s.rev then
      val := s.ws - val + s.pad
   else
      val +:= s.pad
   s.pos := val
   draw_Vhslider_bar(s, active)
   return s.callback.value
end

procedure draw_Vhslider_bar(s, active)
local hh, d

   hh := s.ah - 4
   EraseArea(s.win, s.ax + 2, s.ay + 2, s.aw - 4, hh)
   if \active then {
      d := -1
      FillRectangle(s.win, s.ax + s.pos - hh + 2, s.ay + 4, 2 * hh - 4, hh - 4)
      }
   else
      d := 1
   BevelRectangle(s.win, s.ax + s.pos - hh, s.ay + 2, 2 * hh, hh, d)
   BevelRectangle(s.win, s.ax + s.pos, s.ay + 3, 1 - hh, hh - 2, d)
   BevelRectangle(s.win, s.ax + s.pos, s.ay + 3, hh - 1, hh - 2, d)
end

procedure set_value_Vhslider(s, value)
   couplerset_Vhslider(s, , value)
   return
end

procedure couplerset_Vhslider(s, caller, value)

## break a cycle in callbacks by checking value.
   value := numeric(value) | s.callback.min
   if s.callback.value === value then fail
   s.callback.V.set(s.callback, caller, value)
   s.data := s.callback.value
   if \s.drawn then
      update_Vhslider(s)
end

procedure init_Vhslider(s)

   /s.ah := VSlider_DefWidth
   /s.aw := VSlider_DefLength
   s.ah <:= VSlider_MinWidth
   s.aw <:= VSlider_MinAspect * s.ah
   if /s.callback | type(s.callback) == "procedure" then
      _Vbomb("Vhslider requires a coupler variable callback")
   s.pad := s.ah - 2
   s.ws := real(s.aw - 2 * s.pad)
   s.cv_range := s.callback.max - s.callback.min
   init_Vpane(s)
end

procedure resize_Vhslider(s, x, y, w, h)

   resize_Vidget(s, x, y, w, h)
   if s.aw < s.ah then {
      s.V := procs_Vvslider()
      return s.V.resize(s, x, y, w, h)
      }
   s.pad := s.ah - 2
   s.ws := real(s.aw - 2 * s.pad)
   s.cv_range := s.callback.max - s.callback.min
end

############################################################################
# Utilities - slider wrapper procedures.
############################################################################

procedure outline_Vslider(s)
   BevelRectangle(s.win, s.ax, s.ay, s.aw, s.ah, -2)	# draw trough
end

procedure Vmake_slider(slider_type, w, callback, id, length, width,
                       min, max, init, discontinuous)
local cv, sl, cb, t

   /min := 0
   /max := 1.0
   if not numeric(min) | not numeric(max) | (\init, not numeric(init)) then
      _Vbomb("non-numeric min, max, or init parameter passed to Vxxxxx_slider()")
   if max < min then { min :=: max; t := 1 }
   cv := Vrange_coupler(min, max, init)
   sl := slider_type(w, cv, id, width, length, discontinuous)
   sl.rev := t
   
   add_clients_Vinit(cv, callback, sl)
   return sl
end

############################################################################
# Vvert_slider(w, callback, id, width, length, lower_bound, upper_bound,
#              initial_value) 
############################################################################
procedure Vvert_slider(params[])
local frame, x, y, ins, t, self

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }

   params[6] :=: params[7]
   push(params, Vvslider)
   self :=  Vmake_slider ! params
   if \ins then VInsert(frame, self, x, y)
   return self
end

############################################################################
# Vhoriz_slider(w, callback, id, width, length, left_bound, right_bound,
#              initial_value) 
############################################################################
procedure Vhoriz_slider(params[])
local frame, x, y, ins, self

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }

   push(params, Vhslider)
   self :=  Vmake_slider ! params
   if \ins then VInsert(frame, self, x, y)
   return self
end



#==============================================  /home/gmt/ipl/gprocs/vmenu.icn



############################################################################
#
#	File:     vmenu.icn
#
#	Subject:  Procedures for vidget menus
#
#	Author:   Jon Lipp and Gregg M. Townsend
#
#	Date:     November 8, 1994
#
############################################################################
#
#  Vidgets defined in this file:
#
#	Vmenu_item
#	Vmenu_bar_item
#	Vmenu_frame
#	Vpull_down_button
#
#  Utility procedures in this file:
#	Vsub_menu()
#	Vmenu_bar()
#	Vpull_down_pick_menu()
#	Vpull_down()
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links:  vstyle
#
############################################################################

#====== link vstyle

############################################################################
# Vmenu_item
############################################################################
record Vmenu_item_rec (win, s, callback, id, aw, ah, menu, ax, ay,
   uid, P, D, V, style)

procedure Vmenu_item(params[])
   local self
   static procs

   initial procs := Vstd(event_Vmenu_item, draw_Vmenu_item, outline_menu_pane,
                        resize_Vidget, inrange_Vpane, init_Vmenu_item,
                        couplerset_Vmenu_item)
   self := Vmenu_item_rec ! params
   self.uid := Vget_uid()
   if type(\self.callback) == "Vmenu_frame_rec" then {
      self.menu := self.callback
      self.callback := self.menu.callback
      self.s ||:= " >"
   }

## Init
   self.D := Vstd_draw(draw_off_entry, draw_on_entry)
   self.P := Vstd_pos()
   self.D.outline := 1
   self.V := procs
   self.V.init(self)

   return self
end

#
#  A menu item needs to be sized a little smaller than a normal
#  button, so we steal the 2d init procedure.
#
procedure init_Vmenu_item(self)
   local TW, FH, ascent, descent, basey

   /self.s := ""
   TW := TextWidth(self.win, self.s)
   ascent := WAttrib(self.win, "ascent")
   descent := WAttrib(self.win, "descent")
   FH := ascent + descent
   /self.aw := TW + 5
   /self.ah := FH + 2

   self.aw := 0 < self.aw | 1
   self.ah := 0 < self.ah | 1

   self.D.basex := (self.aw - TW + 1) / 2
   basey := 1 + ascent
   if FH <= 10 then basey := 8
   self.D.basey := basey

end

procedure draw_Vmenu_item(s)
   s.D.draw_off(s)
end

procedure draw_on_entry(s)
   GotoXY(s.win, s.ax+s.D.basex, s.ay+s.D.basey)
   writes(s.win, s.s)
   BevelRectangle(s.win, s.ax, s.ay, s.aw, s.ah)
end

procedure draw_off_entry(s)
   EraseArea(s.win, s.ax, s.ay, s.aw, s.ah)
   GotoXY(s.win, s.ax+s.D.basex, s.ay+s.D.basey)
   writes(s.win, s.s)
end

procedure couplerset_Vmenu_item(s)
   s.V.draw(s)
end

#
#  This is complicated....  if we drag off to the right while within the
#  y-range of the menu item, call its submenu *if* one exists.  Else
#  if there is a release not on the menu item, fall out of loop.  Else
#  if released on menu item and there is *no* submenu, make a return
#  value consisting of the id.  Else, continue through loop.
#
#  This will take return value of submenu (if successful choice) and pass
#  it back up to menu bar item.
#
procedure event_Vmenu_item(self, e, sub)
local  rv

   self.D.draw_on(self)
   (\self.menu).V.resize(self.menu, self.ax+self.aw-4, self.ay)
   show_Vmenu_frame(\self.menu)
   rv := V_FAIL
   repeat {
      if (\self.menu,
         (&x >= self.ax+self.aw) & (self.ay <= &y <= self.ay+self.ah)) then {
         rv := self.menu.F.pick(self.menu, e, 1) | &null
         if \rv ~=== V_DRAGGING & \rv ~=== V_FAIL then
            rv :=  (push(\rv, self.uid))
         }

      else if (\self.menu, e === (&lrelease|&mrelease|&rrelease)) then rv := &null
      else if e === (&lrelease|&mrelease|&rrelease) then rv :=  [self.uid]
      else if self.V.inrange(self, &x, &y) then rv := V_DRAGGING
      if \rv === V_DRAGGING then {
         e := Event(self.win)
         if e === "\^s" then
            until Event(self.win) === (&lpress|&mpress|&rpress) ;
         rv := V_FAIL
         }
      else break
      }
   hide_Vmenu_frame(\self.menu)
   self.D.draw_off(self)
   if rv === V_FAIL then fail
   return rv
end

############################################################################
# Vmenu_bar_item
############################################################################

procedure Vmenu_bar_item(params[])
   local self
   static procs

   initial procs := Vstd(event_Vmenu_bar_item, draw_Vmenu_item,
                        outline_menu_pane, resize_Vmenu_bar_item, inrange_Vpane,
                        null_proc, couplerset_Vmenu_item)
   self := Vmenu_item_rec ! params
   self.uid := Vget_uid()
   if type(\self.menu) ~== "Vmenu_frame_rec" then
      _Vbomb("Vmenu_bar_item must be created with a Vmenu_frame")

## Init
   Vset_style(self, V_RECT)
   self.P := Vstd_pos()
   self.V := procs
   self.callback := (\self.menu).callback
   self.D.init(self)

   return self
end

#
#  Resize ourselves, then tell our submenu to resize itself at the
#  right location.
#
procedure resize_Vmenu_bar_item(self, x, y, w, h)

   resize_Vidget(self, x, y, w, h)
   (\self.menu).V.resize(self.menu, self.ax, self.ay+self.ah)
end

#
#  Process events through a loop, grabbing focus:
#  If release, fall out.  Else, if dragged off bottom, open up submenu.
#  If dragged any other direction, fall out.
#
#  Take return value ( a list) from submenu, and reference callback tables
#  to call correct callback for submenu choice made.
#
procedure event_Vmenu_bar_item(self, e)
local rv, callback, i, t, labels

   if e ~=== &lpress & e ~=== &mpress & e ~=== &rpress then
      fail				# not our event
   self.D.draw_on(self)
   show_Vmenu_frame(\self.menu)
   repeat {
      if e === (&lrelease|&mrelease|&rrelease) then rv := &null
      else if self.V.inrange(self, &x, &y) then rv := V_DRAGGING
      else if (self.ax <= &x <= self.ax+self.aw) & (&y >= self.ay+self.ah) then
         rv := (\self.menu).F.pick(self.menu, e)
      if \rv === V_DRAGGING then {
         e := Event(self.win)
         rv := &null
         }
      else break
   }
   hide_Vmenu_frame(\self.menu)
   self.D.draw_off(self)
   if \rv === V_FAIL then
      return &null
   if \rv then {
      callback := self.callback
      labels := []
      every i := !rv do {
         t := callback[i]
         callback := t[1]
         put(labels, t[2])
      }
      return (\callback)(self, labels) | labels
   }
   return &null
end


############################################################################
# Vmenu_frame
############################################################################

record Vmenu_frame_rec(win, callback, aw, ah, id, temp, drawn,
   lookup, draw, ax, ay, uid, P, F, V)

procedure Vmenu_frame(params[])
local self
static procs

   initial {
      procs := Vstd(event_Vframe, draw_Vframe, outline_menu_pane,
                   resize_Vframe, inrange_Vpane, null_proc,
                   couplerset_Vpane, insert_Vmenu_frame, null_proc,
                   lookup_Vframe, set_abs_Vframe)
   }

   self := Vmenu_frame_rec ! params

## Init
   self.uid := Vget_uid()
   self.V := procs
   self.F := Vstd_draw()
   self.F.pick := pick_Vmenu_frame
   self.F.format := format_Vmenu_frame

   self.P := Vstd_pos()
   init_Vframe(self)
   self.callback := table()
   self.temp := open("vmenu", "g", "canvas=hidden")

   return self
end

#
#  Draw beveled, raised outline
#
procedure outline_menu_pane(self)
   BevelRectangle(self.win, self.ax, self.ay, self.aw, self.ah)
end

#
#  Find minimum bounding encompassing frame.  At the same time, set
#  children to be flush against left edge.
#
procedure format_Vmenu_frame(self, width)
local maxwidth, child

   maxwidth := \width | Vmin_frame_width(self) + 4
   every child := !self.lookup do {
      child.P.w := maxwidth - 4
   }
   self.V.resize(self, 0, 0, maxwidth, Vmin_frame_height(self) + 2)
end

#
#  Open up menu frame.  Copy window on temporary binding.
#  Usually invoked by parent menu item.
#
procedure show_Vmenu_frame(self)

   WAttrib(self.temp, "width="||(self.aw+10), "height="||(self.ah+10))
   CopyArea(self.win, self.temp, self.ax, self.ay, self.aw+5, self.ah+5, 0, 0)
   draw_Vframe(self)
   self.drawn := 1
end

#
#  Hide menu frame.  Copy contents of temporary binding back onto window.
#  Also invoked by parent menu item.
#
procedure hide_Vmenu_frame(self)

   CopyArea(self.temp, self.win, 0, 0, self.aw+5, self.ah+5, self.ax, self.ay)
   self.drawn := &null
end

#
#  Basically the event loop for the menu frame.  Routes events to the
#  appropriate menu item.
#
procedure pick_Vmenu_frame(self, e, sub)
local  focus, rv

   /e := -1
   if /self.drawn then
      show_Vmenu_frame(self)
   rv :=  V_DRAGGING
   repeat {
      focus := self.V.lookup(self, &x, &y) | &null
      if (e === (&lrelease|&mrelease|&rrelease) & /focus) then fail
      else if (/sub, &y < self.ay) | (\sub, &x < self.ax) then return V_DRAGGING
      else if rv := (\focus).V.event(focus, e, sub) then return rv
      else if (e === "\^s" & /focus) then
         until Event(self.win) === (&lpress|&mpress|&rpress) ;
      e := Event(self.win)
   }
end

#
#  Put the entries into the callback table of the frame as such: if the
#  entry has a submenu, put its callback table and string label in, else
#  put the callback procedure and string label in.
#
procedure insert_Vmenu_frame(self, vid, x, y)
   local s

   insert_Vframe(self, vid, x, y)
   s := (type(vid.callback) == "table", vid.s[1:-2]) | vid.s
   self.callback[\vid.uid] := [vid.callback, s]
end

############################################################################
# wrappers for Vsub_menu and Vmwenu_bar
############################################################################

procedure Vsub_menu(w, p[])
   local frame, id, name, callback, ypos, item

   Vwin_check(w, "Vsub_menu()")

   frame := Vmenu_frame(w)
   id := 1
   ypos := 2
   while \(name := pop(p)) do {
      callback := pop(p) | &null
      if type(\name) ~== "string" & not numeric(name) then
         _Vbomb("invalid label passed to Vsub_menu()")
      image(callback) ? { if ="function" then
         _Vbomb("Icon function" || tab(0) ||
                "() not allowed as callback from sub_menu item")
         }
      item := Vmenu_item(w, name, callback, id)
      VInsert(frame, item, 2, ypos)
      id +:= 1
      ypos +:= item.ah
   }
   VFormat(frame)
   return frame
end

procedure Vmenu_bar(p[])
   local parent, x, y, ins, frame, id, name, submenu, xpos, item, win

   if ins := Vinsert_check(p) then {
      parent := pop(p); x := pop(p); y:= pop(p)
      }
   win := pop(p)
   Vwin_check(win, "Vmenu_bar()")

   frame := Vframe(win)
   xpos := id := 1
   while name := pop(p) do {
      submenu := pop(p) | &null
      if type(\name) ~== "string" & not numeric(name) then
         _Vbomb("invalid label passed to Vmenu_bar()")
      if type(\submenu) ~== "Vmenu_frame_rec" then
         _Vbomb("invalid menu parameter to Vmenu_bar()")
      item := Vmenu_bar_item(win, name, , id, , , submenu )
      VInsert(frame, item, xpos, 1)
      id +:= 1
      xpos +:= item.aw
   }
   VFormat(frame)
   frame.V.outline := null_proc

   if \ins then VInsert(parent, frame, x, y)

   return frame
end

############################################################################
# Vpull_down_button
############################################################################

record Vpull_down_button_rec (win, callback, id, sz, pd, data, s, style,
   aw, ah, ax, ay, abx, uid, P, D, V)

procedure Vpull_down_button(params[])
local self
local frame, x, y, ins
static procs

   initial procs := Vstd(event_Vpull_down_button, draw_Vpull_down_button,
      outline_menu_pane, resize_Vpull_down_button, inrange_Vpane,
      init_Vpull_down_button, couplerset_Vpull_down_button,,,,,
      set_value_Vpull_down_button)
   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vpull_down_button_rec ! params
   self.uid := Vget_uid()
   if type(self.pd) ~== "Vmenu_frame_rec" then
      _Vbomb("Vpull_down_button must be created with a Vpull_down")
   Vset_style(self, V_RECT)
   self.V := procs
   self.P := Vstd_pos()
   self.V.init(self)
   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure draw_Vpull_down_button(self)

   self.s := self.data[1:self.sz|0]
   self.D.draw_off(self)
   draw_Vpull_down_button_off(self)
end

procedure draw_Vpull_down_button_arrow(self)
local x, y, sz

   x := self.ax+self.abx; y := self.ay; sz := self.ah

   FillPolygon(self.win, x+0.1*sz, y+0.2*sz, x+0.9*sz, y+0.2*sz,
                x+0.5*sz, y+0.9*sz, x+0.1*sz, y+0.2*sz)
end

procedure draw_Vpull_down_button_off(self)
local x, y

   x := self.ax; y := self.ay
   EraseArea(self.win, x+self.abx+1, y+1, self.aw-self.abx-1, self.ah-1)
   DrawRectangle(self.win, x+self.abx, y, self.aw-self.abx, self.ah)
   draw_Vpull_down_button_arrow(self)
end

procedure draw_Vpull_down_button_on(self)

   FillRectangle(self.win, self.ax+self.abx+1, self.ay+1, self.aw-self.abx, self.ah)
   WAttrib(self.win, "reverse=on")
   draw_Vpull_down_button_arrow(self)
   WAttrib(self.win, "reverse=off")
end

procedure resize_Vpull_down_button(self, x, y, w, h)

   resize_Vidget(self, x, y, w, h)
   self.pd.F.format(self.pd, self.aw)
   self.pd.V.resize(self.pd, self.ax, self.ay+self.ah)
end

procedure couplerset_Vpull_down_button(self, name, value)

   self.D.draw_off(self)
end


procedure event_Vpull_down_button(self, e)
local rv

   if \self.callback.locked then fail
   draw_Vpull_down_button_on(self)
   show_Vmenu_frame(\self.pd)
   rv := V_DRAGGING
   repeat {
      if \e === (&lrelease|&mrelease|&rrelease) then rv := &null
      else if self.V.inrange(self, &x, &y) then rv := V_DRAGGING
      else if (self.ax <= &x <= self.ax+self.aw) & (&y >= self.ay+self.ah) then
         rv := (\self.pd).F.pick(self.pd, e)
      if \rv === V_DRAGGING then {
         e := Event(self.win)
         rv := &null
         }
      else break
   }
   if rv === V_FAIL then rv := &null
   draw_Vpull_down_button_off(self)
   hide_Vmenu_frame(\self.pd)
   if \rv then {
      self.data := self.pd.callback[rv[1]][2]
      self.V.draw(self)
      self.callback.V.set(self.callback, self, self.data)
      return self.data
      }
end

procedure set_value_Vpull_down_button(self, value)

   self.data := \value | ""
end

procedure init_Vpull_down_button(self)
local p

   /self.data := ""
   self.s := self.data
   /self.sz := 24
   self.aw := WAttrib(self.win, "fwidth")*self.sz + 8
   self.ah := WAttrib(self.win, "fheight")

   self.abx := self.aw
# make little arrow box on end.
   self.aw +:= WAttrib(self.win, "fheight")

   p := \self.callback
   self.callback := Vcoupler()
   add_clients_Vinit(self.callback, p, self)

   self.D.init(self)
   self.D.basex := 4
end



############################################################################
#  Utilities.
############################################################################

#
#  Well this is a wrapper for combining a Vpull_down and a
#  Vpull_down_button.
#
#  Vpull_down_pick_menu([frame, x, y, ] w, s, callback, id, size, centered)
#
#  s - a list of string labels for the entries.
#  size - is the number of charcters in the data field to be displayed.
#  centered - non-&null if entries are centered in pull_down.
#
procedure Vpull_down_pick_menu(params[])
local frame, x, y, ins, pd, self

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   put(params); put(params); put(params); put(params);
   Vwin_check(params[1], "Vpull_down_pick_menu()")
   pd := Vpull_down ! (params[1:3] ||| [\params[6] | &null])
   self := Vpull_down_button ! ([params[1]] ||| params[3:6] ||| [pd])

   if \ins then VInsert(frame, self, x, y)
   return self
end

#
#  Vpulldown(..) produces a pull-down list, invoked by
#
#  obj.F.pick(obj)
#
#  returns the string value of the object picked.
#
#  p[] is a list of strings to enter into the list;
#  centered is &null for right justified entries, 1 for centered.
#
#  (This procedure does not support the optional VInsert parameters.)
#
procedure Vpull_down(win, s, centered)
local cv, frame, id, name, style, ypos
local max, i, TW, FH, item, string_list

   Vwin_check(win, "Vpull_down()")
   if type(s) ~== "list" then
      _Vbomb("data parameter to Vpull_down must be a list of strings")
   frame := Vmenu_frame(win)
   ypos := id := 1
   if \centered then {
      max := 0
      every i := !s do max <:= (TextWidth(win, i) + 6)
      }
   string_list := copy(s)
   while name := pop(string_list) do {
      name := \name | ""
      item := Vmenu_item(win, name, , name, max)
      VInsert(frame, item, 1, ypos)
      id +:= 1
      ypos +:= item.ah
   }
   VFormat(frame)
   return frame
end



#============================================  /home/gmt/ipl/gprocs/vscroll.icn



############################################################################
#
#	File:     vscroll.icn
#
#	Subject:  Procedures for scrollbars
#
#	Author:   Jon Lipp and Gregg M. Townsend
#
#	Date:     March 23, 1995
#
############################################################################
#
#  Vidgets defined in this file:
#	Varrow
#	Vvthumb
#	Vhthumb
#	Vscrollbar_frame
#
#  Utility procedures in this file:
#	Vvert_scrollbar()
#	Vhoriz_scrollbar()
#	reformat_Vhthumb()
#	reformat_Vvthumb()
#	Vreformat_vscrollbar()
#	Vreformat_hscrollbar()
#	VReformat()
#
############################################################################
#
#  Includes: vdefns.icn
#
############################################################################
#
#  Links:  vidgets
#
############################################################################

#====== link vidgets

#====== $include "vdefns.icn"

############################################################################
# Varrow
############################################################################

record Varrow_rec(win, callback, aw, ah, rev, dir, incop, id, ax, ay, r,
   uid, P, V)

procedure Varrow(params[])
local frame, x, y, ins, self, init_proc

   init_proc := init_Varrow
   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Varrow_rec ! params[1:7|0]
   self.r := self.aw / 2
   self.uid := Vget_uid()
   self.V := Vstd(event_Varrow, draw_Varrow, 1,
                  resize_Vidget, inrange_Vpane, init_proc,
                  couplerset_Vpane)
   self.P := Vstd_pos()
   self.V.init(self)
   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure event_Varrow(s,e)
local c, prev, new

   if \s.callback.locked then fail
   if e === (&lpress|&mpress|&rpress) then {
      FillTriangle(s.win, s.ax + s.r, s.ay + s.r, s.r - 2, s.dir)
      BevelTriangle(s.win, s.ax + s.r, s.ay + s.r, s.r, s.dir, -2)
      s.callback.V.set(s.callback, s, prev := press_Varrow(s))
      delay(200)
      while (*Pending(s.win) = 0) |
	    (Event(s.win) === (&ldrag|&mdrag|&rdrag)) do {
         new := press_Varrow(s)
	 if new ~= prev then
            s.callback.V.set(s.callback, s, prev := new)
         delay(40)
         }
      draw_Varrow(s)
      return \(s.callback.value)
      }
end

procedure draw_Varrow(s)
   EraseArea(s.win, s.ax, s.ay, s.aw, s.ah)
   BevelTriangle(s.win, s.ax + s.r, s.ay + s.r, s.r, s.dir)
end

procedure press_Varrow(s)
   local v
   v := s.incop(s.callback.value, s.callback.inc)
   if abs(v) < abs(s.callback.inc) / 1000000.0 then	# if close to zero
      v -:= v					# set to zero, preserving type
   return v
end

procedure init_Varrow(s)
   if /s.aw then _Vbomb("must specify a size for a Varrow")
   if (/s.rev & s.dir == !"se") | (\s.rev & s.dir == !"nw") then
      s.incop := proc("+", 2)
   else
      s.incop := proc("-", 2)
   s.ah := s.aw
   s.id := V_ARROW
end

############################################################################
# Vvthumb
############################################################################
record Vthumb_rec (win, callback, id, aw, ah, win_sz, tot_sz, discont,
   sp, sw, tw, th, ws, cv_range, pos, rev, frame, drawn, type,
   ax, ay, uid, P, V)

procedure procs_Vvthumb()
   static procs
   initial procs := Vstd(event_Vvthumb, draw_Vvthumb, 1,
                        resize_Vidget, inrange_Vpane, init_Vvthumb,
                        couplerset_Vvthumb,,,,,set_value_Vvthumb)
   return procs
end

procedure Vvthumb(params[])
local frame, x, y, ins, self

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vthumb_rec ! params
   self.uid := Vget_uid()
   self.V := procs_Vvthumb()
   self.P := Vstd_pos()
   self.type := 1
   self.V.init(self)
   if \ins then VInsert(frame, self, x, y)
   return self
end

#
#  debugging statement--
#
# write("draw: val ", val, " cv value ", s.callback.value, " cv min ",
# s.callback.min, "  ws ", s.ws, "  cv range ", s.cv_range)
#
procedure draw_Vvthumb(s)
   local val

   s.drawn := 1
   val := integer((s.callback.value - s.callback.min) * s.ws / s.cv_range + 0.5)
   if \s.rev then
      val := s.ws - val
   s.pos := val
   BevelRectangle(s.win, s.ax, s.ay + val, s.tw, s.th)
end

procedure event_Vvthumb(s, e)
local value, offset

   if \s.callback.locked then fail
   if e === (&lpress|&mpress|&rpress) then {
      offset := (s.th + 1) / 2
      until e === (&lrelease|&mrelease|&rrelease) do {
         value := ((&y - offset - s.ay) / (0 ~= s.ws)) * s.cv_range | 0
         if \s.rev then
            s.callback.V.set(s.callback, s, s.callback.max - value, s.discont)
         else
            s.callback.V.set(s.callback, s, s.callback.min + value, s.discont)
         s.frame.data := s.callback.value
         update_Vvthumb(s, 1)
         e := Event(s.win)
         }
      update_Vvthumb(s)
      if \s.discont then
         s.callback.V.set(s.callback, s, s.callback.value)
      return \(s.callback.value)
      }
end

procedure update_Vvthumb(s, active)
local val, op, tw, th, sw, sp

   val := integer((s.callback.value - s.callback.min) * s.ws / s.cv_range + 0.5)
   if \s.rev then
      val := s.ws - val

   op := s.pos; tw := s.tw; th := s.th
   sp := s.sp; sw := s.sw
   EraseArea(s.win, s.ax, s.ay + op, tw, th)
   if \active then {
      BevelRectangle(s.win, s.ax, s.ay + val, tw, th, -2)
      FillRectangle(s.win, s.ax + 2, s.ay + val + 2, tw - 4, th - 4)
      }
   else
      BevelRectangle(s.win, s.ax, s.ay + val, tw, th)
   s.pos := val
end

procedure set_value_Vvthumb(s, value)
   couplerset_Vvthumb(s, , value)
end

procedure couplerset_Vvthumb(s, caller, value)
   value := numeric(value) | s.callback.min
   if (\caller).id === V_ARROW then caller := s
   else if value === s.callback.value then fail
   s.frame.data := s.callback.value := value
   if \s.drawn then
      update_Vvthumb(s)
end

procedure init_Vvthumb(s)

   if /s.aw | /s.ah then
      _Vbomb("must specify width and height for Vvthumb")
   if /s.callback | type(s.callback) == "procedure" then
      _Vbomb("Vvthumb requires a coupler variable callback")
   s.sw := 3
   s.sp:= (s.aw - s.sw) / 2
   s.tw := s.aw
   \s.win_sz <:= 0
   if /s.win_sz then s.th := s.tw
   else s.th := ( s.tw < 
                integer( ((1.0 >= real(s.win_sz)/s.tot_sz) | 1.0)\1 * s.ah) ) |
                s.tw
   s.ws := 0 < real(s.ah - s.th) | 0
   s.cv_range := (0 < s.callback.max - s.callback.min | 1.0)

end

############################################################################
# Vhthumb
############################################################################

procedure procs_Vhthumb()
   static procs
   initial procs := Vstd(event_Vhthumb, draw_Vhthumb, 1,
                        resize_Vidget, inrange_Vpane, init_Vhthumb,
                        couplerset_Vhthumb,,,,,set_value_Vhthumb)
   return procs
end

procedure Vhthumb(params[])
local frame, x, y, ins, self

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vthumb_rec ! params
   self.uid := Vget_uid()
   self.V := procs_Vhthumb()
   self.P := Vstd_pos()
   self.V.init(self)
   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure draw_Vhthumb(s)
   local val

   s.drawn := 1
   val := integer((s.callback.value - s.callback.min) * s.ws / s.cv_range + 0.5)
   if \s.rev then
      val := s.ws - val
   s.pos := val
   BevelRectangle(s.win, s.ax + val, s.ay, s.tw, s.th)
end

procedure event_Vhthumb(s, e)
local value, offset

   if \s.callback.locked then fail
   if e === (&lpress|&mpress|&rpress) then {
      offset := (s.tw + 1) / 2
      until e === (&lrelease|&mrelease|&rrelease) do {
         value := ((&x - offset - s.ax)/(0 ~= s.ws)) * s.cv_range | 0
         if \s.rev then
            s.callback.V.set(s.callback, s, s.callback.max - value, s.discont)
         else
            s.callback.V.set(s.callback, s, s.callback.min + value, s.discont)
         s.frame.data := s.callback.value
         update_Vhthumb(s, 1)
         e := Event(s.win)
         }
      update_Vhthumb(s)
      if \s.discont then
         s.callback.V.set(s.callback, s, s.callback.value)
      return \(s.callback.value)
      }
end

procedure update_Vhthumb(s, active)
   local val, op, tw, th, sw, sp

   val := integer((s.callback.value - s.callback.min) * s.ws / s.cv_range + 0.5)
   if \s.rev then
      val := s.ws - val

   op := s.pos; tw := s.tw; th := s.th
   sp := s.sp; sw := s.sw
   EraseArea(s.win, s.ax + op, s.ay, tw, th)
   if \active then {
      BevelRectangle(s.win, s.ax + val, s.ay, tw, th, -2)
      FillRectangle(s.win, s.ax + val + 2, s.ay + 2, tw - 4, th - 4)
      }
   else
      BevelRectangle(s.win, s.ax + val, s.ay, tw, th)
   s.pos := val
end

procedure set_value_Vhthumb(s, value)
   couplerset_Vhthumb(s, s, value)
end

procedure couplerset_Vhthumb(s, caller, value)

   value := numeric(value) | s.callback.min
   if (\caller).id === V_ARROW then caller := s
   else if value === s.callback.value then fail
   s.frame.data := s.callback.value := value
   if \s.drawn then
      update_Vhthumb(s)
end

procedure init_Vhthumb(s)

   if /s.aw | /s.ah then
      _Vbomb("must specify width and height for Vhthumb")
   if /s.callback | type(s.callback) == "procedure" then
      _Vbomb("Vhthumb requires a coupler variable callback")
   s.sw := 3
   s.sp := (s.ah - s.sw) / 2
   s.th := s.ah
   \s.win_sz <:= 0
   if /s.win_sz then s.tw := s.th
   else s.tw := ( s.th < 
                integer( ((1.0 >= real(s.win_sz)/s.tot_sz) | 1.0)\1 * s.aw) ) | 
                s.th
   s.ws := 0 < real(s.aw - s.tw) | 0
   s.cv_range := (0 < s.callback.max - s.callback.min | 1.0)
end

############################################################################
# Vscrollbar_frame 
############################################################################

record Vscrollbar_frame_rec(win, callback, id, aw, ah, lookup, draw, uid,
   data, thumb, ax, ay, P, V)

procedure Vscrollbar_frame(params[])
local self, procs

   procs := Vstd(event_Vframe, draw_Vframe, outline_Vscrollbar,
                resize_Vscrollbar, inrange_Vpane, init_Vframe,
                couplerset_Vpane, insert_Vframe, remove_Vframe,
                lookup_Vframe, set_abs_Vframe)
   self := Vscrollbar_frame_rec ! params
   self.uid := Vget_uid()
   self.V := procs
   self.P := Vstd_pos()
   self.V.init(self)
   return self
end

procedure outline_Vscrollbar(self)
   BevelRectangle(self.win, self.ax, self.ay, self.aw, self.ah, -2)
end

procedure resize_Vscrollbar(self, x, y, w, h)

   resize_Vframe(self, x, y, w, h)

   if self.aw > self.ah then {
      if \self.thumb.type then {		# was formerly vertical
         self.thumb.V := procs_Vhthumb()
	 self.thumb.type := &null
	 }
      VReformat(self, self.aw, self.ah)
      }

   else {
      if /self.thumb.type then {		# was formerly horizontal
         self.thumb.V := procs_Vvthumb()
	 self.thumb.type := 1
	 }
      VReformat(self, self.ah, self.aw)
      }
end

#  These are the middle-man procedures between the scrollbar frame 
#  and the thumb.

procedure couplerset_Vhscrollbar(s, caller, value)
   couplerset_Vhthumb(s.thumb, caller, value)
end

procedure set_value_Vhscrollbar(s, value)
   set_value_Vhthumb(s.thumb, value)
   return
end

procedure couplerset_Vvscrollbar(s, caller, value)
   couplerset_Vvthumb(s.thumb, caller, value)
end

procedure set_value_Vvscrollbar(s, value)
   set_value_Vvthumb(s.thumb, value)
   return
end

############################################################################
# Vertical scrollbar 
############################################################################
procedure Vvert_scrollbar(params[])
local frame, x, y, ins, t, self

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }

   self :=  Vmake_vscrollbar ! params
   self.uid := Vget_uid()
   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure Vmake_vscrollbar(win, callback, id, length, width, 
                           min, max, inc, win_sz, discont)
   local cv, cb, frame, up, down, thumb, tot_sz
   local r, rev, in_max, odd

   Vwin_check(win, "Vvert_scrollbar()")
   if (\win_sz, not numeric(win_sz) | win_sz < 0 ) then
      _Vbomb("negative or non-numeric window_size parameter to Vvert_scrollbar()")
   if (\inc, not numeric(inc) | inc  < 0 ) then
      _Vbomb("negative or non-numeric increment parameter to Vvert_scrollbar()")
   if (\length, not numeric(length) ) then
      _Vbomb("invalid length parameter to Vvert_scrollbar()")
   if (\width, not numeric(width) ) then
      _Vbomb("invalid width parameter to Vvert_scrollbar()")

   /width := VSlider_DefWidth
   /length := VSlider_DefLength
   width <:= VSlider_MinWidth
   length <:= VSlider_MinAspect * width
   /min := 0
   /max := 1.0
   rev := 1
   if max < min then { max :=: min; rev := &null }
   in_max := max
   max -:= (\win_sz | 0) 
   max <:= min
   tot_sz := 0 < abs(in_max-min) | 1
   r := (type(min|max) == "real", 1)
   if (not numeric(\inc) ) | /inc then
      inc := 0.1*abs(max-min)
   (/r, inc := integer(inc), inc <:= 1)

   cv := Vrange_coupler(min, max, , inc)
   frame := Vscrollbar_frame(win, cv, id, width, length)
   Varrow(frame, 2, 2, win, cv, width - 4, width - 4, rev, "n")
   odd := width % 2
   thumb := Vvthumb(frame, 2, width - odd, 
      win, cv, id, width - 4, length - 2 * width + 1 + odd,
      win_sz, tot_sz, discont)
   Varrow(frame, 2, length - width + 2, win, cv, width - 4, width - 4, rev, "s")

   thumb.rev := rev
   cv.V.add_client(cv, thumb)
   add_clients_Vinit(cv, callback, thumb)

   thumb.frame := frame
   frame.thumb := thumb
   frame.V.couplerset := couplerset_Vvscrollbar
   frame.V.set_value := set_value_Vvscrollbar

   return frame
end

############################################################################
# Horizontal scrollbar 
############################################################################
procedure Vhoriz_scrollbar(params[])
local frame, x, y, ins, t, self

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }

   self :=  Vmake_hscrollbar ! params
   self.uid := Vget_uid()
   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure Vmake_hscrollbar(win, callback, id, length, width,
                           min, max, inc, win_sz, discont)
   local cv, cb, frame, up, down, thumb, tot_sz
   local r, rev, in_max, odd

   Vwin_check(win, "Vhoriz_scrollbar().")
   if (\win_sz, not numeric(win_sz) | win_sz < 0 ) then
      _Vbomb("negative or non-numeric window_size parameter to Vhoriz_scrollbar()")
   if (\inc, not numeric(inc) | inc  < 0 ) then
      _Vbomb("negative or non-numeric increment parameter to Vhoriz_scrollbar()")
   if (\length, not numeric(length) ) then
      _Vbomb("invalid length parameter to Vhoriz_scrollbar()")
   if (\width, not numeric(width) ) then
      _Vbomb("invalid width parameter to Vhoriz_scrollbar()")

   /width := VSlider_DefWidth
   /length := VSlider_DefLength
   width <:= VSlider_MinWidth
   length <:= VSlider_MinAspect * width
   /min := 0
   /max := 1.0
   if max < min then {max :=: min; rev := 1 }
   in_max := max
   max -:= (\win_sz | 0)
   max <:= min
   tot_sz := 0 < abs(in_max-min) | 1
   r := (type(min|max) == "real", 1)
   if (not numeric(\inc) ) | /inc then
      inc := 0.1*abs(max-min)
   (/r, inc := integer(inc), inc <:= 1)

   cv := Vrange_coupler(min, max, , inc)
   frame := Vscrollbar_frame(win, cv, id, length, width)
   Varrow(frame, 2, 2, win, cv, width - 4, width - 4, rev, "w")
   odd := width % 2
   thumb := Vhthumb(frame, width - odd, 2, 
      win, cv, id, length - 2 * width + 1 + odd, width - 4,
      win_sz, tot_sz, discont)
   Varrow(frame, length - width + 2, 2, win, cv, width-4, width-4, rev, "e")

   thumb.rev := rev
   cv.V.add_client(cv, thumb)
   add_clients_Vinit(cv, callback, thumb)

   thumb.frame := frame
   frame.thumb := thumb
   frame.V.couplerset := couplerset_Vhscrollbar
   frame.V.set_value := set_value_Vhscrollbar

   return frame
end

############################################################################
# reformatting procedures.  Will just reformat width and length.
############################################################################
procedure reformat_Vvthumb(s, length, width)

   s.P.w := s.aw := \width
   s.P.h := s.ah := \length
   s.sp := (s.aw - s.sw) / 2
   s.tw := s.aw
   if /s.win_sz then s.th := s.tw
   else s.th := ( s.tw <
                integer( ((1.0 >= real(s.win_sz)/s.tot_sz) | 1.0)\1 * s.ah) ) |
                s.tw-1
   s.ws := 0 < real(s.ah - s.th - 2) | 0
end

procedure reformat_Vhthumb(s, length, width)

   s.P.w := s.aw := length
   s.P.h := s.ah := width
   s.sp := (s.ah - s.sw) / 2
   s.th := s.ah
   if /s.win_sz then s.tw := s.th
   else s.tw := ( s.th <
                integer( ((1.0 >= real(s.win_sz)/s.tot_sz) | 1.0)\1 * s.aw) ) |
                s.th-1
   s.ws := 0 < real(s.aw - s.tw - 2) | 0
end

procedure Vreformat_vscrollbar(self, length, width)
   local up, down, thumb

   /width := self.aw
   /length := self.ah
   self.aw := self.P.w := width
   self.ah := self.P.h := length

   up := self.lookup[1]
   thumb := self.lookup[2]
   down := self.lookup[3]

   VRemove(self, up, 1)
   VRemove(self, thumb, 1)
   VRemove(self, down, 1)

   up.dir := "n"
   down.aw := down.ah := up.aw := up.ah :=
      down.P.w := down.P.h := up.P.w := up.P.h := width
   down.r := up.r := (width - 4) / 2
   down.dir := "s"

   reformat_Vvthumb(thumb, length - 2 * width + 2, width - 4)
   VInsert(self, up, 2, 2)
   VInsert(self, thumb, 2, width)
   VInsert(self, down, 2, width + thumb.ah)

end

procedure Vreformat_hscrollbar(self, length, width)
   local left, right, thumb

   /width := self.ah
   /length := self.aw
   self.aw := self.P.w := length
   self.ah := self.P.h := width

   left := self.lookup[1]
   thumb := self.lookup[2]
   right := self.lookup[3]

   VRemove(self, left, 1)
   VRemove(self, thumb, 1)
   VRemove(self, right, 1)

   left.dir := "w"
   left.aw := left.ah := right.aw := right.ah :=
      left.P.w := left.P.h := right.P.w := right.P.h := width
   left.r := right.r := (width - 4) / 2
   right.dir := "e"

   reformat_Vhthumb(thumb, length - 2 * width + 2, width - 4)
   VInsert(self, left, 2, 2)
   VInsert(self, thumb, width, 2)
   VInsert(self, right, width + thumb.aw, 2)
end

############################################################################
#  interface procedure for Vreformat
############################################################################
procedure VReformat(scrollbar, length, width)

   if /scrollbar | type(scrollbar) ~== "Vscrollbar_frame_rec" then
      _Vbomb("invalid scrollbar parameter to VReformat()")

   if \(scrollbar.thumb.type) then
      Vreformat_vscrollbar(scrollbar, length, width)
   else 
      Vreformat_hscrollbar(scrollbar, length, width)
end



#==============================================  /home/gmt/ipl/gprocs/vtext.icn



############################################################################
#
#	File:     vtext.icn
#
#	Subject:  Procedures for textual vidgets
#
#	Author:   Jon Lipp and Gregg M. Townsend
#
#	Date:     March 23, 1995
#
############################################################################
#
#  Vidgets defined in this file:
#	Vtext
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Includes:  keysyms
#
############################################################################
#
#  Links:  vidgets
#
############################################################################

#====== link vidgets

#====== $include "keysyms.icn"

############################################################################
#  Vtext
############################################################################

record Vstd_text(draw_cursor, erase_cursor, draw_data, unblock, block,
   DataPixelSize, MaxPixelSize, NumericData, CursorPos, DataLength,
   OldCursorPos, CursorOn, ta, tb, dx, dy)

record Vtext_rec (win, s, callback, id, MaxChars, mask, data, uid,
   ax, ay, aw, ah, T, P, V)

procedure Vtext(params[])
   local frame, x, y, ins, self
   static procs

   initial {
       procs := Vstd(event_Vtext, draw_Vtext,
          outline_Vtext, resize_Vtext, inrange_Vpane, init_Vtext,
          couplerset_Vtext,,,,, set_value_Vtext)
   }

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vtext_rec ! params[1:7|0]
   Vwin_check(self.win, "Vtext()")
   if (\self.MaxChars, not numeric(self.MaxChars) ) then
      _Vbomb("invalid size parameter to Vtext()")
   if type(\self.mask) ~== "cset" then
      _Vbomb("invalid mask parameter to Vtext()")
   if type(\self.s) ~== "string" & not numeric(self.s) then
      _Vbomb("invalid prompt passed to Vtext()")

   self.uid := Vget_uid()
   self.V := procs
   self.P := Vstd_pos()
   self.T := Vstd_text(draw_cursor_Vtext, erase_cursor_Vtext,
      draw_data_Vtext, unblock_Vtext, block_Vtext)
   init_Vtext(self)

   if \ins then VInsert(frame, self, x, y)
   return self
end

#
#  Initialization
#
procedure init_Vtext(self)
   local p

   /self.s := ""
   /self.MaxChars := 18
   self.s ? if self.s := tab(find("\\=")) then ="\\=" & self.data := tab(0)
   /self.data := ""
   if *self.data > self.MaxChars then self.data := self.data[1:self.MaxChars]
   self.T.DataLength := *self.data
   self.T.MaxPixelSize := WAttrib(self.win, "fwidth")*self.MaxChars
#   /self.T.MaxPixelSize := 250

## check max length by pixel size.
#   if TextWidth(self.win, self.data) > self.T.MaxPixelSize then {
#      t := get_pos_Vtext(self, self.T.MaxPixelSize)
#      self.data := self.data[1:t]
#      }
#   self.T.DataLength := *self.data
   self.T.DataPixelSize := TextWidth(self.win, self.data)

## size by characters - taken out.
   /self.mask := &cset

## initialize with cursor at end
   self.T.ta := self.T.tb := self.T.CursorPos := self.T.DataLength + 1

## initialize with all data blocked out (selected)
#  self.T.ta := 1
#  self.T.tb := self.T.CursorPos := self.T.DataLength + 1

   self.T.dx := TextWidth (self.win, self.s) + 6
   self.aw := self.T.dx + self.T.MaxPixelSize + 4
   self.ah := WAttrib(self.win, "fheight") + 6	# 4 for bevel, 2 for I-bar
   self.T.dy := self.ah - 3 - WAttrib(self.win, "descent")

   p := \self.callback
   self.callback := Vcoupler()
   add_clients_Vinit(self.callback, p, self)
end

#
#  Reconfigure the text vidget.
#
procedure resize_Vtext(s, x, y, w, h)
   s.T.dx := TextWidth (s.win, s.s) + 6
   s.T.DataLength := *s.data
   s.T.MaxPixelSize := WAttrib(s.win, "fwidth") * s.MaxChars
   w := s.aw := s.T.dx + s.T.MaxPixelSize + 4
   h := s.ah := WAttrib(s.win, "fheight") + 6
   resize_Vidget(s, x, y, w, h)
end

#
#  Draw the prompt, the data, outline the data area, then draw
#  the cursor if it was already on previous to calling this
#  procedure (happens with dialog boxes and resize events).
#
procedure draw_Vtext(self)
   local t

   t := self.T.CursorOn
   self.T.CursorOn := &null
   draw_prompt_Vtext(self)
   draw_data_Vtext(self)
   outline_Vtext(self)
   if \t then draw_cursor_Vtext(self)
end

#
#  Outline the data field.
#
procedure outline_Vtext(self)

   BevelRectangle(self.win, self.ax+self.T.dx-4, self.ay,
                  self.aw-(self.T.dx-4), self.ah, -2)
end

#
#  Draw the prompt.
#
procedure draw_prompt_Vtext(self)
   GotoXY(self.win, self.ax, self.ay+self.T.dy)
   writes(self.win, self.s)
   return
end

#
#  Since the cursor is drawn in "reverse" mode, erase it only if it
#  is "on" upon entering this procedure.
#
procedure erase_cursor_Vtext(self)
   local ocx, cy

   if /self.T.CursorOn then fail
   ocx :=  self.T.OldCursorPos

## bracket cursor
   WAttrib(self.win, "drawop=reverse", "linewidth=1")
   DrawSegment(self.win, \ocx-2, self.ay+2, ocx+2, self.ay+2,
             ocx, self.ay+3, ocx, self.ay+self.ah-4,
             ocx-2, self.ay+self.ah-3, ocx+2, self.ay+self.ah-3)
   WAttrib(self.win, "drawop=copy")
   self.T.CursorOn := &null
end

#
#  Draw the cursor only if it was previously "off" at this location.
#
procedure draw_cursor_Vtext(self)
   local ocx, cx, cy

   if \self.T.CursorOn then fail
   cx := self.ax+self.T.dx + get_pixel_pos_Vtext(self, self.T.CursorPos) - 1
## bracket cursor
   WAttrib(self.win, "drawop=reverse", "linewidth=1")
   DrawSegment(self.win, cx-2, self.ay+2, cx+2, self.ay+2,
             cx, self.ay+3, cx, self.ay+self.ah-4,
             cx-2, self.ay+self.ah-3, cx+2, self.ay+self.ah-3)
   WAttrib(self.win, "drawop=copy")
   self.T.OldCursorPos := cx
   self.T.CursorOn := 1
end

#
#  De-block the data (reset ta and tb to CursorPos).
#
procedure unblock_Vtext(self)
   self.T.ta := self.T.CursorPos := self.T.tb
   draw_data_Vtext(self)
end

#
#  Block (select) all the data
#
procedure block_Vtext(self)
   self.T.ta := 1
   self.T.tb := self.T.CursorPos := self.T.DataLength + 1
   draw_data_Vtext(self)
   if self.T.DataLength = 0 then
      draw_cursor_Vtext(self)
end

#
#  Draw the data, reversing that text that lies between ta and tb
#  fields.
#
procedure draw_data_Vtext(self)

#   if self.T.ta = self.T.tb then return
   erase_cursor_Vtext(self)
   GotoXY(self.win, self.ax+self.T.dx, self.ay+self.T.dy)
   if self.T.ta <= self.T.tb then {
      writes(self.win, self.data[1:self.T.ta])
      WAttrib(self.win, "reverse=on")
      writes(self.win, self.data[self.T.ta:self.T.tb])
      WAttrib(self.win, "reverse=off")
      writes(self.win, self.data[self.T.tb:0])
   }
   else {
      writes(self.win, self.data[1:self.T.tb])
      WAttrib(self.win, "reverse=on")
      writes(self.win, self.data[self.T.tb:self.T.ta])
      WAttrib(self.win, "reverse=off")
      writes(self.win, self.data[self.T.ta:0])
   }
   EraseArea(self.win, self.ax+self.T.dx+self.T.DataPixelSize, self.ay+2,
              self.aw-(self.T.dx +self.T.DataPixelSize+1), self.ah-4)
   return
end

#
#  Wow.  Mouse events, block out text, key presses, enter, delete
#  etcetera stuff.  Call callback if linefeed key or return key
#  is pressed.
#
procedure event_Vtext(self, e, x, y)
   static ota
   local otb, rv

   if \self.callback.locked then fail
   /x := &x; /y := &y
   self.T.DataLength := *self.data
   if e === (&lpress|&mpress|&rpress) then {
      WAttrib(self.win, "pointer=xterm")
      otb := self.T.ta := self.T.tb := self.T.CursorPos :=
         get_pos_Vtext(self, &x-(self.ax+self.T.dx))
      if otb = self.T.DataLength+1 & otb = \ota then
         self.T.ta := 1
      draw_data_Vtext(self)
      draw_cursor_Vtext(self)
      until e === (&lrelease|&mrelease|&rrelease) do {
         self.T.tb := get_pos_Vtext(self, &x-(self.ax+self.T.dx))
         if otb ~= self.T.tb then {
            draw_data_Vtext(self)
            self.T.CursorPos := self.T.tb
            draw_cursor_Vtext(self)
            otb := self.T.tb
            }
         e := Event(self.win)
         }
      rv := &null
      WAttrib(self.win, "pointer=top left arrow")
      } ## end mouse event loop
   else if (not &meta) & (not (integer(e) < 0)) then  {
      ## it's a keypress
      if rv := case e of {
         "\^b" | Key_Left | Key_KP_Left:	move_cursor_Vtext(self, -1)
         "\^f" | Key_Right | Key_KP_Right:	move_cursor_Vtext(self, 1)
         "\b" | "\d":				delete_left_Vtext(self)
         "\^k" | "\^u" | "\^x":			delete_line_Vtext(self)
	 (&shift & "\t") | Key_Up | Key_KP_Up:  return V_PREVIOUS
         "\t" | Key_Down | Key_KP_Down:		return V_NEXT
         "\r" | "\l": {
	    self.callback.V.set(self.callback, self, self.data)
	    V_NEXT
	    }
         default:				insert_char_Vtext(self, e)
         }
      then {
         draw_data_Vtext(self)
         draw_cursor_Vtext(self)
         self.T.ta := self.T.tb := self.T.CursorPos
         }
      }
   else
      fail				# not our event

   ota := self.T.ta
   return rv
end

#  Move the cursor one way or another, determine if at bounds.
#
procedure move_cursor_Vtext(self, increment)
   local t

   t := self.T.CursorPos + increment
   if t < 1 | t > self.T.DataLength+1 then fail
   self.T.ta := self.T.tb := self.T.CursorPos := t
   return
end

#
#  Blank out the whole data field.
#
procedure delete_line_Vtext(self)

   self.data := ""
   self.T.DataLength := *self.data
   self.T.DataPixelSize := 0
   self.T.ta := self.T.tb := self.T.CursorPos := 1
   return
end

#
#  Get the character position based on mouse x coordinate.
#
procedure get_pos_Vtext(self, x)
   local tp, c, i, j

   c := 1
   i := j := 0
   while i < x do {
      j := i
      i +:= TextWidth(self.win, self.data[c])
      if (c +:= 1) > self.T.DataLength then break
   }
   if x <= ((i + j) / 2) then
      c -:= 1				# less than halfway into the char
   if i < x then tp := self.T.DataLength+1
   else tp := (1 <= c) | 1
   return tp
end

#
#  Get pixel position in data field based on character position.
#
procedure get_pixel_pos_Vtext(self, CursorPos)
   local sum, i

   sum := 1
   every i := 1 to CursorPos-1 do sum +:= TextWidth(self.win, self.data[i])
   return sum
end

#
#  Insert a character; could replace blocked out text.  Check if
#  insertion will go over bounds.
#
procedure insert_char_Vtext(self, c)

   c := c[1]

   if TextWidth(self.win, c) == 0 then
      fail				# not displayable

   if (self.T.DataLength - abs(self.T.ta-self.T.tb) + 1) > self.MaxChars |
      not (c ? any(self.mask)) then fail

   if self.T.ta ~= self.T.tb then
      change_data_Vtext(self, c)
   else
      self.data := self.data[1:self.T.CursorPos] || c ||
                   self.data[self.T.CursorPos:0]
   self.T.DataLength := *self.data
   self.T.DataPixelSize := TextWidth(self.win, self.data)
   self.T.CursorPos +:= 1
   return
end

#
#  Replace a character at current position.
#
procedure change_data_Vtext(self, c)
   if self.T.tb < self.T.ta then {
      self.data := self.data[1:self.T.tb] || (\c | "") ||
                   self.data[self.T.ta:0]
      self.T.ta := self.T.CursorPos := self.T.tb
      }
   else {
      self.data := self.data[1:self.T.ta] || (\c | "") ||
                   self.data[self.T.tb:0]
      self.T.tb := self.T.CursorPos := self.T.ta
      }
end

#
#  Delete the character to the left of the cursor.
#
procedure delete_left_Vtext(self)
   if self.T.ta ~= self.T.tb then {
      change_data_Vtext(self)
      self.T.DataPixelSize := TextWidth(self.win, self.data)
      return
      }
   else
      if self.T.CursorPos > 1 then {
         self.data := self.data[1:self.T.CursorPos-1] ||
                      self.data[self.T.CursorPos:0]
         self.T.DataPixelSize := TextWidth(self.win, self.data)
         self.T.CursorPos -:= 1
         return
         }
end

#
#  Set the data field to value passed in.
#  NOTE: doesn't pass it through mask right now.
#  Call callback if value if different from internal coupler's
#  value.
#
procedure couplerset_Vtext(self, caller, value)
   local data

   data := string(\value) | ""
   self.data := data
   if *self.data > self.MaxChars then self.data := self.data[1:self.MaxChars]
   self.T.DataLength := *self.data
   self.T.DataPixelSize := TextWidth(self.win, self.data)

## initialize with cursor at end
   self.T.ta := self.T.tb := self.T.CursorPos := self.T.DataLength + 1

## initialize with all data blocked out (selected)
#  self.T.ta := 1
#  self.T.tb := self.T.CursorPos := self.T.DataLength + 1

   draw_data_Vtext(self)

   if numeric(value) then {
      if value = \self.T.NumericData then fail
      self.T.NumericData := value
      }
   else if data === self.data then fail
   self.callback.V.set(self.callback, caller, value)
#   draw_cursor_Vtext(self)
end

#
#  Call couplerset to set value.
#
procedure set_value_Vtext(self, value)
   couplerset_Vtext(self, , value)
   return
end



#===========================================  /home/gmt/ipl/gprocs/vbuttons.icn



############################################################################
#
#	File:     vbuttons.icn
#
#	Subject:  Procedures for buttons
#
#	Author:   Jon Lipp and Gregg M. Townsend
#
#	Date:     November 17, 1994
#
############################################################################
#
#  Vidgets defined in this file:
#
#	Vbutton
#	Vtoggle
#	Vcheckbox  (obsolete)
#	Vmessage
#	Vline
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links: vstyle
#
############################################################################

#====== link vstyle

############################################################################
# Vbutton
############################################################################
record Vbutton_rec (win, s, callback, id, style, aw, ah, data,
   ax, ay, uid, P, D, V)

procedure Vbutton(params[])
   local self, frame, x, y, ins
   static procs

   initial procs := Vstd(event_Vbutton, draw_Vbutton, outline_Vidget,
                        resize_Vbutton, inrange_Vpane, init_Vbutton,
                        couplerset_Vbutton)
   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vbutton_rec ! params[1:8|0]
   Vwin_check(self.win, "Vbutton()")
   if type(\self.s) ~== "string" & not numeric(self.s) then
      _Vbomb("invalid label passed to Vbutton()")
   if (\self.aw, not numeric(self.aw) ) then
      _Vbomb("invalid aw parameter to Vbutton()")
   if (\self.ah, not numeric(self.ah) ) then
      _Vbomb("invalid ah parameter to Vbutton()")

   self.uid := Vget_uid()
   Vset_style(self, self.style)
   self.V := procs
   self.P := Vstd_pos()
   self.V.init(self)

   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure draw_Vbutton(self)
   self.D.draw_off(self)
end

procedure couplerset_Vbutton(self)
   self.V.draw(self)
end

#
#  Dragging mouse over edge toggles mouse "on" or "off".
#
procedure event_Vbutton(self, e)
   local out

   if \self.callback.locked then fail
   if e === (&lpress|&mpress|&rpress) then {
      self.D.draw_on(self)
      repeat {
	 e := Event(self.win)
	 if self.V.inrange(self, &x, &y) then {
	    if e === (&lrelease|&mrelease|&rrelease) then {
	       self.D.draw_off(self)
	       self.callback.V.set(self.callback, self)
	       return self.id
               }
	    else if \out then {
	       self.D.draw_on(self)
	       out := &null
               }
            }
	 else
	    if e === (&ldrag|&mdrag|&rdrag) & /out then {
	       self.D.draw_off(self)
	       out := 1
               }
	    else if e === (&lrelease|&mrelease|&rrelease) then {
	       self.D.draw_off(self)
	       break
               }
         }
      return
      }
end

procedure init_Vbutton (self)
   local p

   p := \self.callback
   self.callback := Vbool_coupler()
   add_clients_Vinit(self.callback, p, self)
   self.D.init(self)
end

procedure resize_Vbutton(s, x, y, w, h)
   
   resize_Vidget(s, x, y, w, h)
   Vset_style(s, s.style)
   s.D.init(s)
end


############################################################################
# Vtoggle
############################################################################

procedure Vtoggle(params[])
   local frame, x, y, ins, self
   static procs

   initial procs := Vstd(event_Vtoggle, draw_Vtoggle, outline_Vidget,
                        resize_Vidget, inrange_Vpane, init_Vbutton,
                        couplerset_Vbutton,,,,,
                        set_value_Vtoggle)
   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vbutton_rec ! params[1:8|0]
   Vwin_check(self.win, "Vtoggle()")
   if type(\self.s) ~== "string" & not numeric(self.s) then
      _Vbomb("invalid label passed to Vtoggle()")
   if (\self.aw, not numeric(self.aw) ) then
      _Vbomb("invalid aw parameter to Vtoggle()")
   if (\self.ah, not numeric(self.ah) ) then
      _Vbomb("invalid ah parameter to Vtoggle()")


   self.uid := Vget_uid()
   Vset_style(self, self.style)
   self.V := procs
   self.P := Vstd_pos()
   self.V.init(self)
   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure draw_Vtoggle(self)
   if \self.callback.value then
      self.D.draw_on(self)
   else
      self.D.draw_off(self)
end


#
#  Basically same functionality as for Vbutton with the exception
#  of maintaining the state of the toogle between events.
#
procedure event_Vtoggle(self, e)
   local out, new, original

   if \self.callback.locked then fail
   if e === (&lpress|&mpress|&rpress) then {
      if /self.callback.value then {
         new := self.D.draw_on
         original := self.D.draw_off
      }
      else {
         new := self.D.draw_off
         original := self.D.draw_on
      }
      new(self)
      repeat {
         e := Event(self.win)
         if self.V.inrange(self, &x, &y) then {
            if e === (&lrelease|&mrelease|&rrelease) then {
               self.callback.V.toggle(self.callback, self)
               self.data := self.callback.value
               return self.id
            }
            else if \out then {
               new(self)
               out := &null
            }
         }
         else
            if e === (&ldrag|&mdrag|&rdrag) & /out then {
               original(self)
               out := 1
            }
            else if e === (&lrelease|&mrelease|&rrelease) then {
               original(self)
               break
            }
      }
      return
   }
end

procedure set_value_Vtoggle(self, value)

   if \value then
      self.callback.V.set(self.callback)
   else
      self.callback.V.unset(self.callback)

   self.data := self.callback.value
   draw_Vtoggle(self)
   return
end

############################################################################
# Vcheckbox
############################################################################
record Vcheckbox_rec (win, callback, id, size, aw, ah, data,
   ax, ay, cw, uid, P, V, D)

procedure Vcheckbox(params[])
   local frame, x, y, ins, self, p
   static procs

   initial {
      procs := Vstd(event_Vtoggle, draw_Vtoggle, outline_Vidget,
                   resize_Vidget, inrange_Vpane,  ,
                   couplerset_Vbutton,,,,, set_value_Vtoggle)
   }

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vcheckbox_rec ! params[1:5|0]
   if ( \self.size, not numeric(self.size) ) then
      _Vbomb("invalid size parameter to Vcheck_box()")
   Vwin_check(self.win, "Vcheck_box()")
   self.uid := Vget_uid()
   self.V := procs
   self.P := Vstd_pos()
   self.D := Vstd_draw(draw_off_Vcheckbox, draw_on_Vcheckbox)

## Init
#  PMIcon fix.
#   self.cw := Clone(self.win, "linewidth=2")
   self.cw := WAttrib(self.win, "linewidth")
   /self.size := 15
   self.aw := self.ah := self.size

   p := \self.callback
   self.callback := Vbool_coupler()
   add_clients_Vinit(self.callback, p, self)

   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure draw_on_Vcheckbox(self)
   local x, y, sz

   x := self.ax
   y := self.ay
   sz := self.size
#  PMIcon fix.
   WAttrib(self.win, "linewidth=2")
   DrawSegment(self.win, x+1, y+1, x+sz-1, y+sz-1, x+1, y+sz-1, x+sz-1, y+1)
#  PMIcon fix.
   WAttrib(self.win, "linewidth="||self.cw)
   self.V.outline(self)
end

procedure draw_off_Vcheckbox(self)
   local x, y, sz

   x := self.ax
   y := self.ay
   sz := self.size
#  PMIcon fix.
   WAttrib(self.win, "reverse=on", "linewidth=2")
   DrawSegment(self.win, x+1, y+1, x+sz-1, y+sz-1, x+1, y+sz-1, x+sz-1, y+1)
#  PMIcon fix.
   WAttrib(self.win, "reverse=off", "linewidth="||self.cw)
   self.V.outline(self)
end

############################################################################
# Vmessage
############################################################################

procedure Vmessage(params[])
   static procs
   local frame, x, y, ins, self

   initial procs := Vstd(null_proc, draw_Vmessage, outline_Vidget,
                        resize_Vidget, null_proc, init_Vmessage,
                        null_proc)
   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vbutton_rec ! params[1:3|0]
   Vwin_check(self.win, "Vmessage()")
   if type(\self.s) ~== "string" & not numeric(self.s) then
      _Vbomb("invalid label passed to Vmessage()")

   self.uid := Vget_uid()
   self.V := procs
   self.D := Vstd_draw()
   self.P := Vstd_pos()
   self.V.init(self)
   if \ins then VInsert(frame, self, x, y)
   return self
end

procedure draw_Vmessage(self)

   GotoXY(self.win, self.ax+self.D.basex, self.ay+self.D.basey)
   writes(self.win, self.s)
#   self.V.outline(self)
end

procedure init_Vmessage(self)
   local TW, FH, ascent, descent

   /self.s := ""
   /self.aw := (TW := TextWidth(self.win, self.s))
   ascent := WAttrib(self.win, "ascent")
   descent := WAttrib(self.win, "descent")
   /self.ah := FH := ascent + descent

   self.D.basex := (self.aw - TW) / 2
   self.D.basey := (self.ah - FH) / 2 + ascent
end

############################################################################
# Vline
#
#  I know, I know, this vidgie is not well designed or efficient.
############################################################################
record Vline_rec (win, ax1, ay1, ax2, ay2, aw, ah, id, uid, P, V)

procedure Vline(params[])
   local self
   static procs

   initial procs := Vstd(null_proc, draw_Vline, null_proc,
                        resize_Vline, null_proc, null_proc,
                        null_proc)
   self := Vline_rec ! params[1:6|0]
   Vwin_check(self.win, "Vline()")
   if not numeric(self.ax1) then
      _Vbomb("invalid coordinate parameter to Vline()")
   if not numeric(self.ax2) then
      _Vbomb("invalid coordinate parameter to Vline()")
   if not numeric(self.ay1) then
      _Vbomb("invalid coordinate parameter to Vline()")
   if not numeric(self.ay2) then
      _Vbomb("invalid coordinate parameter to Vline()")
   self.uid := Vget_uid()
   self.V := procs
   self.P := Vstd_pos()

   return self
end

procedure resize_Vline(frame, self)
   local x, y, w, h, x1, y1, x2, y2

   x := frame.ax
   y := frame.ay
   w := frame.aw
   h := frame.ah
   x1 := self.ax1
   y1 := self.ay1
   x2 := self.ax2
   y2 := self.ay2

   self.ax1 := x + ( (/x1, 0) | (x1 <= -1 , w+x1) |
      (-1 < x1 < 0, w + x1*w) | (0 < x1 < 1, w*x1) | x1 )
   self.ay1 := y + ( (/y1, 0) | (y1 <= -1 , h+y1) |
      (-1 < y1 < 0, h + y1*h) | (0 < y1 < 1, h*y1) | y1 )
   self.ax2 := x + ( (/x2, w) | (x2 <= -1 , w+x2) |
      (-1 < x2 < 0, w + x2*w) | (0 < x2 < 1, w*x2) | x2 )
   self.ay2 := y + ( (/y2, h) | (y2 <= -1 , h+y2) |
      (-1 < y2 < 0, h + y2*h) | (0 < y2 < 1, h*y2) | y2 )
end

procedure draw_Vline(self)
   DrawGroove(self.win, self.ax1, self.ay1, self.ax2, self.ay2)
end

procedure erase_Vline(self)
   DrawGroove(self.win, self.ax1, self.ay1, self.ax2, self.ay2, 0)
end



#=============================================  /home/gmt/ipl/gprocs/vradio.icn



############################################################################
#
#	File:     vradio.icn
#
#	Subject:  Procedures for radio buttons
#
#	Author:   Jon Lipp and Gregg M. Townsend
#
#	Date:     September 24, 1994
#
############################################################################
#
#  Vidgets defined in this file:
#	Vradio_entry
#	Vradio_frame
#
#  Utility procedures in this file:
#	Vradio_buttons()
#	Vvert_radio_buttons()
#	Vhoriz_radio_buttons()
#	init_format_Vrb()
#	format_Vradio_frame()	
#
############################################################################

#====== link vstyle

############################################################################
# Vradio - the radio button.
############################################################################

record Vradio_entry_rec (win, s, callback, id, style, aw, ah, don, ax, ay, uid, P, D, V)

#
# Creation procedure.
#
procedure Vradio_entry(params[])
   local self
   static procs

   initial procs := Vstd(event_Vradio_entry, draw_Vradio_entry,
      outline_radio_pane, resize_Vidget, inrange_Vpane, init_Vradio_entry,
                        couplerset_Vradio_entry)
   self := Vradio_entry_rec ! params
   self.uid := Vget_uid()
   Vset_style(self, self.style)
   self.V := procs
   self.P := Vstd_pos()
   self.V.init(self)
   return self
end

procedure init_Vradio_entry (self)
   local p

   if /self.callback then 
      _Vbomb("must pass a coupler variable to a Vradio_entry button")
   self.D.init(self)
end


#
#  Draw the frame around the radio buttons.
#
procedure outline_radio_pane(self)
   GrooveRectangle(self.win, self.ax, self.ay, self.aw, self.ah)
end


#
#  Draw the radio button.  If coupler's value is this id, draw "on".
#
procedure draw_Vradio_entry(self)
   if self.callback.value === self.id then {
      self.D.draw_on(self)
      self.don := 1
      }
   else {
      self.D.draw_off(self)
      self.don := &null
      }
end

#
#  The coupler notified us, turn "off".
#
procedure couplerset_Vradio_entry(self)
   self.D.draw_off(self)
   self.don := &null
end

#
#  If first time in this button, set coupler, draw "on".
#  If mouse releases on me, return my own record structure.
#
procedure event_Vradio_entry(self, e)

   if self.callback.value ~=== self.id | /self.don then {
      self.callback.V.set(self.callback, self, self.id)
      self.D.draw_on(self)
      self.don := 1
      }
   if \e === (&lrelease|&mrelease|&rrelease) then 
      return self
end


############################################################################
# Vradio_frame
############################################################################

record Vradio_frame_rec(win, cv, callback, id, aw, ah, data,
   lookup, draw, ax, ay, uid, P, V)

#
# Creation procedure.
#
procedure Vradio_frame(params[])
   local self, p
   static procs

   initial {
      procs := Vstd(event_Vradio_frame, draw_Vframe, outline_radio_pane,
                   resize_Vframe, inrange_Vpane, init_Vframe,
                   couplerset_Vpane, insert_Vframe, null_proc,
                   lookup_Vframe, set_abs_Vframe, set_value_Vradio_frame)
   }

   self := Vradio_frame_rec ! params
   self.uid := Vget_uid()
   self.V := procs
   self.P := Vstd_pos()
   self.V.init(self)
   p := \self.callback
   self.callback := Vcoupler()
   add_clients_Vinit(self.callback, p, self)
   
   return self
end

#
#  Distribute mouse event to proper radio button.  If returns
#  a value, (mouse released) notify callbacks, return text label
#  of radio button selected.
#
procedure event_Vradio_frame(self, e, x, y)
   local focus, rv

   if \self.callback.locked then fail
   if e ~=== &lpress & e ~=== &mpress & e ~=== &rpress then fail
   focus := self.V.lookup(self, x, y)
   (\focus).V.event(focus, e)
   repeat {
      e := Event(self.win)
      if e === "\^s" then
         until Event(self.win) === (&lpress|&mpress|&rpress) ;
      if self.V.inrange(self, &x, &y) then 
         focus := self.V.lookup(self, &x, &y)
      if rv := (\focus).V.event(focus, e) then {
         self.data := rv.s
         self.callback.V.set(self.callback, rv, rv.s)
         return rv.s
      }
   }
end

#
#  Set the radio frame according to string label passed in.  Match with
#  string label of a button.  Null sets to no button.
#
procedure set_value_Vradio_frame(self, value)
   local old, kid, id, s, k

   if (/value | *value = 0 | value === V_DUMMY_ID) then {
      kid := &null
      id := V_DUMMY_ID
      s := ""
      }
   else {
      kid := self.cv.curr_id
      id := self.cv.value
      s := self.data
      every (k := !self.lookup | fail) do 
         if value === k.s then {
            id := k.id
            kid := k
            s := value
            break
            }
      }

   old := self.cv.curr_id
   self.cv.curr_id := kid
   self.cv.value := id
   self.data := s

   self.callback.V.set(self.callback, self, self.data)

   (\old).D.draw_off(old)	# clear current button
   (\kid).D.draw_on(kid)	# set new button

   return
end

############################################################################
# Vradio_buttons -
# Construct radio buttons. Parameters:
# 	w - window, proc - the callback procedure,
#	s[] - a list of button labels. 
############################################################################
procedure Vradio_buttons(params[])
   return Vvert_radio_buttons ! params
end


#
# params: (w, s, callback, id, style)
#
procedure Vvert_radio_buttons(params[])
   local frame, x, y, ins, win, s, callback, id, style
   local rb_frame, max, cv, i, rb, first, uncentered

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   win := params[1]
   s := params[2]
   callback := params[3]
   id := params[4]
   style := params[5]
   uncentered := params[6]

   Vwin_check(win, "Vradio_buttons()")
   if type(s) ~== "list" then 
      _Vbomb("data parameter to Vradio_buttons must be a list of strings") 
   cv := Vmenu_coupler()
   rb_frame := Vradio_frame(win, cv, callback, id)
   if /uncentered then {
      max := 0
      every i := !s do max <:= TextWidth(win, i)
      max +:= 8
      }
   if \style == (V_CIRCLE | V_CHECK | V_DIAMOND | 
	 V_CHECK_NO | V_CIRCLE_NO | V_DIAMOND_NO) then
      max +:= 4 + WAttrib(win, "fheight")
   every i := 1 to *s do {
      rb := Vradio_entry(win, s[i], cv, i, style, max)
      VInsert(rb_frame, rb, 0, (i-1)*rb.ah)
   }

   init_format_Vrb(rb_frame)
   format_Vradio_frame(rb_frame)

   if \ins then VInsert(frame, rb_frame, x, y)
   return rb_frame
end

procedure Vhoriz_radio_buttons(params[])
   local frame, x, y, ins, win, s, callback, id, style, hpos
   local rb_frame, max, cv, i, rb, first

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   win := params[1]
   s := params[2]
   callback := params[3]
   id := params[4]
   style := params[5]

   Vwin_check(win, "Vradio_buttons()")
   if type(s) ~== "list" then
      _Vbomb("data parameter to Vradio_buttons must be a list of strings")
   cv := Vmenu_coupler()
   rb_frame := Vradio_frame(win, cv, callback, id)
   hpos := 0
   every i := 1 to *s do {
      rb := Vradio_entry(win, s[i], cv, i, style)
      VInsert(rb_frame, rb, hpos, 0)
      hpos +:= rb.aw
   }

   init_format_Vrb(rb_frame)
   rb_frame.V.resize(rb_frame, 0, 0, Vmin_frame_width(rb_frame), 
      Vmin_frame_height(rb_frame))

   if \ins then VInsert(frame, rb_frame, x, y)
   return rb_frame
end

#
#  Set to no radio button selected, format size of frame.
#	
procedure init_format_Vrb(rb_frame)

   rb_frame.cv.value :=  V_DUMMY_ID
   rb_frame.cv.curr_id := &null
   rb_frame.data := ""
end

#
#  Get size of frame based on entries.
#
procedure format_Vradio_frame(self, width)
local maxwidth, child

   maxwidth := \width | Vmin_frame_width(self) + 4
   every child := !self.lookup do {
      child.P.w := maxwidth
   }
   self.V.resize(self, 0, 0, maxwidth, Vmin_frame_height(self))
end



#=============================================  /home/gmt/ipl/gprocs/vsetup.icn



############################################################################
#
#	File:     vsetup.icn
#
#	Subject:  Procedures for vidget application setup
#
#	Author:   Gregg M. Townsend
#
#	Date:     August 23, 1995
#
############################################################################
#
#  vsetup(win, cbk, wlist[]) initializes a set of widgets according to
#  a list of specifications created by the interface editor VIB.
#
#  win can be an existing window, a list of command arguments to be
#  passed to Window(), null, or omitted.  In the latter three cases
#  a new window is opened if &window is null.
#
#  cbk is a default callback routine to be used when no callback is
#  specified for a particular vidget.
#
#  wlist is a list of specifications; the first must be the Sizer and
#  the last may be null.  Each specification is itself a list consisting
#  of a specification string, a callback routine, and an optional list
#  of additional specifications.  Specification strings vary by vidget
#  type, but the general form is "ID:type:style:n:x,y,w,h:label".
#
#  vsetup returns a table of vidgets indexed by vidget ID.
#  The root vidget is included with the ID of "root".
#
############################################################################
#
#  Links:  graphics,
#          vidgets, vslider, vmenu, vscroll, vtext, vbuttons, vradio
#
############################################################################

#====== link graphics
#====== link vidgets
#====== link vslider
#====== link vmenu
#====== link vscroll
#====== link vtext
#====== link vbuttons
#====== link vradio

record VS_rec(var, typ, sty, num, x, y, w, h, lbl, cbk, etc)


## vsetup(win, cbk, wlist[]) -- set up vidgets and return table of handles
#
#  win is an existing window, or a list of command args for Window(), or &null.
#  cbk is a callback routine to use when a vidget's callback is null.
#  wlist is a list of vidget specs as constructed by vib (or uix).

procedure vsetup(args[])
   local r, wlbl, root, vtable, wspec, alist, win, winargs, cbk

   case type(args[1]) of {		# check for window or arglist argument
      "window":	win := get(args)
      "list":	winargs := get(args)
      "null":	get(args)
      }
   /win := &window

   if type(args[1]) ~== "list" then	# check for callback argument
      cbk := get(args)

   wspec := get(args)			# first spec gives window size

   if /win then {			# if we don't have a window
      r := VS_crack(wspec) | _Vbomb("bad specification in vsetup")
      wlbl := ("" ~== r.lbl) |
         (&progname ? {while tab(upto('/')+1); tab(upto('.')|0)})
      alist := []
      put(alist, "width=" || (r.x + r.w))
      put(alist, "height=" || (r.y + r.h))
      put(alist, "label=" || wlbl)
      put(alist, \win)
      win := Window ! alist
      }

   VSetFont(win)			# set correct text font

   vtable := table()			# make table of handles
   vtable["root"] := root := Vroot_frame(win)	# insert root frame
   every r := VS_crack(\!args, cbk) do
      vtable[r.var] := VS_obj(win, root, r)	# insert other vidgets
   VResize(root)			# configure and realize vidgets
   root.id := "root"
   return vtable			# return table
end



## VS_crack(wspec, cbk) -- extract elements of spec and put into record
#
#  cbk is a default callback to use if the spec doesn't supply one.

procedure VS_crack(wspec, cbk)
   local r, f

   r := VS_rec()
   (get(wspec) | fail) ? { 
      r.var := tab(upto(':')) | fail;  move(1)
      r.typ := tab(upto(':')) | fail;  move(1)
      r.sty := tab(upto(':')) | fail;  move(1)
      r.num := tab(upto(':')) | fail;  move(1)
      r.x := tab(upto(',')) | fail;  move(1)
      r.y := tab(upto(',')) | fail;  move(1)
      r.w := tab(upto(',')) | fail;  move(1)
      r.h := tab(upto(':')) | fail;  move(1)
      r.lbl := tab(0)
      }
   r.cbk := \get(wspec) | cbk
   r.etc := get(wspec)
   return r
end



## VS_obj(win, root, r) -- create vidget depending on type

procedure VS_obj(win, root, r)
   local obj, gc, p, lo, hi, iv, args

   case r.typ of {
      "Label" | "Message": {
         obj := Vmessage(win, r.lbl)
         VInsert(root, obj, r.x, r.y, r.w, r.h)
         obj.id := r.var
         }
      "Line": {
         obj := Vline(win, r.x, r.y, r.w, r.h)
         obj.id := r.var
         VInsert(root, obj)
         }
      "Rect": {
         if r.sty == "" then
            if integer(r.num) > 0 then
               r.sty := "grooved"
            else
               r.sty := "invisible"
         obj := Vpane(win, r.cbk, r.var, r.sty)
         VInsert(root, obj, r.x, r.y, r.w, r.h)
         }
      "Check": {
         obj := Vcheckbox(win, r.cbk, r.var, r.w)
         VInsert(root, obj, r.x, r.y, r.w, r.h)
         }
      "Button": {
         if r.num == "1" then
            p := Vtoggle
         else
            p := Vbutton
         obj := p(win, r.lbl, r.cbk, r.var, r.sty, r.w, r.h)
         VInsert(root, obj, r.x, r.y)
         }
      "Choice": {
         obj := Vradio_buttons(win, r.etc, r.cbk, r.var, V_DIAMOND_NO)
         VInsert(root, obj, r.x, r.y)
         }
      "Slider" | "Scrollbar" : {
         r.lbl ? {
            lo := numeric(tab(upto(',')))
            move(1)
            hi := numeric(tab(upto(',')))
            move(1)
            iv := numeric(tab(0))
            }
         if r.num == "" then
            r.num := &null
         obj := case (r.sty || r.typ) of {
            "hSlider":
               Vhoriz_slider(win, r.cbk, r.var, r.w, r.h, lo, hi, iv, r.num)
            "vSlider":
               Vvert_slider(win, r.cbk, r.var, r.h, r.w, hi, lo, iv, r.num)
            "hScrollbar":
               Vhoriz_scrollbar(win, r.cbk, r.var, r.w, r.h, lo, hi, , , r.num) 
            "vScrollbar":
               Vvert_scrollbar(win, r.cbk, r.var, r.h, r.w, hi, lo, , , r.num)
            }
         VSetState(obj, iv)			# needed for scrollbars
         VInsert(root, obj, r.x, r.y)
         }
      "Text": {
         obj := Vtext(win, r.lbl, r.cbk, r.var, r.num)
         VInsert(root, obj, r.x, r.y)
         }
      "Menu": {
         obj := Vmenu_bar(win, r.lbl, VS_submenu(win, r.etc, r.cbk))
         obj.id := obj.lookup[1].id := r.var
         VInsert(root, obj, r.x, r.y)
         }
      default: {
         _Vbomb("unrecognized object in vsetup: " || image(r.typ))
         fail
         }
   }
   return obj
end



## VS_submenu(win, lst, cbk) -- create submenu vidget

procedure VS_submenu(win, lst, cbk)
   local a, c, lbl

   a := [win]
   while *lst > 0 do {
      put(a, get(lst))
      if type(lst[1]) == "list" then
         put(a, VS_submenu(win, get(lst), cbk))
      else
         put(a, cbk)
      }
   return Vsub_menu ! a
end



#==============================================  /home/gmt/ipl/gprocs/bevel.icn



############################################################################
#
#	File:     bevel.icn
#
#	Subject:  Procedures for drawing beveled objects
#
#	Author:   Gregg M. Townsend
#
#	Date:     July 11, 1995
#
############################################################################
#
#  These procedures allow the drawing of buttons and other objects
#  with a three-dimensional appearance.  They are intended to be
#  used like other graphics primitives (DrawRectangle() etc.).
#  However, this abstraction fails if the background color changes
#  or if clipping is set, due to the use of cached graphics contexts.
#
#  BevelReset(win) -- set/reset colors for beveling
#	This procedure is called automatically by the others.
#	It can be called explicitly if the background color is changed.
#
#  BevelCircle(win, x, y, r, bw) -- draw beveled circle
#  BevelDiamond(win, x, y, r, bw) -- draw beveled diamond
#  BevelTriangle(win, x, y, r, o, bw) -- draw beveled triangle
#  BevelSquare(win, x, y, r, bw) -- draw beveled square
#	These procedures draw a figure centered at (x,y) and having
#	a "radius" of r.  bw is the bevel width, in pixels.
#       o is the triangle orientation: "n", "s", "e", or "w".
#
#  FillSquare(win, x, y, r) -- fill square centered at (x,y)
#  FillDiamond(win, x, y, r) -- fill diamond centered at (x,y)
#  FillTriangle(win, x, y, r, o) -- fill triangle centered at (x,y)
#	These procedures complement the beveled outline procedures
#	by filling a figure centered at (x,y).  Fillcircle is already
#	an Icon function and so is not included here.
#
#  RidgeRectangle(win, x, y, w, h, bw) -- draw ridged rectangle
#  GrooveRectangle(win, x, y, w, h, bw) -- draw grooved rectangle
#  BevelRectangle(win, x, y, w, h, bw) -- draw beveled rectangle
#	These procedures draw a rectangle with the given external
#	dimensions and border width.  Beveled rectangles are raised
#	if bw > 0 or sunken if bw < 0.
#
#  DrawRidge(win, x1, y1, x2, y2, w) -- draw a ridged line
#  DrawGroove(win, x1, y1, x2, y2, w) -- draw a grooved line
#	These procedures draw a groove or ridge of width 2 at any angle.
#	If w = 0, a groove or ridge is erased to the background color.
#
#  For BevelSquare() and FillSquare(), the width drawn is 2 * r + 1,
#  not just 2 * r.  This is necessary to keep the visual center at the
#  specified (x, y) and is consistent with the other centered procedures
#  and the built-in function FillCircle.
#
############################################################################
#
#  Includes:  vdefns
#
############################################################################
#
#  Links:  graphics
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################


#====== $include "vdefns.icn"

#====== link graphics


global bev_table
record bev_record(shadow, hilite)


#  BevelReset(win) -- set/reset colors for beveling
#
#  Called automatically the first time a beveling procedure is called;
#  must also be called explicitly if the background color is changed.
#  (Pale, weak background colors work best with beveling.)

procedure BevelReset(win)	#: set colors for beveled drawing
   local b, h, l, s, hilite, shadow, lhilite, lshadow

   /win := &window
   /bev_table := table()

   if b := \bev_table[win] then {
      Uncouple(b.hilite)
      Uncouple(b.shadow)
      b := &null
      }

   if WAttrib(win, "depth") >= 4 then {

      HLS(ColorValue(Bg(win))) ? {
         h := tab(many(&digits))
         move(1)
         l := tab(many(&digits))
         move(1)
         s := tab(0)
         }
   
      case l of {
          0 <= l < 10 & l:	  { lshadow := 25;	lhilite := 50 }
         10 <= l < 25 & l:	  { lshadow := 0;	lhilite := l + 25 }
         25 <= l < 75 & l:	  { lshadow := l - 25;	lhilite := l + 25 }
         75 <= l < 90 & l:	  { lshadow := l - 25;	lhilite := 100 }
         default:		  { lshadow := 50;	lhilite := 75 }
         }
      s /:= 2
   
      shadow := Clone(win, "fg=" || HLSValue(h || ":" || lshadow || ":" || s),
         "linewidth=1", "linestyle=solid", "fillstyle=solid", "drawop=copy")
      hilite := Clone(shadow,
         "fg=" || HLSValue(h || ":" || lhilite || ":" || s))
      b := bev_record(\shadow, \hilite)
      }

   if /b then {
      shadow := Clone(win, "fg=black",
         "linewidth=1", "linestyle=solid", "fillstyle=solid", "drawop=copy")
      hilite := Clone(shadow, "fillstyle=textured", "pattern=gray")
      b := bev_record(shadow, hilite)
      }

   bev_table[win] := bev_record(shadow, hilite)
   return win
end


#  bev_lookup(win) -- look up and return bev_record for a window.
#
#  (Internal procedure)

procedure bev_lookup(win)
   local b, dx, dy
   b := \(\bev_table)[win] | bev_table[BevelReset(win)]
   dx := "dx=" || WAttrib(win, "dx")
   dy := "dy=" || WAttrib(win, "dy")
   every WAttrib(b.shadow | b.hilite, dx, dy)
   return b
end


#  BevelCircle(win, x, y, r, bw) -- draw beveled circle

procedure BevelCircle(win, x, y, r, bw)		#: draw beveled circle
   local b, upper, lower, a

   if type(win) ~== "window" then
      return BevelCircle((\&window | runerr(140)), win, x, y, r)
   b := bev_lookup(win)

   /r := 6
   /bw := 2
   if bw >= 0 then {
      upper := b.hilite
      lower := b.shadow
      }
   else {
      upper := b.shadow
      lower := b.hilite
      bw := -bw
      }

   a := -&pi / 8
   while (bw -:= 1) >= 0 do {
      DrawCircle(lower, x, y, r, a, &pi)
      DrawCircle(upper, x, y, r, a + &pi, &pi)
      r -:= 1
      }
   return win
end


#  BevelDiamond(win, x, y, r, bw) -- draw beveled diamond

procedure BevelDiamond(win, x, y, r, bw)	#: draw beveled diamond
   local b, upper, lower

   if type(win) ~== "window" then
      return BevelDiamond((\&window | runerr(140)), win, x, y, r)
   b := bev_lookup(win)

   /r := 6
   /bw := 3
   if bw >= 0 then {
      upper := b.hilite
      lower := b.shadow
      }
   else {
      upper := b.shadow
      lower := b.hilite
      bw := -bw
      }

   while (bw -:= 1) >= 0 do {
      DrawLine(lower, x - r, y, x, y + r, x + r, y)
      DrawLine(upper, x - r, y, x, y - r, x + r, y)
      r -:= 1
      }
   return win
end


#  BevelTriangle(win, x, y, r, o, bw) -- draw beveled triangle

procedure BevelTriangle(win, x, y, r, o, bw)
   local b, upper, lower

   if type(win) ~== "window" then
      return BevelTriangle((\&window | runerr(140)), win, x, y, r, o)
   b := bev_lookup(win)

   /r := 6
   /bw := 2
   if bw >= 0 then {
      upper := b.hilite
      lower := b.shadow
      }
   else {
      upper := b.shadow
      lower := b.hilite
      bw := -bw
      }

   while (bw -:= 1) >= 0 do {
      case o of {
         default: {  #"n"
            DrawLine(lower, x - r, y + r, x + r, y + r, x, y - r)
            DrawLine(upper, x - r, y + r, x, y - r)
            }
         "s": {
            DrawLine(lower, x, y + r, x + r, y - r)
            DrawLine(upper, x, y + r, x - r, y - r, x + r, y - r)
            }
         "e": {
            DrawLine(lower, x - r, y + r, x + r, y)
            DrawLine(upper, x - r, y + r, x - r, y - r, x + r, y)
            }
         "w": {
            DrawSegment(lower, x - r, y, x + r, y + r, x + r, y + r, x + r, y-r)
            DrawLine(upper, x - r, y, x + r, y - r)
            }
         }
      r -:= 1
      }
   return win
end


#  BevelSquare(win, x, y, r, bw) -- draw beveled square

procedure BevelSquare(win, x, y, r, bw)		#: draw beveled square

   if type(win) ~== "window" then
      return BevelSquare((\&window | runerr(140)), win, x, y, r)
   /r := 6
   return BevelRectangle(win, x - r, y - r, 2 * r + 1, 2 * r + 1, bw)
end


#  RidgeRectangle(win, x, y, w, h, bw) -- draw ridged rectangle

procedure RidgeRectangle(win, x, y, w, h, bw)	#: draw ridged rectangle

   if type(win) ~== "window" then
      return RidgeRectangle((\&window | runerr(140)), win, x, y, w, h)
   /bw := 2
   return GrooveRectangle(win, x, y, w, h, -bw)
end


#  GrooveRectangle(win, x, y, w, h, bw) -- draw grooved rectangle

procedure GrooveRectangle(win, x, y, w, h, bw)	#: draw grooved rectangle
   local abw

   if type(win) ~== "window" then
      return GrooveRectangle((\&window | runerr(140)), win, x, y, w, h)

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   /bw := 2
   if bw >= 0 then
      bw := (bw + 1) / 2
   else
      bw := -((-bw + 1) / 2)
   abw := abs(bw)

   BevelRectangle(win, x, y, w, h, -bw)
   BevelRectangle(win, x + abw, y + abw, w - 2 * abw, h - 2 * abw, bw)
   return win
end


#  BevelRectangle(win, x, y, w, h, bw) -- draw beveled rectangle
#
#  bw is the border width (>0 for raised bevel, <0 for sunken bevel).
#  (x,y,w,h) bounds the entire beveled rectangle, not the usable area inside.

procedure BevelRectangle(win, x, y, w, h, bw)	#: draw beveled rectangle
   local b, upper, lower, xx, yy

   if type(win) ~== "window" then
      return BevelRectangle((\&window | runerr(140)), win, x, y, w, h)
   b := bev_lookup(win)

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   /bw := 2
   if bw >= 0 then {
      upper := b.hilite
      lower := b.shadow
      }
   else {
      upper := b.shadow
      lower := b.hilite
      bw := -bw
      }

   xx := x + w
   yy := y + h
   FillRectangle(lower, x, yy, w, -bw, xx, y, -bw, h)

   while (bw -:= 1) >= 0 do {
      DrawLine(upper, x, yy -:= 1, x, y, xx -:= 1, y)
      x +:= 1
      y +:= 1
      }

   return win
end


#  DrawRidge(win, x1, y1, x2, y2, w) -- draw a ridged line
#
#  If w is negative, a groove is drawn instead.

procedure DrawRidge(win, x1, y1, x2, y2, w)	#: draw ridged line

   if type(win) ~== "window" then
      return DrawRidge((\&window | runerr(140)), win, x1, y1, x2, y2)
   /w := 2

   DrawGroove(win, x1, y1, x2, y2, -w)
   return win
end


#  DrawGroove(win, x1, y1, x2, y2, w) -- draw a grooved line
#
#  If w > 0, draw groove of width 2.
#  If w = 0, erase groove/ridge of width 2.
#  If w < 0, draw ridge of width 2.
#
#  Horizontal and vertical grooves fill the same pixels as lines drawn
#  linewidth=2.  Angled grooves are not necessarily the same, though.

procedure DrawGroove(win, x1, y1, x2, y2, w)	#: draw grooved line
   local a, n, b, upper, lower, fg

   if type(win) ~== "window" then
      return DrawGroove((\&window | runerr(140)), win, x1, y1, x2, y2)

   /w := 2
   x1 := integer(x1)
   y1 := integer(y1)
   x2 := integer(x2)
   y2 := integer(y2)

   if w ~= 0 then {			# if really drawing
      b := bev_lookup(win)
      upper := b.shadow
      lower := b.hilite
      }
   else {
      fg := Fg(win)			# if erasing, draw in bg color
      Fg(win, Bg(win))
      upper := lower := win
      }

   a := atan(y2 - y1, x2 - x1)
   if a < 0 then
      a +:= &pi
   n := integer(8 * a / &pi)

   if w < 0 then			# if groove/ridge swap
      upper :=: lower
   if n = 2 then			# if tricky illumination angle
      upper :=: lower

   if 2 <= n <= 5 then {		# approximately vertical
      DrawLine(upper, x1 - 1, y1, x2 - 1, y2)
      DrawLine(lower, x1, y1, x2, y2)
      }
   else {				# approximately horizontal
      DrawLine(upper, x1, y1 - 1, x2, y2 - 1)
      DrawLine(lower, x1, y1, x2, y2)
      }

   Fg(win, \fg)				# restore foreground if changed
   return win
end


#  FillSquare(win, x, y, r) -- fill square centered at (x,y)

procedure FillSquare(win, x, y, r)		#: draw filled square
   if type(win) ~== "window" then
      return FillSquare((\&window | runerr(140)), win, x, y)
   return FillRectangle(win, x - r, y - r, 2 * r + 1, 2 * r + 1)
end


#  FillDiamond(win, x, y, r) -- fill diamond centered at (x,y)

procedure FillDiamond(win, x, y, r)		#: draw filled diamond
   if type(win) ~== "window" then
      return FillDiamond((\&window | runerr(140)), win, x, y)
   return FillPolygon(win, x - r, y, x, y + r + 1, x + r + 1, y, x, y - r - 1)
end


#  FillTriangle(win, x, y, r, o) -- fill triangle centered at (x,y)
#
#  r is "radius" (1/2 of side of enclosing square)
#  o is orientation ("n", "s", "e", "w")

procedure FillTriangle(win, x, y, r, o)		#: draw filled triangle
   if type(win) ~== "window" then
      return FillTriangle((\&window | runerr(140)), win, x, y, r)
   return case o of {
      default:  #"n"
         FillPolygon(win, x - r - 1, y + r + 1, x, y - r, x + r + 1, y + r + 1)
      "s":
         FillPolygon(win, x - r, y - r, x, y + r, x + r, y - r)
      "e":
         FillPolygon(win, x - r, y - r, x + r, y, x - r, y + r)
      "w":
         FillPolygon(win, x + r + 1, y - r - 1, x - r, y, x + r + 1, y + r + 1)
      }
end




#==============================================  /home/gmt/ipl/gprocs/color.icn



############################################################################
#
#	File:     color.icn
#
#	Subject:  Procedures dealing with colors
#
#	Author:   Gregg M. Townsend
#
#	Date:     July 10, 1995
#
############################################################################
#
#  ScaleGamma(v, g) nonlinearly scales the number v (between 0.0 and 1.0)
#  to an integer between 0 and 65535 using a gamma correction factor g.
#  the default value of g is 2.5.
#
#  Blend(color1, color2, color3,...) generates ColorValue(color1), then
#  some intermediate shades, then ColorValue(color2), then some more
#  intermediate shades, and so on, finally generating the color value of
#  the last argument.  An integer argument can be interpolated at any
#  point to set the number of steps (the default is four) from one color
#  to the next.
#
#  Contrast(win, colr) returns either "white" or "black", depending
#  on which provides the greater contrast with the specified color.
#
#  Shade(win, colr) sets the foreground for an area filling operation.
#  On a color screen, Shade() sets the foreground color and returns the
#  window.  On a bilevel monochrome screen, Shade() sets the foreground
#  to a magic-square dithering pattern approximating the luminance of the
#  color specified.  If the environment variable XSHADE is set to "gray"
#  (or "grey") then Shade simulates a multilevel grayscale monitor.
#  If it is set to any other value, Shade simulates a bilevel monitor.
#
#  RandomColor(win, palette) returns a randomly chosen color from the
#  given image palette, excluding the "extra" grays of the palette, if
#  any.  (Colors are selected from a small finite palette, rather than
#  from the entire color space, to avoid running out of colors if a
#  large number of random choices are desired.)  The default palette
#  for this procedure is "c6".
#
#  PaletteGrays[win,] palette) is like PaletteChars but it returns only
#  the characters corresponding to shades of gray.  The characters are
#  ordered from black to white, and in all palettes the shades of gray
#  are equally spaced.
#
#  RGBKey([win,] palette, r, g, b) returns a palette key given the
#  three color components as real number from 0.0 to 1.0.
#  HSVKey([win,] palette, h, s, v) returns a palette key given a
#  hue, saturation, and value as real numbers from 0.0 to 1.0.
#
#  HSV() and HSVValue() convert between Icon color strings and strings
#  containing slash-separated HSV values with maxima of "360/100/100".
#  HSV(k) returns the h/s/v interpretation of an Icon color specification;
#  HSVValue(hsv) translates an h/s/v value into an Icon r,g,b value.
#
#  HLS() and HLSValue() convert between Icon color strings and strings
#  containing colon-separated HLS values with maxima of "360:100:100".
#  HLS(k) returns the h:l:s interpretation of an Icon color specification;
#  HLSValue(hls) translates an h:l:s value into an Icon r,g,b value.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################


#   ScaleGamma(v, g) -- scale fraction to int with gamma correction.

procedure ScaleGamma(v, g)		#: scale with gamma correction
   /g := 2.5
   return integer(65535 * v ^ (1.0 / g))
end


#  Blend(color1, color2, ...) -- generate sequence of colors

procedure Blend(args[])			#: generate sequence of colors
   local win, n, s, a, i, f1, f2, r1, g1, b1, r2, g2, b2, r3, g3, b3

   n := 4
   if type(args[1]) == "window" then
      win := get(args)
   else
      win := &window

   while a := get(args) do
      if integer(a) >= 0 then
         n := integer(a)
      else {
         s := ColorValue(win, a) | fail
         s ? {
            r2 := tab(many(&digits));  move(1)
            g2 := tab(many(&digits));  move(1)
            b2 := tab(many(&digits))
            }
         if /r1 then
            suspend s
         else
            every i := 1 to n do {
               f2 := real(i) / real(n)
               f1 := 1.0 - f2
               r3 := integer(f1 * r1 + f2 * r2)
               g3 := integer(f1 * g1 + f2 * g2)
               b3 := integer(f1 * b1 + f2 * b2)
               suspend r3 || "," || g3 || "," || b3
               }
         r1 := r2
         g1 := g2
         b1 := b2
         }
end


#  Contrast(win, color) -- return "white" or "black" to maximize contrast

procedure Contrast(win, color)		#: choose contrasting color
   static l
   initial l := ["white", "black"]

   if type(win) == "window" then
      return l[1 + PaletteKey(win, "g2", color)]
   else
      return l[1 + PaletteKey("g2", win)]
end


#  Shade(win, color) -- approximate a shade with a pattern if bilevel screen

procedure Shade(win, color)		#: dither shade using pattern
   local r, g, b
   static dmat, env
   initial env := ("" ~== map(getenv("XSHADE")))

   if type(win) ~== "window" then {
      color := win
      win := &window
      }
   if WAttrib(win, "depth") ~== "1" & /env then {
      Fg(win, color) | fail
      return win
      }
   (ColorValue(win, color) | fail) ? {
      r := tab(many(&digits));  move(1)
      g := tab(many(&digits));  move(1)
      b := tab(many(&digits))
      }
   g := integer(0.30 * r + 0.59 * g + 0.11 * b)

   if \env == ("gray" | "grey") then {
      Fg(win, g || "," || g || "," || g)
      return win
      }

   /dmat := [
      "4,15,15,15,15",
      "4,15,15,13,15",
      "4,11,15,13,15",
      "4,10,15,13,15",
      "4,10,15,5,15",
      "4,10,7,5,15",
      "4,10,7,5,14",
      "4,10,7,5,10",
      "4,10,5,5,10",
      "4,10,5,5,2",
      "4,10,4,5,2",
      "4,10,0,5,2",
      "4,10,0,5,0",
      "4,8,0,5,0",
      "4,8,0,1,0",
      "4,8,0,0,0",
      "4,0,0,0,0",
      ]
   WAttrib(win, "fillstyle=textured")
   g := g / 3856 + 1
   Pattern(win, dmat[g])
   return win
end


#   RandomColor(win, palette) -- choose random color

procedure RandomColor(win, palette)	#: choose random color
   local s, n

   if type(win) ~== "window" then
      palette:= win			# window allowed but ignored
   /palette := "c6"

   s := PaletteChars(palette)
   palette ?
      if ="c" & any('23456') then {
         n := integer(move(1))
         s := s[1 +: n * n * n]
         }
   return PaletteColor(palette, ?s)
end


#  PaletteGrays(win, palette) -- return grayscale entries from palette.

procedure PaletteGrays(win, palette)	#: grayscale entries from palette

   if (type(win) ~== "window") then
      palette := win				# window not needed

   palette := string(palette) | runerr(103, palette)

   if palette ? ="g" then
      return PaletteChars(palette)

   return case palette of {
      "c1":	"0123456"
      "c2":	"kxw"
      "c3":	"@abMcdZ"
      "c4":	"0$%&L*+-g/?@}"
      "c5":	"\0}~\177\200\37\201\202\203\204>\205\206\207\210]_
                  \211\212\213\214|"
      "c6":	"\0\330\331\332\333\334+\335\336\337\340\341V\342\343\344\345_
                  \346\201\347\350\351\352\353\254\354\355\356\357\360\327"
      default:	fail
      }
end


#  RGBKey(win, palette, r, g, b) -- find key given real-valued color

procedure RGBKey(win, palette, r, g, b)	#: return palette key for color

   if type(win) ~== "window" then	# allow unused window argument
      win :=: palette :=: r :=: g :=: b
   r := integer(r * 65535.99)
   g := integer(g * 65535.99)
   b := integer(b * 65535.99)
   return PaletteKey(palette, r || "," || g || "," || b)
end


#  HSVKey(win, palette, h, s, v) -- find nearest key from h,s,v in [0.0,1.0]
#
#  HSV conversion based on Foley et al, 2/e, p.593

procedure HSVKey(win, palette, h, s, v)	#: nearest key from HSV specification
   local i, f, p, q, t, r, g, b

   if type(win) ~== "window" then	# allow unused window argument
      win :=: palette :=: h :=: s :=: v

   if s = 0.0 then			# achromatic case
      return RGBKey(palette, v, v, v)

   h *:= 6.0				# hue [0.0 - 6.0)
   if h >= 6.0 then
      h := 0.0

   i := integer(h)
   f := h - i
   p := v * (1.0 - s)
   q := v * (1.0 - f * s)
   t := v * (1.0 - (1.0 - f) * s)

   case i of {
      0: { r := v;  g := t;  b := p }	# red - yellow
      1: { r := q;  g := v;  b := p }	# yellow - green
      2: { r := p;  g := v;  b := t }	# green - cyan
      3: { r := p;  g := q;  b := v }	# cyan - blue
      4: { r := t;  g := p;  b := v }	# blue - magenta
      5: { r := v;  g := p;  b := q }	# magenta - red
      }

   return RGBKey(palette, r, g, b)
end


#  HSV(k) -- return h/s/v interpretation of color spec.
#
#  h is hue (0 <= h < 360)
#  s is saturation (0 <= s <= 100)
#  v is value (0 <= v <= 100)
#
#  based on Foley et al, 2/e, p.592

procedure HSV(k)			#: HSV interpretation of color
   local r, g, b, h, s, v, min, max, d

   (ColorValue(k) | fail) ? {
      r := tab(many(&digits)) / 65535.0
      move(1)
      g := tab(many(&digits)) / 65535.0
      move(1)
      b := tab(many(&digits)) / 65535.0
      }

   min := r;  min >:= g;  min >:= b		# minimum
   max := r;  max <:= g;  max <:= b		# maximum
   d := max - min				# difference

   v := max					# value is max of all values
   if max > 0 then
      s := d / max				# saturation is (max-min)/max
   else
      s := 0.0

   if s = 0 then
      h := 0.0					# use hue 0 if unsaturated
   else if g = max then
      h := 2 + (b - r) / d			# yellow through cyan
   else if b = max then
      h := 4 + (r - g) / d			# cyan through magenta
   else if g < b then
      h := 6 + (g - b) / d			# magenta through red
   else
      h := (g - b) / d				# red through yellow

   return integer(60 * h + 0.5) || "/" ||
      integer(100 * s + 0.5) || "/" || integer(100 * v + 0.5)
end


#  HSVValue(hsv) -- return ColorValue of h/s/v string
#
#  h is hue (0 <= h <= 360)
#  s is saturation (0 <= s <= 100)
#  v is value (0 <= v <= 100)
#
#  based on Foley et al, 2/e, p.593

procedure HSVValue(hsv)			#: color value of HSV specification
   local h, s, v, r, g, b, i, f, p, q, t

   hsv ? {
      h := tab(many(&digits)) / 360.0 | fail
      ="/" | fail
      s := tab(many(&digits)) / 100.0 | fail
      ="/" | fail
      v := tab(many(&digits)) / 100.0 | fail
      pos(0) | fail
      }
   if (h | s | v) > 1 then fail

   if s = 0.0 then {			# achromatic case
      v := integer(65535 * v + 0.499999)
      return v || "," || v || "," || v
      }

   h *:= 6.0				# hue [0.0 - 6.0)
   if h >= 6.0 then
      h := 0.0

   i := integer(h)
   f := h - i
   p := v * (1.0 - s)
   q := v * (1.0 - f * s)
   t := v * (1.0 - (1.0 - f) * s)

   case i of {
      0: { r := v;  g := t;  b := p }	# red - yellow
      1: { r := q;  g := v;  b := p }	# yellow - green
      2: { r := p;  g := v;  b := t }	# green - cyan
      3: { r := p;  g := q;  b := v }	# cyan - blue
      4: { r := t;  g := p;  b := v }	# blue - magenta
      5: { r := v;  g := p;  b := q }	# magenta - red
      }

   return integer(65535 * r + 0.499999) || "," ||
      integer(65535 * g + 0.499999) || "," || integer(65535 * b + 0.499999)
end


#  HLS(k) -- return h:l:s interpretation of color spec.
#
#  h is hue (0 <= h < 360)
#  l is lightness (0 <= l <= 100)
#  s is saturation (0 <= s <= 100)
#
#  based on Foley et al, 2/e, p.595

procedure HLS(k)			#: HLS interpretation of color
   local r, g, b, h, l, s, min, max, delta

   (ColorValue(k) | fail) ? {
      r := tab(many(&digits)) / 65535.0
      move(1)
      g := tab(many(&digits)) / 65535.0
      move(1)
      b := tab(many(&digits)) / 65535.0
      }

   min := r;  min >:= g;  min >:= b	# minimum
   max := r;  max <:= g;  max <:= b	# maximum
   delta := max - min			# difference

   l := (max + min) / 2			# lightness

   if max = min then 
      h := s := 0			# achromatic

   else {

      if l <= 0.5 then
         s := delta / (max + min)	# saturation
      else
         s := delta / (2 - max - min)

      if r = max then
         h := (g - b) / delta		# yellow through magenta
      else if g = max then
         h := 2 + (b - r) / delta	# cyan through yellow
      else # b = max
         h := 4 + (r - g) / delta	# magenta through cyan
      if h < 0 then
         h +:= 6			# ensure positive value
      }

   return integer(60 * h + 0.5) || ":" ||
      integer(100 * l + 0.5) || ":" || integer(100 * s + 0.5)
end


#  HLSValue(hls) -- return ColorValue of h:l:s string
#
#  h is hue (0 <= h <= 360)
#  l is lightness (0 <= l <= 100)
#  s is saturation (0 <= s <= 100)
#
#  based on Foley & Van Dam, 1/e, p.619

procedure HLSValue(hls)			#: color value of HLS specification
   local h, l, s, r, g, b, m1, m2

   hls ? {
      h := tab(many(&digits)) / 360.0 | fail
      =":" | fail
      l := tab(many(&digits)) / 100.0 | fail
      =":" | fail
      s := tab(many(&digits)) / 100.0 | fail
      pos(0) | fail
      }
   if (h | l | s) > 1 then fail

   if l <= 0.5 then
      m2 := l * (1 + s)
   else
      m2 := l + s - (l * s)
   m1 := 2 * l - m2

   if s = 0.0 then
      r := g := b := l			# achromatic
   else {
      r := hls_rgb_val(m1, m2, h + 0.3333333)
      g := hls_rgb_val(m1, m2, h)
      b := hls_rgb_val(m1, m2, h - 0.3333333)
      }

   return integer(65535 * r + 0.499999) || "," ||
      integer(65535 * g + 0.499999) || "," || integer(65535 * b + 0.499999)
end

procedure hls_rgb_val(n1, n2, hue)	# helper function for HLSValue
   hue *:= 6
   if hue >= 6 then
      hue -:= 6
   else if hue < 0 then
      hue +:= 6
   if (hue < 1) then
      return n1 + (n2 - n1) * hue
   else if (hue < 3) then
      return n2
   else if (hue < 4) then
      return n1 + (n2 - n1) * (4 - hue)
   else
      return n1
end



#============================================  /home/gmt/ipl/gprocs/enqueue.icn



############################################################################
#
#	File:     enqueue.icn
#
#	Subject:  Procedures for queued events
#
#	Author:   Gregg M. Townsend
#
#	Date:     July 4, 1995
#
############################################################################
#
#      These procedures help encode, decode, and queue Icon window events.
#
#      Icon's event queue is a list accessed via Pending(); the list
#   can be inspected or altered by the Icon program.  An event is stored
#   as three consecutive entries on the list.  The first is the event code:
#   a string for a keypress, or an integer for any other event.  The next
#   two list entries are integers, interpreted as a packed structure:
#	0000 0000 0000 0SMC  XXXX XXXX XXXX XXXX   (second entry)
#	0EEE MMMM MMMM MMMM  YYYY YYYY YYYY YYYY   (third entry)
#
#   The fields have these meanings:
#	X...X	&x: 16-bit signed x-coordinate value
#	Y...Y	&y: 16-bit signed y-coordinate value
#	SMC	&shift, &meta, and &control (modifier keys)
#	E...M	&interval, interpreted as  M * 16 ^ E
#	0	currently unused; should be zero
#
#
#      pack_modkeys(s) encodes a set of modifier keys, returning an
#   integer with the corresponding bits set.  The string s contains
#   any combination of the letters c, m, and s to specify the bits
#   desired.
#
#      pack_intrvl(n) encodes an interval of n milliseconds and returns
#   a left-shifted integer suitable for combining with a y-coordinate.
#
#      unpack_modkeys(n) returns a string containing 0 to 3 of the
#   letters c, m, and s, depending on which modifier key bits are
#   set in the argument n.
#
#      unpack_intrvl(n) discards the rightmost 16 bits of the integer
#   n (the y-coordinate) and decodes the remainder to return an
#   integer millisecond count.
#
#      Enqueue([window,] eventcode, x, y, modkeys, interval) synthesizes
#   and enqueues an event for a window, packing the interval and modifier
#   keys (specified as above) into the correct places.  Default values
#   are:
#	eventcode = &null
#	x = 0
#	y = 0
#	interval = 0
#	modkeys = ""
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################


#  pack_intrvl(n) -- encode event interval

procedure pack_intrvl(n)			#: encode event interval
   local e

   n := integer(n) | runerr(101, n)	# ensure integer
   n <:= 0				# ensure nonnegative
   e := 0				# assume exponent of 0

   while n >= 16r1000 do {		# if too big
      n := ishift(n, -4)		# reduce significance
      e +:= 16r1000			# increase exponent
   }
   return ishift(e + n, 16)		# return shifted result
end


#  unpack_intrvl(n) -- decode event interval

procedure unpack_intrvl(n)			#: decode event interval
   local e

   n := integer(n) | runerr(101, n)	# ensure integer
   e := iand(ishift(n, -28), 7)		# exponent
   n := iand(ishift(n, -16), 16rFFF)	# mantissa
   return ishift(n, 4 * e)
end


#  pack_modkeys(s) -- encode modifier keys

procedure pack_modkeys(s)			#: encode modifier keys
   local b, c

   b := 0
   s := string(s) | runerr(103, s)		# ensure string value
   every c := !s do case c of {			# set bit for each flag
      "c":	b := ior(b, 16r10000)
      "m":	b := ior(b, 16r20000)
      "s":	b := ior(b, 16r40000)
      default:	runerr(205, s)			# diagnose bad flag
      }
   return b					# return result
end


#  unpack_modkeys(n) -- decode modifier keys

procedure unpack_modkeys(n)			#: decode modifier keys
   local s

   n := integer(n) | runerr(101, n)		# ensure integer
   s := ""
   if iand(n, 16r10000) ~= 0 then s ||:= "c"	# check each bit
   if iand(n, 16r20000) ~= 0 then s ||:= "m"
   if iand(n, 16r40000) ~= 0 then s ||:= "s"
   return s					# return result string
end


#  Enqueue(window, eventcode, x, y, modkeys, interval) -- enqueue event

procedure Enqueue(win, eventcode, x, y, modkeys, interval)	#: enqueue event

   if type(win) ~== "window" then {
      win :=: eventcode :=: x :=: y :=: modkeys :=: interval
      win := &window
      }
   /x := 0
   /y := 0
   x +:= WAttrib(win, "dx")
   y +:= WAttrib(win, "dy")
   return put(Pending(win),
      eventcode,
      ior(pack_modkeys(\modkeys | ""), iand(x, 16rFFFF)),
      ior(pack_intrvl(\interval | 0), iand(y, 16rFFFF)))
end



#==============================================  /home/gmt/ipl/gprocs/gpxop.icn



############################################################################
#
#	File:     gpxop.icn
#
#	Subject:  Procedures for graphics operations
#
#	Author:   Gregg M. Townsend
#
#	Date:     July 11, 1995
#
############################################################################
#
#  The following procedures allow an additional first argument
#  specifying a window to use instead of &window:
#
#  LeftString(x, y, s), CenterString(x, y, s), and RightString(x, y, s)
#  draw a string centered vertically about y and left-justified,
#  centered, or right-justified about x.
#
#  ClearOutline(x, y, w, h) draws a rectangle in the foreground color
#  and fills it with the background color.
#
#  Translate(dx, dy, w, h) adjusts a window's dx and dy attributes by
#  the values given.  Note that the resulting attribute values are the
#  sums of the existing values with the parameters, so that successive
#  translations accumulate.  If w and h are supplied, the clipping
#  region is set to a rectangle of size (w, h) at the new origin.
#
#  Zoom(x1, y1, w1, h1, x2, y2, w2, h2) is a distorting variation of
#  CopyArea that can be used to shrink or enlarge a rectangular area.
#  Zero, one, or two window arguments can be supplied.  Rectangle 1 is
#  copied to fill rectangle 2 using simple pixel sampling and replication.
#  The rectangles can overlap.  The usual defaults apply for both rectangles.
#
#  Sweep() lets the user select a rectangular area using the mouse.
#  Called when a mouse button is pressed, Sweep handles all subsequent
#  events until a mouse button is released.  As the mouse moves, a
#  reverse-mode outline rectangle indicates the selected area.  The
#  pixels underneath the rectangle outline are considered part of this
#  rectangle, implying a minimum width/height of 1, and the rectangle
#  is clipped to the window  boundary.  Sweep returns a list of four
#  integers [x,y,w,h] giving the rectangle bounds in canonical form
#  (w and h always positive).  Note that w and h give the width as
#  measured in FillRectangle terms (number of pixels included) rather
#  than DrawRectangle terms (coordinate difference).
#
#  Capture(palette, x, y, w, h) converts a window region into an
#  image string using the specified palette, and returns the string.
#
############################################################################
#
#  Links: gpxlib
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################

#====== link gpxlib


#   LeftString(x, y, s) -- draw string left-justified at (x,y).

procedure LeftString(win, x, y, s)		#: draw left-justified string
   if type(win) ~== "window" then {
      win :=: x :=: y :=: s
      win := &window
      }
   y +:= (WAttrib(win, "ascent") - WAttrib(win, "descent")) / 2 + 1
   return DrawString(win, x, y, s)
end


#   CenterString(x, y, s) -- draw string centered about (x,y).

procedure CenterString(win, x, y, s)		#: draw centered string
   if type(win) ~== "window" then {
      win :=: x :=: y :=: s
      win := &window
      }
   x -:= TextWidth(win, s) / 2
   y +:= (WAttrib(win, "ascent") - WAttrib(win, "descent")) / 2 + 1
   return DrawString(win, x, y, s)
end


#   RightString(x, y, s) -- draw string right-justified at (x,y).

procedure RightString(win, x, y, s)		#: draw right-justified string
   if type(win) ~== "window" then {
      win :=: x :=: y :=: s
      win := &window
      }
   x -:= TextWidth(win, s)
   y +:= (WAttrib(win, "ascent") - WAttrib(win, "descent")) / 2 + 1
   return DrawString(win, x, y, s)
end


#   ClearOutline(x, y, w, h) -- draw rectangle and fill background.

procedure ClearOutline(win, x, y, w, h)		#: draw and clear rectangle
   if type(win) ~== "window" then {
      win :=: x :=: y :=: w :=: h
      win := &window
      }

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   DrawRectangle(win, x, y, w, h)
   EraseArea(win, x+1, y+1, w-1, h-1)
   return win
end


#   Translate(dx, dy, w, h) -- add translation and possibly clipping.

procedure Translate(win, dx, dy, w, h)		#: add translation
   if type(win) ~== "window" then {
      win :=: dx :=: dy :=: w :=: h
      win := &window
      }
   WAttrib(win, "dx=" || WAttrib(win,"dx")+dx, "dy=" || WAttrib(win,"dy")+dy)
   Clip(win, 0, 0, \w, \h)
   return win
end


#  Sweep() -- sweep out area with mouse, return bounds

procedure Sweep(win)				#: sweep area with mouse
   local x, y, w, h, wmin, wmax, hmin, hmax

   /win := &window
   win := Clone(win, "drawop=reverse")

   x := &x					# set initial rect bounds
   y := &y
   w := h := 0

   wmin := -WAttrib(win, "dx") - x		# calc coordinate limits
   hmin := -WAttrib(win, "dy") - y
   wmax := wmin + WAttrib(win, "width") - 1
   hmax := hmin + WAttrib(win, "height") - 1

   DrawRectangle(win, x, y, w, h)		# draw initial bounding rect
   until Event(win) === (&lrelease | &mrelease | &rrelease) do {
      DrawRectangle(win, x, y, w, h)		# erase old bounds
      w := &x - x				# calc new width & height
      h := &y - y
      w <:= wmin				# clip to stay on window
      w >:= wmax
      h <:= hmin
      h >:= hmax
      DrawRectangle(win, x, y, w, h)		# draw new bounds
      }
   DrawRectangle(win, x, y, w, h)		# erase bounding rectangle

   if w < 0 then x -:= (w := -w)		# ensure nonnegative sizes
   if h < 0 then y -:= (h := -h)

   Uncouple(win)
   return [x, y, w + 1, h + 1]			# return FillRectangle bounds
end


#  Zoom(win1, win2, x1, y1, w1, h1, x2, y2, w2, h2) -- copy and distort.

procedure Zoom(args[])				#: zoom image
   local win1, x1, y1, w1, h1
   local win2, x2, y2, w2, h2
   local x, y, scr

   if type(args[1]) == "window" then
      win1 := get(args)
   else
      win1 := \&window | runerr(140, &window)
   if type(args[1]) == "window" then
      win2 := get(args)
   else
      win2 := win1

   x1 := \get(args) | -WAttrib(win1, "dx")
   y1 := \get(args) | -WAttrib(win1, "dy")
   w1 := \get(args) | WAttrib(win1, "width") - (x1 + WAttrib(win1, "dx"))
   h1 := \get(args) | WAttrib(win1, "height") - (y1 + WAttrib(win1, "dy"))
   if w1 < 0 then
      x1 -:= (w1 := -w1)
   if h1 < 0 then
      y1 -:= (h1 := -h1)

   x2 := \get(args) | -WAttrib(win2, "dx")
   y2 := \get(args) | -WAttrib(win2, "dy")
   w2 := \get(args) | WAttrib(win2, "width") - (x2 + WAttrib(win2, "dx"))
   h2 := \get(args) | WAttrib(win2, "height") - (y2 + WAttrib(win2, "dy"))
   if w2 < 0 then
      x2 -:= (w2 := -w2)
   if h2 < 0 then
      y2 -:= (h2 := -h2)

   if w1 = 0 | w2 = 0 | h1 = 0 | h2 = 0 then
      return

   scr := ScratchCanvas(win2, w2, h1) | fail
   every x := 0 to w2 - 1 do
      CopyArea(win1, scr, x1 + w1 * ((x + 0.5) / w2), y1, 1, h1, x, 0)
   every y := 0 to h2 - 1 do
      CopyArea(scr, win2, 0, h1 * ((y + 0.5) / h2), w2, 1, x2, y2 + y)

   EraseArea(scr)		# release colors
   return win1
end


#  Capture(win, pal, x, y, w, h) -- capture screen region as image string

$define CaptureChunk 100

procedure Capture(win, pal, x, y, w, h)		#: capture image as string
   local a, c, s, t

   if type(win) ~== "window" then {
      win :=: pal :=: x :=: y :=: w :=: h
      win := \&window | runerr(140, &window)
      }

   /pal := "c1"

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   PaletteChars(win, pal) | runerr(205, pal)

   # accumulate the image in chunks and then concatenate
   # (much faster than concatenating single chars on a very long string)
   s := ""
   a := []
   every c := PaletteKey(win, pal, Pixel(win, x, y, w, h)) do
      if *(s ||:= c) >= CaptureChunk then {
         put(a, s)
         s := ""
         }
   put(a, s)

   s := w || "," || pal || ","
   while s ||:= get(a)
   return s
end



#=============================================  /home/gmt/ipl/gprocs/gpxlib.icn



############################################################################
#
#	File:     gpxlib.icn
#
#	Subject:  Procedures for graphics tasks
#
#	Author:   Gregg M. Townsend
#
#	Date:     July 24, 1995
#
############################################################################
#
#   The following procedure allows an additional first argument
#   specifying a window to use instead of &window:
#
#   ScratchCanvas(w, h) returns a hidden-canvas window for temporary use.
#   The same scratch window (per display) is returned by successive calls,
#   avoiding the cost of creation.  The size is guaranteed to be at least
#   (w, h), which default to the size of the window.  The scratch window
#   must not be closed by the caller, but an EraseArea can be done to
#   reclaim any allocated colors.
#
#   NOTE:  There's only one scratch canvas, and it's used by some library
#   procedures including Zoom, Drag, and Popup.  Watch out for conflicts.
#
############################################################################
#
#   The following procedures do not accept a window argument:
#
#   PushWin(L) pushes &window onto the front of list L if the first
#   element of the list is not a window.  This aids in constructing
#   variable-argument procedures with an optional window argument.
#
#   Distance(x1, y1, x2, y2) returns the distance between two points
#   as a real number.
#
#   InBounds(x, y, w, h) checks whether &x and &y are within the given
#   region:  it returns &null if x <= &x <= x+w and y <= &y <= y+h,
#   and fails otherwise.
#
############################################################################
#
#  Links: wopen
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################

#====== link wopen


#   PushWin(L) -- push &window on list if no window already there.

procedure PushWin(a)
   if not (type(a[1]) == "window") then
      push(a, &window)
   return a
end


#   Distance(x1, y1, x2, y2) -- compute distance between two points.

procedure Distance(x1, y1, x2, y2)		#: distance between two points
   x1 -:= x2
   y1 -:= y2
   return sqrt(x1 * x1 + y1 * y1)
end


#   InBounds(x, y, w, h) -- succeed if (&x,&y) is in a rectangular area.

procedure InBounds(x, y, w, h)			#: check point within rectangle
   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)
   return (x <= &x <= x + w) & (y <= &y <= y + h) & &null
end


#  ScratchCanvas([win,] w, h) -- return hidden window for temporary use.

procedure ScratchCanvas(win, w, h)		#: return scratch canvas
   local d
   static dpytab
   initial dpytab := table()

   if type(win) ~== "window" then {
      win :=: w :=: h
      win := &window
      }
   /w := WAttrib(win, "width")
   /h := WAttrib(win, "height")
   w <:= 100				# if too teeny, can't open
   h <:= 100

   d := WAttrib(win, "display")
   /dpytab[d] := WOpen("width=" || w, "height=" || h, "canvas=hidden",
      "display=" || d)
   win := dpytab[d]
   if /win then
      fail
   if WAttrib(win, "width") < w | WAttrib(win, "height") < h then
      WAttrib(win, "width=" || w, "height=" || h)
   return win
end



#=============================================  /home/gmt/ipl/gprocs/window.icn



############################################################################
#
#	File:     window.icn
#
#	Subject:  Procedure for opening window
#
#	Authors:  Gregg M. Townsend
#
#	Date:     July 14, 1995
#
############################################################################
#
#  Window() opens a window with provisions for option processing and
#  error handling.  The returned window is assigned to &window if
#  &window is null.  If the window cannot be opened, the program is
#  aborted.
#
#  The characteristics of the window are set from several sources:
#  Window's arguments, optionally including the program argument list;
#  user defaults; and built-in defaults.  These built-in defaults are
#  the same as for optwindow(): bg=gray-white, fg=black, size=500,300.
#
#  With one exception, arguments to Window() are attribute specifications
#  such as those used with open() and WAttrib().  Order is significant,
#  with later attributes overriding earlier ones.
#
#  Additionally, the program argument list -- the single argument passed
#  to the main procedure -- can be passed as an argument to Window().
#  Options specified with a capital letter are removed from the list and
#  interpreted as attribute specifications, again in a manner consistent
#  with optwindow().
#
#  Because the Window() arguments are processed in order, attributes that
#  appear before the program arglist can be overridden by command-line
#  options when the program is executed.  If attributes appear after the
#  program arglist, they cannot be overridden.  For example, with
#
#	procedure main(args)
#	Window("size=600,400", "fg=yellow", args, "bg=black")
#
#  the program user can change the size and foreground color
#  but not the background color.
#
#  User defaults are applied at the point where the program arglist appears
#  (and before processing the arglist).  If no arglist is supplied, no
#  defaults are applied.  Defaults are obtained by calling WDefault().
#  Icon attribute names are used as option names;  &progname is used
#  as the program name after trimming directories and extensions.
#
#  The following table lists the options recognized in the program arglist,
#  the corresponding attribute (and WDefault()) names, the default values
#  if any, and the meanings.  All legal attributes are allowed in the
#  Window() call, but only these are set from the command line or
#  environment:
#
#	arg	attribute	default		meaning
#	---	---------	-------		--------------------------
#	-B	bg		gray-white	background color
#	-F	fg		black		foreground color
#	-T	font		 -		text font
#	-L	label		&progname	window title
#				(trimmed)
#
#	-D	display		 -		window device
#	-X	posx		 -		horizontal position
#	-Y	posy		 -		vertical position
#	-W	width		500		window width
#	-H	height		300		window height
#
#	-S	size		500,300		size
#	-P	pos		 -		position
#	-G	geometry	 -		window size and/or position
#
#	-A	<any>		 -		use "-A name=value"
#						to set arbitrary attribute
#
#	-!	 -		 -		write open() params to &error
#						(for debugging)
#
############################################################################
#
#  Includes:  vdefns
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################


#====== $include "vdefns.icn"

global wdw_debug			# non-null if to trace open call


#  Window(att, ..., arglist, ..., att) -- open window and set &window

procedure Window(args[])
   local cs, pname, att, omit1, omit2, name, val, a, win

   wdw_debug := &null
   att := table()

   # Trim &progname for use as option index and window label.
   cs := &cset -- &letters -- &digits -- '.$_'
   &progname ? {
      while tab(upto(cs)) do
         move(1)
      pname := tab(upto('.') | 0)
   }
   if pname == "" then
      pname := &progname

   # Process arguments.
   every a := !args do
      case type(a) of {
         "string": a ? {
            name := tab(upto("=")) | runerr(205, a)
            move(1)
            val := tab(0)
            wdw_register(att, name, val)
            }
         "list": {
            wdw_defaults(att, a, pname)
            wdw_options(att, a)
            }
         default:
            runerr(110, a)
         }

   # Set defaults for certain attributes if not set earlier.
   /att["fg"] := "black"
   /att["bg"] := VBackground
   /att["label"] := pname

   if /att["image"] & not (att["canvas"] === "maximal") then {	# don't override
      /att["width"] := 500
      /att["height"] := 300
      }

   # Open the window.  Defer "font" and "fg" until later because they can
   # cause failure.  Don't defer "bg", because it affects the initial
   # window appearance, but try again without it if the open fails.
   omit1 := set(["fg", "font"])
   omit2 := set(["fg", "font", "bg"])
   win := wdw_open(att, omit1 | omit2) | stop(&progname, ": can't open window")

   # Set foreground, background, and font, giving a nonfatal message if
   # the value is unacceptable.  Then return the window.
   wdw_attrib(win, att, "fg")
   wdw_attrib(win, att, "bg")
   wdw_attrib(win, att, "font")
   GotoRC(win, 1, 1)			# now that font has been set
   /&window := win
   return win
end


#  wdw_defaults(att, arglist, pname) -- find defaults and store in att table
#
#  arglist is checked for "-D displayname", which is honored if present.
#  pname is the program name for calling xdefault.
#  A list of several attribute names (see code) is checked.

procedure wdw_defaults(att, arglist, pname)
   local w, oname, dpy

   # We need to have a window in order to read defaults, and unless we honor
   # the -D option from the command line here it becomes pretty useless.
   dpy := ("display=" || wdw_peekopt(arglist, "D")) | "fg=black"

   # Open an offscreen window.
   w := open("Window()", "g", "canvas=hidden", "size=32,32", dpy) |
      stop(&progname, ": can't open display")

   # Set attributes from environment.  Order is significant here:
   # pos & size override geometry, and posx/posy/width/height override both.
   every oname := "display" | "bg" | "fg" | "font" | "windowlabel" | "label" |
         "geometry" | "size" | "pos" | "posx" | "posy" | "width" | "height" do
      wdw_register(att, oname, WDefault(w, pname, oname))

   # Delete the offscreen window, and return.
   Uncouple(w)
   return
end


#  wdw_peekopt(arglist, ch) -- return value of option 'ch' from arglist
#
#  Option cracking rules are identical with wdw_options().
#  Fails if the option does not appear.

procedure wdw_peekopt(arglist, ch)
   local a, opt, val

   arglist := copy(arglist)
   while a := get(arglist) do a ? {
      if ="-" & (opt := tab(any(&ucase))) then {
         if pos(0) then
            val := get(arglist) | fail
         else
            val := tab(0)
         if opt == ch then
            return val
         }
      }
   fail
end


#  wdw_options(att, arglist) - move options from arglist into att table
#
#  Upper-case options in the argument list are stored in the table "att"
#  under their attribute names (see code for list).  An "option" is a list
#  entry beginning with "-" and an option letter; its value follows in the
#  same string (if more characters remain) or in the next entry.
#
#  This procedure can be "fooled" if a non-upper-case option is followed
#  in the next entry by a value that looks like the start of an option.
#
#  Options and values are removed from arglist, leaving only the unprocessed
#  entries.
#
#  The special option "-!" takes no value and causes wdw_debug to be set.

procedure wdw_options(att, arglist)
   local a, opt, name, val, rejects

   rejects := []
   while a := get(arglist) do a ? {
      if ="-" & (opt := tab(any(&ucase))) then {
         if pos(0) then
            val := get(arglist) | stop(&progname, ": missing value for ", a)
         else
            val := tab(0)
         case opt of {
            "B":  wdw_register(att, "bg", val)
            "F":  wdw_register(att, "fg", val)
            "T":  wdw_register(att, "font", val)
            "L":  wdw_register(att, "label", val)
            "D":  wdw_register(att, "display", val)
            "X":  wdw_register(att, "posx", val)
            "Y":  wdw_register(att, "posy", val)
            "W":  wdw_register(att, "width", val)
            "H":  wdw_register(att, "height", val)
            "P":  wdw_register(att, "pos", val)
            "S":  wdw_register(att, "size", val)
            "G":  wdw_register(att, "geometry", val)
            "A":  val ? {
               name := tab(upto("=")) |
                  stop(&progname, ": malformed -A option: ", val)
               move(1)
               wdw_register(att, name, tab(0))
               }
            default:  stop(&progname, ": unrecognized option -", opt)
            }
         }
      else if ="-!" & pos(0) then
         wdw_debug := 1
      else
         put(rejects, a)
      }

   # Arglist is now empty; put back args that we didn't use.
   while put(arglist, get(rejects))
   return
end



#  wdw_register(att, name, val) -- store attribute val in att[name]
#
#  The compound attributes "pos", "size",  and "geometry" are broken down
#  into their component parts and stored as multiple values.  A runtime
#  error occurs if any of these is malformed.  Interactions with
#  "canvas=maximal" are also handled.

procedure wdw_register(att, name, val)
   wdw_reg(att, name, val) | runerr(205, name || "=" || val)
   return
end

procedure wdw_reg(att, name, val)
   case name of {
      "size": val ? {		# size=www,hhh
         att["width"] := tab(many(&digits)) | fail
         ="," | fail
         att["height"] := tab(many(&digits)) | fail
         pos(0) | fail
         if \att["canvas"] == "maximal" then
            delete(att, "canvas")
         }
      "pos": val ? {		# pos=xxx,yyy
         att["posx"] := tab(many(&digits)) | fail
         ="," | fail
         att["posy"] := tab(many(&digits)) | fail
         pos(0) | fail
         }
      "geometry": val ? {	# geometry=[wwwxhhh][+xxx+yyy]
         if att["width"] := tab(many(&digits))
         then {
            ="x" | fail
            att["height"] := tab(many(&digits)) | fail
            if \att["canvas"] == "maximal" then
               delete(att, "canvas")
            }
         if ="+" then {
            att["posx"] := tab(many(&digits)) | fail
            ="+" | fail
            att["posy"] := tab(many(&digits)) | fail
            }
         pos(0) | fail
         }
      "canvas": {
         att[name] := val
         if val == "maximal" then
            every delete(att, "width" | "height")
         }
      default: {
         att[name] := val
         }
      }
   return
end


#  wdw_open(att, omit) -- open window with attributes from att table
#
#  Ignore null or empty attributes and those in the "omit" set.
#  Trace open call if wdw_debug is set.  Set &window.

procedure wdw_open(att, omit)
   local args, name

   args := [&progname, "g"]
   every name := key(att) do
      if not member(omit, name) then
         put(args, name || "=" || ("" ~== \att[name]))

   if \wdw_debug then {
      writes(&errout, "Window: open(", image(args[1]))
      every writes(&errout, ",", image(args[2 to *args]))
      write(&errout, ")")
      }

   return open ! args
end


#  wdw_attrib(win, att, name) -- call WAttrib(win, name=att[name])
#
#  Null and empty values are ignored.
#  Failure is diagnosed on stderr.
#  The call is traced if wdw_debug is set.

procedure wdw_attrib(win, att, name)
   local val, s

   val := ("" ~== \att[name]) | return
   s := name || "=" || val
   if \wdw_debug then
      write(&errout, "Window: WAttrib(", image(s), ")")
   WAttrib(win, s) | write(&errout, &progname, ": can't set ", s)
   return
end



#==============================================  /home/gmt/ipl/gprocs/wopen.icn



############################################################################
#
#	File:     wopen.icn
#
#	Subject:  Procedures for graphics input/output
#
#	Authors:  Gregg M. Townsend and Ralph E. Griswold
#
#	Date:     November 14, 1994
#
############################################################################
#
#  WOpen(attrib, ...) -- open and return window
#  WRead(w) -- read line from window
#  WReads(w, i) -- read i characters from window
#  WWrite(w, s, ...) -- write line to window
#  WWrites(w, s, ...) -- write partial line to window
#  WDelay(w, n) -- flush window and then delay n milliseconds
#  WClose(w) -- close window; if w === &window, set &window null
#
#  These procedures provide window input and output using "W" names as
#  substitutes for standard input and output functions.  WOpen() opens
#  and returns a window; the result is also assigned to &window if
#  &window is null.  All other routines use &window if the first
#  argument is not a window.
#
############################################################################
#
#  WDone(), WQuit(), QuitCheck(), and QuitEvents() incorporate knowledge
#  of the Icon standard set of "quit" events, currently the letters
#  "q" or "Q".  The procedures themselves are trivial.
#  WQuit() consumes unread window events and succeeds if a quit event
#  is seen.  It does not wait.  WDone() waits until a quit event is read,
#  then exits the program.  QuitCheck(ev) calls exit() if its parameter
#  is a quit event; QuitCheck can be used with the vidget package as a
#  default event handler.  QuitEvents() generates the standard set of
#  quit events.
#
############################################################################
#
#  ZDone() is a zooming version of WDone().  If the window is resized
#  while waiting for a quit event, its contents are zoomed to fill the
#  new size.  Zooming to a multiple of the original size can also be
#  accomplished by typing a nonzero digit into the window.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################

#====== link gpxop


procedure WOpen(args[])
   push(args, "g")
   push(args, "")
   if /&window then
      return &window := open ! args
   else
      return open ! args
end


procedure WRead(window)
   if /window then
      window := \&window | runerr(140, &window)
   return read(window)
end


procedure WReads(window, i)
   if /window then
      window := \&window | runerr(140, &window)
   else if type(window) ~== "window" then {
      i := window
      window := \&window | runerr(140, &window)
      }
   return reads(window, i)
end


procedure WWrite(args[])
   if not (type(args[1]) == "window") then
      push(args, \&window) | runerr(140, &window)
   return write ! args
end


procedure WWrites(args[])
   if not (type(args[1]) == "window") then
      push(args, \&window) | runerr(140, &window)
   return writes ! args
end


procedure WDelay(window, n)
   if /window then
      window := \&window | runerr(140, &window)
   else if type(window) ~== "window" then {
      n := window
      window := \&window | runerr(140, &window)
      }
   integer(n) | runerr(101, n)
   WFlush(window)
   delay(n)
   return window
end


procedure WClose(window)
   if /window then
      window := \&window | runerr(140, &window)
   if window === &window then
      &window := &null
   return close(window)
end


procedure QuitEvents()
   suspend !"qQ"
end


procedure QuitCheck(ev)
   if ev === QuitEvents() then
      exit()
   return
end


procedure WQuit(win)
   /win := &window
   while *Pending(win) > 0 do
      if Event(win) === QuitEvents() then
         return win
   fail
end


procedure WDone(win)
   /win := &window
   until Event(win) === QuitEvents()
   exit()
end


#  ZDone(win) -- like WDone(), but zoom window if resized while waiting

procedure ZDone(win)
   local org, e, w, h, ww, hh, x0, y0

   /win := &window
   x0 := -WAttrib(win, "dx")
   y0 := -WAttrib(win, "dy")
   w := WAttrib(win, "width")
   h := WAttrib(win, "height")
   org := WOpen("width=" || w, "height=" || h, "canvas=hidden") | WDone()
   CopyArea(win, org, x0, y0)
   while e := Event(win) do case e of {
      QuitEvents(win):
         exit()
      &resize:
         Zoom(org, win, , , , , x0, y0)
      !"123456789": {
         ww := e * w
         hh := e * h
         WAttrib(win, "width=" || ww, "height=" || hh)
         Zoom(org, win, , , , , x0, y0, ww, hh)
         }
      }
end



#===========================================  /home/gmt/ipl/gprocs/vcoupler.icn



############################################################################
#
#	File:     vcoupler.icn
#
#	Subject:  Procedures for coupler variables
#
#	Author:   Jon Lipp
#
#	Date:     March 23, 1995
#
############################################################################
#
#  Vidgets defined in this file:
#
#	Vcoupler
#	Vrange_coupler
#	Vstrset_coupler
#	Vbool_coupler
#	Vtable_coupler
#	Vmenu_coupler
#
#  Utility procedures in this file:
#
#	add_clients_Vinit()
#
############################################################################
#
#  Links:  vidgets
#
############################################################################

#====== link vidgets

record Vcoupler_rec(value, callers, clients, id, curr_id, old_id, 
                    allowed, locked, uid, V)

############################################################################
# Vcoupler
############################################################################

procedure Vcoupler(params[])
   local self
   static procs

   initial procs := Vstd_coupler(set_Vcoupler, add_client_Vcoupler,
			init_Vcoupler, null_proc, null_proc,
                        null_proc)

   self := Vcoupler_rec ! params
   self.uid := Vget_uid()
   self.V := procs
   self.V.init(self)
   return self
end


procedure call_clients_Vcoupler(s, caller, val)
local i, c

   every i := 1 to *s.clients do {
      c := s.clients[i]
      if type(c) == "procedure" then c(s.callers[i], val)
      else if type(c) ? find("coupler") then c.V.set(c, caller, val)
      else if type(c) == !Vrecset then {
         # don't call yourself
         if (type(\caller) == type(c) & \caller["uid"] === c["uid"]) then
            next
         c.V.couplerset(c, caller, val)
         }
      }
end

procedure set_Vcoupler(s, caller, val, call_clients)
   if \s.locked then fail
   s.value := val
   if /call_clients then
      call_clients_Vcoupler(s, caller, val)
   return val
end

#
#  Client is the client of course; caller is the vidget record to be passed
#  to this client if type(client) == "procedure".
#
procedure add_client_Vcoupler(s, client, caller)
local pl

   image(client) ? { if ="function" then
      _Vbomb("Icon function" || tab(0) || "() not allowed as callback")
   }
   put (s.clients, client)
   put (s.callers, caller)
end

procedure init_Vcoupler(s)
  /s.clients := []
  /s.callers := []
  s.id := V_COUPLER
end

############################################################################
# Vrange_coupler
# Range couplers are Vcouplers whose values are limited to a
# particular range of legal values.  Presently they must be numeric.
# The default increment is 0.1.
############################################################################
record Vrange_coupler_rec(min, max, value, inc, callers, clients, real, id, 
   locked, uid, V)

procedure Vrange_coupler(params[])
   local self
   static procs

   initial procs := Vstd_coupler(set_Vrange_coupler,
			add_client_Vcoupler,
			init_Vrange_coupler, null_proc,
                        null_proc, null_proc)

   self := Vrange_coupler_rec ! params
   self.uid := Vget_uid()
   self.V := procs
   self.V.init(self)
   return self
end

#
#  If the value passed is out of range, change caller
procedure set_Vrange_coupler(s, caller, val, call_clients)
local theMax

   if \s.locked then fail
   theMax := numeric(s.max) | (type(s.max) == !Vcoupler_recset, s.max.value) |
     _Vbomb("illegal value in Vrange_coupler set")
   val := (s.min > val, s.min) | (theMax < val, theMax)
   s.value := val
   if /s.real then val := integer(val)
   if /call_clients then
      call_clients_Vcoupler(s, caller, val)
   return val
end

procedure init_Vrange_coupler(s)
   /s.min := 0; /s.max := 1.0
   if \s.value < s.min | \s.value > s.max then s.value := s.min

   /s.value := \ s.min
   s.real := (type(s.min|s.max) == "real", 1)
  
   /s.inc := 0.1*(s.max-s.min) 
   if /s.real then s.inc := integer(s.inc)
   init_Vcoupler(s)
end

############################################################################
# strset_coupler
############################################################################

procedure Vstrset_coupler(params[])
   local self
   static procs

   initial procs := Vstd_coupler(set_Vstrset_coupler, 
			add_client_Vcoupler,
			init_Vstrset_coupler, null_proc,
                        null_proc, null_proc)

   self := Vcoupler_rec ! params
   self.uid := Vget_uid()
   self.V := procs
   self.V.init(self)
   return self
end

procedure set_Vstrset_coupler(s, id, val)
   if \s.locked then fail
   if !s.allowed === val then 
      return set_Vcoupler(s, id, val)
end

procedure init_Vstrset_coupler(s)
  /s.allowed := []
  init_Vcoupler(s)
end

############################################################################
# Vbool_coupler
############################################################################

procedure Vbool_coupler(params[])
   local self
   static procs

   initial procs := Vstd_coupler(set_Vbool_coupler, 
			add_client_Vcoupler,
			init_Vcoupler, unset_Vbool_coupler,
			toggle_Vbool_coupler, eval_Vbool_coupler)

   self := Vcoupler_rec ! params
   self.uid := Vget_uid()
   self.V := procs
   self.V.init(self)
   return self
end

procedure eval_Vbool_coupler(s)
   return \s.value
end

procedure set_Vbool_coupler(s, caller)
   if \s.locked then fail
   s.value := 1
   call_clients_Vcoupler(s, caller, 1)
   return s.value
end

procedure unset_Vbool_coupler(s, caller)
   s.value := &null
   call_clients_Vcoupler(s, caller, &null)
   return s.value
end

procedure toggle_Vbool_coupler(s, caller)
   local newstate

   newstate := (/s.value, 1)
   return set_Vcoupler(s, caller, newstate)
end

############################################################################
# Vtable_coupler
############################################################################

procedure Vtable_coupler(params[])
   local self
   static procs

   initial procs := Vstd_coupler(set_Vtable_coupler, 
			add_client_Vcoupler,
			init_Vtable_coupler, null_proc,
                        null_proc, null_proc)

   self := Vcoupler_rec ! params
   self.uid := Vget_uid()
   self.V := procs
   self.V.init(self)
   return self
end

procedure set_Vtable_coupler(s, id, key, val)
   s.value[key] := val
   call_clients_Vcoupler(s, id, val)
end

procedure init_Vtable_coupler(s) 
  s.value := table()
  init_Vcoupler(s)
end

############################################################################
# Vmenu_coupler
############################################################################

procedure Vmenu_coupler(params[])
   local self
   static procs

   initial procs := Vstd_coupler(set_Vmenu_coupler, 
			null_proc,
			null_proc, null_proc,
                        null_proc, null_proc)

   self := Vcoupler_rec ! params
   self.uid := Vget_uid()
   self.V := procs
   self.V.init(self)
   return self
end


procedure set_Vmenu_coupler(s, id, val)
   if \s.locked then fail
   s.old_id := s.curr_id
   s.curr_id := id
   s.value := val
   (\s.old_id).V.couplerset(s.old_id, , val)
   return val
end
 

############################################################################
# Utilities 
############################################################################

#
#  Takes the callback parameter passed in upon creation of a vidget and
#  adds them to the client list of the coupler variable, checking if it
#  is a list or not.
#
procedure add_clients_Vinit(cv, callbacks, vid)
local cb

   if type(\callbacks) == "list" then
      every cb := !callbacks do cv.V.add_client(cv, \cb, vid)
   else
      cv.V.add_client(cv, \callbacks, vid)
end




#=============================================  /home/gmt/ipl/gprocs/vframe.icn



############################################################################
#
#	File:     vframe.icn
#
#	Subject:  Procedures for pane frame vidgets
#
#	Author:   Jon Lipp
#
#	Date:     March 23, 1995
#
############################################################################
#
#  Vidgets defined in this file:
#
# 	Vframe
#	Vroot_frame
#
#  Utility procedures in this file:
#
# 	Vmin_frame_width()
#	Vmin_frame_height()
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links:  vidgets
#
############################################################################

#====== link vidgets

############################################################################
#	frame vidget -
#       Keeps track of panes.  Frames can contain
#       sub-frames in a hierarchy.  Frames know their own absolute
#       coordinates and the relative sizes and positions of their
#       children (panes and sub-frames).  They determine positioning
#       and size of each child, and route events.
############################################################################

record Vframe_rec(win, aw, ah, callback, id, lookup, draw, ax, ay,
   uid, P, F, V)

#
#  Creation procedure for a Vframe.
#	Specify its "own" utility procedures (V field).
#	Specify "special" procedures (format, in F field).
#	Get a unique id (uid).
#	check implicit insertion, insert if necessary.
#
procedure Vframe(params[])
   local self, procs, spec_procs, frame, x, y, ins

   procs := Vstd(event_Vframe, draw_Vframe, outline_Vidget,
      resize_Vframe, inrange_Vpane, init_Vframe,
      couplerset_Vpane, insert_Vframe, remove_Vframe,
      lookup_Vframe, set_abs_Vframe)
   spec_procs := Vstd_dialog( , , format_Vframe)

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vframe_rec ! params[1:6|0]
   Vwin_check(self.win, "Vframe()")
   if (\self.aw, not numeric(self.aw) ) then
      _Vbomb("invalid aw parameter to Vframe()")
   if (\self.ah, not numeric(self.ah) ) then
      _Vbomb("invalid ah parameter to Vframe()")

   self.uid := Vget_uid()
   self.V := procs
   self.F := spec_procs
   self.P := Vstd_pos()
   self.V.init(self)
   if \ins then VInsert(frame, self, x, y)
   return self
end

#
#  Initialize procedure for Vframe.  Other frame types call this.
#
procedure init_Vframe(s)
   s.lookup := []
   s.draw := []
end

#
#  draw the contents of the frame.
#
procedure draw_Vframe(s, erased)
local p

#  PMIcon: fixed bug; drawig before resize.
   if /s.aw | /s.ah then _Vbomb("frame not resized yet")
   /erased & EraseArea(s.win, s.ax, s.ay, s.aw, s.ah)
   every p := !s.draw do p.V.draw(p, "erased")
   s.V.outline(s)
end

#
#  Set the absolute coordinates of everything on the draw list;
#  Don't do it for Vline, it is special.
#  It used to be that if the vidget is a Vpane,
#  a resize event was sent, so that it would notify its callback.
#  That "feature" has been commented out in the code below.
#
procedure resize_Vframe(s, x,y,wid,h)
local w, slots

   resize_Vidget(s, x, y, wid, h)
   every w := !s.draw do {
      if (type(w) == "Vline_rec") then
         w.V.resize(s, w)
      else s.V.set_abs(s, w)
#     if type(w) == "Vpane_rec" then
#        w.V.event(w, -10)
      }
end
#
#  Determine the absolute coordinates of a vdiget based on its parent
#  frame's absolute coordinates, and the "virtual" coordinates passed
#  in upon creation.
#  Allows for the fact that a pane can have relative
#  position and size contraints intertwined with absolute.
#
procedure set_abs_Vframe(s, vid)
local ax,ay,aw,ah, a, b, w, h, vx, vy, vw, vh

   w := s.aw; h := s.ah
   vx := vid.P.x; vy := vid.P.y
   vw := vid.P.w; vh := vid.P.h

   ax := s.ax + ( (vx <= -1, w + vx - (\vid.aw | 0)) |
      (type(vx) == "real",
      (-1 <= vx < 0, w - vx*w) |
      (0 < vx <= 1, vx*w) ) | vx )
   ay := s.ay + ( (vy <= -1, h + vy - (\vid.ah | 0)) |
      (type(vy) == "real",
      (-1 <= vy < 0, h - vy*h) |
      (0 < vy <= 1, vy*h) ) | vy )

   aw := (\vw, (type(vw) == "real", 0 < vw <= 1, vw*w) |
      vw) | \vid.aw | w
   ah := (\vh, (type(vh) == "real", 0 < vh <= 1, vh*h) |
      vh) | \vid.ah | h
   aw := integer(aw)
   ah := integer(ah)

## don't let kid be bigger than the frame.
   if (a := aw + ax) > (b := s.aw + s.ax) then aw -:= (a-b)
   if (a := ah + ay) > (b := s.ah + s.ay) then ah -:= (a-b)
   vid.V.resize(vid, ax, ay, aw, ah)
end

#
# Don't erase the vidget if erase is non-&null.
#
procedure remove_Vframe(s, pane, erase)
local new, k

   new := []
   every k := !s.lookup do if k ~=== pane then put(new,k)
   s.lookup := new
   new := []
   every k := !s.draw do if k ~=== pane then put(new,k)
   s.draw := new

   if /erase then VErase(pane)
end

#
#  Insert a vidget into a frame.
#
procedure insert_Vframe(s, pane, x, y, w, h)
local wc

#defaults
   /x := 0
   /y := 0
   /w := \pane.aw
   /h := \pane.ah
   pane.P.x := x
   pane.P.y := y
   pane.P.w := w
   pane.P.h := h
   put(s.draw, pane)
   if not (image(pane.V.event) ? find("null_proc") ) then
      put(s.lookup, pane)
   if (\s.ax, \s.ay, \s.aw, s.ah) then { # is this frame sized yet
      if (type(pane) == "Vline_rec") then
         pane.V.resize(s, pane)
      else
         s.V.set_abs(s, pane)
   }
end

#
#  Get events, lookup vidget based on (x, y), call its event loop.
#
procedure event_Vframe(s, e, x, y)
local dest

   if dest := s.V.lookup(s, x, y) then {
      return dest.V.event(dest, e, x, y)
   }
end

#
#  For every vidget on lookup list, check if (x, y) lie within its
#  boundaries.  Doesn't address overlapping vidgets.
#
procedure lookup_Vframe(s, x, y)
local w

   every w := !s.lookup do
      if w.V.inrange(w, x, y) then
         return w
end

#
#  Determine and set the minumum bounding rectangle which encompasses
#  all vidgets within the frame.  Restriction is that all vidgies must have
#  been inserted with absolute coordinates and sizes.
#
procedure format_Vframe(self)
   resize_Vidget(self, , , Vmin_frame_width(self), Vmin_frame_height(self))
end


############################################################################
# Vroot_frame -
# Root of the X-Idol event window demultiplexing recordes.
# The root_frame record serves as the root for windows that are
# subdivided.
############################################################################

procedure Vroot_frame(params[])
   local self, spec_procs
   static procs

   initial {
      procs := Vstd(event_Vroot_frame, draw_Vframe, null_proc,
                   resize_Vroot_frame, inrange_Vpane, init_Vroot_frame,
                   couplerset_Vpane, insert_Vframe, remove_Vframe,
                   lookup_Vframe, set_abs_Vframe)
      spec_procs := Vstd_dialog( , , format_Vframe)

      VInit()
   }

   self := Vframe_rec ! params[1:2|0]
   Vwin_check(self.win, "Vroot_frame()")
   self.uid := Vget_uid()
   self.V := procs
   self.F := spec_procs
   self.P := Vstd_pos()
   self.V.init(self)
   return self
end

procedure init_Vroot_frame(s)
   s.ax := s.ay := 0
   init_Vframe(s)
end

#
#  Process events (same as for a frame).  Difference, is if we get a resize,
#  resize all vidgets within, and redraw screen (no lookup performed).
#
procedure event_Vroot_frame(s,e,x,y)
local dest

   if e === &resize then {
      s.V.resize(s)
      return &null
   }
   else {
      if dest:= s.V.lookup(s,x,y) then
         return dest.V.event(dest,e,x,y)
      else fail
   }
end

#
# The window was resized!  Well... reconfigure all the absolute
# position and sizes for all panes.  This benefits relative values
# the most.
#
procedure resize_Vroot_frame(s)

   s.aw := WAttrib(s.win, "width")
   s.ah := WAttrib(s.win, "height")
   resize_Vframe(s, s.ax, s.ay, s.aw, s.ah)
   s.V.draw(s)
end

############################################################################
# Utility procedures for frames.
############################################################################

#
# Min--- returns the minimum size of the frame that will encase all
# children.  NOTE - this can only be determined if all the children
# were inserted with absolute co-ords and sizes. I.e. positive and
# integral x, y, w, & h.
#
procedure Vmin_frame_width(s)
   local max, vid

   max := 2
   every vid := (!s.draw) do
      if (type(vid) ~== "Vline_rec") then {
         if type(vid.P.x) == "real" | type(vid.P.w) == "real" |
            vid.P.x < 0 | vid.P.w < 0 then
            _Vbomb("attempt to format a frame with non-absolute sized and positioned children")
         max <:= (vid.P.x + vid.P.w )
      }
   return max
end

procedure Vmin_frame_height(s)
   local max, vid

   max := 2
   every vid := (!s.draw) do
      if (type(vid) ~== "Vline_rec") then {
         if type(vid.P.y) == "real" | type(vid.P.h) == "real" |
            vid.P.y < 0 | vid.P.h < 0 then
            _Vbomb("attempt to format a frame with non-absolute sized and positioned children")
         max <:= (vid.P.y + vid.P.h )
      }
   return max
end



#=============================================  /home/gmt/ipl/gprocs/viface.icn



############################################################################
#
#	File:     viface.icn
#
#	Subject:  Procedures for interfacing vidgets
#
#	Author:   Jon Lipp
#
#	Date:     August 23, 1995
#
############################################################################
#
#  Utility procedures in this file:
#	VDraw()
#	VErase()
#	VOutline()
#	VResize()
#	VRemove()
#	VInsert()
#	VEvent()
#	VRegister()
#	VUnregister()
#	VOpenDialog()
#	VFormat()
#	VAddClient()
#	VToggle()
#	VUnSet()
#	VSetState()  [formerly SetVidget() and VSet()]
#	VGetState()
#	ProcessEvent()
#	GetEvents()
#	VEcho()
#	VSetFont()
#
############################################################################
#
#  Includes:  vdefns
#
############################################################################
#
#  Links:  vidgets
#
############################################################################

#====== link vidgets

#====== $include "vdefns.icn"

procedure VDraw(vid, code)
   if not (type(vid) == !Vrecset ) then
      _Vbomb("invalid vidget parameter to VDraw()")

   vid.V.draw(vid, code)
end

procedure VErase(vid)
   if not (type(vid) == !Vrecset) then
      _Vbomb("invalid vidget parameter to VErase()")
   if type(vid) == "Vline_rec" then
      erase_Vline(vid)
   else
      EraseArea(vid.win, vid.ax, vid.ay, vid.aw, vid.ah)
end

procedure VOutline(vid)
   if not (type(vid) == !Vrecset ) then
      _Vbomb("invalid vidget parameter to VOutline()")

   vid.V.outline(vid)
end

procedure VResize(vid, x, y, w, h)
   if not (type(vid) == !Vrecset ) then
      _Vbomb("invalid vidget parameter to VResize()")
   if type(vid) == "Vline_rec" then {
      vid.ax1 := \x
      vid.ay1 := \y
      vid.ax2 := vid.ax1 + \w
      vid.ay2 := vid.ay1 + \h
   }
   else {
      vid.ax := \x
      vid.ay := \y
      vid.aw := \w
      vid.ah := \h
   }
   vid.V.resize(vid)
end

procedure VRemove(frame, vid, erase)
   if not (type(frame) ? find("frame") ) then
      _Vbomb("invalid frame parameter to VRemove()")
   else if not (type(vid) == !Vrecset ) then
      _Vbomb("invalid vidget parameter to VRemove()")
 
   frame.V.remove(frame, vid, erase)
end

procedure VInsert(frame, vid, x, y, w, h)
   if not (type(frame) ? find("frame") ) then
      _Vbomb("invalid frame parameter to VInsert()")
   else if not (type(vid) == !Vrecset ) then
      _Vbomb("invalid vidget parameter to VInsert(): " || image(vid))
   else if (\x, not numeric(x) ) then
      _Vbomb("non-numeric x parameter to VInsert()")
   else if (\y, not numeric(y) ) then
      _Vbomb("non-numeric y parameter to VInsert()")
   else if (\w, not numeric(w) ) then
      _Vbomb("non-numeric w parameter to VInsert()")
   else if (\h, not numeric(h) ) then
      _Vbomb("non-numeric y parameter to VInsert()")
   frame.V.insert(frame, vid, x, y, w, h)
end

procedure VEvent(vid, e, x, y)
   if not (type(vid) == !Vrecset ) then
      _Vbomb("invalid vidget parameter to VEvent()")

   return vid.V.event(vid, e, x, y)
end

############################################################################
#  The following two procedure are only for use with dialog box frames
#  and menu_frames.
#
#  VRegister is analogous to VInsert, except, it tells the dialog box that
#  this is an editable field.
############################################################################
procedure VRegister(dialog, vid, x, y, w, h)
   if not (type(dialog) ? find("dialog_frame") ) then
      _Vbomb("invalid dialog parameter to VRegister()")
   else if not (type(vid) == !Vrecset ) then
      _Vbomb("invalid vidget parameter to VRegister()")
   else if (\x, not numeric(x) ) then
      _Vbomb("Non-numeric x parameter to VRegister()")
   else if (\y, not numeric(y) ) then
      _Vbomb("Non-numeric y parameter to VRegister()")
   else if (\w, not numeric(w) ) then
      _Vbomb("Non-numeric w parameter to VRegister()")
   else if (\h, not numeric(h) ) then
      _Vbomb("Non-numeric y parameter to VRegister()")

   dialog.F.register(dialog, vid, x, y, w, h)
end

procedure VUnregister(dialog, vid)
   if not (type(dialog) ? find("dialog_frame") ) then
      _Vbomb("invalid dialog parameter to VUnregister()")
   else if not (type(vid) == !Vrecset ) then
      _Vbomb("invalid vidget parameter to VUnregister()")

   dialog.F.unregister(dialog, vid)
end

#
# Vopen_dialog
# Opens a dialog for input.  Returns the list of new objects, or the
# original data if "cancel" was picked.
#
# open a dialog box at (x, y);  dialog contains a record of type
# 'dialog', data is a list of initial values corresponding to the
# objects "registered" with the dialog; default_string is the label
# of the control button to press upon hitting a return.
#
# If x is null and y is not, y is an "ID" for the dialog box, which
# opens at the default location but can be moved by the user.  The
# location is remembered and applied to subsequent opens.
#
procedure VOpenDialog(dialog, x, y, data, default_string)
   if not (type(dialog) ? find("dialog_frame") ) then
      _Vbomb("invalid dialog parameter to VOpenDialog()")
   if \x & not (numeric(x) & numeric(y)) then
      _Vbomb("invalid x or y parameter passed to VOpenDialog()")
   /data := []
   return \(dialog.F.open_dialog(dialog, x, y, data, default_string)) | data
end


#
#  VFormat resizes the frame, and figures out the width and height
#  automatically, contingent on all vidgets being inserted or registered
#  with absolute coordinates.
#
procedure VFormat(frame)
   if not (type(frame) ? find("frame") ) then
      _Vbomb("invalid frame parameter to VFormat()")

   frame["F"].format(frame)
end

############################################################################
#  The following procedure is only for use with couplers.
############################################################################

procedure VAddClient(coupler, client, caller)
   if not (type(coupler) ? find("coupler") ) then
      _Vbomb("invalid coupler parameter to VAddClient()")

   coupler.V.add_client(coupler, client, caller)
end

procedure VToggle(coupler)
   if not (type(coupler) ? find("coupler") ) then
      _Vbomb("invalid coupler parameter to VToggle()")

   coupler.V.toggle(coupler)
end

procedure VUnSet(coupler)
   if not (type(coupler) ? find("coupler") ) then
      _Vbomb("invalid coupler parameter to VUnSet()")

   coupler.V.unset(coupler)
end

procedure VLock(coupler)
   if not (type(coupler) ? find("coupler") ) then
      _Vbomb("invalid coupler parameter to VLock()")

   coupler.locked := 1
end

procedure VUnLock(coupler)
   if not (type(coupler) ? find("coupler") ) then
      _Vbomb("invalid coupler parameter to VUnLock()")

   coupler.locked := &null
end

############################################################################
# VSetState sets the vidget | coupler to the value.
############################################################################
procedure VSetState(vid, val, code)
   if type(vid) ? find("coupler") then
      return (\(\vid).V.set)(vid, , val, code)
   else if type(vid) == !Vrecset then
      return (\(\vid).V.set_value)(vid, val, code)
   else 
      _Vbomb("invalid vidget parameter to VSetState()")
end

procedure SetVidget(vid, val, code)	# old name
   SetVidget := VSetState
   return VSetState(vid, val, code)
end

procedure VSet(vid, val, code)		# older name
   VSet := VSetState
   return VSetState(vid, val, code)
end

############################################################################
# VGetState returns the value of the vidget state.
############################################################################
procedure VGetState(vid)
   if type(vid) ? find("button" | "scroll" | "slide" | "radio" | "text") then
      return (\vid.callback).value
   else
      fail
end


############################################################################
# Event handlers. 
############################################################################

procedure GetEvents(vidget, missed, all, resize)
   repeat ProcessEvent(vidget, missed, all, resize)
end

procedure ProcessEvent(vidget, missed, all, resize)
   local event, lrv

   type(vidget) ? {
      if not find("frame")
      then _Vbomb("invalid frame argument to ProcessEvent()")
      }

   event := Event(vidget.win)

   if event === &resize then {
      (\resize)(vidget, event, &x, &y)
      VEvent(vidget, event, &x, &y)
      }

   (\(lrv := vidget.V.lookup(vidget,&x,&y)) & lrv.V.event(lrv,event,&x,&y)) |
      (\missed)(event, &x, &y)

   (\all)(event, &x, &y)

   return event

end


############################################################################
#  VEcho(v, x) -- echoing callback routine
#
#  VEcho can be used as the default callback routine passed to vsetup.
#  It just prints a message on standard output giving the value of x.
############################################################################

procedure vecho(v, x)	# old name
   vecho := VEcho
   return VEcho(v, x)
end

procedure VEcho(v, x)
   writes("callback: id=", v.id, ", value=")
   if type(x) == "list" then {
      writes("[")
      writes(image(x[1]))
      every writes(",", image(x[2 to *x]))
      writes("]")
      }
   else
      writes(image(x))
   write()
   return
end


############################################################################
#  VSetFont(win) -- set vidget font in window.
#
#  VSetFont tries to set a 7-pixel-wide font for use by VIB and vidgets.
############################################################################

procedure vsetfont(win)		# old name
   vsetfont := VSetFont
   return VSetFont(win)
end

procedure VSetFont(win)
   local spec, maybe

   /win := &window
   if WAttrib(win, "fwidth") = VFWidth then
      return win			# existing font is acceptable

   every spec := 

$ifdef _X_WINDOW_SYSTEM
         "lucidasanstypewriter-bold-12" |
         "-*-lucidatypewriter-bold-r-*-*-12-*-*-*-*-70-iso8859-1" | 
         "-*-lucidatypewriter-bold-r-*-*-*-*-*-*-*-70-iso8859-1" | 
         "-*-*-r-*-sans-*-*-*-*-m-70-iso8859-1" |
         "-*-*-r-*-*-*-*-*-*-m-70-iso8859-1" |
         "-*-*-r-*-*-*-*-*-*-c-70-iso8859-1"
$else
         ("mono,bold," | "mono," | "typewriter,") || (12 | 11 | 13 | 10 | 14)
$endif

      do {
         Font(win, spec) | next		# try a font
         /maybe := spec			# remember first success
         if WAttrib(win, "fwidth") = VFWidth then
            return win			# this font is right size
         }

   # No font was the right size.  Go back to the first one that was legal.
   # If nothing works, return with the font unchanged.
   Font(win, \maybe)
   return win
end



#==============================================  /home/gmt/ipl/gprocs/vpane.icn



############################################################################
#
#	File:     vpane.icn
#
#	Subject:  Procedures for vidget panes
#
#	Author:   Jon Lipp
#
#	Date:     March 23, 1995
#
############################################################################
#
#  Vidgets defined in this file:
#	Vpane
#
############################################################################
#
#  Links:  vidgets
#
############################################################################

#====== link vidgets

############################################################################
#  pane - a simple region on the window
############################################################################

record Vpane_rec(win, callback, id, style, aw, ah, ax, ay,
	uw, uh, ux, uy, uid, P, V)

procedure Vpane(params[])
   local self, frame, x, y, ins
   static procs

   initial procs := Vstd(event_Vpane, draw_Vpane, outline_Vpane,
                        resize_Vpane, inrange_Vpane, init_Vpane,
                        couplerset_Vpane)

   if ins := Vinsert_check(params) then {
      frame := pop(params); x := pop(params); y:= pop(params)
      }
   self := Vpane_rec ! params[1:7|0]
   Vwin_check(self.win, "Vpane()")
   if (\self.aw, not numeric(self.aw) ) then
      _Vbomb("invalid aw parameter to Vpane()")
   if (\self.ah, not numeric(self.ah) ) then
      _Vbomb("invalid ah parameter to Vpane()")

   /self.style := "invisible"
   if integer(self.style) then
      if self.style > 0 then
	 self.style := "grooved"
      else
	 self.style := "invisible"

   self.uid := Vget_uid()
   self.V := procs
   self.P := Vstd_pos()
   
   if \ins then VInsert(frame, self, x, y)
   return self
end

#
#  check if (x, y) lie within the bounds of a vidget.
#
procedure inrange_Vpane(self, x, y)
   if (/self.ax | /self.ay | /self.aw | /self.ah) then
      _Vbomb("VResize() not invoked on this vidget")
   return self.ax <= \x < self.ax + self.aw & self.ay <= \y < self.ay + self.ah
end

#
#  Set the absolute position and size fields of a vidget.
#
procedure resize_Vidget(self, x, y, w, h)
   self.ax := \x 
   self.ay := \y
   self.aw := \w
   self.ah := \h
end

#
#  Set the absolute position and size fields of a Pane vidget.
#
procedure resize_Vpane(self, x, y, w, h)
   local border

   resize_Vidget(self, x, y, w, h)
   if self.style == "invisible" then
      border := 0
   else
      border := 2
   self.ux := self.ax + border
   self.uy := self.ay + border
   self.uw := self.aw - 2 * border
   self.uh := self.ah - 2 * border
end

#
#  Draw the outline of an arbitrary vidget
#
procedure outline_Vidget(self)
   GrooveRectangle(self.win, self.ax, self.ay, self.aw, self.ah)
end

#
#  Draw the outline of a Vpane vidget
#
procedure outline_Vpane(self)
   case self.style of {
      "sunken":  BevelRectangle(self.win, self.ax, self.ay, self.aw, self.ah,-2)
      "grooved": GrooveRectangle(self.win, self.ax, self.ay, self.aw, self.ah)
      "raised":  BevelRectangle(self.win, self.ax, self.ay, self.aw, self.ah)
   }
end

#  At the very least, tell a Vpane to outline itself.
#
procedure draw_Vpane(self)
   self.V.outline(self)
end

#  
#  If the Vpane has a callback, call (or set) it; otherwise, reject the event.
#
procedure event_Vpane(self, e, x, y)
   local cb

   cb := self.callback
   /x := &x
   /y := &y
   if type(\cb) == "procedure" then		# procedure
      return cb(self, e, x, y) | &null
   if find("coupler",type(\cb)) then {		# coupler
      if \self.callback.locked then fail
      return cb.V.set(cb, self) | &null
      }
   fail						# reject
end

#
#  If the vidget with this procedure as its couplerset is notified by
#  a coupler, nothing will happen.
#
procedure couplerset_Vpane(self)
end

#
#  Release the resources associated with the binding on a window.
#
procedure destruct_Vpane(self)
   Uncouple(self.win)
end

#
#  No init for Vpane.
#
procedure init_Vpane(self)
end



#===============================================  /home/gmt/ipl/gprocs/vstd.icn



############################################################################
#
#	File:     vstd.icn
#
#	Subject:  Procedures for standard lookups
#
#	Author:   Jon Lipp
#
#	Date:     March 3, 1995
#
############################################################################
#
#  Utility procedures in this file:
#	VInit()
#	null_proc()
#	Vget_uid()
#	_Vbomb()
#	Vinsert_check()
#	Vwin_check()
#
############################################################################

record Vstd(event, draw, outline, resize, inrange, init, couplerset,
           insert, remove, lookup, set_abs, set_value )

record Vstd_coupler(set, add_client, init, unset, toggle, eval)

record Vstd_dialog(open_dialog, register, format, unregister, entries, focus,
   text_entries, text_lu)

#
#  Used by menus, buttons
#
record Vstd_draw(draw_off, draw_on, init, space, CS, CP, outline,
   basex, basey, pick, format)

#
#  type is non-null for vertical; &null for horizontal.
#
record Vstd_scrollbar(sp, sw, tw, th, ws, cv_range, oldpos, rev, 
   frame, drawn, type)
record Vstd_pos(x, y, w, h)

global Vrecset, Vcoupler_recset
global V_TEXT_PAD, V_NO_RB_FOCUS, V_DRAGGING, V_FAIL
global V_IMAGE, V_IMAGE_NO, V_RECT, V_2D, V_CHECK, V_CIRCLE, V_DIAMOND, V_XBOX
global V_RECT_NO, V_2D_NO, V_CHECK_NO, V_CIRCLE_NO, V_DIAMOND_NO, V_XBOX_NO
global V_CANCEL, V_OK, V_NEXT, V_PREVIOUS
global V_ARROW, V_COUPLER, V_DUMMY_ID

procedure null_proc()
end

procedure VInit()
initial {

#  Define the cset of all allowable vidget record types.
   Vrecset := set(["Vbutton_rec", "Vcheckbox_rec", 
      "Vline_rec", "Vdialog_frame_rec", 
      "Vframe_rec",  "Vmenu_item_rec", 
      "Vmenu_frame_rec", "Vradio_entry_rec", "Vradio_frame_rec", 
      "Vpull_down_button_rec", "Vpane_rec", "Varrow_rec",
      "Vthumb_rec", "Vscrollbar_frame_rec",
      "Vslider_rec", "Vtext_rec", "Vgrid_rec"])

   Vcoupler_recset := set(["Vcoupler_rec", "Vrange_coupler_rec"])

#  The padding in a Vtext_in between the data outline and the data text.
   V_TEXT_PAD 		:= 4

#  Used for button styles.
   V_RECT := V_2D 	:= -690402
   V_CHECK 		:= -690403
   V_CIRCLE 		:= -690404
   V_RECT_NO := V_2D_NO	:= -690406
   V_CHECK_NO 		:= -690407
   V_CIRCLE_NO 		:= -690408
   V_XBOX		:= -690409
   V_XBOX_NO		:= -690410
   V_DIAMOND		:= -690411
   V_DIAMOND_NO		:= -690412
   V_IMAGE              := -690413
   V_IMAGE_NO           := -690414

#  Used for communication bewtween a dialog box and its contents.
   V_CANCEL 		:= -690417
   V_OK		  	:= -690418
   V_NEXT		:= -690419
   V_PREVIOUS		:= -690420

#  Used for telling a radio button frame *not* to turn on a default
#  selection.
   V_NO_RB_FOCUS	:= -690421

#  Used in menus.
   V_DRAGGING		:= -690422
   V_FAIL		:= -690423

#  Lets a thumb know an arrow called its couplerset.
   V_ARROW		:= -690424
   V_COUPLER 		:= -690425
   V_DUMMY_ID		:= -690426
}

end
   
procedure Vget_uid()
   static uid
   initial uid := 0

   uid +:= 1
   return uid
end

procedure _Vbomb(str)

   write(&errout, "Vidget error: ", str)
   runerr(600)

end   

procedure Vinsert_check(p)

   if type(p[1]) ? find("frame") then {
      if not (numeric(p[2]), numeric(p[3])) then
         _Vbomb("invalid x or y coordinate to VInsert()")
      return 1
   }
   else fail
end

procedure Vwin_check(win, caller)

   if not (type(win) ? ="window") then
      _Vbomb("invalid window parameter to "|| caller)
end



#=============================================  /home/gmt/ipl/gprocs/vstyle.icn



############################################################################
#
#	File:     vstyle.icn
#
#	Subject:  Procedures for drawing buttons
#
#	Author:   Jon Lipp and Gregg M. Townsend
#
#	Date:     March 6, 1995
#
############################################################################
#
#  Utility procedures in this file:
#	Vset_style()
#
############################################################################

#====== link imscolor

procedure Vset_style (vid, style)

   style := integer(style) | case style of {
      &null:		V_RECT
      "regular":	V_RECT
      "regularno":	V_RECT_NO
      "check":		V_CHECK
      "checkno":	V_CHECK_NO
      "circle":		V_CIRCLE
      "circleno":	V_CIRCLE_NO
      "diamond":	V_DIAMOND
      "diamondno":	V_DIAMOND_NO
      "xbox":		V_XBOX
      "xboxno":		V_XBOX_NO
      "image":		V_IMAGE
      "imageno":	V_IMAGE_NO
      default:		_Vbomb("invalid style parameter")
      }

   vid.style := style
   case style of {
      V_RECT :
	 vid.D := Vstd_draw(draw_off_rect, draw_on_rect, init_rect)
      V_CHECK :
	 vid.D := Vstd_draw(draw_off_check, draw_on_check, init_check)
      V_CIRCLE :
	 vid.D := Vstd_draw(draw_off_circle, draw_on_circle, init_circle)
      V_DIAMOND:
	 vid.D := Vstd_draw(draw_off_diamond, draw_on_diamond, init_diamond)
      V_XBOX :
	 vid.D := Vstd_draw(draw_off_xbox, draw_on_xbox, init_xbox)
      V_IMAGE :
         vid.D := Vstd_draw(draw_off_image, draw_on_image, init_image)
      V_RECT_NO : {
         vid.D := Vstd_draw(draw_off_rect, draw_on_rect, init_rect)
         vid.D.outline := 1
         }
      V_CHECK_NO : {
         vid.D := Vstd_draw(draw_off_check, draw_on_check, init_check)
         vid.D.outline := 1
         }
      V_CIRCLE_NO : {
         vid.D := Vstd_draw(draw_off_circle, draw_on_circle, init_circle)
         vid.D.outline := 1
         }
      V_DIAMOND_NO: {
         vid.D := Vstd_draw(draw_off_diamond, draw_on_diamond, init_diamond)
         vid.D.outline := 1
         }
      V_XBOX_NO : {
	 vid.D := Vstd_draw(draw_off_xbox, draw_on_xbox, init_xbox)
	 vid.D.outline := 1
	 }
      V_IMAGE_NO : {
         vid.D := Vstd_draw(draw_off_image, draw_on_image, init_image)
         vid.D.outline := 1  
         }
      default: _Vbomb("invalid style parameter")
      }
end


procedure init_xbox(s)
   # nothing to do
end

procedure draw_off_xbox(s)
   if /s.D.outline then {
      EraseArea(s.win, s.ax + 2, s.ay + 2, s.aw - 4, s.ah - 4)
      BevelRectangle(s.win, s.ax, s.ay, s.aw, s.ah, 2)
      }
   else
      EraseArea(s.win, s.ax, s.ay, s.aw, s.ah)
end

procedure draw_on_xbox(s)
   WAttrib(s.win, "linewidth=2")
   DrawSegment(s.win, s.ax + 4, s.ay + 4, s.ax + s.aw - 4, s.ay + s.ah - 4, 
      s.ax + s.aw - 4, s.ay + 4, s.ax + 4, s.ay + s.ah - 4)
   WAttrib(s.win, "linewidth=1")
   if /s.D.outline then
      BevelRectangle(s.win, s.ax, s.ay, s.aw, s.ah, -2)
end


procedure init_rect(s)
   local TW, FH, ascent, descent

   /s.s := ""
   TW := TextWidth(s.win, s.s)
   ascent := WAttrib(s.win, "ascent")
   descent := WAttrib(s.win, "descent")
   FH := ascent + descent
   /s.aw := TW + 8
   /s.ah := FH + 8

   s.aw := 0 < s.aw | 1
   s.ah := 0 < s.ah | 1

   s.D.basex := (s.aw - TW - 1) / 2
   s.D.basey := (s.ah - FH) / 2 + ascent
end

procedure draw_off_rect(s)
   EraseArea(s.win, s.ax, s.ay, s.aw, s.ah)
   GotoXY(s.win, s.ax+s.D.basex, s.ay+s.D.basey)
   writes(s.win, s.s)
   if /s.D.outline then
      BevelRectangle(s.win, s.ax, s.ay, s.aw, s.ah, 2)
end

procedure draw_on_rect(s)
   FillRectangle(s.win, s.ax, s.ay, s.aw, s.ah)
   WAttrib(s.win, "reverse=on")
   GotoXY(s.win, s.ax+s.D.basex, s.ay+s.D.basey)
   writes(s.win, s.s)
   WAttrib(s.win, "reverse=off")
   if /s.D.outline then
      BevelRectangle(s.win, s.ax, s.ay, s.aw, s.ah, -2)
end


procedure init_check(s)
   local FH, ascent, descent

   /s.s := ""
   s.D.space := 4
   ascent := WAttrib(s.win, "ascent")
   descent := WAttrib(s.win, "descent")
   FH := ascent + descent
   /s.ah := FH + 8
   /s.aw := TextWidth(s.win, s.s) + FH + 3*s.D.space

   s.aw := 0 < s.aw | 1
   s.ah := 0 < s.ah | 1

   s.D.basex := FH + 2*s.D.space
   s.D.basey := (s.ah - FH)/2 + ascent

   s.D.CS := FH
   s.D.CP := (s.ah-s.D.CS)/2
end

procedure draw_off_check(s)
   local sp, cp, cs, ax, ay

   sp := s.D.space; cp := s.D.CP; cs := s.D.CS
   ax := s.ax; ay := s.ay

   BevelRectangle(s.win, ax+sp, ay+cp, cs, cs, 2)
   EraseArea(s.win, ax+sp+2, ay+cp+2, cs-4, cs-4)
   GotoXY(s.win, ax+s.D.basex, ay+s.D.basey)
   writes(s.win, s.s)
   if /s.D.outline then
      GrooveRectangle(s.win, s.ax, s.ay, s.aw, s.ah)
end

procedure draw_on_check(s)
   local sp, cs, cp, ax, ay

   sp := s.D.space; cp := s.D.CP; cs := s.D.CS
   ax := s.ax; ay := s.ay

   BevelRectangle(s.win, ax+sp, ay+cp, cs, cs, -2)
   FillRectangle(s.win, ax+sp+2, ay+cp+2, cs-4, cs-4)
   GotoXY(s.win, ax+s.D.basex, ay+s.D.basey)
   writes(s.win, s.s)
   if /s.D.outline then
      GrooveRectangle(s.win, s.ax, s.ay, s.aw, s.ah)
end


procedure init_circle(s)
   local FH, ascent, descent

   /s.s := ""
   s.D.space := 4
   ascent := WAttrib(s.win, "ascent")
   descent := WAttrib(s.win, "descent")
   FH := ascent + descent
   /s.ah := FH + 8
   /s.aw := TextWidth(s.win, s.s) + FH + 3*s.D.space

   s.aw := 0 < s.aw | 1
   s.ah := 0 < s.ah | 1

   s.D.basex := FH + 2*s.D.space
   s.D.basey := (s.ah -FH)/2 + ascent

   s.D.CS := FH + 1
   s.D.CP := (s.ah-s.D.CS)/2
end

procedure draw_off_circle(s)
   local da, ax, ay, r

   da := s.D
   r := da.CS / 2 - 1
   ax := s.ax
   ay := s.ay

   EraseArea(s.win, ax+da.space, ay+da.CP, da.CS, da.CS)
   BevelCircle(s.win, ax+da.space+r, ay+da.CP+r, r, 2)

   GotoXY(s.win, ax+da.basex, ay+da.basey)
   writes(s.win, s.s)
   if /da.outline then
      GrooveRectangle(s.win, s.ax, s.ay, s.aw, s.ah)
end

procedure draw_on_circle(s)
   local da, ax, ay, r

   da := s.D
   da := s.D
   r := da.CS / 2 - 1
   ax := s.ax
   ay := s.ay

   FillCircle(s.win, ax+da.space+r, ay+da.CP+r, r - 1)
   BevelCircle(s.win, ax+da.space+r, ay+da.CP+r, r, -2)

   GotoXY(s.win, ax+da.basex, ay+da.basey)
   writes(s.win, s.s)
   if /da.outline then
      GrooveRectangle(s.win, s.ax, s.ay, s.aw, s.ah)
end


procedure init_diamond(s)
   local FH, ascent, descent

   /s.s := ""
   s.D.space := 4
   ascent := WAttrib(s.win, "ascent")
   descent := WAttrib(s.win, "descent")
   FH := ascent + descent
   /s.ah := FH + 8
   /s.aw := TextWidth(s.win, s.s) + FH + 3*s.D.space

   s.aw := 0 < s.aw | 1
   s.ah := 0 < s.ah | 1

   s.D.basex := FH + 2*s.D.space
   s.D.basey := (s.ah - FH)/2 + ascent

   s.D.CS := FH + 1
   s.D.CP := (s.ah-s.D.CS)/2
end

procedure draw_off_diamond(s)
   local sp, cp, cs, ax, ay, r

   sp := s.D.space; cp := s.D.CP; cs := s.D.CS
   ax := s.ax; ay := s.ay
   r := cs / 2

   EraseArea(s.win, ax+sp, ay+cp, cs, cs)
   BevelDiamond(s.win, ax+sp+r, ay+cp+r, r, 2)
   GotoXY(s.win, ax+s.D.basex, ay+s.D.basey)
   writes(s.win, s.s)
   if /s.D.outline then
      GrooveRectangle(s.win, s.ax, s.ay, s.aw, s.ah)
end

procedure draw_on_diamond(s)
   local sp, cs, cp, ax, ay, r

   sp := s.D.space; cp := s.D.CP; cs := s.D.CS
   ax := s.ax; ay := s.ay
   r := cs / 2

   BevelDiamond(s.win, ax+sp+r, ay+cp+r, r, -2)
   FillDiamond(s.win, ax+sp+r, ay+cp+r, r - 2)
   GotoXY(s.win, ax+s.D.basex, ay+s.D.basey)
   writes(s.win, s.s)
   if /s.D.outline then
      GrooveRectangle(s.win, s.ax, s.ay, s.aw, s.ah)
end


#  undocumented image button code from Lorne Foss & Clint Jeffery, UTSA
#
#  If type = V_IMAGE | V_IMAGE_NO, button string is used as image source.
#  If it contains a comma, it's a DrawImage string.
#  If not, it's the name of a GIF file in the current directory.
#  Size is determined by the GIF or DrawImage image.

procedure init_image(s)
   local imagefile
 
   imagefile := s.s 
   if string(s.s) then {
      if not find(",", s.s) then {
         s.s := WOpen("canvas=hidden","image="||imagefile) |
            _Vbomb("can't initialize button image from file " || s.s)
         s.aw := WAttrib(s.s,"width")
         s.ah := WAttrib(s.s,"height")
         }
      else {
         s.aw := imswidth(s.s)
         s.ah := imsheight(s.s)
	 if /s.aw | /s.ah then
            _Vbomb("illegal DrawImage string for button")
         }
      if /s.D.outline then {
         s.aw +:= 4
         s.ah +:= 4
         }
      }
end

procedure draw_on_image(s)  
   draw_image_helper(s, -2, FillRectangle)
end

procedure draw_off_image(s)
   draw_image_helper(s, 2, EraseArea)
end

procedure draw_image_helper(s, bevel, bgproc)
   local b

   if /s.D.outline then {
      BevelRectangle(s.win, s.ax, s.ay, s.aw, s.ah, bevel)
      b := abs(bevel)
      }
   else
      b := 0

   if type(s.s) == "window" then
      CopyArea(s.s, s.win, 0, 0, s.aw, s.ah, s.ax + b, s.ay + b)
   else {
      bgproc(s.win, s.ax + b, s.ay + b, s.aw - 2 * b, s.ah - 2 * b)
      DrawImage(s.win, s.ax + b, s.ay + b, s.s)
      }
end



#===========================================  /home/gmt/ipl/gprocs/imscolor.icn



############################################################################
#
#	File:     imscolor.icn
#
#	Subject:  Procedures for manipulating images
#
#	Author:   Gregg M. Townsend
#
#	Date:     July 11, 1995
#
############################################################################
#
#  imswidth(im) returns the width of an image.
#  imsheight(im) returns the height of an image.
#  imspalette(im) returns the palette used by an image.
#
#  imsmap(s1, s2, s3) returns an image produced by mapping the data (only)
#  of image s1 and replacing characters found in s2 with corresponding
#  characters from s3.
#
#  imswrite(f, s, n) writes image string s to file f, limiting the line
#  length to n characters.  Defaults are f = &output, n = 79.  Extra
#  punctuation in s makes the lines break at nonsensical places, but
#  the output is still legal.
#
#  drawpalette([win,] p, x, y, w, h, f) draws the colors of palette p
#  in the given rectangular region.  The layout algorithm works best
#  when the height is two to four times the width.  Characters in the
#  flag string f have these meanings:
#	l	label each color with its key
#	o	outline each color in black
#	u	unframed use: don't hash unused cells at end
#
#  pickpalette([win,] p, dx, dy, w, h) returns the character at offset
#  (dx, dy) within a region drawn by drawpalette(win, p, x, y, w, h).
#
#  XPMImage([win,] f, palette) reads an XPM (X Pixmap) format image from
#  the open file f and returns an Icon image specification that uses the
#  specified palette.  XPMImage() fails if it cannot decode the file.
#  If f is omitted, &input is used; if palette is omitted, "c1" is used.
#  Not all variants of XPM format are handled; in particular, images that
#  use more than one significant input character per pixel, or that use
#  the old XPM Version 1 format, cause XPMImage() to fail.  No window
#  is required, but X-specific color names like "papayawhip" will not
#  be recognized without a window.
#
############################################################################
#
#  Links: graphics
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################

#====== link graphics


#  imspalette(im) -- return palette used by image

procedure imspalette(im)			#: palette for image
   im ? {tab(upto(',') + 1) & return ((="#" & &null) | tab(upto(',')))}
end


#  imswidth(im) -- return width of image

procedure imswidth(im)				#: width of image
   im ? return integer(tab(upto(',')))
end


#  imsheight(im) -- return height of image

procedure imsheight(im)				#: height of image
   local pal, w, n, d, c

   im ? {
      w := integer(tab(upto(','))) | fail
      move(1)
      if ="#" then {
         n := IMH_Count('0123456789ABCDEFabcdef')
         d := (w + 3) / 4
         return (n + d - 1) / d
         }
      pal := tab(upto(',')) | fail
      move(1)
      c := cset(PaletteChars(pal)) | fail
      n := IMH_Count(c ++ '~\xFF')
      return (n + w - 1) / w
      }
end

procedure IMH_Count(c)		# count remaining chars that are in cset c
   local n

   n := 0
   while tab(upto(c)) do
      n +:= *tab(many(c))
   return n
end


#  imsmap(s1, s2, s3) -- map the data (only) of an image string

procedure imsmap(s1, s2, s3)			#: map data of image string
   s1 ? return tab(upto(',')+1) || tab(upto(',')+1) || map(tab(0), s2, s3)
end


#  imswrite(f, s, n) -- write image string s to file f, max linelength of n.

procedure imswrite(f, s, n)			#: write image string
   local w, h, p, d, ll

   w := imswidth(s) | fail
   h := imsheight(s) | fail
   p := imspalette(s) | fail

   if /p then				# if bilevel image
      d := (w + 3) / 4			# number of digits per row
   else
      d := w

   /f := &output
   /n := 79

   # Figure out a reasonable line length for output, with n as maximum
   n -:= 1				# allow for underscore
   if upto('\0', PaletteChars(\p)) then
      n /:= 4				# allow for escapes
   ll := 1 + (n > (d - 1) / seq(1))	# divide line as equally as possible

   # Write the image as a multiline string constant.
   s ? {
      tab(upto(',') + 1)
      ="#" | tab(upto(',') + 1)
      write(f, "\"", w, ",", (\p || ",") | "#", "_")
      while not pos(0) do IWR_Row(f, move(d) | tab(0), ll)
      write(f, "\"")
      }
   return
end

procedure IWR_Row(f, s, n)	# write one row, max n bytes per line
   s ? while not pos(0) do
      write(f, image(move(n) | tab(0)) [2:-1], "_")
   return
end


#  drawpalette(win, p, x, y, w, h, f) -- draw palette in region

procedure drawpalette(win, p, x, y, w, h, f)	#: draw palette
   local nw, nh, c, s, colr, x1, x2, y1, y2, i, j, ret
   static cs
   initial cs := &ascii[33+:95]

   if type(win) ~== "window" then {
      win :=: p :=: x :=: y :=: w :=: h :=: f
      win := \&window | runerr(140, &window)
      }
   win := Clone(win, "fg=black")
   ret := win

   /p := "c1"
   /f := ""

   /x := -WAttrib(win, "dx")
   /y := -WAttrib(win, "dy")
   /w := WAttrib(win, "width") - (x + WAttrib(win, "dx"))
   /h := WAttrib(win, "height") - (y + WAttrib(win, "dy"))

   if w < 0 then
      x -:= (w := -w)
   if h < 0 then
      y -:= (h := -h)

   s := PAL_Order(p) | fail
   nw := case p of {
      "c1":		6
      "c2":		2
      "c3":		3
      "c4":		4
      "c5":		5
      "c6":		6
      default:		integer(w / sqrt(w * h / *s))
      }
   nh := (*s + nw - 1) / nw

   EraseArea(win, x, y, w, h)
   if f ? upto('o') then {
      w -:= 1
      h -:= 1
      }

   i := j := 0
   every c := !s do {
      x1 := x + j * w / nw
      x2 := x + (j + 1) * w / nw
      y1 := y + i * h / nh
      y2 := y + (i + 1) * h / nh
      Fg(win, colr := PaletteColor(p, c)) | (ret := &null)
      FillRectangle(win, x1, y1, x2 - x1, y2 - y1)
      if upto('l', f) then {
         Fg(win, Contrast(win, colr))
         if not upto(cs, c) then
            c := image(c)[-3:-1]
         CenterString(win, (x1 + x2) / 2, (y1 + y2) / 2, c)
         }
      if upto('o', f) then {
         Fg(win, "black")
         DrawRectangle(win, x1, y1, x2 - x1, y2 - y1)
         }
      if (j +:= 1) >= nw then {
         j := 0
         i +:= 1
         }
      }

   # if some cells are unfilled, and the 'u' flag is not given,
   # hash the unfilled cells with a diagonal pattern.
   if j > 0 & not upto('u', f) then {
      x1 := x + j * w / nw
      y1 := y + i * h / nh
      x2 := x + w
      y2 := y + h
      WAttrib(win, "fg=black", "pattern=diagonal", "fillstyle=textured")
      FillRectangle(win, x1, y1, x2 - x1, y2 - y1)
      if upto('o', f) then {
         WAttrib(win, "fillstyle=solid")
         DrawRectangle(win, x1, y1, x2 - x1, y2 - y1)
         }
      }

   Uncouple(win)
   return \ret
end


#  pickpalette(win, p, dx, dy, w, h) -- return key picked from drawn palette

procedure pickpalette(win, p, dx, dy, w, h)	#: key from drawn palette
   local s, nw, nh

   if type(win) ~== "window" then {
      win :=: p :=: dx :=: dy :=: w :=: h
      win := \&window | runerr(140, &window)
      }
   /w := WAttrib(win, "width")
   /h := WAttrib(win, "height")
   if dx < 0 | dy < 0 | dx >= w | dy >= h then
      fail

   s := PAL_Order(p) | fail
   nw := case p of {
      "c1":		6
      "c2":		2
      "c3":		3
      "c4":		4
      "c5":		5
      "c6":		6
      default:		integer(w / sqrt(w * h / *s))
      }
   nh := (*s + nw - 1) / nw
   dx := ((dx + 1) * nw - 1) / w
   dy := ((dy + 1) * nh - 1) / h
   return s[1 + nw * dy + dx]
end


#  PAL_Order(p) -- return reordered palette chars (internal routine)
#
#  Normal order for color cube is sorted r/g/b, then extra grays.
#  Reorder by g/r/b followed by full set of grays, including duplicates,
#  back to black.  Returns unmodified list of characters for c1 and
#  grayscale palettes.

procedure PAL_Order(p)
   local palchars, s, t, n, n3, i, l

   palchars := PaletteChars(p) | fail

   p ? {
      if not (="c" & any('23456')) then return palchars
      n := integer(move(1))
      }

   palchars ? {

      l := list(n, "")
      n3 := n * n * n
      while &pos <= n3 do
         every !l ||:= (move(n) \ 1)
      s := ""
      every s ||:= !l		# build g/r/b cube portion

      t := ""
      every i := 1 to (n3 - 1) by (n * (n + 1) + 1) do
         t ||:= palchars[i] || move(n - 1)
      }

   return s || reverse(t)
end


#  XPMImage(win, f, palette) -- read XPM file and return Icon image spec

procedure XPMImage(win, f, pal)			#: image string for XPM file
   local w, h, nc, cpp, i, im, c, k, s1, s2

   if type(win) ~== "window" then {
      win :=: f :=: pal
      win := &window		# okay if null
      }
   /f := &input
   /pal := "c1"
   type(f) == "file" | runerr(105, f)
   PaletteChars(pal) | runerr(205, f)

   (read(f) ? find("XPM")) | fail
   (XPM_RdStr(f) | fail) ? {
      tab(many(' \t'));  w := tab(many(&digits)) | fail
      tab(many(' \t'));  h := tab(many(&digits)) | fail
      tab(many(' \t'));  nc := tab(many(&digits)) | fail
      tab(many(' \t'));  cpp := tab(many(&digits)) | fail
   }
   if w = 0 | h = 0 then
      fail

   # read colors and figure out translation
   s1 := s2 := ""
   every i := 1 to nc do (XPM_RdStr(f) | fail) ? {
      s1 ||:= move(1)
      if cpp > 1 then
         =" " | fail			# if not blank, we can't handle it
      k := &null
      # find a color key we can decipher; try color, then grayscale, then mono
      (c := !"cgm") & tab(upto(' \t') + 1) & =c & tab(many(' \t')) &
         (k := XPM_Key(win, pal, (tab(upto(' \t') | 0))))
      # use first color found, or default if none
      s2 ||:= \k | PaletteKey(pal, "gray")
      }

   # construct image
   im := w || "," || pal || ","
   if cpp = 1 then
      while im ||:= map(XPM_RdStr(f), s1, s2)
   else
      while im ||:= map(XPM_Nth(XPM_RdStr(f), cpp), s1, s2)
   return im
end

procedure XPM_Key(win, pal, s)	#  return key corresponding to color s

   if s == "None" then {		# if transparent
      if PaletteColor(pal, "~") then	# if "~" is in palette
         return "\xFF"			# then use "\xFF" for transparent
      else
         return "~"			# but use "~" if possible
      }

   if \win then
      return PaletteKey(win, pal, s)	# return key from palette, or fail
   else
      return PaletteKey(pal, s)		# return key from palette, or fail
end

procedure XPM_RdStr(f)		# read next C string from file f
   local line, s

   while line := read(f) do line ? {
      tab(many(' \t'))
      ="\"" | next
      if s := tab(upto('"')) then
         return s
      }
   fail
end

procedure XPM_Nth(s, n)		#  concatenate every nth character from s
   local t
   n -:= 1
   t := ""
   s ? while t ||:= move(1) do
      move(n)
   return t
end