# action-demo.tcl --

source action.tcl

package require Tk 8.4
package require action


set smile {R0lGODlhDwAPAMYAAAAAAH1/ZsLGnOPns9/jrX1/XwgICJ6hfdDUp+vvwPf7xvv/xvv/wvn9
verur8fLk5mcd/v/ydvfsvv/y+frr/v/uvv/t4eKYdTYo/v/w/D0vSYnHu/zwuntsy4vIvD0
sPr/tOLnoYiLZvv/vfv/wOntteHluN3hqBESDejtp/r/sfr/r3R3UM3Rl/v/vPP3uQUGBO/z
wOzwsCgpHPL3qvr/rfr/q9nelPT5sPr/tvv/ueHlqNrfl/r/qvr/qPr/p+XqmOjtpPr/o8HF
fbC0evr/rDIzIvr/oPn/jvn/kfn/mD5AJvn/nfr/nn6BUOjtncjMgzs9JsfMecfMbjEzHbq/
b+zyko+SXvn+or7Ddjg6IS8xGwgJBL7Da/n/lKarZcHFe+jukfX7levxitDWd+3zgfn/it3j
fpKWVYGFTtvhgMfMbXp9Qv//////////////////////////////////////////////////
/////////////////////////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwA
AAAADwAPAAAHsoB/goIAhYWDiH+FAQIDBAWHiAYHCAkKCwwNDg8AgwAQCxESE5gUFRYXnYoY
GRobHAsdHh8gIZ0AIiMkJQAmCycoKSorLIUtFS4vMDELMjM0NTY3hTg5Fjo7GQsgPD0+P0CF
QSrk5D1C6OhDhUQ1RUY/R0hJSktMTU63Tz9QUVJIU6hUUWJFFYArWI5k0bKFS5ckXr6oUgQm
jJgxZMqYOYNmIiEAadQgWcMmUiJFhjz+CQQAOw==}
set bigsmile {R0lGODlhDwAPAMYAAAAAAH1/ZsLGnOPns9/jrX1/XwgICJ6hfdDUp+vvwPf7xvv/xvv/wvn9
verur8fLk5mcd/v/ydvfsvv/y+frr/v/uvv/t4eKYdTYo/v/w/D0vSYnHu/zwuntsy4vIvD0
sPr/tOLnoYiLZvv/vfv/wOntteHluN3hqBESDejtp/r/sfr/r3R3UM3Rl/v/vPP3uQUGBO/z
wOzwsCgpHPL3qvr/rfr/q9nelPT5sPr/tjExMfv/ueHlqNrfl/r/qvr/p+XqmOjtpMDEifr/
o8DDfsHFfbC0er+/v2JiYhwcHDo6Ovr/nn6BUOjtnTIzIczMzP///+Xl5ZKSkuzyko+SXvn+
omRmS+rq6tnZ2V5fSfn/lKarZcHFe+jukd3jfpKWVYGFTtvhgPn/jsfMbXp9QgAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAACH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwA
AAAADwAPAAAHsIB/goIAhYWDiH+FAQIDBAWHiAYHCAkKCwwNDg8AgwAQCxESE5gUFRYXnYoY
GRobHAsdHh8gIZ0AIiMkJQAmCycoKSorLIUtFS4vMDELMjM0NTY3hTg5Ojs8GQsgPT46P0CF
QSo6OkIqPkNE5UNFhUY1OkdIOklKSEc6S0y3TU5PUKIEhCJFxxRVAKhUsfLkCpQrWLJo2aJK
EZcuhgp5+VKREAAwYcSMIRMpkaKMiQIBADs=}
set frown {R0lGODlhDwAPAMYAAAAAAH1/ZsLGnOPns9/jrX1/XwgICJ6hfdDUp+vvwPf7xvv/xvv/wvn9
verur8fLk5mcd/v/ydvfsvv/y+frr/v/uvv/t4eKYdTYo/v/w/D0vSYnHu/zwuntsy4vIvD0
sPr/tOLnoYiLZvv/vfv/wOntteHluN3hqBESDejtp/r/sfr/r3R3UM3Rl/v/vPP3uQUGBO/z
wOzwsCgpHPL3qvr/rfr/q9nelPT5sPr/tvv/ueHlqNrfl/r/qvr/qPr/p+XqmOjtpO3yp9HW
ju7zm/r/o8HFfbC0evr/rL/Dfzg6JC8xGwgJBb7DdPn/m/n/nfr/nn6BUOjtncjMgzs9JsfM
efn/jsfMbjEzHbq/b/n/mOzyko+SXvn+ovr/oPn/lfn/h/n/jfn/kfn/lKarZcHFe+jukfX7
lfj+kvn/iPn/it3jfpKWVYGFTtvhgMfMbXp9Qv//////////////////////////////////
/////////////////////////yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwA
AAAADwAPAAAHtIB/goIAhYWDiH+FAQIDBAWHiAYHCAkKCwwNDg8AgwAQCxESE5gUFRYXnYoY
GRobHAsdHh8gIZ0AIiMkJQAmCycoKSorLIUtFS4vMDELMjM0NTY3hTg5Fjo7GQsgPD0+P0CF
QSrkKkJDREXqRUaFRzVIPUlKS0xNTk9QUbdSP1NUVaxcwZJFyxZVALh08eLkixUwYcSMIaNK
URkzZ9BYSaNmDZuKhAC0cWPlDZxIiRQZAvknEAA7}
set sick {R0lGODlhDwAPAMYAAAAAAF5wSpGucqbKgaLFe1luQwgICHuRY6G9gLPUjrndkLjgj7XeirDa
hKPMeYmtZXqOZMbnocPlnsDkmb3ilLTdibHbhK7agKvZfFt0QqfCh8fnoxsfFrXWkiYtHiMs
G6TOeRAVDKnXeZfBa2l8VMPlncTmn6O/hT5IMq3OiqXNexYcEJS9aabWdaTVc0xiNZy6fL/j
mMDkmi84JrTTkiYsHio2H5jEayAqFqLUcKHTb4y3X7fbkLzhlK3af57SapDAYavQhbngj7jf
jrffjKbOe4exXY3CWJbNX5jPY5rPZJvQZnegToGdYrbei7LchoWmYyYxGx8oFQUHA3GcR5TM
XZfOYUxoMqbNfbHchYyuaCkzHYWrX6LTb3ynU6wTDaVrRZPMW43CWWV9S67ZgazZfqnYep3R
ariEU8c6IGKIPYWoYp/Jc6XTdqTUc57Sa4e4WFh4OFdvPpC7ZX+oVUxmMsjopMjopMjopMjo
pMjopMjopMjopMjopMjopMjopCH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwA
AAAADwAPAAAHs4B/goIAhYWDiH+FAQIDBAWHiAYHCAkKCwwNDg8AgwAQERITFAsVFhcYGZ2K
GhscHR4LHyAhIiOdACQlJicoKQsqKywtLi+FMDEyMzQ1CzY3ODk6O4U8PdfXPj/b20CFQUJD
RBVFRkdISUpLTIVNThVPUFFSU1RVSFZXuFhZWltcXbx8ARNGzCoAY8iUMdOiyxk0aaqoWaVo
DZs2brq8WQInDkVCAOTM6UKnTqREigx9/BMIADs=}



# create some images
image create photo bigsmile -data $bigsmile
image create photo smile  -data $smile
image create photo frown -data $frown
image create photo sick -data $sick


# make the demo look nice
if {$tcl_platform(platform) == "unix"} {
   set palette grey80
   tk_setPalette $palette
   option add *background $palette
   option add *foreground black
   option add *Labelframe.relief groove
   option add *Labelframe.borderWidth 2
   option add *Cheeseframe.relief groove ; # our custom widget class
   option add *Cheeseframe.borderWidth 2 ; # our custom widget class
   option add *Button.borderWidth 1
   option add *Radiobutton.borderWidth 1
   option add *Menu.borderWidth 1
   option add *Menu.activeBorderWidth 1
   option add *Entry.borderWidth 1
   option add *Entry.background white
   option add *Entry.foreground black
}

option add *Label.anchor w
option add *Cheeseframe.cmd.text "Invoke"
option add *Cheeseframe.hlp.text "This is a custom \"Cheeseframe\" class widget\nwith registered action applicators and options"


# this is a command that we'll associate with actions later.. it's just
# something to do
proc mbox {act} {
   tk_messageBox \
       -parent . \
       -title "Action Message Box" \
       -icon info \
       -message "A message box from action \"$act\"\n\nConfiguration:\n[::action::configure $act]" \
       -type ok
}


# this allows the ui to apply preferences to an action. by configuring the
# action here, those options will propogate to various widgets that the action
# has been applied
proc applyAction {act} {
   ::action::configure $act \
       -text $::actionText($act) \
       -image $::actionImage($act) \
       -command $::actionCmd($act) \
       -cheesecolor $::actionColor($act) \
       -state $::actionState($act)
   return 1
}


# creates frame and some controls to configure the action options, such as
# images, text, and command
proc actionConfigFrame {f act} {

   set ::actionCmd($act) [::action::cget $act -command]
   set ::actionImage($act) [::action::cget $act -image]
   set ::actionText($act) [::action::cget $act -text]
   set ::actionColor($act) [::action::cget $act -cheesecolor]
   set ::actionState($act) [::action::cget $act -state]


   labelframe $f \
       -text "Action: $act"
   label $f.l1 -text "Text:"
   entry $f.e \
       -textvariable ::actionText($act) \
       -validate all \
       -vcmd [list applyAction $act]
   label $f.l2 -text "Image:"
   foreach img {bigsmile smile frown sick} {
      radiobutton $f.r$img \
          -image $img \
          -variable ::actionImage($act) \
          -value $img \
          -command [list applyAction $act]
   }
   label $f.l3 -text "Command:"
   radiobutton $f.rbell \
       -text "Bell" \
       -variable ::actionCmd($act) \
       -value "bell" \
       -command [list applyAction $act]
   radiobutton $f.rmbox \
       -text "Message Box" \
       -variable ::actionCmd($act) \
       -value [list mbox $act] \
       -command [list applyAction $act]
   label $f.l4 -text "Cheeseframe:"
   foreach color {palegreen skyblue} {
      radiobutton $f.$color \
          -text "$color" \
          -value $color \
          -variable ::actionColor($act) \
          -command [list applyAction $act]
   }

   label $f.l5 -text "State:"
   foreach state {normal disabled} {
      radiobutton $f.$state \
          -text "$state" \
          -value $state \
          -variable ::actionState($act) \
          -command [list applyAction $act]
   }


   grid $f.l1 $f.e         -         -         -        - -stick ew -padx 4 -pady 4
   grid $f.l2 $f.rbigsmile $f.rsmile $f.rfrown $f.rsick x -stick ew -padx 4 -pady 4
   grid $f.l3 $f.rbell     - $f.rmbox          -        - -stick w  -padx 4 -pady 4
   grid $f.l4 $f.palegreen - $f.skyblue -      -        - -stick w  -padx 4 -pady 4
   grid $f.l5 $f.normal    - $f.disabled -     -        - -stick w  -padx 4 -pady 4
   grid columnconfigure $f 5 -weight 1
   return $f
}


# this creates our custom class of widget... a Cheeseframe
proc createCheeseFrame {f} {
   labelframe $f \
       -class Cheeseframe
   label $f.hlp
   label $f.img
   button $f.cmd 
   grid $f.hlp -      -stick ew -padx 4 -pady 4
   grid $f.img $f.cmd -stick ew -padx 4 -pady 4
   grid columnconfigure $f 1 -weight 1
   return $f
}


# this has the smarts to apply an action to our custom Cheeseframe class
# widgets
proc cheeseframeApplicator {w act} {
   # let's parse thru the current configuration and only use what is available
   # to us. By doing reacting to options instead of looking for specific
   # options, this allows us to not really care if one of the options is
   # missing. For example, if the -cheesecolor option is removed, this proc
   # will still function just fine, only the -cheesecolor will never be
   # processed. Of course, if we really had to have it, we could generate an
   # error if we didn't find it.   
   foreach optSet [::action::configure $act] {
      switch -- [lindex $optSet 0] {
         -text    {$w configure -text [lindex $optSet 1]}
         -image   {$w.img configure -image [lindex $optSet 1]}
         -command {$w.cmd configure -command [lindex $optSet 1]}
         -state   {$w.cmd configure -state [lindex $optSet 1]}
         -cheesecolor {
            set color [lindex $optSet 1]
            #$w configure -background $color
            foreach child [winfo children $w] {
               $child configure -background $color
            }
         }
      }
   }
}

# this little proc will be used to validate a color is a color when setting
# the -cheesecolor option. This prevents someone from doing this:
#    -cheesecolor 1
# The "configure" will return an error.
proc cheesecolorValidator {color} {
   if {[catch {winfo rgb . $color} err]} {
      return -code error "invalid cheesecolor $color"
   }
}


# add our custom -cheesecolor option for Cheeseframes and set the applicator
# proc
::action::addOption -cheesecolor palegreen cheesecolorValidator
::action::setApplicator Cheeseframe cheeseframeApplicator



# create a couple of actions and a little ui to configure what the actions do
# notice we are not setting -cheesecolor, these actions will pick up the
# default value, though we could just as easy set the value here.
action::create uno -text "Uno!" -image "smile" -command "bell" -cheesecolor skyblue
action::create dos -text "Dos!" -image "bigsmile" -command [list mbox dos]
actionConfigFrame .cfguno uno
actionConfigFrame .cfgdos dos


# create a menu bar so we can show off actions in a Menu class widget
menu .m -relief flat
. configure -menu .m
.m add cascade \
    -label "File" \
    -menu .m.file
.m add cascade \
    -label "Actions" \
    -menu .m.acts

menu .m.file
menu .m.acts


# create some buttons so we can show off actions in Button class widgets
labelframe .buttons \
    -text "Buttons with Actions"
grid [button .buttons.uno] [button .buttons.dos] -stick ew -padx 4 -pady 4
grid columnconfigure .buttons {0 1} -weight 1


# create our custom Cheeseframe widgets so we can show off the flexible nature
# of the action framework for allowing everything to be configurable.
labelframe .cheese \
    -text "Custom widgets that accept actions"
grid [createCheeseFrame .cheese.uno] [createCheeseFrame .cheese.dos] \
    -stick ew -padx 4 -pady 4
grid columnconfigure .cheese {0 1} -weight 1


# apply the actions to the widgets
::action::apply uno .buttons.uno .m.acts .cheese.uno
::action::apply dos .buttons.dos .m.acts .cheese.dos


# lastly, create an "exit" action and a button
::action::create exit \
    -text "Exit" \
    -command "exit"
button .exit
::action::apply exit .exit .m.file


# oh, and stick in a label that explains what we are doing
label .help -text {
This demo shows the practical use action framework. We have create two actions
and have allowed these actions to modified through the user interface.  Each
action has been applied to a menu, a button, and a custom widget.  Options
and action applicators for the menu and button are standard in the action
package. For the custom widget, we have added a color option to action
framework, provided a custom color validator and a widget applicator for our
custom widget class.

You will notice by configuring the action, the options will automatically be
propogated and be appropriately applied to each type of widget.
} -justify left

grid .help    -       -stick {} -padx 4 -pady 4
grid .cfguno  .cfgdos -stick ew -padx 4 -pady 4
grid .buttons -       -stick ew -padx 4 -pady 4
grid .cheese  -       -stick ew -padx 4 -pady 4
grid .exit    -       -stick ew -padx 4 -pady 4
grid columnconfigure . {0 1} -weight 1