# action.tcl --
#
#       This file provides the complete package that introduces the concept of
#       "actions" to Tk. All code is contained with the ::action or ::action
#       decedent namespaces.
#
# Copyright (c) 2003 Bryan Schofield
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to
# deal in the Software without restriction, including without limitation the
# rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
# sell copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
# IN THE SOFTWARE.
#
#
# TERMS AND DEFINITIONS
#
# action        A collection of options and values that can be set and queried
#               at a single data repository but applies to any number of Tk
#               widgets. These options, typically refered to as "configuration
#               options", may not be applicable to all widgets. Under these
#               circumstances, the said options are simply ignored for some
#               widgets.
#
# applicator    A procedure that is capable of extracting useful configuration
#               options from an action and appling the values of those options
#               to a particular class of widgets.
#
# validator     A procedure that can ensure the validity of an action
#               configuration option. Validator procedures are invoked during
#               action configuration and can generate errors if option values
#               are invalid.
#
#
#
# THE ACTION FRAMEWORK
#
# The action framework, or Framework, consists of mechanisms for specifying
# action options, configuring or querying action options, and application of
# action configuration options to Tk widgets. The Framework itself does not
# provide details of what an action consists of or how the actions are applied
# to common Tk widgets. However, this package provides implementations for
# applying actions to Button and Menu class widgets.
# See ::action::initializeDefaults
#
#
#
# COMMANDS
# 
# Details on commands can be read for specific commands at each command's proc
# definition. A summary of the widely used commands is provided here.
#
#
# Adding, removing, and querying action configuration options
#
#  ::action::addOption name defaultValue ?validationCmd?
#  ::action::removeOption name
#  ::action::getOptionList
#
#
# Setting and querying widget class applicators
#
#  ::action::setApplicator class applicatorCmd
#  ::action::getApplicator class
#
#
# Creating, deleting, configuring, and querying actions
#
#  ::action::create act ?option value ...?
#  ::action::delete act
#  ::action::exists act
#  ::action::cget act opt
#  ::action::configure act ?option value ...?
#
#
# Applying, removing, and querying relationships bewteen actions and widgets
#  ::action::apply act args
#  ::action::remove act args
#  ::action::widgets act
#
#
#
# DEFAULT ACTION CONFIGURATION OPTIONS AND WIDGET CLASS APPLICATORS
#
# -text         The text or label associated with an action
# -image        The image associated with an action
# -command      The command to evaluated when an action is invoked
# -state        The state of the action, which can be "normal" or "disabled"
#
# Button        Sets -text, -image, -command, -state options according to the
#               action and -compound to "left"
# Menu          Adds or modifies a menu entry matching the text string value
#               of the -text action option. Sets the -image, -command, and
#               -state  options according to the actions, the -label according
#               to the -text action option, and -compound to "left".
#
# * ATTENTION *
# The Menu applicator uses the "-text" value to identify which entry, if any,
# in a menu corresponds to the action. This is done by trying to find a menu
# entry index by pattern matching. See the menu man page or documentation for
# more details on menu pattern matching for indices. If the menu has an entry
# with the same -label value as the action's -text value, that menu entry will
# be considered to be associated with the action. In short don't do this and
# expect the Menu applicator to know that you want to *add* a new entry
# instead of *modify* an existing entry:
#
#   ::action::create a -text "Hello" -command "doSomething"
#   menu .m
#   .m add command -label "Hello" -command "doSomethingElse"
#   ::action::apply a .m
#   # BAD! The action just overrode the -command menu option for
#   # manually configured menu entry.
#
# Having said that, it safe to change the action -text option. The menu
# applicator will know to change the existing entry instead of creating a new
# one.
#
#   ::action::create a -text "Hello" -command "sayHello"
#   menu .m
#   ::action::apply a .m
#   ...
#   ::action::configure a -text "Goodbye" -command "sayGoodbye"
#   # GOOD! The action just changes the label and command of the
#   # existing menu entry for "a"
#
#
#
# TYPICAL USAGE
#
# package require action
# namespace eval ::img {}
# image create photo ::img::myImg -file myimage.gif
# ::action::create myAction \ 
#     -text "Do Something" \ 
#     -image ::img::myImg \ 
#     -command [list myCommand]
# button .b1
# button .b2
# menu .menubar
# menu .popup
# ::action::apply myAction .b1 .b2 .menubar .popup
#    ...
# ::action::configure myAction -state "disabled"
#    ...
# ::action::configure myAction -state "normal" -text "Tun Sie Etwas"
#
#
#
#
# ADVANCED USAGE
#
# # add a new option for Superframe class widgets
# proc ::action::validator::superopt { value } {
#    if { ... } {
#       # $value is not ok!
#       return -code error "invalid superopt value \"$value\", must be ..."
#    }
# }
# ::action::addOption -superopt "Super Default" ::action::validator::superopt
#
# # add a new widget class, Superframe to accept actions
# proc ::action::applicator::Superframe {widget act} {
#    foreach optSet [::action::configure $act] {
#       switch -- [lindex $optSet 0] {
#           -text     {# do something to $widget}
#           -image    {# do something to $widget}
#           -command  {# do something to $widget}
#           -state    {# do something to $widget}
#          -superopt {# do something to $widget}
#      }
#   }
# }
#
# ::action::create superAction \
#     -text "Do Something" \ 
#     -image ::img::myImg \ 
#     -command [list myCommand] \ 
#     -superopt "Be super!"
#
# Superframe .sf
# ::action::apply superAction .sf
#
#

package require Tcl 8.4
package require Tk 8.4
package provide action 1.0


namespace eval ::action {
   # a namespace for containing procs that validate values for options
   namespace eval validator {}
   # a namespace for containing procs that apply actions to widgets
   namespace eval applicator {}

   # array of commands used to apply actions to classes of widgets
   # key is widget class
   variable applicator
   array set applicator {}


   # default option/value array
   # this contains option names as keys and default values
   variable option
   array set option {}
   variable validator
   array set validator {}


   # the action data array
   variable action
   array set action {}
}




# ::action::addOption --
#
#       Adds an option to the action framework. Action are able to configure
#       this option immediately after the option was added. Existing actions
#       will inherit default values.
#
# Arguments:
#       name          The name of the option
#       defaultValue  The option default value
#       validationCmd A tcl command to be evaluated when this option is 
#                     configured. This command will be passed the value of the
#                     option and should generate an error if the value is 
#                     invalid.
#
# Results:
#       Error if the option name has white spaces or upper case letters
#       Nothing if successful
#
proc ::action::addOption {name defaultValue {validationCmd ""}} {
   # if the name has capital letters or white space, reject it
   if {![regexp {^-?([a-z]|[0-9])+$} $name]} {
      return -code error "invalid option name \"$name\", names must be all lower case and can not have white spaces"
   }
   # make sure the first character is a "-"
   if {[string index $name 0] != "-"} {
      set name "-$name"
   }
   # set the default value of this option, if one already exists, then we will
   # just override it
   variable option
   variable validator
   set option($name) $defaultValue
   set validator($name) $validationCmd
   return
}





# ::action::removeOption --
#
#       Removes an option from the action framework.
#
# Arguments:
#       name    The name of the option
#
# Results:
#       Error if the option of the name
#       Nothing if successful
#
proc ::action::removeOption {name} {
   variable option
   variable action
   variable validator
   # make sure the first character is a "-"
   if {[string index $name 0] != "-"} {
      set name "-$name"
   }
   if {![info exists option($name)]} {
      return -code error "action option \"$name\" does not exist"
   }
   # remove any references that existing action may have
   foreach act [array names action] {
      unset -nocomplain action($act,$name)
   }
   # remove the default option/value
   unset option($name) validator($name)
   return
}




# ::action::getOptionList --
#
#       Get a list of options, default values, and validator commands in the
#       action framework. The list format is:
#          {{option defaultValue validatorCmd}
#           {option defaultValue validatorCmd} ..}
#
# Arguments:
#       none
#
# Results:
#       List of options, default values and validator commands
#
proc ::action::getOptionList {} {
   variable option
   variable validator
   set optSet {}
   foreach opt [lsort [array names option]] {
      lappend optSet [list $opt $option($opt) $validator($opt)]
   }
   return $optSet
}




# ::action::initializeDefaults --
#
#       This command sets up a set of default options and widget class
#       handlers in the action frame work
#
# Arguments:
#       none
# 
# Results:
#      none
#
proc ::action::initializeDefaults {} {
   ::action::addOption -text ""
   ::action::addOption -image "" ::action::validator::image
   ::action::addOption -command "" 
   ::action::addOption -state "normal" ::action::validator::state
   ::action::setApplicator Button ::action::applicator::Button
   ::action::setApplicator Menu ::action::applicator::Menu
   return
}



# ::action::create --
#
#       Creates a new action with a given name and configures it according to
#       any specified options.
#
# Arguments:
#       act     The action name. This must be a unique name
#       args    Options configuration arguments
#
# Returns:
#       Error if an action by the specified name already exists
#       Error if any of the configuration options are invalid
#       The action name if successful
#
proc ::action::create {act args} {
   if {[::action::exists $act]} {
      return -code error "action \"$act\" already exists"
   }

   variable action
   # the list of widgets associated with the action
   set action($act,widgets) {}
   set action($act,previousConfig) {} ; # this will get set in the "configure" below
   # if we catch an error configuring the options, make sure we clean up
   # anything that we might have created
   if {[catch {eval ::action::configure $act $args} err]} {
      catch {::action::delete $act}
      return -code error $err
   }
   return $act
}





# ::action::delete --
#
#       Deletes an action from the action framework
#
# Arguments:
#       act     The action name
# 
# Results:
#       none
#
proc ::action::delete {act} {
   if {![::action::exists $act]} {
      return -code error "action \"$act\" does not exist"
   }
   variable action
   # the list of widgets associated with the action
   unset -nocomplain action($act,widgets) action($act,previousConfig)
   array unset action "$act,*"
   return 
}




# ::action::exists --
#
#       Determines if an action of the specified name exists
#
# Arguments:
#       act     The action name
#
# Results:
#      Returns 1 if action exists
#      Returns 0 if action does not exist
#
proc ::action::exists {act} {
   variable action
   return [info exists action($act,widgets)]
}





# ::action::cget --
#
#       Get the value for an option of an action
#
# Arguments:
#       act     The action name
#       opt     The configuration option name
#
# Results:
#       Error if the option name is invalid
#       Value if the option for the action action has been configured via 
#               "configure" method
#       Default option value if the option for the action has not been 
#               configured via the "configure" method
#
proc ::action::cget {act opt} {
   variable option
   variable action
   # make sure the action exists
   if {![::action::exists $act]} {
      return -code error "action \"$act\" does not exist"
   }
   # make sure the option is valid
   if {![info exists option($opt)]} {
      return -code error "invalid option \"$opt\", must be [array names option]"
   }
   if {[info exists action($act,$opt)]} {
      # return the action configured value
      return $action($act,$opt)
   } else {
      # return the default value
      return $option($opt)
   }
}



# ::action::configure --
#
#       Configures options for an action or returns a list describing the
#       current configuration for the the action. The list is presented in 
#       the following format:
#        {{-option value defaultValue} {-option value defaultValue} ...}
#
# Arguments:
#       act     The action name
#       args    (optional) list of options and values
#
# Results:
#       Error if any of the configuration options are invalid or have invalid
#               values
#       Nothing if options were successfully applied
#       Current configuration list if no configuration options were specified
#
proc ::action::configure {act args} {
   if {![::action::exists $act]} {
      return -code error "action \"$act\" does not exist"
   }
   # if arguments were specified, then we should apply them to the action
   # if not, then we should generate a current option configuration list
   if {$args != ""} {
      return [eval ::action::applyConfigure $act $args]
   } else {
      return [::action::generateCurrentConfigurationList $act]
   }
}



# ::action::applyConfigure --
#
#       Applies configuration option to an action
#
# Arguments:
#       act     The action name
#       args    List of configuration options
#
# Results:
#       Error if any of the configuration options are invalid or have invalid
#               values
#       Nothing if options were successfully applied
#
proc ::action::applyConfigure {act args} {
   variable option
   variable validator
   variable action
   set action($act,previousConfig) [::action::configure $act]
   foreach {opt value} $args {
      # make sure the option is valid
      if {![info exists option($opt)]} {
         return -code error "invalid option \"$opt\", must be [join [array names option] {, }]"
      }
      # make sure the option value is valid
      if {($validator($opt) != "")
          && [catch {eval $validator($opt) \$value} err]} {
         return -code error "option \"$opt\" has invalid value of \"$value\", $err"
      }
      # save the option value
      set action($act,$opt) $value
   }
   eval ::action::apply $act [::action::widgets $act]
   return
}

# ::action::generateCurrentConfigurationList --
#
#       Generates a list of the current configuration for the action in the tk
#       configure style:
#           {{-option value defaultValue} {-option value defaultValue} ...}
#
# Arguments:
#       act     The action name
# 
# Results:
#       configuration list
#
proc ::action::generateCurrentConfigurationList { act } {
   variable option
   variable action
   set config {}
   foreach opt [array names option] {
      lappend config [list $opt [::action::cget $act $opt] $option($opt)]
   }
   return $config
}



# ::action::setApplicator --
#
#       Registers an applicator for a particular class. The applicator command
#       will be evaluated with widget name and a list of configuration options
#       as returned by "configure". The applicator can be removed by
#       re-registering the class with an empty string
#
# Arguments:
#       class           The widget class
#       applicatorCmd   The command to evaluate to apply an action to a class
#                       of widgets.
#
# Results:
#       none
#
proc ::action::setApplicator {class applicatorCmd} {
   variable applicator
   if {$applicatorCmd == ""} {
      unset -nocomplain applicator($class)
   } else {
      set applicator($class) $applicatorCmd
   }
   return
}


# ::action::getApplicator --
#
#       Gets the applicator command for a particular class. If no applicator
#       command has been registers, an empty string is returned
#
# Arguments:
#       class   The widget class
#
# Results:
#       A tcl command if applicator has been registered
#       An empty string if no applicator has been registered
#      
proc ::action::getApplicator {class} {
   variable applicator
   if {[info exists applicator($class)]} {
      return $applicator($class)
   } else {
      return ""
   }
}


# ::action::apply --
#
#       Applies an action to a set of widgets. This is accomplished by
#       delegating actual application to registered applicators depending on
#       the class of the widget(s)
#
# Arguments:
#       act     The action name
#       args    List of widgets to apply the action to
#
# Returns:
#       Error if action does not exist
#       Error if widget does not exist
#       Error if widget class has no registered applicator
#       Nothing if successful
#
proc ::action::apply {act args} {
   variable action
   if {![::action::exists $act]} {
      return -code error "action \"$act\" does not exist"
   }
   foreach widget $args {
      if {$widget == ""} { continue }
      if {![winfo exists $widget]} {
         return -code error "can not apply action \"$act\" to \"$widget\", widget does not exist"
      }
      set class [winfo class $widget]
      set applicator [::action::getApplicator $class]
      if {$applicator == ""} {
         return -code error "can not apply action \"$act\" to \"$widget\", no applicator for class \"$class\" has been registered"
      }
      eval $applicator $widget $act
      if {[lsearch $action($act,widgets) $widget] == -1} {
         lappend action($act,widgets) $widget
      }
   }
   return
}


# ::action::remove --
#
#       Removes any association between an action and a set of widgets. The
#       widgets are *not* modified as a result of doing this. It merely breaks
#       the connection of the action and widgets for future modification to
#       the action
#
# Arguments:
#       act     The action name
#       args    List of widgets to apply the action to
#
# Returns:
#       Error if action does not exist
#       Error if widget does not exist
#       Error if widget class has no registered applicator
#       Nothing if successful
#
proc ::action::remove {act args} {

   variable action
   if {![::action::exists $act]} {
      return -code error "action \"$act\" does not exist"
   }
   foreach widget $args {
      if {$widget == ""} { continue }
      set i [lsearch $action($act,widgets) $widget]
      if {$i != -1} {
         set action($act,widgets) [lreplace $action($act,widgets) $i $i]
      }
   }
}


# ::action::widgets --
#
#       Returns a list widgets that the action has been applied to and still
#       exists.
#
# Arguments:
#       act     The action name
#
# Results:
#       A list of widgets
#
proc ::action::widgets {act} {
   if {![::action::exists $act]} {
      return -code error "action \"$act\" does not exist"
   }
   variable action
   # build a list of widgets and make sure that any destroyed widgets have
   # been removed from the list
   set widgets {}
   foreach w $action($act,widgets) {
      if {[winfo exists $w]} {
         lappend widgets $w
      }
   }
   # save the new, edited list
   set action($act,widgets) $widgets
   return $widgets
}


#======================================================================
# validators
#======================================================================
proc ::action::validator::image { imgName } {
   if {[lsearch [::image names] $imgName] == -1} {
      return -code error "image \"$imgName\" does not exist"
   }
}

proc ::action::validator::state { state } {
   if {($state != "normal") && ($state != "disabled")} {
      return -code error "invalid state \"$state\", must be normal, disabled"
   }
}


#======================================================================
# applicators
#======================================================================
proc ::action::applicator::Button {b act} {
   # it's good if we just casually look to see what options the action has
   # available to us, rather than just expecting it to have some specific
   # options. You never know, someone might have removed an option. At any
   # rate, we can look at the configuration and when we see something we like,
   # apply it to the button
   foreach optSet [::action::configure $act] {
      switch -- [lindex $optSet 0] {
         -text    {$b configure -text [lindex $optSet 1]}
         -image   {$b configure -image [lindex $optSet 1] -compound left}
         -command {$b configure -command [lindex $optSet 1]}
         -state   {$b configure -state [lindex $optSet 1]}
      }
   }
}

proc ::action::applicator::Menu {m act} {
   # try to find the menu item in the menu that corresponds to this action.
   # we have to use the previous configuration information to find the action
   # by label because the by the time we will have been called, the action
   # might have a new -text value, which would make it impossible to find the
   # original menu entry.
   set label ""
   foreach optSet $::action::action($act,previousConfig) {
      switch -- [lindex $optSet 0] {
         -text {set label [lindex $optSet 1]}
      }
   }
   # now find the old label in the menu
   if {[catch {$m index $label} index]} {
      # hmm, no menu item exists, let's create one
      $m add command
      set index end
   }
   # now casually look to see what we can configure in the menu entry
   foreach optSet [::action::configure $act] {
      switch -- [lindex $optSet 0] {
         -text    {$m entryconfigure $index -label [lindex $optSet 1]}
         -image   {$m entryconfigure $index -image [lindex $optSet 1] -compound left}
         -command {$m entryconfigure $index -command [lindex $optSet 1]}
         -state   {$m entryconfigure $index -state [lindex $optSet 1]}
      }
   }
   
}


#======================================================================
# Initialize defaults
#======================================================================
::action::initializeDefaults