#=================================================================  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.Cursor