path: root/ipl/gprocs/dialog.icn

############################################################################
#
#	File:     dialog.icn
#
#	Subject:  Procedures for dialogs
#
#	Authors:  Ralph E. Griswold and Gregg M. Townsend
#
#	Date:     December 14, 1999
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#  This file contains several procedures for posting dialog boxes:
#
#  AskDialog() -- TextDialog() with only caption and "No" instead of "Cancel"
#  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.
#
############################################################################
#
#  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.
#
############################################################################
#
#  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
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links:  graphics, vbuttons, vdialog, vradio, vslider, vidgets
#
############################################################################

link graphics
link vbuttons
link vdialog
link vradio
link vslider
link vidgets

$include "vdefns.icn"

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 AskDialog(win, caption)

   return TextDialog(win, caption, , , , , ["Okay", "No"])

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
   local temp_win
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then {
      win :=: captions :=: labels :=: defaults :=: widths :=: buttons :=:
         index
      win := &window
      /win := temp_win := WOpen("canvas=hidden", "bg=" || VBackground)
      }

   /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]
   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)

   WClose(\temp_win)

   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
   local temp_win
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then {
      win :=: captions :=: labels :=: defaults :=:  buttons :=: index
      win := &window
      /win := temp_win := WOpen("canvas=hidden", "bg=" || VBackground)
      }

   /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 | defaults)
   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)

   WClose(\temp_win)

   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
   local temp_win
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then {
      win :=: captions :=: labels :=: deflt :=: buttons :=: index
      win := &window
      /win := temp_win := WOpen("canvas=hidden", "bg=" || VBackground)
      }

   /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]

   WClose(\temp_win)

   return dialog_button

end

procedure Notice(captions[])		#: notice dialog
   local win, temp_win
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(captions[1]) == "window" then
      win := get(captions)
   else {
      win := &window
      /win := temp_win := WOpen("canvas=hidden", "bg=" || VBackground)
      }

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

   dialog_value := &null

   WClose(\temp_win)

   return dialog_button

end

procedure SaveDialog(win, caption, filename, len)	#: save dialog
   local temp_win
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then {
      win :=: caption :=: filename :=: len
      win := &window
      /win := temp_win := WOpen("canvas=hidden", "bg=" || VBackground)
      }

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

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

   dialog_value := dialog_value[1]

   WClose(\temp_win)

   return dialog_button

end

procedure OpenDialog(win, caption, filename, len)	#: open dialog
   local temp_win
   static type

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then {
      win :=: caption :=: filename :=: len
      win := &window
      /win := temp_win := WOpen("canvas=hidden", "bg=" || VBackground)
      }

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

   TextDialog(win, caption, , filename, len)

   dialog_value := dialog_value[1]

   WClose(\temp_win)

   return dialog_button

end

procedure dialog_cb(vidget, s)

   dialog_button := vidget.s

   return

end

#  ColorDialog(win, captions, color, callback, id) -- display color dialog

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

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
$define MaxStaticCol	200	# maximum colors before recycling

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

   initial type := proc("type", 0)	# protect attractive name

   if type(win) ~== "window" then {
      win :=: captions :=: refcolor :=: callback :=: id
      win := &window
      /win := temp_win := WOpen("canvas=hidden", "bg=" || VBackground)
      }

   /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.dialog := dialog
   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

   WClose(\temp_win)

   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 r

   r := cdl_data.rect
   cdl_data.fg := Fg(r.win)
   cdl_data.fillargs := [r.win, r.ux, r.uy, r.uw, r.uh]
   if cdl_data.mutable := NewColor(cdl_data.rect.win, cdl_data.orgcolor) then {
      Fg(r.win, cdl_data.mutable)
      FillRectangle ! cdl_data.fillargs
      }
   else
      cdl_data.nc := 0
   if Fg(r.win, \cdl_data.refcolor) then {
      cdl_data.fillargs[-1] -:= r.uh / 8
      FillRectangle(r.win, r.ux, r.uy + r.uh, r.uw, -r.uh / 8)
      }
   Fg(r.win, cdl_data.fg)
   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)
   EraseArea(cdl_data.rect.win)
   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 r, win, x1, x2, y, dy

   r := cdl_data.rect
   win := r.win
   if \cdl_data.mutable then
      Color(win, cdl_data.mutable, c)		# set the mutable color
   else {
      if ((cdl_data.nc +:= 1) > MaxStaticCol) | (not Fg(win, c)) then {
	 EraseArea(win)				# free allocated colors
	 VDraw(cdl_data.dialog)			# redraw vidget
         if Fg(r.win, \cdl_data.refcolor) then	# redraw reference color
            FillRectangle(r.win, r.ux, r.uy + r.uh, r.uw, -r.uh / 8)
	 Fg(win, c)				# set new foreground
	 cdl_data.nc := 1
      }
      FillRectangle ! cdl_data.fillargs
      Fg(win, cdl_data.fg)
   }

   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(win, x, y, w, h, proc, args[])

$define BorderWidth 4
$define ShadowWidth 4

procedure Popup(args[])			#: create popup subwindow
   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")
   w >:= WAttrib(win, "width")			# limit to size of full win
   h >:= WAttrib(win, "height")
   /x := (WAttrib(win, "width") - w) / 2 - dx	# center the subwindow
   /y := (WAttrib(win, "height") - h) / 2 - dy

   # 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, "__Popup__") |
      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