class Balloonwidget {
inherit itk::Widget
itk_option define -balloonhelp balloonHelp BalloonHelp ""
private variable balloon_queue ""
private variable destroy_queue ""
public method enter
public method leave
public method balloon
constructor { args } {
bind $itk_component(hull) <Enter> [code $this enter]
bind $itk_component(hull) <Leave> [code $this leave]
eval itk_initialize $args }
}
body Balloonwidget::enter { } {
if {$balloon_queue != ""} {
after cancel $balloon_queue
}
if {$itk_option(-balloonhelp) != ""} {
set balloon_queue [after 750 [code $this balloon]]
}
}
body Balloonwidget::leave { } {
if {$balloon_queue != ""} {
after cancel $balloon_queue
}
set destroy_queue [after 100 {catch {destroy .balloon_help}}]
}
body Balloonwidget::balloon { } {
set t .balloon_help
catch {destroy $t}
toplevel $t
wm overrideredirect $t 1
if {[tk windowingsystem] == "aqua"} {
#unsupported1 style $itk_component(hull) floating sideTitlebar
::tk::unsupported::MacWindowStyle style $t help none
}
label $t.l \
-text " $itk_option(-balloonhelp) " \
-relief solid \
-bd 2 \
-bg gold \
-fg #000000 \
-font font_b
pack $t.l -fill both
set x [expr [winfo pointerx $itk_component(hull)] + 8]
set y [expr [winfo pointery $itk_component(hull)] + 20]
if {[expr $x + [winfo reqwidth $t.l]] > [winfo screenwidth $t.l]} {
set x [expr [winfo screenwidth $t.l] - [winfo reqwidth $t.l] - 2]
}
if {[expr $y + [winfo reqheight $t.l]] > [winfo screenheight $t.l]} {
set y [expr $y - 20 - [winfo reqheight $t.l] - 2]
}
wm geometry $t +$x\+$y
#bind $t <Enter> [list [after cancel $destroy_queue]]
#bind $t <Leave> "catch {destroy .balloon_help}"
}
class gEntry {
inherit Balloonwidget
itk_option define -image image Image "" {
if {$itk_option(-image) != ""} {
$itk_component(icon) configure \
-image $itk_option(-image) \
-width [expr [image width $itk_option(-image)] + 4] \
-height [expr [image height $itk_option(-image)] + 4]
}
}
itk_option define -padxy padXY Pad 0 {
$itk_component(padding) configure -borderwidth $itk_option(-padxy)
}
itk_option define -disabledbackground disabledBackground Background "#dcdcdc"
itk_option define -disabledforeground disabledForeground DisabledForeground "#a9a9a9"
itk_option define -foreground foreground Foreground "#000000" {
if {$itk_option(-state) != "disabled"} {
$itk_component(entry) configure -foreground $itk_option(-foreground)
}
}
itk_option define -textbackground textBackground Background "#ffffff" {
if {$itk_option(-state) != "disabled"} {
$itk_component(entry) configure -background $itk_option(-textbackground)
$itk_component(icon) configure -background $itk_option(-textbackground)
}
$itk_component(frame) configure -background $itk_option(-textbackground)
}
itk_option define -entryfont entryFont Font font_e {
$itk_component(entry) configure -font $itk_option(-entryfont)
}
itk_option define -state state State "normal" {
if {$itk_option(-state) == "disabled"} {
$itk_component(entry) configure \
-state disabled \
-background $itk_option(-disabledbackground) \
-foreground $itk_option(-disabledforeground)
$itk_component(frame) configure \
-background $itk_option(-disabledbackground)
$itk_component(icon) configure \
-background $itk_option(-disabledbackground)
} else {
$itk_component(entry) configure \
-state normal \
-background $itk_option(-textbackground) \
-foreground $itk_option(-foreground)
$itk_component(frame) configure \
-background $itk_option(-textbackground)
$itk_component(icon) configure \
-background $itk_option(-textbackground)
}
}
itk_option define -type type Type "string"
itk_option define -defaultvalue defaultValue DefaultValue ""
itk_option define -precision precision Precision "2"
itk_option define -maximum maximum Maximum ""
itk_option define -minimum minimum Minimum ""
itk_option define -allowblank allowBlank AllowBlank "1"
itk_option define -linkcommand linkCommand Command ""
itk_option define -editcommand editCommand Command ""
itk_option define -command command Command ""
public method validate
public method focusOut
public method update
public method query
public method keystroke
constructor { args } {
itk_component add padding {
frame $itk_interior.p \
-relief flat \
}
pack $itk_component(padding) -fill x
itk_component add frame {
frame $itk_interior.p.f \
-borderwidth 2 \
-relief sunken
} {
usual
keep -borderwidth
keep -relief
}
pack $itk_component(frame) -fill x
itk_component add icon {
label $itk_interior.p.f.icon \
-anchor c \
-padx 0 \
-pady 0 \
-bd 0
}
pack $itk_component(icon) -side left
itk_component add entry {
entry $itk_interior.p.f.entry \
-relief flat \
-borderwidth 0 \
-highlightthickness 0 \
-selectborderwidth 0 \
-validate all \
-validatecommand [code $this validate %V %P]
} {
keep -insertbackground -insertborderwidth -insertwidth
keep -insertontime -insertofftime
keep -selectbackground -selectforeground
keep -textvariable
keep -width
keep -justify
keep -show
}
pack $itk_component(entry) -side right -fill x -expand true
bind $itk_component(entry) <FocusOut> [code $this focusOut]
bind $itk_component(entry) <Return> [code $this focusOut]
bind $itk_component(entry) <KeyPress> [code $this keystroke]
eval itk_initialize $args
}
}
body gEntry::query { } {
return [$itk_component(entry) get]
}
body gEntry::update { a_value } {
if {[validate "focusout" $a_value]} {
$itk_component(entry) configure -state normal
$itk_component(entry) delete 0 end
$itk_component(entry) insert 0 $a_value
$itk_component(entry) configure -state $itk_option(-state)
focusOut -nolink
}
}
body gEntry::validate { reason new_string } {
switch -- $reason {
key {
switch -- $itk_option(-type) {
real {
if {[regexp -- {^-?\d*\.?\d*$} $new_string]} {
return 1
} else {
bell
return 0
}
}
int {
if {[regexp -- {^-?\d*$} $new_string]} {
return 1
} else {
bell
return 0
}
}
default {
return 1
}
}
}
forced {
# Trust myself to only force it to accept well-formed values
return 1
}
focusout {
switch -- $itk_option(-type) {
real {
if {[regexp -- {^-?\.?$} $new_string]} {set new_string ""}
if {$new_string == ""} {
if {$itk_option(-allowblank)} {
return 1
} elseif {$itk_option(-defaultvalue) != ""} {
set new_string $itk_option(-defaultvalue)
} else {
set new_string 0
}
}
if {$itk_option(-maximum) != ""} {
if {$new_string > $itk_option(-maximum)} {
set new_string $itk_option(-maximum)
}
}
if {$itk_option(-minimum) != ""} {
if {$new_string < $itk_option(-minimum)} {
set new_string $itk_option(-minimum)
}
}
$itk_component(entry) delete 0 end
$itk_component(entry) insert 0 [format %.$itk_option(-precision)f $new_string]
# Need to turn valistaion back on, as setting the entry content
# here will have turned it off.
after idle [list $itk_component(entry) configure -validate all]
return 1
}
int {
if {[regexp -- {^-?$} $new_string]} {set new_string ""}
if {$new_string == ""} {
if {$itk_option(-allowblank)} {
return 1
} elseif {$itk_option(-defaultvalue) != ""} {
set new_string $itk_option(-defaultvalue)
} else {
set new_string 0
}
}
if {$itk_option(-maximum) != ""} {
if {$new_string > $itk_option(-maximum)} {
set new_string $itk_option(-maximum)
}
}
if {$itk_option(-minimum) != ""} {
if {$new_string < $itk_option(-minimum)} {
set new_string $itk_option(-minimum)
}
}
$itk_component(entry) delete 0 end
$itk_component(entry) insert 0 $new_string
# Need to turn validation back on, as setting the entry content
# here will have turned it off.
after idle [list $itk_component(entry) configure -validate all]
return 1
}
default {
return 1
}
}
}
default {
return 1
}
}
}
body gEntry::focusOut { { a_link "-link" } } {
$itk_component(entry) selection clear
if {$itk_option(-command) != ""} {
uplevel #0 [list $itk_option(-command) "[$itk_component(entry) get]"]
}
if { $a_link != "-nolink" } {
if {$itk_option(-linkcommand) != ""} {
uplevel #0 $itk_option(-linkcommand)
}
}
}
body gEntry::keystroke { } {
if {$itk_option(-editcommand) != ""} {
uplevel #0 $itk_option(-editcommand)
}
}
usual gEntry {
#rename -disabledbackground -background background Background
keep -textbackground -background
keep -selectforeground -selectbackground
keep -disabledbackground -disabledforeground
keep -entryfont
keep -padxy
}
# ###############################################################################
# FILEENTRY
# ###############################################################################
class SettingWidget {
# Common variables
private common widgets ; # array
# Procedures
public proc refresh { a_parameter }
public proc refreshAll { }
# Member variables
protected variable parameter ""
private variable old_value ""
private variable canbeblank 0
# Methods
protected method getValue ; # virtual
public method setValue ; # virtual
public method downloadFromSession
protected method uploadToSessionIfChanged
constructor { a_parameter } { }
}
body SettingWidget::constructor { a_parameter } {
set parameter $a_parameter
lappend widgets($a_parameter) $this
}
body SettingWidget::refresh { a_parameter } {
if {[info exists widgets($a_parameter)]} {
foreach i_widget $widgets($a_parameter) {
$i_widget downloadFromSession
}
}
}
body SettingWidget::refreshAll { } {
foreach i_parameter [array names widgets] {
refresh $i_parameter
}
}
body SettingWidget::getValue { } { error "Virtual method SettingWidget::getValue not overridden" }
body SettingWidget::setValue { } { error "Virtual method SettingWidget::getValue not overridden" }
body SettingWidget::uploadToSessionIfChanged { } {
#added by luke on 9 November 2007.
# If one presses return in a setting entry while it is blank, the interpreter gave an error
# See bug 42. The if statement below catches that case and leaves the old_value unchanged
if {([getValue] == "") && ($canbeblank == 0)} {
$::session updateSetting $parameter $old_value 1 1
}
#######################################################
# if the current value doesn't match the old value
if {[getValue] != $old_value} {
# update the session with the current value
$::session updateSetting $parameter [getValue] 1 1
# update the old value
set old_value [getValue]
#added by luke on 3 December 2007
#A hack to send the detector and reversephi keywords. reversephi should only
#be sent to ipmosflm if the detector manufacturer is already set.
if {$parameter == "detector_manufacturer"} {
$::mosflm sendCommand "detector $old_value"
}
if {$parameter == "reverse_phi"} {
if {([$::session getReversePhi]) && ([$::session getDetectorManufacturer] != "")} {
$::mosflm sendCommand "detector [$::session getDetectorManufacturer] reversephi"
} else {
$::mosflm sendCommand "detector [$::session getDetectorManufacturer]"
}
}
###################################################################
} else {
}
}
body SettingWidget::downloadFromSession { } {
set l_new_value [$::session getParameterValue $parameter]
set old_value $l_new_value
setValue $l_new_value
}
class SettingEntry {
inherit gEntry SettingWidget
# itk_option define -parameter parameter Parameter "" {
# set parameter $itk_option(-parameter)
# }
public method update
public method getValue
public method setValue
public method publicUploadToSessionIfChanged
constructor { a_parameter args } {
eval gEntry::constructor $args
SettingWidget::constructor $a_parameter
} {
bind $itk_component(entry) <FocusOut> +[code $this uploadToSessionIfChanged]
bind $itk_component(entry) <Return> +[code $this uploadToSessionIfChanged]
}
}
body SettingEntry::update { a_value } {
gEntry::update $a_value
uploadToSessionIfChanged
}
body SettingEntry::getValue { } {
return [$itk_component(entry) get]
}
body SettingEntry::setValue { a_value } {
$itk_component(entry) configure -state normal
$itk_component(entry) delete 0 end
$itk_component(entry) insert end $a_value
$itk_component(entry) configure -state $itk_option(-state)
}
usual SettingEntry {
usual gEntry
}
body SettingEntry::publicUploadToSessionIfChanged {} {
uploadToSessionIfChanged
# puts "did it"
}
class Indexwizard {
inherit itk::Widget
constructor {args} { }
}
body Indexwizard::constructor { args } {
# Toolbars ###############################################
itk_component add spotfinding_toolbar {
frame .c.spot
}
# Divider
itk_component add spotfinding_divider1 {
frame $itk_component(spotfinding_toolbar).div1 \
-width 2 \
-relief sunken \
-bd 1
}
itk_component add beam_x_e {
SettingEntry $itk_component(spotfinding_toolbar).bxe beam_x \
-image ::img::beam_x16x16 \
-balloonhelp "Beam x position" \
-type real \
-precision 2 \
-width 6 \
-justify right
}
itk_component add beam_y_e {
SettingEntry $itk_component(spotfinding_toolbar).bye beam_y \
-image ::img::beam_y16x16 \
-balloonhelp "Beam y position" \
-type real \
-precision 2 \
-width 6 \
-justify right
}
itk_component add distance_e {
SettingEntry $itk_component(spotfinding_toolbar).de distance \
-image ::img::distance16x16 \
-balloonhelp "Crystal to detector distance" \
-type real \
-precision 2 \
-width 6 \
-justify right
}
itk_component add spotfinding_divider2 {
frame $itk_component(spotfinding_toolbar).div2 \
-width 2 \
-relief sunken \
-bd 1
}
# Frames
# pack $itk_component(spotfinding_toolbar) -side top -fill both
# Spot finding panel
###############################################################
grid $itk_component(spotfinding_toolbar) -row 0 -column 0 -sticky nswe
pack $itk_component(spotfinding_divider1) -side top -fill both
pack $itk_component(beam_x_e) -side top -fill both
pack $itk_component(beam_y_e) -side top -fill both
pack $itk_component(distance_e) -side top -fill both
eval itk_initialize $args
}
# Launch and completion methods #####################################
usual Indexwizard {
}
#Indexwizard .c
#pack .c
class test {
inherit itk::Widget
constructor { args } {
itk_option add hull.width hull.height
$itk_component(hull) configure -width 1050 -height 768
wm minsize [winfo toplevel $itk_component(hull)] 1050 768
pack propagate $itk_interior 0
itk_component add spot {
frame .c.spott
}
itk_component add index {
Indexwizard $itk_component(spot).kk
}
itk_component add indexing {
label $itk_component(spot).ttt \
-text "aaaa"
}
pack $itk_component(spot) -side top -fill both
grid $itk_component(spot) -row 1 -column 0 -sticky nswe
pack $itk_component(indexing) -side top -fill both
# pack $itk_component(index) -side top -fill both
}
}
test .c
pack .c