# Dialogs, a collection of dialog widgets
#
# In this file the following widget classes are defined:
#
#   WarningDialog
#   InformationDialog
#   QuestionDialog
#   MessageDialog
# 
# These widget classes are defined in terms of the Athena
# TransientShell, Form, Label and Command widget classes
# The following resources can be additionally set:
#
#   resource        class     default value
# ===================================================================
#   message         String    ""
#   okLabel         Label     "Ok"
#   okCallback      Callback  "popdown $ShellName"
#   cancelLabel     Label     "Cancel"
#   cancelCallback  Callback  "popdown $ShellName"
#   itemFont        BoldFont  -adobe-times-bold-r-*-*-24-*-*-*-*-*-*-*
#   itemText        String    ?
#
# itemFont and itemText are not valid for the MessageDialog,
# the default of itemText depends on the Widget class. 
#
# The following sample script illustrates the usage of these
# widget classes.
#
#---------
# Box b topLevel
#   Command InformationDialog b callback "popup i none"
#   Command MessageDialog b callback "popup m none"
#   Command QuestionDialog b callback "popup q none"
#   Command WarningDialog b callback "popup w none"
# realize
#
# InformationDialog i topLevel message "The computation took 5 seconds."
# MessageDialog m topLevel message "Hello world"
# QuestionDialog q topLevel message "Do you want to exit?" okCallback quit
# WarningDialog w topLevel message "You will overwrite your Files!" \
#      okCallback {puts "I have warned you!"; popdown w}
#---------
# Gustaf Neumann,           Mohegan Lake, Jan 28, 1993

proc WarningDialog {name parent args} {
  return [GenericDialog WarningDialog "!" $name $parent $args]
}
proc InformationDialog {name parent args} {
  return [GenericDialog InformationDialog "i" $name $parent $args]
}
proc QuestionDialog {name parent args} {
  return [GenericDialog QuestionDialog "?" $name $parent $args]
}
proc MessageDialog {name parent args} {
  return [GenericDialog MessageDialog "" $name $parent $args]
}

proc GenericDialog {wClass defaultItemText name parent largs} {
  global _wafeWidget
  set resList {}

  if [_managedWidget largs] { 
    set S [TransientShell $name $parent destroyCallback {_destroyCallback %W} ]
  } else { 
    set S [TransientShell $name $parent unmanaged destroyCallback {_destroyCallback %W} ]
  }

  callback $S popupCallback positionCursor 0
  set _wafeWidget($S) $wClass

  _defaultValue $S message String ""
  _defaultValue $S itemFont BoldFont \
    -adobe-times-bold-r-*-*-24-*-*-*-*-*-*-*
  _defaultValue $S okLabel Label "Ok"
  _defaultValue $S okCallback Callback "popdown $S"
  _defaultValue $S cancelLabel Label "Cancel"
  _defaultValue $S cancelCallback Callback "popdown $S"
  _defaultValue $S itemText String $defaultItemText

  for {set i 0;set nargs [llength $largs]} {$i<$nargs} {incr i} {
    set arg [lindex $largs $i] 
    if {[lsearch -exact $resources $arg] != -1} {
      set $arg [lindex $largs [incr i]]
    } else {
      lappend resList [lindex $largs $i]
      lappend resList [lindex $largs [incr i]]
    } 
  }

  mergeResources topLevel \
     *$name*Command.left chainLeft \
     *$name*Command.right chainLeft \
     *$name*Command.bottom chainBottom \
     *$name*Command.top chainBottom \
     *$name*Label.top chainTop \
     *$name*Label.bottom chainBottom \
     *$name*Label.borderWidth 0

  set F [Form $name-F $S]
  if [string compare "" $defaultItemText] {
    set vref [Label item $F \
      font $itemFont label $itemText right chainLeft]
    Label message $F \
      label $message left chainLeft fromHoriz $F.item
    sV $F.message vertDistance [expr ([gV $F.item height]+5-[gV $F.message height])/2]
  } else {
    set vref [Label message $F label $message]
  }

  Command ok $F \
    fromVert $vref \
    callback $okCallback \
    label $okLabel
  Command cancel $F \
    fromVert $vref fromHoriz $F.ok \
    callback $cancelCallback \
    label $cancelLabel
 
  foreach var {$resources} {
    trace variable $var w _GenericDialog_change
  }

  if [string compare "" $resList] {
    eval _setValues $name $resList
  }
  return $S
}

proc _GenericDialog_change {class instanceAtt op} {
  global $class
  regexp {^(.*),(.*)$} $instanceAtt all id res
  set newValue [set ${class}($instanceAtt)]
  set name [widgetName $id]
  switch -exact $res {
    message {
      _setValues $id*message label $newValue
    }
    itemFont {
      if [isWidget $id*item] {
	_setValues $id*item font $newValue
      }
    }
    itemText {
      if [isWidget $id*item] {
	_setValues $id*item label $newValue
      }
    }
    okLabel {
      _setValues $id*ok label $newValue
    }
    okCallback {
      _setValues $id*ok callback $newValue
    }
    cancelLabel {
      _setValues $id*cancel label $newValue
    }
    cancelCallback {
      _setValues $id*cancel callback $newValue
    }
  }
}

