diff options
Diffstat (limited to 'library')
136 files changed, 11097 insertions, 2124 deletions
diff --git a/library/bgerror.tcl b/library/bgerror.tcl index 3372115..f46ab4c 100644 --- a/library/bgerror.tcl +++ b/library/bgerror.tcl @@ -7,6 +7,7 @@ # Donal K. Fellows. # # Copyright (c) 1998-2000 by Ajuba Solutions. +# Copyright (c) 2007 by ActiveState Software Inc. # Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net> namespace eval ::tk::dialog::error { @@ -15,6 +16,7 @@ namespace eval ::tk::dialog::error { option add *ErrorDialog.function.text [mc "Save To Log"] \ widgetDefault option add *ErrorDialog.function.command [namespace code SaveToLog] + option add *ErrorDialog*Label.font TkCaptionFont widgetDefault if {[tk windowingsystem] eq "aqua"} { option add *ErrorDialog*background systemAlertBackgroundActive \ widgetDefault @@ -40,7 +42,7 @@ proc ::tk::dialog::error::Details {} { if { ($caption eq "") || ($command eq "") } { grid forget $w.function } - lappend command [.bgerrorDialog.top.info.text get 1.0 end-1c] + lappend command [$w.top.info.text get 1.0 end-1c] $w.function configure -text $caption -command $command grid $w.top.info - -sticky nsew -padx 3m -pady 3m } @@ -93,29 +95,21 @@ proc ::tk::dialog::error::bgerror err { # Ok the application's tkerror either failed or was not found # we use the default dialog then : set windowingsystem [tk windowingsystem] - - if {($windowingsystem eq "classic") - || ($windowingsystem eq "aqua")} { - set ok [mc Ok] - set messageFont system - set textRelief flat - set textHilight 0 + if {$windowingsystem eq "aqua"} { + set ok [mc Ok] } else { - set ok [mc OK] - set messageFont {Times -18} - set textRelief sunken - set textHilight 1 + set ok [mc OK] } - - # Truncate the message if it is too wide (longer than 30 characacters) or - # too tall (more than 4 newlines). Truncation occurs at the first point at + # Truncate the message if it is too wide (>maxLine characters) or + # too tall (>4 lines). Truncation occurs at the first point at # which one of those conditions is met. set displayedErr "" set lines 0 + set maxLine 45 foreach line [split $err \n] { - if { [string length $line] > 30 } { - append displayedErr "[string range $line 0 29]..." + if { [string length $line] > $maxLine } { + append displayedErr "[string range $line 0 [expr {$maxLine-3}]]..." break } if { $lines > 4 } { @@ -127,50 +121,42 @@ proc ::tk::dialog::error::bgerror err { incr lines } - set w .bgerrorDialog set title [mc "Application Error"] - set text [mc {Error: %1$s} $displayedErr] + set text [mc "Error: %1\$s" $displayedErr] set buttons [list ok $ok dismiss [mc "Skip Messages"] \ - function [mc "Details >>"]] + function [mc "Details >>"]] # 1. Create the top-level window and divide it into top # and bottom parts. - destroy .bgerrorDialog - toplevel .bgerrorDialog -class ErrorDialog - wm withdraw .bgerrorDialog - wm title .bgerrorDialog $title - wm iconname .bgerrorDialog ErrorDialog - wm protocol .bgerrorDialog WM_DELETE_WINDOW { } + set dlg .bgerrorDialog + destroy $dlg + toplevel $dlg -class ErrorDialog + wm withdraw $dlg + wm title $dlg $title + wm iconname $dlg ErrorDialog + wm protocol $dlg WM_DELETE_WINDOW { } - if {($windowingsystem eq "classic") - || ($windowingsystem eq "aqua")} { - ::tk::unsupported::MacWindowStyle style .bgerrorDialog moveableAlert {} + if {$windowingsystem eq "aqua"} { + ::tk::unsupported::MacWindowStyle style $dlg moveableAlert {} } elseif {$windowingsystem eq "x11"} { - wm attributes .bgerrorDialog -type dialog + wm attributes $dlg -type dialog } - frame .bgerrorDialog.bot - frame .bgerrorDialog.top + frame $dlg.bot + frame $dlg.top if {$windowingsystem eq "x11"} { - .bgerrorDialog.bot configure -relief raised -bd 1 - .bgerrorDialog.top configure -relief raised -bd 1 + $dlg.bot configure -relief raised -bd 1 + $dlg.top configure -relief raised -bd 1 } - pack .bgerrorDialog.bot -side bottom -fill both - pack .bgerrorDialog.top -side top -fill both -expand 1 - - set W [frame $w.top.info] - text $W.text \ - -yscrollcommand [list $W.scroll set]\ - -setgrid true \ - -width 40 \ - -height 10 \ - -state normal \ - -relief $textRelief \ - -highlightthickness $textHilight \ - -wrap char - if {$windowingsystem eq "aqua"} { - $W.text configure -width 80 -background white + pack $dlg.bot -side bottom -fill both + pack $dlg.top -side top -fill both -expand 1 + + set W [frame $dlg.top.info] + text $W.text -setgrid true -height 10 -wrap char \ + -yscrollcommand [list $W.scroll set] + if {$windowingsystem ne "aqua"} { + $W.text configure -width 40 } scrollbar $W.scroll -command [list $W.text yview] @@ -184,84 +170,70 @@ proc ::tk::dialog::error::bgerror err { # 2. Fill the top part with bitmap and message # Max-width of message is the width of the screen... - set wrapwidth [winfo screenwidth .bgerrorDialog] + set wrapwidth [winfo screenwidth $dlg] # ...minus the width of the icon, padding and a fudge factor for # the window manager decorations and aesthetics. - set wrapwidth [expr {$wrapwidth-60-[winfo pixels .bgerrorDialog 9m]}] - label .bgerrorDialog.msg -justify left -text $text -font $messageFont \ - -wraplength $wrapwidth - if {($windowingsystem eq "classic") - || ($windowingsystem eq "aqua")} { + set wrapwidth [expr {$wrapwidth-60-[winfo pixels $dlg 9m]}] + label $dlg.msg -justify left -text $text -wraplength $wrapwidth + if {$windowingsystem eq "aqua"} { # On the Macintosh, use the stop bitmap - label .bgerrorDialog.bitmap -bitmap stop + label $dlg.bitmap -bitmap stop } else { # On other platforms, make the error icon - canvas .bgerrorDialog.bitmap -width 32 -height 32 -highlightthickness 0 - .bgerrorDialog.bitmap create oval 0 0 31 31 -fill red -outline black - .bgerrorDialog.bitmap create line 9 9 23 23 -fill white -width 4 - .bgerrorDialog.bitmap create line 9 23 23 9 -fill white -width 4 + canvas $dlg.bitmap -width 32 -height 32 -highlightthickness 0 + $dlg.bitmap create oval 0 0 31 31 -fill red -outline black + $dlg.bitmap create line 9 9 23 23 -fill white -width 4 + $dlg.bitmap create line 9 23 23 9 -fill white -width 4 } - grid .bgerrorDialog.bitmap .bgerrorDialog.msg \ - -in .bgerrorDialog.top \ - -row 0 \ - -padx 3m \ - -pady 3m - grid configure .bgerrorDialog.msg -sticky nsw -padx {0 3m} - grid rowconfigure .bgerrorDialog.top 1 -weight 1 - grid columnconfigure .bgerrorDialog.top 1 -weight 1 + grid $dlg.bitmap $dlg.msg -in $dlg.top -row 0 -padx 3m -pady 3m + grid configure $dlg.msg -sticky nsw -padx {0 3m} + grid rowconfigure $dlg.top 1 -weight 1 + grid columnconfigure $dlg.top 1 -weight 1 # 3. Create a row of buttons at the bottom of the dialog. set i 0 foreach {name caption} $buttons { - button .bgerrorDialog.$name \ - -text $caption \ - -default normal \ - -command [namespace code [list set button $i]] - grid .bgerrorDialog.$name \ - -in .bgerrorDialog.bot \ - -column $i \ - -row 0 \ - -sticky ew \ - -padx 10 - grid columnconfigure .bgerrorDialog.bot $i -weight 1 + button $dlg.$name -text $caption -default normal \ + -command [namespace code [list set button $i]] + grid $dlg.$name -in $dlg.bot -column $i -row 0 -sticky ew -padx 10 + grid columnconfigure $dlg.bot $i -weight 1 # We boost the size of some Mac buttons for l&f - if {($windowingsystem eq "classic") - || ($windowingsystem eq "aqua")} { + if {$windowingsystem eq "aqua"} { if {($name eq "ok") || ($name eq "dismiss")} { - grid columnconfigure .bgerrorDialog.bot $i -minsize 90 + grid columnconfigure $dlg.bot $i -minsize 90 } - grid configure .bgerrorDialog.$name -pady 7 + grid configure $dlg.$name -pady 7 } incr i } # The "OK" button is the default for this dialog. - .bgerrorDialog.ok configure -default active + $dlg.ok configure -default active - bind .bgerrorDialog <Return> [namespace code Return] - bind .bgerrorDialog <Destroy> [namespace code [list Destroy %W]] - .bgerrorDialog.function configure -command [namespace code Details] + bind $dlg <Return> [namespace code Return] + bind $dlg <Destroy> [namespace code [list Destroy %W]] + $dlg.function configure -command [namespace code Details] # 6. Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display (Motif style) and de-iconify it. - ::tk::PlaceWindow .bgerrorDialog + ::tk::PlaceWindow $dlg # 7. Ensure that we are topmost. - raise .bgerrorDialog + raise $dlg if {[tk windowingsystem] eq "win32"} { # Place it topmost if we aren't at the top of the stacking # order to ensure that it's seen - if {[lindex [wm stackorder .] end] ne ".bgerrorDialog"} { - wm attributes .bgerrorDialog -topmost 1 + if {[lindex [wm stackorder .] end] ne "$dlg"} { + wm attributes $dlg -topmost 1 } } # 8. Set a grab and claim the focus too. - ::tk::SetFocusGrab .bgerrorDialog .bgerrorDialog.ok + ::tk::SetFocusGrab $dlg $dlg.ok # 9. Wait for the user to respond, then restore the focus and # return the index of the selected button. Restore the focus @@ -272,7 +244,7 @@ proc ::tk::dialog::error::bgerror err { vwait [namespace which -variable button] set copy $button; # Save a copy... - ::tk::RestoreFocusGrab .bgerrorDialog .bgerrorDialog.ok destroy + ::tk::RestoreFocusGrab $dlg $dlg.ok destroy if {$copy == 1} { return -code break diff --git a/library/button.tcl b/library/button.tcl index 195566e..d095b8a 100644 --- a/library/button.tcl +++ b/library/button.tcl @@ -16,7 +16,7 @@ # The code below creates the default class bindings for buttons. #------------------------------------------------------------------------- -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { +if {[tk windowingsystem] eq "aqua"} { bind Radiobutton <Enter> { tk::ButtonEnter %W } @@ -35,6 +35,9 @@ if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { bind Checkbutton <ButtonRelease-1> { tk::ButtonUp %W } + bind Checkbutton <Leave> { + tk::ButtonLeave %W + } } if {"win32" eq [tk windowingsystem]} { bind Checkbutton <equal> { @@ -55,6 +58,9 @@ if {"win32" eq [tk windowingsystem]} { bind Checkbutton <Enter> { tk::CheckRadioEnter %W } + bind Checkbutton <Leave> { + tk::ButtonLeave %W + } bind Radiobutton <1> { tk::CheckRadioDown %W @@ -69,7 +75,7 @@ if {"win32" eq [tk windowingsystem]} { if {"x11" eq [tk windowingsystem]} { bind Checkbutton <Return> { if {!$tk_strictMotif} { - tk::CheckRadioInvoke %W + tk::CheckInvoke %W } } bind Radiobutton <Return> { @@ -78,17 +84,20 @@ if {"x11" eq [tk windowingsystem]} { } } bind Checkbutton <1> { - tk::CheckRadioInvoke %W + tk::CheckInvoke %W } bind Radiobutton <1> { tk::CheckRadioInvoke %W } bind Checkbutton <Enter> { - tk::ButtonEnter %W + tk::CheckEnter %W } bind Radiobutton <Enter> { tk::ButtonEnter %W } + bind Checkbutton <Leave> { + tk::CheckLeave %W + } } bind Button <space> { @@ -116,9 +125,6 @@ bind Button <ButtonRelease-1> { } bind Checkbutton <FocusIn> {} -bind Checkbutton <Leave> { - tk::ButtonLeave %W -} bind Radiobutton <FocusIn> {} bind Radiobutton <Leave> { @@ -442,7 +448,7 @@ proc ::tk::ButtonUp w { } -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { +if {[tk windowingsystem] eq "aqua"} { #################### # Mac implementation @@ -633,3 +639,110 @@ proc ::tk::CheckRadioInvoke {w {cmd invoke}} { uplevel #0 [list $w $cmd] } } + +# Special versions of the handlers for checkbuttons on Unix that do the magic +# to make things work right when the checkbutton indicator is hidden; +# radiobuttons don't need this complexity. + +# ::tk::CheckInvoke -- +# The procedure below invokes the checkbutton, like ButtonInvoke, but handles +# what to do when the checkbutton indicator is missing. Only used on Unix. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckInvoke {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + # Additional logic to switch the "selected" colors around if necessary + # (when we're indicator-less). + + if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} { + if {[$w cget -selectcolor] eq $Priv($w,aselectcolor)} { + $w configure -selectcolor $Priv($w,selectcolor) + } else { + $w configure -selectcolor $Priv($w,aselectcolor) + } + } + uplevel #0 [list $w invoke] + } +} + +# ::tk::CheckEnter -- +# The procedure below enters the checkbutton, like ButtonEnter, but handles +# what to do when the checkbutton indicator is missing. Only used on Unix. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckEnter {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + # On unix the state is active just with mouse-over + $w configure -state active + + # If the mouse button is down, set the relief to sunken on entry. + # Overwise, if there's an -overrelief value, set the relief to that. + + set Priv($w,relief) [$w cget -relief] + if {$Priv(buttonWindow) eq $w} { + $w configure -relief sunken + set Priv($w,prelief) sunken + } elseif {[set over [$w cget -overrelief]] ne ""} { + $w configure -relief $over + set Priv($w,prelief) $over + } + + # Compute what the "selected and active" color should be. + + if {![$w cget -indicatoron] && [$w cget -selectcolor] ne ""} { + set Priv($w,selectcolor) [$w cget -selectcolor] + lassign [winfo rgb $w [$w cget -selectcolor]] r1 g1 b1 + lassign [winfo rgb $w [$w cget -activebackground]] r2 g2 b2 + set Priv($w,aselectcolor) \ + [format "#%04x%04x%04x" [expr {($r1+$r2)/2}] \ + [expr {($g1+$g2)/2}] [expr {($b1+$b2)/2}]] + # use uplevel to work with other var resolvers + if {[uplevel #0 [list set [$w cget -variable]]] + eq [$w cget -onvalue]} { + $w configure -selectcolor $Priv($w,aselectcolor) + } + } + } + set Priv(window) $w +} + +# ::tk::CheckLeave -- +# The procedure below leaves the checkbutton, like ButtonLeave, but handles +# what to do when the checkbutton indicator is missing. Only used on Unix. +# +# Arguments: +# w - The name of the widget. + +proc ::tk::CheckLeave {w} { + variable ::tk::Priv + if {[$w cget -state] ne "disabled"} { + $w configure -state normal + } + + # Restore the original button "selected" color; assume that the user + # wasn't monkeying around with things too much. + + if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} { + $w configure -selectcolor $Priv($w,selectcolor) + } + unset -nocomplain Priv($w,selectcolor) Priv($w,aselectcolor) + + # Restore the original button relief if it was changed by Tk. That is + # signaled by the existence of Priv($w,prelief). + + if {[info exists Priv($w,relief)]} { + if {[info exists Priv($w,prelief)] && \ + $Priv($w,prelief) eq [$w cget -relief]} { + $w configure -relief $Priv($w,relief) + } + unset -nocomplain Priv($w,relief) Priv($w,prelief) + } + + set Priv(window) "" +} diff --git a/library/choosedir.tcl b/library/choosedir.tcl index 0fd3f01..00dca9d 100644 --- a/library/choosedir.tcl +++ b/library/choosedir.tcl @@ -25,7 +25,7 @@ proc ::tk::dialog::file::chooseDir:: {args} { variable ::tk::Priv set dataName __tk_choosedir upvar ::tk::dialog::file::$dataName data - ::tk::dialog::file::chooseDir::Config $dataName $args + Config $dataName $args if {$data(-parent) eq "."} { set w .$dataName @@ -41,14 +41,14 @@ proc ::tk::dialog::file::chooseDir:: {args} { destroy $w ::tk::dialog::file::Create $w TkChooseDir } else { - set data(dirMenuBtn) $w.f1.menu - set data(dirMenu) $w.f1.menu.menu - set data(upBtn) $w.f1.up - set data(icons) $w.icons - set data(ent) $w.f2.ent - set data(okBtn) $w.f2.ok - set data(cancelBtn) $w.f2.cancel - set data(hiddenBtn) $w.f2.hidden + set data(dirMenuBtn) $w.contents.f1.menu + set data(dirMenu) $w.contents.f1.menu.menu + set data(upBtn) $w.contents.f1.up + set data(icons) $w.contents.icons + set data(ent) $w.contents.f2.ent + set data(okBtn) $w.contents.f2.ok + set data(cancelBtn) $w.contents.f2.cancel + set data(hiddenBtn) $w.contents.f2.hidden } if {$::tk::dialog::file::showHiddenBtn} { $data(hiddenBtn) configure -state normal @@ -58,6 +58,15 @@ proc ::tk::dialog::file::chooseDir:: {args} { grid remove $data(hiddenBtn) } + # When using -mustexist, manage the OK button state for validity + $data(okBtn) configure -state normal + if {$data(-mustexist)} { + $data(ent) configure -validate key \ + -validatecommand [list ::tk::dialog::file::chooseDir::IsOK? $w %P] + } else { + $data(ent) configure -validate none + } + # Dialog boxes should be transient with respect to their parent, # so that they will always stay on top of their parent window. However, # some window managers will create the window as withdrawn if the parent @@ -69,7 +78,8 @@ proc ::tk::dialog::file::chooseDir:: {args} { wm transient $w $data(-parent) } - trace add variable data(selectPath) write [list ::tk::dialog::file::SetPath $w] + trace add variable data(selectPath) write \ + [list ::tk::dialog::file::SetPath $w] $data(dirMenuBtn) configure \ -textvariable ::tk::dialog::file::${dataName}(selectPath) @@ -199,25 +209,25 @@ proc ::tk::dialog::file::chooseDir::OkCmd {w} { # 4b. If the value is different from the current directory, change to # that directory. - set selection [tk::IconList_Curselection $data(icons)] - if { [llength $selection] != 0 } { + set selection [tk::IconList_CurSelection $data(icons)] + if {[llength $selection] != 0} { set iconText [tk::IconList_Get $data(icons) [lindex $selection 0]] set iconText [file join $data(selectPath) $iconText] - ::tk::dialog::file::chooseDir::Done $w $iconText + Done $w $iconText } else { set text [$data(ent) get] - if { $text eq "" } { + if {$text eq ""} { return } - set text [eval file join [file split [string trim $text]]] - if { ![file exists $text] || ![file isdirectory $text] } { + set text [file join {*}[file split [string trim $text]]] + if {![file exists $text] || ![file isdirectory $text]} { # Entry contains an invalid directory. If it's the same as the # last time they came through here, reset the saved value and end # the dialog. Otherwise, save the value (so we can do this test # next time). - if { $text eq $data(previousEntryText) } { + if {$text eq $data(previousEntryText)} { set data(previousEntryText) "" - ::tk::dialog::file::chooseDir::Done $w $text + Done $w $text } else { set data(previousEntryText) $text } @@ -225,8 +235,8 @@ proc ::tk::dialog::file::chooseDir::OkCmd {w} { # Entry contains a valid directory. If it is the same as the # current directory, end the dialog. Otherwise, change to that # directory. - if { $text eq $data(selectPath) } { - ::tk::dialog::file::chooseDir::Done $w $text + if {$text eq $data(selectPath)} { + Done $w $text } else { set data(selectPath) $text } @@ -235,10 +245,22 @@ proc ::tk::dialog::file::chooseDir::OkCmd {w} { return } +# Change state of OK button to match -mustexist correctness of entry +# +proc ::tk::dialog::file::chooseDir::IsOK? {w text} { + upvar ::tk::dialog::file::[winfo name $w] data + + set ok [file isdirectory $text] + $data(okBtn) configure -state [expr {$ok ? "normal" : "disabled"}] + + # always return 1 + return 1 +} + proc ::tk::dialog::file::chooseDir::DblClick {w} { upvar ::tk::dialog::file::[winfo name $w] data - set selection [tk::IconList_Curselection $data(icons)] - if { [llength $selection] != 0 } { + set selection [tk::IconList_CurSelection $data(icons)] + if {[llength $selection] != 0} { set filenameFragment \ [tk::IconList_Get $data(icons) [lindex $selection 0]] set file $data(selectPath) @@ -247,7 +269,7 @@ proc ::tk::dialog::file::chooseDir::DblClick {w} { return } } -} +} # Gets called when user browses the IconList widget (dragging mouse, arrow # keys, etc) @@ -279,11 +301,8 @@ proc ::tk::dialog::file::chooseDir::Done {w {selectFilePath ""}} { if {$selectFilePath eq ""} { set selectFilePath $data(selectPath) } - if { $data(-mustexist) } { - if { ![file exists $selectFilePath] || \ - ![file isdir $selectFilePath] } { - return - } + if {$data(-mustexist) && ![file isdirectory $selectFilePath]} { + return } set Priv(selectFilePath) $selectFilePath } diff --git a/library/clrpick.tcl b/library/clrpick.tcl index 02793cc..092915c 100644 --- a/library/clrpick.tcl +++ b/library/clrpick.tcl @@ -105,10 +105,11 @@ proc ::tk::dialog::color:: {args} { # restore any grab that was in effect. vwait ::tk::Priv(selectColor) + set result $Priv(selectColor) ::tk::RestoreFocusGrab $w $data(okBtn) unset data - return $Priv(selectColor) + return $result } # ::tk::dialog::color::InitValues -- @@ -123,8 +124,7 @@ proc ::tk::dialog::color::InitValues {dataName} { set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}] # ColorbarWidth is the width of each colorbar - set data(colorbarWidth) \ - [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}] + set data(colorbarWidth) [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}] # Indent is the width of the space at the left and right side of the # colorbar. It is always half the selector polygon width, because the @@ -213,12 +213,12 @@ proc ::tk::dialog::color::BuildDialog {w} { set stripsFrame [frame $topFrame.colorStrip] set maxWidth [::tk::mcmaxamp &Red &Green &Blue] - set maxWidth [expr {$maxWidth<6?6:$maxWidth}] - set colorList [list \ - red [mc "&Red"] \ - green [mc "&Green"] \ - blue [mc "&Blue"] \ - ] + set maxWidth [expr {$maxWidth<6 ? 6 : $maxWidth}] + set colorList { + red "&Red" + green "&Green" + blue "&Blue" + } foreach {color l} $colorList { # each f frame contains an [R|G|B] entry and the equiv. color strip. set f [frame $stripsFrame.$color] @@ -226,9 +226,10 @@ proc ::tk::dialog::color::BuildDialog {w} { # The box frame contains the label and entry widget for an [R|G|B] set box [frame $f.box] - bind [::tk::AmpWidget label $box.label -text $l: -width $maxWidth \ - -anchor ne] <<AltUnderlined>> [list focus $box.entry] - + ::tk::AmpWidget label $box.label -text "[mc $l]:" \ + -width $maxWidth -anchor ne + bind $box.label <<AltUnderlined>> [list focus $box.entry] + entry $box.entry -textvariable \ ::tk::dialog::color::[winfo name $w]($color,intensity) \ -width 4 @@ -236,14 +237,15 @@ proc ::tk::dialog::color::BuildDialog {w} { pack $box.entry -side left -anchor n -pady 0 pack $box -side left -fill both - set height [expr \ - {[winfo reqheight $box.entry] - \ - 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])}] + set height [expr { + [winfo reqheight $box.entry] - + 2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd]) + }] - canvas $f.color -height $height\ - -width $data(BARS_WIDTH) -relief sunken -bd 2 + canvas $f.color -height $height \ + -width $data(BARS_WIDTH) -relief sunken -bd 2 canvas $f.sel -height $data(PLGN_HEIGHT) \ - -width $data(canvasWidth) -highlightthickness 0 + -width $data(canvasWidth) -highlightthickness 0 pack $f.color -expand yes -fill both pack $f.sel -expand yes -fill both @@ -254,16 +256,16 @@ proc ::tk::dialog::color::BuildDialog {w} { set data($color,sel) $f.sel bind $data($color,col) <Configure> \ - [list tk::dialog::color::DrawColorScale $w $color 1] + [list tk::dialog::color::DrawColorScale $w $color 1] bind $data($color,col) <Enter> \ - [list tk::dialog::color::EnterColorBar $w $color] + [list tk::dialog::color::EnterColorBar $w $color] bind $data($color,col) <Leave> \ - [list tk::dialog::color::LeaveColorBar $w $color] + [list tk::dialog::color::LeaveColorBar $w $color] bind $data($color,sel) <Enter> \ - [list tk::dialog::color::EnterColorBar $w $color] + [list tk::dialog::color::EnterColorBar $w $color] bind $data($color,sel) <Leave> \ - [list tk::dialog::color::LeaveColorBar $w $color] + [list tk::dialog::color::LeaveColorBar $w $color] bind $box.entry <Return> [list tk::dialog::color::HandleRGBEntry $w] } @@ -274,11 +276,11 @@ proc ::tk::dialog::color::BuildDialog {w} { # selected color # set selFrame [frame $topFrame.sel] - set lab [::tk::AmpWidget label $selFrame.lab -text [mc "&Selection:"] \ - -anchor sw] + set lab [::tk::AmpWidget label $selFrame.lab \ + -text [mc "&Selection:"] -anchor sw] set ent [entry $selFrame.ent \ - -textvariable ::tk::dialog::color::[winfo name $w](selection) \ - -width 16] + -textvariable ::tk::dialog::color::[winfo name $w](selection) \ + -width 16] set f1 [frame $selFrame.f1 -relief sunken -bd 2] set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70] @@ -294,7 +296,7 @@ proc ::tk::dialog::color::BuildDialog {w} { # the botFrame frame contains the buttons # set botFrame [frame $w.bot -relief raised -bd 1] - + ::tk::AmpWidget button $botFrame.ok -text [mc "&OK"] \ -command [list tk::dialog::color::OkCmd $w] ::tk::AmpWidget button $botFrame.cancel -text [mc "&Cancel"] \ @@ -302,7 +304,7 @@ proc ::tk::dialog::color::BuildDialog {w} { set data(okBtn) $botFrame.ok set data(cancelBtn) $botFrame.cancel - + grid x $botFrame.ok x $botFrame.cancel x -sticky ew grid configure $botFrame.ok $botFrame.cancel -padx 10 -pady 10 grid columnconfigure $botFrame {0 4} -weight 1 -uniform space @@ -310,13 +312,13 @@ proc ::tk::dialog::color::BuildDialog {w} { grid columnconfigure $botFrame 2 -weight 2 -uniform space pack $botFrame -side bottom -fill x - # Accelerator bindings bind $lab <<AltUnderlined>> [list focus $ent] bind $w <KeyPress-Escape> [list tk::ButtonInvoke $data(cancelBtn)] bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A] wm protocol $w WM_DELETE_WINDOW [list tk::dialog::color::CancelCmd $w] + bind $lab <Destroy> [list tk::dialog::color::CancelCmd $w] } # ::tk::dialog::color::SetRGBValue -- @@ -329,11 +331,11 @@ proc ::tk::dialog::color::SetRGBValue {w color} { set data(red,intensity) [lindex $color 0] set data(green,intensity) [lindex $color 1] set data(blue,intensity) [lindex $color 2] - + RedrawColorBars $w all # Now compute the new x value of each colorbars pointer polygon - foreach color [list red green blue ] { + foreach color {red green blue} { set x [RgbToX $w $data($color,intensity)] MoveSelector $w $data($color,sel) $color $x 0 } @@ -345,9 +347,11 @@ proc ::tk::dialog::color::SetRGBValue {w color} { # proc ::tk::dialog::color::XToRgb {w x} { upvar ::tk::dialog::color::[winfo name $w] data - + set x [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}] - if {$x > 255} { set x 255 } + if {$x > 255} { + set x 255 + } return $x } @@ -357,11 +361,10 @@ proc ::tk::dialog::color::XToRgb {w x} { # proc ::tk::dialog::color::RgbToX {w color} { upvar ::tk::dialog::color::[winfo name $w] data - + return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}] } - # ::tk::dialog::color::DrawColorScale -- # # Draw color scale is called whenever the size of one of the color @@ -380,7 +383,7 @@ proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { # First remove all the lines that already exist. if { $data(lines,$c,last) > $data(lines,$c,start)} { for {set i $data(lines,$c,start)} \ - {$i <= $data(lines,$c,last)} { incr i} { + {$i <= $data(lines,$c,last)} {incr i} { $sel delete $i } } @@ -388,7 +391,7 @@ proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { if {[info exists data($c,index)]} { $sel delete $data($c,index) } - + # Draw the selection polygons CreateSelector $w $sel $c $sel bind $data($c,index) <ButtonPress-1> \ @@ -421,7 +424,7 @@ proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { # l is the canvas index of the first colorbar. set l $data(lines,$c,start) } - + # Draw the color bars. set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}] for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} { @@ -429,26 +432,20 @@ proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { set startx [expr {$i * $data(colorbarWidth) + $highlightW}] if {$c eq "red"} { set color [format "#%02x%02x%02x" \ - $intensity \ - $data(green,intensity) \ - $data(blue,intensity)] + $intensity $data(green,intensity) $data(blue,intensity)] } elseif {$c eq "green"} { set color [format "#%02x%02x%02x" \ - $data(red,intensity) \ - $intensity \ - $data(blue,intensity)] + $data(red,intensity) $intensity $data(blue,intensity)] } else { set color [format "#%02x%02x%02x" \ - $data(red,intensity) \ - $data(green,intensity) \ - $intensity] + $data(red,intensity) $data(green,intensity) $intensity] } if {$create} { set index [$col create rect $startx $highlightW \ [expr {$startx +$data(colorbarWidth)}] \ - [expr {[winfo height $col] + $highlightW}]\ - -fill $color -outline $color] + [expr {[winfo height $col] + $highlightW}] \ + -fill $color -outline $color] } else { $col itemconfigure $l -fill $color -outline $color incr l @@ -472,9 +469,9 @@ proc ::tk::dialog::color::DrawColorScale {w c {create 0}} { proc ::tk::dialog::color::CreateSelector {w sel c } { upvar ::tk::dialog::color::[winfo name $w] data set data($c,index) [$sel create polygon \ - 0 $data(PLGN_HEIGHT) \ - $data(PLGN_WIDTH) $data(PLGN_HEIGHT) \ - $data(indent) 0] + 0 $data(PLGN_HEIGHT) \ + $data(PLGN_WIDTH) $data(PLGN_HEIGHT) \ + $data(indent) 0] set data($c,x) [RgbToX $w $data($c,intensity)] $sel move $data($c,index) $data($c,x) 0 } @@ -487,8 +484,8 @@ proc ::tk::dialog::color::RedrawFinalColor {w} { upvar ::tk::dialog::color::[winfo name $w] data set color [format "#%02x%02x%02x" $data(red,intensity) \ - $data(green,intensity) $data(blue,intensity)] - + $data(green,intensity) $data(blue,intensity)] + $data(finalCanvas) configure -bg $color set data(finalColor) $color set data(selection) $color @@ -571,7 +568,7 @@ proc ::tk::dialog::color::MoveSelector {w sel color x delta} { set diff [expr {$x - $data($color,x)}] $sel move $data($color,index) $diff 0 set data($color,x) [expr {$data($color,x) + $diff}] - + # Return the x value that it was actually set at return $x } @@ -587,7 +584,7 @@ proc ::tk::dialog::color::ReleaseMouse {w sel color x delta} { upvar ::tk::dialog::color::[winfo name $w] data set x [MoveSelector $w $sel $color $x $delta] - + # Determine exactly what color we are looking at. set data($color,intensity) [XToRgb $w $x] @@ -601,13 +598,15 @@ proc ::tk::dialog::color::ReleaseMouse {w sel color x delta} { # proc ::tk::dialog::color::ResizeColorBars {w} { upvar ::tk::dialog::color::[winfo name $w] data - - if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || - (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} { + + if { + ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || + (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0) + } then { set data(BARS_WIDTH) $data(NUM_COLORBARS) } InitValues [winfo name $w] - foreach color [list red green blue ] { + foreach color {red green blue} { $data($color,col) configure -width $data(canvasWidth) DrawColorScale $w $color 1 } @@ -626,7 +625,7 @@ proc ::tk::dialog::color::HandleSelEntry {w} { set data(selection) $data(finalColor) return } - + set R [expr {[lindex $color 0]/0x100}] set G [expr {[lindex $color 1]/0x100}] set B [expr {[lindex $color 2]/0x100}] @@ -642,7 +641,7 @@ proc ::tk::dialog::color::HandleSelEntry {w} { proc ::tk::dialog::color::HandleRGBEntry {w} { upvar ::tk::dialog::color::[winfo name $w] data - foreach c [list red green blue] { + foreach c {red green blue} { if {[catch { set data($c,intensity) [expr {int($data($c,intensity))}] }]} { @@ -686,10 +685,9 @@ proc ::tk::dialog::color::OkCmd {w} { set Priv(selectColor) $data(finalColor) } -# user hits Cancel button +# user hits Cancel button or destroys window # proc ::tk::dialog::color::CancelCmd {w} { variable ::tk::Priv set Priv(selectColor) "" } - diff --git a/library/comdlg.tcl b/library/comdlg.tcl index 6ded323..39d27d3 100644 --- a/library/comdlg.tcl +++ b/library/comdlg.tcl @@ -182,7 +182,7 @@ proc ::tk::FocusGroup_Destroy {t w} { unset FocusOut($name) } } else { - if {[info exists Priv(focus,$t)] && $Priv(focus,$t) eq $w} { + if {[info exists Priv(focus,$t)] && ($Priv(focus,$t) eq $w)} { set Priv(focus,$t) "" } unset -nocomplain FocusIn($t,$w) FocusOut($t,$w) @@ -257,7 +257,7 @@ proc ::tk::FDGetFileTypes {string} { if {[llength $t] < 2 || [llength $t] > 3} { error "bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\"" } - eval lappend [list fileTypes([lindex $t 0])] [lindex $t 1] + lappend fileTypes([lindex $t 0]) {*}[lindex $t 1] } set types {} @@ -269,6 +269,15 @@ proc ::tk::FDGetFileTypes {string} { continue } + # Validate each macType. This is to agree with the + # behaviour of TkGetFileFilters(). This list may be + # empty. + foreach macType [lindex $t 2] { + if {[string length $macType] != 4} { + error "bad Macintosh file type \"$macType\"" + } + } + set name "$label \(" set sep "" set doAppend 1 diff --git a/library/console.tcl b/library/console.tcl index b473dd4..e44324f 100644 --- a/library/console.tcl +++ b/library/console.tcl @@ -22,7 +22,7 @@ namespace eval ::tk::console { variable showMatches 1 ; # show multiple expand matches variable inPlugin [info exists embed_args] - variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used + variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used if {$inPlugin} { @@ -48,74 +48,92 @@ proc ::tk::ConsoleInit {} { wm withdraw . } - if {$tcl_platform(platform) eq "macintosh" - || [tk windowingsystem] eq "aqua"} { + if {[tk windowingsystem] eq "aqua"} { set mod "Cmd" } else { set mod "Ctrl" } - if {[catch {menu .menubar} err]} { bgerror "INIT: $err" } - .menubar add cascade -label File -menu .menubar.file -underline 0 - .menubar add cascade -label Edit -menu .menubar.edit -underline 0 + if {[catch {menu .menubar} err]} { + bgerror "INIT: $err" + } + AmpMenuArgs .menubar add cascade -label [mc &File] -menu .menubar.file + AmpMenuArgs .menubar add cascade -label [mc &Edit] -menu .menubar.edit menu .menubar.file -tearoff 0 - .menubar.file add command -label [mc "Source..."] \ - -underline 0 -command tk::ConsoleSource - .menubar.file add command -label [mc "Hide Console"] \ - -underline 0 -command {wm withdraw .} - .menubar.file add command -label [mc "Clear Console"] \ - -underline 0 -command {.console delete 1.0 "promptEnd linestart"} - if {$tcl_platform(platform) eq "macintosh" - || [tk windowingsystem] eq "aqua"} { - .menubar.file add command -label [mc "Quit"] \ - -command exit -accel Cmd-Q - } else { - .menubar.file add command -label [mc "Exit"] \ - -underline 1 -command exit + AmpMenuArgs .menubar.file add command -label [mc "&Source..."] \ + -command {tk::ConsoleSource} + AmpMenuArgs .menubar.file add command -label [mc "&Hide Console"] \ + -command {wm withdraw .} + AmpMenuArgs .menubar.file add command -label [mc "&Clear Console"] \ + -command {.console delete 1.0 "promptEnd linestart"} + if {[tk windowingsystem] ne "aqua"} { + AmpMenuArgs .menubar.file add command -label [mc E&xit] -command {exit} } menu .menubar.edit -tearoff 0 - .menubar.edit add command -label [mc "Cut"] -underline 2 \ - -command { event generate .console <<Cut>> } -accel "$mod+X" - .menubar.edit add command -label [mc "Copy"] -underline 0 \ - -command { event generate .console <<Copy>> } -accel "$mod+C" - .menubar.edit add command -label [mc "Paste"] -underline 1 \ - -command { event generate .console <<Paste>> } -accel "$mod+V" + AmpMenuArgs .menubar.edit add command -label [mc Cu&t] -accel "$mod+X"\ + -command {event generate .console <<Cut>>} + AmpMenuArgs .menubar.edit add command -label [mc &Copy] -accel "$mod+C"\ + -command {event generate .console <<Copy>>} + AmpMenuArgs .menubar.edit add command -label [mc P&aste] -accel "$mod+V"\ + -command {event generate .console <<Paste>>} if {$tcl_platform(platform) ne "windows"} { - .menubar.edit add command -label [mc "Clear"] -underline 2 \ - -command { event generate .console <<Clear>> } + AmpMenuArgs .menubar.edit add command -label [mc Cl&ear] \ + -command {event generate .console <<Clear>>} } else { - .menubar.edit add command -label [mc "Delete"] -underline 0 \ - -command { event generate .console <<Clear>> } -accel "Del" - - .menubar add cascade -label Help -menu .menubar.help -underline 0 + AmpMenuArgs .menubar.edit add command -label [mc &Delete] \ + -command {event generate .console <<Clear>>} -accel "Del" + + AmpMenuArgs .menubar add cascade -label [mc &Help] -menu .menubar.help menu .menubar.help -tearoff 0 - .menubar.help add command -label [mc "About..."] \ - -underline 0 -command tk::ConsoleAbout + AmpMenuArgs .menubar.help add command -label [mc &About...] \ + -command tk::ConsoleAbout } + AmpMenuArgs .menubar.edit add separator + AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \ + -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>} + AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \ + -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>} + . configure -menu .menubar - set con [text .console -yscrollcommand [list .sb set] -setgrid true] - scrollbar .sb -command [list $con yview] - pack .sb -side right -fill both - pack $con -fill both -expand 1 -side left - switch -exact $tcl_platform(platform) { - "macintosh" { - $con configure -font {Monaco 10 normal} -highlightthickness 0 - } - "windows" { - $con configure -font systemfixed - } - "unix" { - if {[tk windowingsystem] eq "aqua"} { - $con configure -font {Monaco 10 normal} -highlightthickness 0 - } - } + # See if we can find a better font than the TkFixedFont + catch {font create TkConsoleFont {*}[font configure TkFixedFont]} + set families [font families] + switch -exact -- [tk windowingsystem] { + aqua { set preferred {Monaco 10} } + win32 { set preferred {ProFontWindows 8 Consolas 8} } + default { set preferred {} } + } + foreach {family size} $preferred { + if {[lsearch -exact $families $family] != -1} { + font configure TkConsoleFont -family $family -size $size + break + } } + # Provide the right border for the text widget (platform dependent). + ::ttk::style layout ConsoleFrame { + Entry.field -sticky news -border 1 -children { + ConsoleFrame.padding -sticky news + } + } + ::ttk::frame .consoleframe -style ConsoleFrame + + set con [text .console -yscrollcommand [list .sb set] -setgrid true \ + -borderwidth 0 -highlightthickness 0 -font TkConsoleFont] + if {[tk windowingsystem] eq "aqua"} { + scrollbar .sb -command [list $con yview] + } else { + ::ttk::scrollbar .sb -command [list $con yview] + } + pack .sb -in .consoleframe -fill both -side right -padx 1 -pady 1 + pack $con -in .consoleframe -fill both -expand 1 -side left -padx 1 -pady 1 + pack .consoleframe -fill both -expand 1 -side left + ConsoleBind $con $con tag configure stderr -foreground red @@ -129,6 +147,9 @@ proc ::tk::ConsoleInit {} { focus $con + # Avoid listing this console in [winfo interps] + if {[info command ::send] eq "::send"} {rename ::send {}} + wm protocol . WM_DELETE_WINDOW { wm withdraw . } wm title . [mc "Console"] flush stdout @@ -302,6 +323,39 @@ proc ::tk::ConsolePrompt {{partial normal}} { $w see end } +# Copy selected text from the console +proc ::tk::console::Copy {w} { + if {![catch {set data [$w get sel.first sel.last]}]} { + clipboard clear -displayof $w + clipboard append -displayof $w $data + } +} +# Copies selected text. If the selection is within the current active edit +# region then it will be cut, if not it is only copied. +proc ::tk::console::Cut {w} { + if {![catch {set data [$w get sel.first sel.last]}]} { + clipboard clear -displayof $w + clipboard append -displayof $w $data + if {[$w compare sel.first >= output]} { + $w delete sel.first sel.last + } + } +} +# Paste text from the clipboard +proc ::tk::console::Paste {w} { + catch { + set clip [::tk::GetSelection $w CLIPBOARD] + set list [split $clip \n\r] + tk::ConsoleInsert $w [lindex $list 0] + foreach x [lrange $list 1 end] { + $w mark set insert {end - 1c} + tk::ConsoleInsert $w "\n" + tk::ConsoleInvoke + tk::ConsoleInsert $w $x + } + } +} + # ::tk::ConsoleBind -- # This procedure first ensures that the default bindings for the Text # class have been defined. Then certain bindings are overridden for @@ -314,7 +368,9 @@ proc ::tk::ConsoleBind {w} { bindtags $w [list $w Console PostConsole [winfo toplevel $w] all] ## Get all Text bindings into Console - foreach ev [bind Text] { bind Console $ev [bind Text $ev] } + foreach ev [bind Text] { + bind Console $ev [bind Text $ev] + } ## We really didn't want the newline insertion... bind Console <Control-Key-o> {} ## ...or any Control-v binding (would block <<Paste>>) @@ -326,6 +382,8 @@ proc ::tk::ConsoleBind {w} { # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. # Otherwise, if a widget binding for one of these is defined, the + # <Keypress> class binding will also fire and insert the character + # which is wrong. bind Console <Alt-KeyPress> {# nothing } bind Console <Meta-KeyPress> {# nothing} @@ -354,22 +412,40 @@ proc ::tk::ConsoleBind {w} { <<Console_Transpose>> <Control-Key-t> <<Console_ClearLine>> <Control-Key-u> <<Console_SaveCommand>> <Control-Key-z> + <<Console_FontSizeIncr>> <Control-Key-plus> + <<Console_FontSizeDecr>> <Control-Key-minus> } { event add $ev $key bind Console $key {} } - + if {[tk windowingsystem] eq "aqua"} { + foreach {ev key} { + <<Console_FontSizeIncr>> <Command-Key-plus> + <<Console_FontSizeDecr>> <Command-Key-minus> + } { + event add $ev $key + bind Console $key {} + } + } bind Console <<Console_Expand>> { - if {[%W compare insert > promptEnd]} {::tk::console::Expand %W} + if {[%W compare insert > promptEnd]} { + ::tk::console::Expand %W + } } bind Console <<Console_ExpandFile>> { - if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path} + if {[%W compare insert > promptEnd]} { + ::tk::console::Expand %W path + } } bind Console <<Console_ExpandProc>> { - if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc} + if {[%W compare insert > promptEnd]} { + ::tk::console::Expand %W proc + } } bind Console <<Console_ExpandVar>> { - if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var} + if {[%W compare insert > promptEnd]} { + ::tk::console::Expand %W var + } } bind Console <<Console_Eval>> { %W mark set insert {end - 1c} @@ -378,7 +454,8 @@ proc ::tk::ConsoleBind {w} { break } bind Console <Delete> { - if {[%W tag nextrange sel 1.0 end] ne "" && [%W compare sel.first >= promptEnd]} { + if {{} ne [%W tag nextrange sel 1.0 end] \ + && [%W compare sel.first >= promptEnd]} { %W delete sel.first sel.last } elseif {[%W compare insert >= promptEnd]} { %W delete insert @@ -386,7 +463,8 @@ proc ::tk::ConsoleBind {w} { } } bind Console <BackSpace> { - if {[%W tag nextrange sel 1.0 end] ne "" && [%W compare sel.first >= promptEnd]} { + if {{} ne [%W tag nextrange sel 1.0 end] \ + && [%W compare sel.first >= promptEnd]} { %W delete sel.first sel.last } elseif {[%W compare insert != 1.0] && \ [%W compare insert > promptEnd]} { @@ -409,11 +487,15 @@ proc ::tk::ConsoleBind {w} { } bind Console <Control-e> [bind Console <End>] bind Console <Control-d> { - if {[%W compare insert < promptEnd]} break + if {[%W compare insert < promptEnd]} { + break + } %W delete insert } bind Console <<Console_KillLine>> { - if {[%W compare insert < promptEnd]} break + if {[%W compare insert < promptEnd]} { + break + } if {[%W compare insert == {insert lineend}]} { %W delete insert } else { @@ -467,42 +549,24 @@ proc ::tk::ConsoleBind {w} { } bind Console <F9> { eval destroy [winfo child .] - if {$tcl_platform(platform) eq "macintosh"} { - if {[catch {source [file join $tk_library console.tcl]}]} {source -rsrc console} - } else { - source [file join $tk_library console.tcl] + source [file join $tk_library console.tcl] + } + if {[tk windowingsystem] eq "aqua"} { + bind Console <Command-q> { + exit } } - if {$::tcl_platform(platform) eq "macintosh" || [tk windowingsystem] eq "aqua"} { - bind Console <Command-q> { - exit - } + bind Console <<Cut>> { ::tk::console::Cut %W } + bind Console <<Copy>> { ::tk::console::Copy %W } + bind Console <<Paste>> { ::tk::console::Paste %W } + + bind Console <<Console_FontSizeIncr>> { + set size [font configure TkConsoleFont -size] + font configure TkConsoleFont -size [incr size] } - bind Console <<Cut>> { - # Same as the copy event - if {![catch {set data [%W get sel.first sel.last]}]} { - clipboard clear -displayof %W - clipboard append -displayof %W $data - } - } - bind Console <<Copy>> { - if {![catch {set data [%W get sel.first sel.last]}]} { - clipboard clear -displayof %W - clipboard append -displayof %W $data - } - } - bind Console <<Paste>> { - catch { - set clip [::tk::GetSelection %W CLIPBOARD] - set list [split $clip \n\r] - tk::ConsoleInsert %W [lindex $list 0] - foreach x [lrange $list 1 end] { - %W mark set insert {end - 1c} - tk::ConsoleInsert %W "\n" - tk::ConsoleInvoke - tk::ConsoleInsert %W $x - } - } + bind Console <<Console_FontSizeDecr>> { + set size [font configure TkConsoleFont -size] + font configure TkConsoleFont -size [incr size -1] } ## @@ -533,7 +597,6 @@ proc ::tk::ConsoleBind {w} { if {"%A" ne ""} { ::tk::console::TagProc %W } - break } } @@ -552,7 +615,7 @@ proc ::tk::ConsoleInsert {w s} { return } catch { - if {[$w compare sel.first <= insert] + if {[$w compare sel.first <= insert] \ && [$w compare sel.last >= insert]} { $w tag remove sel sel.first promptEnd $w delete sel.first sel.last @@ -618,10 +681,16 @@ Tk $::tk_patchLevel" # w - console text widget proc ::tk::console::TagProc w { - if {!$::tk::console::magicKeys} { return } + if {!$::tk::console::magicKeys} { + return + } set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]" set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c] - if {$i eq ""} {set i promptEnd} else {append i +2c} + if {$i eq ""} { + set i promptEnd + } else { + append i +2c + } regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c if {[llength [EvalAttached [list info commands $c]]]} { $w tag add proc $i "insert-1c wordend" @@ -653,30 +722,42 @@ proc ::tk::console::TagProc w { # Calls: ::tk::console::Blink proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} { - if {!$::tk::console::magicKeys} { return } - if {[set ix [$w search -back $c1 insert $lim]] ne ""} { + if {!$::tk::console::magicKeys} { + return + } + if {{} ne [set ix [$w search -back $c1 insert $lim]]} { while { [string match {\\} [$w get $ix-1c]] && - [set ix [$w search -back $c1 $ix-1c $lim]] ne "" + [set ix [$w search -back $c1 $ix-1c $lim]] ne {} } {} set i1 insert-1c - while {$ix ne ""} { + while {$ix ne {}} { set i0 $ix set j 0 - while {[set i0 [$w search $c2 $i0 $i1]] ne ""} { + while {[set i0 [$w search $c2 $i0 $i1]] ne {}} { append i0 +1c - if {[string match {\\} [$w get $i0-2c]]} continue + if {[string match {\\} [$w get $i0-2c]]} { + continue + } incr j } - if {!$j} break + if {!$j} { + break + } set i1 $ix - while {$j && [set ix [$w search -back $c1 $ix $lim]] ne ""} { - if {[string match {\\} [$w get $ix-1c]]} continue + while {$j && [set ix [$w search -back $c1 $ix $lim]] ne {}} { + if {[string match {\\} [$w get $ix-1c]]} { + continue + } incr j -1 } } - if {[string match {} $ix]} { set ix [$w index $lim] } - } else { set ix [$w index $lim] } + if {[string match {} $ix]} { + set ix [$w index $lim] + } + } else { + set ix [$w index $lim] + } if {$::tk::console::blinkRange} { Blink $w $ix [$w index insert] } else { @@ -696,12 +777,18 @@ proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} { # Calls: ::tk::console::Blink proc ::tk::console::MatchQuote {w {lim 1.0}} { - if {!$::tk::console::magicKeys} { return } + if {!$::tk::console::magicKeys} { + return + } set i insert-1c set j 0 - while {[set i [$w search -back \" $i $lim]] ne ""} { - if {[string match {\\} [$w get $i-1c]]} continue - if {!$j} {set i0 $i} + while {[set i [$w search -back \" $i $lim]] ne {}} { + if {[string match {\\} [$w get $i-1c]]} { + continue + } + if {!$j} { + set i0 $i + } incr j } if {$j&1} { @@ -769,17 +856,31 @@ proc ::tk::console::ConstrainBuffer {w size} { proc ::tk::console::Expand {w {type ""}} { set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]" set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c] - if {$tmp eq ""} {set tmp promptEnd} else {append tmp +2c} - if {[$w compare $tmp >= insert]} { return } + if {$tmp eq ""} { + set tmp promptEnd + } else { + append tmp +2c + } + if {[$w compare $tmp >= insert]} { + return + } set str [$w get $tmp insert] switch -glob $type { - path* { set res [ExpandPathname $str] } - proc* { set res [ExpandProcname $str] } - var* { set res [ExpandVariable $str] } + path* { + set res [ExpandPathname $str] + } + proc* { + set res [ExpandProcname $str] + } + var* { + set res [ExpandVariable $str] + } default { set res {} foreach t {Pathname Procname Variable} { - if {![catch {Expand$t $str} res] && ($res ne "")} { break } + if {![catch {Expand$t $str} res] && ($res ne "")} { + break + } } } } @@ -788,10 +889,12 @@ proc ::tk::console::Expand {w {type ""}} { set repl [lindex $res 0] $w delete $tmp insert $w insert $tmp $repl {input stdin} - if {($len > 1) && $::tk::console::showMatches && $repl eq $str} { + if {($len > 1) && ($::tk::console::showMatches) && ($repl eq $str)} { puts stdout [lsort [lreplace $res 0 0]] } - } else { bell } + } else { + bell + } return [incr len -1] } @@ -816,7 +919,9 @@ proc ::tk::console::ExpandPathname str { set dir [file tail $str] ## Check to see if it was known to be a directory and keep the trailing ## slash if so (file tail cuts it off) - if {[string match */ $str]} { append dir / } + if {[string match */ $str]} { + append dir / + } if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} { set match {} } else { @@ -843,7 +948,9 @@ proc ::tk::console::ExpandPathname str { } else { ## This may look goofy, but it handles spaces in path names eval append match $m - if {[file isdir $match]} {append match /} + if {[file isdir $match]} { + append match / + } if {[string match ?*/* $str]} { set match [file dirname $str]/$match } elseif {[string match /* $str]} { @@ -903,12 +1010,14 @@ proc ::tk::console::ExpandProcname str { # possible further matches proc ::tk::console::ExpandVariable str { - if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { + if {[regexp {([^\(]*)\((.*)} $str -> ary str]} { ## Looks like they're trying to expand an array. set match [EvalAttached [list array names $ary $str*]] if {[llength $match] > 1} { set vars $ary\([ExpandBestMatch $match $str] - foreach var $match {lappend vars $ary\($var\)} + foreach var $match { + lappend vars $ary\($var\) + } return $vars } elseif {[llength $match] == 1} { set match $ary\($match\) @@ -941,8 +1050,8 @@ proc ::tk::console::ExpandVariable str { proc ::tk::console::ExpandBestMatch {l {e {}}} { set ec [lindex $l 0] if {[llength $l]>1} { - set e [string length $e]; incr e -1 - set ei [string length $ec]; incr ei -1 + set e [expr {[string length $e] - 1}] + set ei [expr {[string length $ec] - 1}] foreach l $l { while {$ei>=$e && [string first $ec $l]} { set ec [string range $ec 0 [incr ei -1]] @@ -953,4 +1062,4 @@ proc ::tk::console::ExpandBestMatch {l {e {}}} { } # now initialize the console -::tk::ConsoleInit +::tk::ConsoleInit diff --git a/library/demos/README b/library/demos/README index cb856cb..7285a93 100644 --- a/library/demos/README +++ b/library/demos/README @@ -1,9 +1,9 @@ This directory contains a collection of programs to demonstrate the features of the Tk toolkit. The programs are all scripts for -"wish", a windowing shell. If wish has been installed in /usr/local +"wish", a windowing shell. If wish has been installed on your path then you can invoke any of the programs in this directory just -by typing its file name to your command shell. Otherwise invoke -wish with the file as its first argument, e.g., "wish hello". +by typing its file name to your command shell under Unix. Otherwise +invoke wish with the file as its first argument, e.g., "wish hello". The rest of this file contains a brief description of each program. Files with names ending in ".tcl" are procedure packages used by one or more of the demo programs; they can't be used as programs by diff --git a/library/demos/anilabel.tcl b/library/demos/anilabel.tcl new file mode 100644 index 0000000..61e6315 --- /dev/null +++ b/library/demos/anilabel.tcl @@ -0,0 +1,160 @@ +# anilabel.tcl -- +# +# This demonstration script creates a toplevel window containing +# several animated label widgets. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk + +set w .anilabel +catch {destroy $w} +toplevel $w +wm title $w "Animated Label Demonstration" +wm iconname $w "anilabel" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "Four animated labels are displayed below; each of the labels on the left is animated by making the text message inside it appear to scroll, and the label on the right is animated by animating the image that it displays." +pack $w.msg -side top + +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x + +# Ensure that this this is an array +array set animationCallbacks {} + +## This callback is the core of how to do animation in Tcl/Tk; all +## animations work in basically the same way, with a procedure that +## uses the [after] command to reschedule itself at some point in the +## future. Of course, the details of how to update the state will vary +## according to what is being animated. +proc RotateLabelText {w interval} { + global animationCallbacks + + # Schedule the calling of this procedure again in the future + set animationCallbacks($w) [after $interval RotateLabelText $w $interval] + + # We do marquee-like scrolling text by chopping characters off the + # front of the text and sticking them on the end. + set text [$w cget -text] + set newText [string range $text 1 end][string index $text 0] + $w configure -text $newText +} + +## A helper procedure to start the animation happening. +proc animateLabelText {w text interval} { + global animationCallbacks + + # Install the text into the widget + $w configure -text $text + + # Schedule the start of the animation loop + set animationCallbacks($w) [after $interval RotateLabelText $w $interval] + + # Make sure that the animation stops and is cleaned up after itself + # when the animated label is destroyed. Note that at this point we + # cannot manipulate the widget itself, as that has already died. + bind $w <Destroy> { + after cancel $animationCallbacks(%W) + unset animationCallbacks(%W) + } +} + +## Next, a similar pair of procedures to animate a GIF loaded into a +## photo image. +proc SelectNextImageFrame {w interval} { + global animationCallbacks + set animationCallbacks($w) \ + [after $interval SelectNextImageFrame $w $interval] + set image [$w cget -image] + + # The easy way to animate a GIF! + set idx -1 + scan [$image cget -format] "GIF -index %d" idx + if {[catch { + # Note that we get an error if the index is out of range + $image configure -format "GIF -index [incr idx]" + }]} then { + $image configure -format "GIF -index 0" + } +} +proc animateLabelImage {w imageData interval} { + global animationCallbacks + + # Create a multi-frame GIF from base-64-encoded data + set image [image create photo -format GIF -data $imageData] + + # Install the image into the widget + $w configure -image $image + + # Schedule the start of the animation loop + set animationCallbacks($w) \ + [after $interval SelectNextImageFrame $w $interval] + + # Make sure that the animation stops and is cleaned up after itself + # when the animated label is destroyed. Note that at this point we + # cannot manipulate the widget itself, as that has already died. + # Also note that this script is in double-quotes; this is always OK + # because image names are chosen automatically to be simple words. + bind $w <Destroy> " + after cancel \$animationCallbacks(%W) + unset animationCallbacks(%W) + rename $image {} + " +} + +# Make some widgets to contain the animations +labelframe $w.left -text "Scrolling Texts" +labelframe $w.right -text "GIF Image" +pack $w.left $w.right -side left -padx 10 -pady 10 -expand yes + +# This method of scrolling text looks far better with a fixed-width font +label $w.left.l1 -bd 4 -relief ridge -font fixedFont +label $w.left.l2 -bd 4 -relief groove -font fixedFont +label $w.left.l3 -bd 4 -relief flat -font fixedFont -width 18 +pack $w.left.l1 $w.left.l2 $w.left.l3 -side top -expand yes -padx 10 -pady 10 -anchor w +# Don't need to do very much with this label except turn off the border +label $w.right.l -bd 0 +pack $w.right.l -side top -expand yes -padx 10 -pady 10 + +# This is a base-64-encoded animated GIF file. +set tclPoweredData { + R0lGODlhKgBAAPQAAP//////zP//AP/MzP/Mmf/MAP+Zmf+ZZv+ZAMz//8zM + zMyZmcyZZsxmZsxmAMwzAJnMzJmZzJmZmZlmmZlmZplmM5kzM2aZzGZmzGZm + mWZmZmYzZmYzMzNmzDMzZgAzmSH+IE1hZGUgd2l0aCBHSU1QIGJ5IExARGVt + YWlsbHkuY29tACH5BAVkAAEALAAAAAAqAEAAAAX+YCCOZEkyTKM2jOm66yPP + dF03bx7YcuHIDkGBR7SZeIyhTID4FZ+4Es8nQyCe2EeUNJ0peY2s9mi7PhAM + ngEAMGRbUpvzSxskLh1J+Hkg134OdDIDEB+GHxtYMEQMTjMGEYeGFoomezaC + DZGSHFmLXTQKkh8eNQVpZ2afmDQGHaOYSoEyhhcklzVmMpuHnaZmDqiGJbg0 + qFqvh6UNAwB7VA+OwydEjgujkgrPNhbTI8dFvNgEYcHcHx0lB1kX2IYeA2G6 + NN0YfkXJ2BsAMuAzHB9cZMk3qoEbRzUACsRCUBK5JxsC3iMiKd8GN088SIyT + 0RAFSROyeEg38caDiB/+JEgqxsODrZJ1BkT0oHKSmI0ceQxo94HDpg0qsuDk + UmRAMgu8OgwQ+uIJgUMVeGXA+IQkzEeHGvD8cIGlDXsLiRjQ+EHroQhea7xY + 8IQBSgYYDi1IS+OFBCgaDMGVS3fGi5BPJpBaENdQ0EomKGD56IHwO39EXiSC + Ysgxor5+Xfgq0qByYUpiXmwuoredB2aYH4gWWda0B7SeNENpEJHC1ghi+pS4 + AJpIAwWvKPBi+8YEht5EriEqpFfMlhEdkBNpx0HUhwypx5T4IB1MBg/Ws2sn + wV3MSQOkzI8fUd48Aw3dOZto71x85hHtHijYv18Gf/3GqCdDCXHNoICBobSo + IqBqJLyCoH8JPrLgdh88CKCFD0CGmAiGYPgffwceZh6FC2ohIIklnkhehTNY + 4CIHHGzgwYw01ujBBhvAqKOLLq5AAk9kuSPkkKO40NB+h1gnypJIIvkBf09a + N5QIRz5p5ZJXJpmlIVhOGQA2TmIJZZhKKmmll2BqyWSXWUrZpQtpatlmk1c2 + KaWRHeTZEJF8SqLDn/hhsOeQgBbqAh6DGqronxeARUIIACH5BAUeAAAALAUA + LgAFAAUAAAUM4CeKz/OV5YmqaRkCACH5BAUeAAEALAUALgAKAAUAAAUUICCK + z/OdJVCaa7p+7aOWcDvTZwgAIfkEBR4AAQAsCwAuAAkABQAABRPgA4zP95zA + eZqoWqqpyqLkZ38hACH5BAUKAAEALAcALgANAA4AAAU7ICA+jwiUJEqeKau+ + r+vGaTmac63v/GP9HM7GQyx+jsgkkoRUHJ3Qx0cK/VQVTKtWwbVKn9suNunc + WkMAIfkEBQoAAAAsBwA3AAcABQAABRGgIHzk842j+Yjlt5KuO8JmCAAh+QQF + CgAAACwLADcABwAFAAAFEeAnfN9TjqP5oOWziq05lmUIACH5BAUKAAAALA8A + NwAHAAUAAAUPoPCJTymS3yiQj4qOcPmEACH5BAUKAAAALBMANwAHAAUAAAUR + oCB+z/MJX2o+I2miKimiawgAIfkEBQoAAAAsFwA3AAcABQAABRGgIHzfY47j + Q4qk+aHl+pZmCAAh+QQFCgAAACwbADcABwAFAAAFEaAgfs/zCV9qPiNJouo7 + ll8IACH5BAUKAAAALB8ANwADAAUAAAUIoCB8o0iWZggAOw== +} + +# Finally, set up the text scrolling animation +animateLabelText $w.left.l1 "* Slow Animation *" 300 +animateLabelText $w.left.l2 "* Fast Animation *" 80 +animateLabelText $w.left.l3 "This is a longer scrolling text in a widget that will not show the whole message at once. " 150 +animateLabelImage $w.right.l $tclPoweredData 100 diff --git a/library/demos/aniwave.tcl b/library/demos/aniwave.tcl new file mode 100644 index 0000000..6122132 --- /dev/null +++ b/library/demos/aniwave.tcl @@ -0,0 +1,104 @@ +# aniwave.tcl -- +# +# This demonstration script illustrates how to adjust canvas item +# coordinates in a way that does something fairly similar to waveform +# display. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk + +set w .aniwave +catch {destroy $w} +toplevel $w +wm title $w "Animated Wave Demonstration" +wm iconname $w "aniwave" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration contains a canvas widget with a line item inside it. The animation routines work by adjusting the coordinates list of the line; a trace on a variable is used so updates to the variable result in a change of position of the line." +pack $w.msg -side top + +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x + +# Create a canvas large enough to hold the wave. In fact, the wave +# sticks off both sides of the canvas to prevent visual glitches. +pack [canvas $w.c -width 300 -height 200 -background black] -padx 10 -pady 10 -expand yes + +# Ensure that this this is an array +array set animationCallbacks {} + +# Creates a coordinates list of a wave. This code does a very sketchy +# job and relies on Tk's line smoothing to make things look better. +set waveCoords {} +for {set x -10} {$x<=300} {incr x 5} { + lappend waveCoords $x 100 +} +lappend waveCoords $x 0 [incr x 5] 200 + +# Create a smoothed line and arrange for its coordinates to be the +# contents of the variable waveCoords. +$w.c create line $waveCoords -tags wave -width 1 -fill green -smooth 1 +proc waveCoordsTracer {w args} { + global waveCoords + # Actual visual update will wait until we have finished + # processing; Tk does that for us automatically. + $w.c coords wave $waveCoords +} +trace add variable waveCoords write [list waveCoordsTracer $w] + +# Basic motion handler. Given what direction the wave is travelling +# in, it advances the y coordinates in the coordinate-list one step in +# that direction. +proc basicMotion {} { + global waveCoords direction + set oc $waveCoords + for {set i 1} {$i<[llength $oc]} {incr i 2} { + if {$direction eq "left"} { + lset waveCoords $i [lindex $oc \ + [expr {$i+2>[llength $oc] ? 1 : $i+2}]] + } else { + lset waveCoords $i \ + [lindex $oc [expr {$i-2<0 ? "end" : $i-2}]] + } + } +} + +# Oscillation handler. This detects whether to reverse the direction +# of the wave by checking to see if the peak of the wave has moved off +# the screen (whose size we know already.) +proc reverser {} { + global waveCoords direction + if {[lindex $waveCoords 1] < 10} { + set direction "right" + } elseif {[lindex $waveCoords end] < 10} { + set direction "left" + } +} + +# Main animation "loop". This calls the two procedures that handle the +# movement repeatedly by scheduling asynchronous calls back to itself +# using the [after] command. This procedure is the fundamental basis +# for all animated effect handling in Tk. +proc move {} { + basicMotion + reverser + + # Theoretically 100 frames-per-second (==10ms between frames) + global animationCallbacks + set animationCallbacks(simpleWave) [after 10 move] +} + +# Initialise our remaining animation variables +set direction "left" +set animateAfterCallback {} +# Arrange for the animation loop to stop when the canvas is deleted +bind $w.c <Destroy> { + after cancel $animationCallbacks(simpleWave) + unset animationCallbacks(simpleWave) +} +# Start the animation processing +move diff --git a/library/demos/arrow.tcl b/library/demos/arrow.tcl index 61b17dc..5011f6f 100644 --- a/library/demos/arrow.tcl +++ b/library/demos/arrow.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + # arrowSetup -- # This procedure regenerates all the text and graphics in the canvas # window. It's called when the canvas is initially created, and also @@ -105,7 +107,6 @@ proc arrowSetup c { } set w .arrow -global tk_library catch {destroy $w} toplevel $w wm title $w "Arrowhead Editor Demonstration" @@ -116,11 +117,9 @@ set c $w.c label $w.msg -font $font -wraplength 5i -justify left -text "This widget allows you to experiment with different widths and arrowhead shapes for lines in canvases. To change the line width or the shape of the arrowhead, drag any of the three boxes attached to the oversized arrow. The arrows on the right give examples at normal scale. The text at the bottom shows the configuration options as you'd enter them for a canvas line item." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x canvas $c -width 500 -height 350 -relief sunken -borderwidth 2 pack $c -expand yes -fill both @@ -140,8 +139,9 @@ if {[winfo depth $c] > 1} { set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" set demo_arrowInfo(activeStyle) "-fill red -outline black -width 1" } else { + # Main widget program sets variable tk_demoDirectory set demo_arrowInfo(bigLineStyle) "-fill black \ - -stipple @[file join $tk_library demos images grey.25]" + -stipple @[file join $tk_demoDirectory images grey.25]" set demo_arrowInfo(boxStyle) "-fill {} -outline black -width 1" set demo_arrowInfo(activeStyle) "-fill black -outline black -width 1" } diff --git a/library/demos/bind.tcl b/library/demos/bind.tcl index 4b4e1ac..d9bc22f 100644 --- a/library/demos/bind.tcl +++ b/library/demos/bind.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .bind catch {destroy $w} toplevel $w @@ -14,11 +16,9 @@ wm title $w "Text Demonstration - Tag Bindings" wm iconname $w "bind" positionWindow $w -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ -width 60 -height 24 -font $font -wrap word @@ -66,12 +66,13 @@ foreach tag {d1 d2 d3 d4 d5 d6} { $w.text tag bind $tag <Any-Enter> "$w.text tag configure $tag $bold" $w.text tag bind $tag <Any-Leave> "$w.text tag configure $tag $normal" } -$w.text tag bind d1 <1> {source [file join $tk_library demos items.tcl]} -$w.text tag bind d2 <1> {source [file join $tk_library demos plot.tcl]} -$w.text tag bind d3 <1> {source [file join $tk_library demos ctext.tcl]} -$w.text tag bind d4 <1> {source [file join $tk_library demos arrow.tcl]} -$w.text tag bind d5 <1> {source [file join $tk_library demos ruler.tcl]} -$w.text tag bind d6 <1> {source [file join $tk_library demos cscroll.tcl]} +# Main widget program sets variable tk_demoDirectory +$w.text tag bind d1 <1> {source [file join $tk_demoDirectory items.tcl]} +$w.text tag bind d2 <1> {source [file join $tk_demoDirectory plot.tcl]} +$w.text tag bind d3 <1> {source [file join $tk_demoDirectory ctext.tcl]} +$w.text tag bind d4 <1> {source [file join $tk_demoDirectory arrow.tcl]} +$w.text tag bind d5 <1> {source [file join $tk_demoDirectory ruler.tcl]} +$w.text tag bind d6 <1> {source [file join $tk_demoDirectory cscroll.tcl]} $w.text mark set insert 0.0 $w.text configure -state disabled diff --git a/library/demos/bitmap.tcl b/library/demos/bitmap.tcl index e0a5d94..453987d 100644 --- a/library/demos/bitmap.tcl +++ b/library/demos/bitmap.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + # bitmapRow -- # Create a row of bitmap items in a window. # @@ -31,7 +33,6 @@ proc bitmapRow {w args} { } set w .bitmap -global tk_library catch {destroy $w} toplevel $w wm title $w "Bitmap Demonstration" @@ -41,11 +42,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "This window displays all of Tk's built-in bitmaps, along with the names you can use for them in Tcl scripts." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.frame bitmapRow $w.frame.0 error gray12 gray25 gray50 gray75 diff --git a/library/demos/browse b/library/demos/browse index 2de9ec0..d107f28 100644 --- a/library/demos/browse +++ b/library/demos/browse @@ -7,6 +7,8 @@ exec wish "$0" ${1+"$@"} # directory and allows you to open files or subdirectories by # double-clicking. +package require Tk + # Create a scrollbar on the right side of the main window and a listbox # on the left side. diff --git a/library/demos/button.tcl b/library/demos/button.tcl index d11416c..bb943e6 100644 --- a/library/demos/button.tcl +++ b/library/demos/button.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .button catch {destroy $w} toplevel $w @@ -17,20 +19,16 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "If you click on any of the four buttons below, the background of the button area will change to the color indicated in the button. You can press Tab to move among the buttons, then press Space to invoke the current button." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +pack [addSeeDismiss $w.buttons $w] -side bottom -fill x proc colorrefresh {w col} { $w configure -bg $col - $w.buttons configure -bg $col if {[tk windowingsystem] eq "aqua"} { # set highlightbackground of all buttons in $w set l [list $w] while {[llength $l]} { - set l [concat [lrange $l 1 end] [winfo children [set b [lindex $l 0]]]] + set l [concat [lassign $l b] [winfo children $b]] if {[winfo class $b] eq "Button"} { $b configure -highlightbackground $col } diff --git a/library/demos/check.tcl b/library/demos/check.tcl index 4ec9ef3..c072096 100644 --- a/library/demos/check.tcl +++ b/library/demos/check.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .check catch {destroy $w} toplevel $w @@ -14,18 +16,56 @@ wm title $w "Checkbutton Demonstration" wm iconname $w "check" positionWindow $w -label $w.msg -font $font -wraplength 4i -justify left -text "Three checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. Click the \"See Variables\" button to see the current values of the variables." +label $w.msg -font $font -wraplength 4i -justify left -text "Four checkbuttons are displayed below. If you click on a button, it will toggle the button's selection state and set a Tcl variable to a value indicating the state of the checkbutton. The first button also follows the state of the other three. If only some of the three are checked, the first button will display the tri-state mode. Click the \"See Variables\" button to see the current values of the variables." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -button $w.buttons.vars -text "See Variables" \ - -command "showVars $w.dialog wipers brakes sober" -pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w [list safety wipers brakes sober]] +pack $btns -side bottom -fill x +checkbutton $w.b0 -text "Safety Check" -variable safety -relief flat \ + -onvalue "all" \ + -offvalue "none" \ + -tristatevalue "partial" checkbutton $w.b1 -text "Wipers OK" -variable wipers -relief flat checkbutton $w.b2 -text "Brakes OK" -variable brakes -relief flat checkbutton $w.b3 -text "Driver Sober" -variable sober -relief flat -pack $w.b1 $w.b2 $w.b3 -side top -pady 2 -anchor w +pack $w.b0 -side top -pady 2 -anchor w +pack $w.b1 $w.b2 $w.b3 -side top -pady 2 -anchor w -padx 15 + +## This code makes $w.b0 function as a tri-state button; it's not +## needed at all for just straight yes/no buttons. + +set in_check 0 +proc tristate_check {n1 n2 op} { + global safety wipers brakes sober in_check + if {$in_check} { + return + } + set in_check 1 + if {$n1 eq "safety"} { + if {$safety eq "none"} { + set wipers 0 + set brakes 0 + set sober 0 + } elseif {$safety eq "all"} { + set wipers 1 + set brakes 1 + set sober 1 + } + } else { + if {$wipers == 1 && $brakes == 1 && $sober == 1} { + set safety all + } elseif {$wipers == 1 || $brakes == 1 || $sober == 1} { + set safety partial + } else { + set safety none + } + } + set in_check 0 +} + +trace variable wipers w tristate_check +trace variable brakes w tristate_check +trace variable sober w tristate_check +trace variable safety w tristate_check diff --git a/library/demos/clrpick.tcl b/library/demos/clrpick.tcl index 4abd5a7..ba50b75 100644 --- a/library/demos/clrpick.tcl +++ b/library/demos/clrpick.tcl @@ -6,6 +6,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .clrpick catch {destroy $w} toplevel $w @@ -16,11 +18,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "Press the buttons below to choose the foreground and background colors for the widgets in this window." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x button $w.back -text "Set background color ..." \ -command \ diff --git a/library/demos/colors.tcl b/library/demos/colors.tcl index ff72bee..99dec92 100644 --- a/library/demos/colors.tcl +++ b/library/demos/colors.tcl @@ -8,6 +8,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .colors catch {destroy $w} toplevel $w @@ -18,11 +20,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing several color names is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by dragging in the listbox window with button 2 pressed. If you double-click button 1 on a color, then the application's color palette will be set to match that color" pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.frame -borderwidth 10 pack $w.frame -side top -expand yes -fill y diff --git a/library/demos/combo.tcl b/library/demos/combo.tcl new file mode 100644 index 0000000..5dad9f0 --- /dev/null +++ b/library/demos/combo.tcl @@ -0,0 +1,62 @@ +# combo.tcl -- +# +# This demonstration script creates several combobox widgets. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .combo +catch {destroy $w} +toplevel $w +wm title $w "Combobox Demonstration" +wm iconname $w "combo" +positionWindow $w + +ttk::label $w.msg -font $font -wraplength 5i -justify left -text "Three different\ + combo-boxes are displayed below. You can add characters to the first\ + one by pointing, clicking and typing, just as with an entry; pressing\ + Return will cause the current value to be added to the list that is\ + selectable from the drop-down list, and you can choose other values\ + by pressing the Down key, using the arrow keys to pick another one,\ + and pressing Return again. The second combo-box is fixed to a\ + particular value, and cannot be modified at all. The third one only\ + allows you to select values from its drop-down list of Australian\ + cities." +pack $w.msg -side top -fill x + +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w {firstValue secondValue ozCity}] +pack $btns -side bottom -fill x + +ttk::frame $w.f +pack $w.f -fill both -expand 1 +set w $w.f + +set australianCities { + Canberra Sydney Melbourne Perth Adelaide Brisbane + Hobart Darwin "Alice Springs" +} +set secondValue unchangable +set ozCity Sydney + +ttk::labelframe $w.c1 -text "Fully Editable" +ttk::combobox $w.c1.c -textvariable firstValue +ttk::labelframe $w.c2 -text Disabled +ttk::combobox $w.c2.c -textvariable secondValue -state disabled +ttk::labelframe $w.c3 -text "Defined List Only" +ttk::combobox $w.c3.c -textvariable ozCity -state readonly \ + -values $australianCities +bind $w.c1.c <Return> { + if {[%W get] ni [%W cget -values]} { + %W configure -values [concat [%W cget -values] [list [%W get]]] + } +} + +pack $w.c1 $w.c2 $w.c3 -side top -pady 5 -padx 10 +pack $w.c1.c -pady 5 -padx 10 +pack $w.c2.c -pady 5 -padx 10 +pack $w.c3.c -pady 5 -padx 10 diff --git a/library/demos/cscroll.tcl b/library/demos/cscroll.tcl index 7fa1dcc..f6e88f4 100644 --- a/library/demos/cscroll.tcl +++ b/library/demos/cscroll.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .cscroll catch {destroy $w} toplevel $w @@ -18,11 +20,9 @@ set c $w.c label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget that can be scrolled either using the scrollbars or by dragging with button 2 in the canvas. If you click button 1 on one of the rectangles, its indices will be printed on stdout." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.grid scrollbar $w.hscroll -orient horiz -command "$c xview" diff --git a/library/demos/ctext.tcl b/library/demos/ctext.tcl index 3be4b58..e894bc2 100644 --- a/library/demos/ctext.tcl +++ b/library/demos/ctext.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .ctext catch {destroy $w} toplevel $w @@ -25,11 +27,9 @@ label $w.msg -font $font -wraplength 5i -justify left -text "This window display the character just after the insertion cursor." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x canvas $c -relief flat -borderwidth 0 -width 500 -height 350 pack $w.c -side top -expand yes -fill both @@ -40,7 +40,7 @@ $c create rectangle 245 195 255 205 -outline black -fill red # First, create the text item and give it bindings so it can be edited. -$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)." -width 440 -anchor n -font {Helvetica 24} -justify left] +$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)." -width 440 -anchor n -font $textFont -justify left] $c bind text <1> "textB1Press $c %x %y" $c bind text <B1-Motion> "textB1Move $c %x %y" $c bind text <Shift-1> "$c select adjust current @%x,%y" diff --git a/library/demos/en.msg b/library/demos/en.msg new file mode 100644 index 0000000..d4783fe --- /dev/null +++ b/library/demos/en.msg @@ -0,0 +1,97 @@ +::msgcat::mcset en "Widget Demonstration" +::msgcat::mcset en "tkWidgetDemo" +::msgcat::mcset en "&File" +::msgcat::mcset en "About..." +::msgcat::mcset en "&About..." +::msgcat::mcset en "<F1>" +::msgcat::mcset en "&Quit" +::msgcat::mcset en "Meta+Q" ;# Displayed hotkey +::msgcat::mcset en "Meta-q" ;# Actual binding sequence +::msgcat::mcset en "Ctrl+Q" ;# Displayed hotkey +::msgcat::mcset en "Control-q" ;# Actual binding sequence +::msgcat::mcset en "Variable values" +::msgcat::mcset en "Variable values:" +::msgcat::mcset en "OK" +::msgcat::mcset en "Run the \"%s\" sample program" +::msgcat::mcset en "Dismiss" +::msgcat::mcset en "Rerun Demo" +::msgcat::mcset en "Demo code: %s" +::msgcat::mcset en "About Widget Demo" +::msgcat::mcset en "Tk widget demonstration application" +::msgcat::mcset en "Copyright (c) %s" "Copyright \u00a9 %s" +::msgcat::mcset en " + @@title + Tk Widget Demonstrations + @@newline + @@normal + @@newline + + This application provides a front end for several short scripts + that demonstrate what you can do with Tk widgets. Each of the + numbered lines below describes a demonstration; you can click on + it to invoke the demonstration. Once the demonstration window + appears, you can click the + @@bold + See Code + @@normal + button to see the Tcl/Tk code that created the demonstration. If + you wish, you can edit the code and click the + @@bold + Rerun Demo + @@normal + button in the code window to reinvoke the demonstration with the + modified code. + @@newline +" +::msgcat::mcset en "Labels, buttons, checkbuttons, and radiobuttons" +::msgcat::mcset en "Labels (text and bitmaps)" +::msgcat::mcset en "Labels and UNICODE text" +::msgcat::mcset en "Buttons" +::msgcat::mcset en "Check-buttons (select any of a group)" +::msgcat::mcset en "Radio-buttons (select one of a group)" +::msgcat::mcset en "A 15-puzzle game made out of buttons" +::msgcat::mcset en "Iconic buttons that use bitmaps" +::msgcat::mcset en "Two labels displaying images" +::msgcat::mcset en "A simple user interface for viewing images" +::msgcat::mcset en "Labelled frames" +::msgcat::mcset en "Listboxes" +::msgcat::mcset en "The 50 states" +::msgcat::mcset en "Colors: change the color scheme for the application" +::msgcat::mcset en "A collection of famous and infamous sayings" +::msgcat::mcset en "Entries and Spin-boxes" +::msgcat::mcset en "Entries without scrollbars" +::msgcat::mcset en "Entries with scrollbars" +::msgcat::mcset en "Validated entries and password fields" +::msgcat::mcset en "Spin-boxes" +::msgcat::mcset en "Simple Rolodex-like form" +::msgcat::mcset en "Text" +::msgcat::mcset en "Basic editable text" +::msgcat::mcset en "Text display styles" +::msgcat::mcset en "Hypertext (tag bindings)" +::msgcat::mcset en "A text widget with embedded windows" +::msgcat::mcset en "A search tool built with a text widget" +::msgcat::mcset en "Canvases" +::msgcat::mcset en "The canvas item types" +::msgcat::mcset en "A simple 2-D plot" +::msgcat::mcset en "Text items in canvases" +::msgcat::mcset en "An editor for arrowheads on canvas lines" +::msgcat::mcset en "A ruler with adjustable tab stops" +::msgcat::mcset en "A building floor plan" +::msgcat::mcset en "A simple scrollable canvas" +::msgcat::mcset en "Scales" +::msgcat::mcset en "Horizontal scale" +::msgcat::mcset en "Vertical scale" +::msgcat::mcset en "Paned Windows" +::msgcat::mcset en "Horizontal paned window" +::msgcat::mcset en "Vertical paned window" +::msgcat::mcset en "Menus" +::msgcat::mcset en "Menus and cascades (sub-menus)" +::msgcat::mcset en "Menu-buttons" +::msgcat::mcset en "Common Dialogs" +::msgcat::mcset en "Message boxes" +::msgcat::mcset en "File selection dialog" +::msgcat::mcset en "Color picker" +::msgcat::mcset en "Miscellaneous" +::msgcat::mcset en "The built-in bitmaps" +::msgcat::mcset en "A dialog box with a local grab" +::msgcat::mcset en "A dialog box with a global grab" diff --git a/library/demos/entry1.tcl b/library/demos/entry1.tcl index 0136b84..eef8964 100644 --- a/library/demos/entry1.tcl +++ b/library/demos/entry1.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .entry1 catch {destroy $w} toplevel $w @@ -17,11 +19,9 @@ positionWindow $w label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries by dragging with mouse button2 pressed." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x entry $w.e1 entry $w.e2 diff --git a/library/demos/entry2.tcl b/library/demos/entry2.tcl index a81e0d5..d0ca35a 100644 --- a/library/demos/entry2.tcl +++ b/library/demos/entry2.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .entry2 catch {destroy $w} toplevel $w @@ -17,11 +19,9 @@ positionWindow $w label $w.msg -font $font -wraplength 5i -justify left -text "Three different entries are displayed below, with a scrollbar for each entry. You can add characters by pointing, clicking and typing. The normal Motif editing characters are supported, along with many Emacs bindings. For example, Backspace and Control-h delete the character to the left of the insertion cursor and Delete and Control-d delete the chararacter to the right of the insertion cursor. For entries that are too large to fit in the window all at once, you can scan through the entries with the scrollbars, or by dragging with mouse button2 pressed." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.frame -borderwidth 10 pack $w.frame -side top -fill x -expand 1 diff --git a/library/demos/entry3.tcl b/library/demos/entry3.tcl index 36daf5b..3d76c2e 100644 --- a/library/demos/entry3.tcl +++ b/library/demos/entry3.tcl @@ -1,4 +1,4 @@ -# entry2.tcl -- +# entry3.tcl -- # # This demonstration script creates several entry widgets whose # permitted input is constrained in some way. It also shows off a @@ -8,6 +8,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .entry3 catch {destroy $w} toplevel $w @@ -15,11 +17,10 @@ wm title $w "Constrained Entry Demonstration" wm iconname $w "entry3" positionWindow $w - label $w.msg -font $font -wraplength 5i -justify left -text "Four different\ entries are displayed below. You can add characters by pointing,\ clicking and typing, though each is constrained in what it will\ - accept. The first only accepts integers or the empty string\ + accept. The first only accepts 32-bit integers or the empty string\ (checking when focus leaves it) and will flash to indicate any\ problem. The second only accepts strings with fewer than ten\ characters and sounds the bell when an attempt to go over the limit\ @@ -30,11 +31,9 @@ label $w.msg -font $font -wraplength 5i -justify left -text "Four different\ characters (silently ignoring further ones), and displaying them as\ asterisk characters." -frame $w.buttons -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 - +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x # focusAndFlash -- # Error handler for entry widgets that forces the focus onto the @@ -63,6 +62,8 @@ proc focusAndFlash {W fg bg {count 9}} { } labelframe $w.l1 -text "Integer Entry" +# Alternatively try using {string is digit} for arbitrary length numbers, +# and not just 32-bit ones. entry $w.l1.e -validate focus -vcmd {string is integer %P} $w.l1.e configure -invalidcommand \ "focusAndFlash %W [$w.l1.e cget -fg] [$w.l1.e cget -bg]" @@ -181,5 +182,4 @@ grid $w.l1 $w.l2 -in $w.mid -padx 3m -pady 1m -sticky ew grid $w.l3 $w.l4 -in $w.mid -padx 3m -pady 1m -sticky ew grid columnconfigure $w.mid {0 1} -uniform 1 pack $w.msg -side top -pack $w.buttons -side bottom -fill x -pady 2m pack $w.mid -fill both -expand 1 diff --git a/library/demos/filebox.tcl b/library/demos/filebox.tcl index 5ac67cb..032e3d8 100644 --- a/library/demos/filebox.tcl +++ b/library/demos/filebox.tcl @@ -6,6 +6,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .filebox catch {destroy $w} toplevel $w @@ -16,11 +18,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "Enter a file name in the entry box or click on the \"Browse\" buttons to select a file name using the file selection dialog." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x foreach i {open save} { set f [frame $w.$i] @@ -33,7 +33,7 @@ foreach i {open save} { pack $f -fill x -padx 1c -pady 3 } -if {![string compare $tcl_platform(platform) unix]} { +if {[tk windowingsystem] eq "x11"} { checkbutton $w.strict -text "Use Motif Style Dialog" \ -variable tk_strictMotif -onvalue 1 -offvalue 0 pack $w.strict -anchor c @@ -59,10 +59,16 @@ proc fileDialog {w ent operation} { {"All files" *} } if {$operation == "open"} { - set file [tk_getOpenFile -filetypes $types -parent $w] + global selected_type + if {![info exists selected_type]} { + set selected_type "Tcl Scripts" + } + set file [tk_getOpenFile -filetypes $types -parent $w \ + -typevariable selected_type] + puts "You selected filetype \"$selected_type\"" } else { set file [tk_getSaveFile -filetypes $types -parent $w \ - -initialfile Untitled -defaultextension .txt] + -initialfile Untitled -defaultextension .txt] } if {[string compare $file ""]} { $ent delete 0 end diff --git a/library/demos/floor.tcl b/library/demos/floor.tcl index abd921e..827600b 100644 --- a/library/demos/floor.tcl +++ b/library/demos/floor.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + # floorDisplay -- # Recreate the floorplan display in the canvas given by "w". The # floor given by "active" is displayed on top with its office structure @@ -1288,7 +1290,7 @@ proc fg3 {w color} { # Below is the "main program" that creates the floorplan demonstration. set w .floor -global c tk_library currentRoom colors activeFloor +global c currentRoom colors activeFloor catch {destroy $w} toplevel $w wm title $w "Floorplan Canvas Demonstration" @@ -1299,36 +1301,32 @@ wm minsize $w 100 100 label $w.msg -font $font -wraplength 8i -justify left -text "This window contains a canvas widget showing the floorplan of Digital Equipment Corporation's Western Research Laboratory. It has three levels. At any given time one of the levels is active, meaning that you can see its room structure. To activate a level, click the left mouse button anywhere on it. As the mouse moves over the active level, the room under the mouse lights up and its room number appears in the \"Room:\" entry. You can also type a room number in the entry and the room will light up." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x set f [frame $w.frame] pack $f -side top -fill both -expand yes -set h [scrollbar $f.hscroll -highlightthickness 0 -orient horizontal] -set v [scrollbar $f.vscroll -highlightthickness 0 -orient vertical] -set f1 [frame $f.f1 -bd 2 -relief sunken] -set c [canvas $f1.c -width 900 -height 500 -borderwidth 0 \ - -highlightthickness 0 -xscrollcommand "$h set" -yscrollcommand "$v set"] +set h [scrollbar $f.hscroll -orient horizontal] +set v [scrollbar $f.vscroll -orient vertical] +set f1 [frame $f.f1 -borderwidth 2 -relief sunken] +set c [canvas $f1.c -width 900 -height 500 -highlightthickness 0 \ + -xscrollcommand [list $h set] \ + -yscrollcommand [list $v set]] pack $c -expand yes -fill both -grid $f1 -padx 1 -pady 1 \ - -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news -grid $v -padx 1 -pady 1 \ - -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -grid $h -padx 1 -pady 1 \ - -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $f1 -padx 1 -pady 1 -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news +grid $v -padx 1 -pady 1 -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news +grid $h -padx 1 -pady 1 -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news grid rowconfig $f 0 -weight 1 -minsize 0 grid columnconfig $f 0 -weight 1 -minsize 0 pack $f -expand yes -fill both -padx 1 -pady 1 -$v config -command "$c yview" -$h config -command "$c xview" +$v configure -command [list $c yview] +$h configure -command [list $c xview] # Create an entry for displaying and typing in current room. -entry $c.entry -width 10 -relief sunken -bd 2 -textvariable currentRoom +entry $c.entry -width 10 -textvariable currentRoom # Choose colors, then fill in the floorplan. diff --git a/library/demos/form.tcl b/library/demos/form.tcl index 579b4af..4d80437 100644 --- a/library/demos/form.tcl +++ b/library/demos/form.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .form catch {destroy $w} toplevel $w @@ -17,11 +19,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "This window contains a simple form where you can type in the various entries and use tabs to move circularly between the entries." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x foreach i {f1 f2 f3 f4 f5} { frame $w.$i -bd 2 diff --git a/library/demos/goldberg.tcl b/library/demos/goldberg.tcl new file mode 100644 index 0000000..284b5c2 --- /dev/null +++ b/library/demos/goldberg.tcl @@ -0,0 +1,1833 @@ +##+################################################################# +# +# TkGoldberg.tcl +# by Keith Vetter, March 13, 2003 +# +# "Man will always find a difficult means to perform a simple task" +# Rube Goldberg +# +# Reproduced here with permission. +# +##+################################################################# +# +# Keith Vetter 2003-03-21: this started out as a simple little program +# but was so much fun that it grew and grew. So I apologize about the +# size but I just couldn't resist sharing it. +# +# This is a whizzlet that does a Rube Goldberg type animation, the +# design of which comes from an New Years e-card from IncrediMail. +# That version had nice sound effects which I eschewed. On the other +# hand, that version was in black and white (actually dark blue and +# light blue) and this one is fully colorized. +# +# One thing I learned from this project is that drawing filled complex +# objects on a canvas is really hard. More often than not I had to +# draw each item twice--once with the desired fill color but no +# outline, and once with no fill but with the outline. Another trick +# is erasing by drawing with the background color. Having a flood fill +# command would have been extremely helpful. +# +# Two wiki pages were extremely helpful: Drawing rounded rectangles +# which I generalized into Drawing rounded polygons, and regular +# polygons which allowed me to convert ovals and arcs into polygons +# which could then be rotated (see Canvas Rotation). I also wrote +# Named Colors to aid in the color selection. +# +# I could comment on the code, but it's just 26 state machines with +# lots of canvas create and move calls. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk + +set w .goldberg +catch {destroy $w} +toplevel $w +wm title $w "Tk Goldberg (demonstration)" +wm iconname $w "goldberg" +wm resizable $w 0 0 +#positionWindow $w + +label $w.msg -font {Arial 10} -wraplength 4i -justify left -text "This is a\ + demonstration of just how complex you can make your animations\ + become. Click the ball to start things moving!\n\n\"Man will always\ + find a difficult means to perform a simple task\"\n - Rube Goldberg" +pack $w.msg -side top + +###--- End of Boilerplate ---### + +# Ensure that this this is an array +array set animationCallbacks {} +bind $w <Destroy> { + if {"%W" eq [winfo toplevel %W]} { + unset S C speed + } +} + +set S(title) "Tk Goldberg" +set S(speed) 5 +set S(cnt) 0 +set S(message) "\\nWelcome\\nto\\nTcl/Tk" +array set speed {1 10 2 20 3 50 4 80 5 100 6 150 7 200 8 300 9 400 10 500} + +set MSTART 0; set MGO 1; set MPAUSE 2; set MSSTEP 3; set MBSTEP 4; set MDONE 5 +set S(mode) $::MSTART + +# Colors for everything +set C(fg) black +set C(bg) gray75 +set C(bg) cornflowerblue + +set C(0) white; set C(1a) darkgreen; set C(1b) yellow +set C(2) red; set C(3a) green; set C(3b) darkblue +set C(4) $C(fg); set C(5a) brown; set C(5b) white +set C(6) magenta; set C(7) green; set C(8) $C(fg) +set C(9) blue4; set C(10a) white; set C(10b) cyan +set C(11a) yellow; set C(11b) mediumblue; set C(12) tan2 +set C(13a) yellow; set C(13b) red; set C(14) white +set C(15a) green; set C(15b) yellow; set C(16) gray65 +set C(17) \#A65353; set C(18) $C(fg); set C(19) gray50 +set C(20) cyan; set C(21) gray65; set C(22) $C(20) +set C(23a) blue; set C(23b) red; set C(23c) yellow +set C(24a) red; set C(24b) white; + +proc DoDisplay {w} { + global S C + + ttk::frame $w.ctrl -relief ridge -borderwidth 2 -padding 5 + pack [frame $w.screen -bd 2 -relief raised] \ + -side left -fill both -expand 1 + + canvas $w.c -width 860 -height 730 -bg $C(bg) -highlightthickness 0 + $w.c config -scrollregion {0 0 1000 1000} ;# Kludge: move everything up + $w.c yview moveto .05 + pack $w.c -in $w.screen -side top -fill both -expand 1 + + bind $w.c <3> [list $w.pause invoke] + bind $w.c <Destroy> { + after cancel $animationCallbacks(goldberg) + unset animationCallbacks(goldberg) + } + DoCtrlFrame $w + DoDetailFrame $w + if {[tk windowingsystem] ne "aqua"} { + ttk::button $w.show -text "\u00bb" -command [list ShowCtrl $w] -width 2 + } else { + button $w.show -text "\u00bb" -command [list ShowCtrl $w] -width 2 -highlightbackground $C(bg) + } + place $w.show -in $w.c -relx 1 -rely 0 -anchor ne + update +} + +proc DoCtrlFrame {w} { + global S + ttk::button $w.start -text "Start" -command [list DoButton $w 0] + ttk::checkbutton $w.pause -text "Pause" -command [list DoButton $w 1] \ + -variable S(pause) + ttk::button $w.step -text "Single Step" -command [list DoButton $w 2] + ttk::button $w.bstep -text "Big Step" -command [list DoButton $w 4] + ttk::button $w.reset -text "Reset" -command [list DoButton $w 3] + ttk::labelframe $w.details + raise $w.details + set S(details) 0 + ttk::checkbutton $w.details.cb -text "Details" -variable S(details) + ttk::labelframe $w.message -text "Message" + ttk::entry $w.message.e -textvariable S(message) -justify center + ttk::labelframe $w.speed -text "Speed: 0" + ttk::scale $w.speed.scale -orient h -from 1 -to 10 -variable S(speed) + ttk::button $w.about -text About -command [list About $w] + + grid $w.start -in $w.ctrl -row 0 -sticky ew + grid rowconfigure $w.ctrl 1 -minsize 10 + grid $w.pause -in $w.ctrl -row 2 -sticky ew + grid $w.step -in $w.ctrl -sticky ew -pady 2 + grid $w.bstep -in $w.ctrl -sticky ew + grid $w.reset -in $w.ctrl -sticky ew -pady 2 + grid rowconfigure $w.ctrl 10 -minsize 18 + grid $w.details -in $w.ctrl -row 11 -sticky ew + grid rowconfigure $w.ctrl 11 -minsize 20 + $w.details configure -labelwidget $w.details.cb + grid [ttk::frame $w.details.b -height 1] ;# Work around minor bug + raise $w.details + raise $w.details.cb + grid rowconfigure $w.ctrl 50 -weight 1 + trace variable ::S(mode) w [list ActiveGUI $w] + trace variable ::S(details) w [list ActiveGUI $w] + trace variable ::S(speed) w [list ActiveGUI $w] + + grid $w.message -in $w.ctrl -row 98 -sticky ew -pady 5 + grid $w.message.e -sticky nsew + grid $w.speed -in $w.ctrl -row 99 -sticky ew -pady {0 5} + pack $w.speed.scale -fill both -expand 1 + grid $w.about -in $w.ctrl -row 100 -sticky ew + bind $w.reset <3> {set S(mode) -1} ;# Debugging + + ## See Code / Dismiss buttons hack! + set btns [addSeeDismiss $w.ctrl.buttons $w] + grid [ttk::separator $w.ctrl.sep] -sticky ew -pady 4 + set i 0 + foreach b [winfo children $btns] { + if {[winfo class $b] eq "TButton"} { + grid [set b2 [ttk::button $w.ctrl.b[incr i]]] -sticky ew + foreach b3 [$b configure] { + set b3 [lindex $b3 0] + # Some options are read-only; ignore those errors + catch {$b2 configure $b3 [$b cget $b3]} + } + } + } + destroy $btns +} + +proc DoDetailFrame {w} { + set w2 $w.details.f + ttk::frame $w2 + + set bd 2 + ttk::label $w2.l -textvariable S(cnt) -background white + grid $w2.l - - - -sticky ew -row 0 + for {set i 1} {1} {incr i} { + if {[info procs "Move$i"] eq ""} break + ttk::label $w2.l$i -text $i -anchor e -width 2 -background white + ttk::label $w2.ll$i -textvariable STEP($i) -width 5 -background white + set row [expr {($i + 1) / 2}] + set col [expr {(($i + 1) & 1) * 2}] + grid $w2.l$i -sticky ew -row $row -column $col + grid $w2.ll$i -sticky ew -row $row -column [incr col] + } + grid columnconfigure $w2 1 -weight 1 +} + +# Map or unmap the ctrl window +proc ShowCtrl {w} { + if {[winfo ismapped $w.ctrl]} { + pack forget $w.ctrl + $w.show config -text "\u00bb" + } else { + pack $w.ctrl -side right -fill both -ipady 5 + $w.show config -text "\u00ab" + } +} + +proc DrawAll {w} { + ResetStep + $w.c delete all + for {set i 0} {1} {incr i} { + set p "Draw$i" + if {[info procs $p] eq ""} break + $p $w + } +} + +proc ActiveGUI {w var1 var2 op} { + global S MGO MSTART MDONE + array set z {0 disabled 1 normal} + + set m $S(mode) + set S(pause) [expr {$m == 2}] + $w.start config -state $z([expr {$m != $MGO}]) + $w.pause config -state $z([expr {$m != $MSTART && $m != $MDONE}]) + $w.step config -state $z([expr {$m != $MGO && $m != $MDONE}]) + $w.bstep config -state $z([expr {$m != $MGO && $m != $MDONE}]) + $w.reset config -state $z([expr {$m != $MSTART}]) + + if {$S(details)} { + grid $w.details.f -sticky ew + } else { + grid forget $w.details.f + } + set S(speed) [expr {round($S(speed))}] + $w.speed config -text "Speed: $S(speed)" +} + +proc Start {} { + global S MGO + set S(mode) $MGO +} + +proc DoButton {w what} { + global S MDONE MGO MSSTEP MBSTEP MPAUSE + + if {$what == 0} { ;# Start + if {$S(mode) == $MDONE} { + Reset $w + } + set S(mode) $MGO + } elseif {$what == 1} { ;# Pause + set S(mode) [expr {$S(pause) ? $MPAUSE : $MGO}] + } elseif {$what == 2} { ;# Step + set S(mode) $MSSTEP + } elseif {$what == 3} { ;# Reset + Reset $w + } elseif {$what == 4} { ;# Big step + set S(mode) $MBSTEP + } +} + +proc Go {w {who {}}} { + global S speed animationCallbacks MGO MPAUSE MSSTEP MBSTEP + + set now [clock clicks -milliseconds] + catch {after cancel $animationCallbacks(goldberg)} + if {$who ne ""} { ;# Start here for debugging + set S(active) $who; + set S(mode) $MGO + } + if {$S(mode) == -1} return ;# Debugging + set n 0 + if {$S(mode) != $MPAUSE} { ;# Not paused + set n [NextStep $w] ;# Do the next move + } + if {$S(mode) == $MSSTEP} { ;# Single step + set S(mode) $MPAUSE + } + if {$S(mode) == $MBSTEP && $n} { ;# Big step + set S(mode) $MSSTEP + } + + set elapsed [expr {[clock click -milliseconds] - $now}] + set delay [expr {$speed($S(speed)) - $elapsed}] + if {$delay <= 0} { + set delay 1 + } + set animationCallbacks(goldberg) [after $delay [list Go $w]] +} + +# NextStep: drives the next step of the animation +proc NextStep {w} { + global S MSTART MDONE + set rval 0 ;# Return value + + if {$S(mode) != $MSTART && $S(mode) != $MDONE} { + incr S(cnt) + } + set alive {} + foreach {who} $S(active) { + set n ["Move$who" $w] + if {$n & 1} { ;# This guy still alive + lappend alive $who + } + if {$n & 2} { ;# Next guy is active + lappend alive [expr {$who + 1}] + set rval 1 + } + if {$n & 4} { ;# End of puzzle flag + set S(mode) $MDONE ;# Done mode + set S(active) {} ;# No more animation + return 1 + } + } + set S(active) $alive + return $rval +} +proc About {w} { + set msg "$::S(title)\nby Keith Vetter, March 2003\n(Reproduced by kind\ + permission of the author)\n\n\"Man will always find a difficult\ + means to perform a simple task.\"\nRube Goldberg" + tk_messageBox -parent $w -message $msg -title About +} +################################################################ +# +# All the drawing and moving routines +# + +# START HERE! banner +proc Draw0 {w} { + set color $::C(0) + set xy {579 119} + $w.c create text $xy -text "START HERE!" -fill $color -anchor w \ + -tag I0 -font {{Times Roman} 12 italic bold} + set xy {719 119 763 119} + $w.c create line $xy -tag I0 -fill $color -width 5 -arrow last \ + -arrowshape {18 18 5} + $w.c bind I0 <1> Start +} +proc Move0 {w {step {}}} { + set step [GetStep 0 $step] + + if {$::S(mode) > $::MSTART} { ;# Start the ball rolling + MoveAbs $w I0 {-100 -100} ;# Hide the banner + return 2 + } + + set pos { + {673 119} {678 119} {683 119} {688 119} + {693 119} {688 119} {683 119} {678 119} + } + set step [expr {$step % [llength $pos]}] + MoveAbs $w I0 [lindex $pos $step] + return 1 +} + +# Dropping ball +proc Draw1 {w} { + set color $::C(1a) + set color2 $::C(1b) + set xy {844 133 800 133 800 346 820 346 820 168 844 168 844 133} + $w.c create poly $xy -width 3 -fill $color -outline {} + set xy {771 133 685 133 685 168 751 168 751 346 771 346 771 133} + $w.c create poly $xy -width 3 -fill $color -outline {} + + set xy [box 812 122 9] + $w.c create oval $xy -tag I1 -fill $color2 -outline {} + $w.c bind I1 <1> Start +} +proc Move1 {w {step {}}} { + set step [GetStep 1 $step] + set pos { + {807 122} {802 122} {797 123} {793 124} {789 129} {785 153} + {785 203} {785 278 x} {785 367} {810 392} {816 438} {821 503} + {824 585 y} {838 587} {848 593} {857 601} {-100 -100} + } + if {$step >= [llength $pos]} { + return 0 + } + set where [lindex $pos $step] + MoveAbs $w I1 $where + + if {[lindex $where 2] eq "y"} { + Move15a $w + } + if {[lindex $where 2] eq "x"} { + return 3 + } + return 1 +} + +# Lighting the match +proc Draw2 {w} { + set color red + set color $::C(2) + set xy {750 369 740 392 760 392} ;# Fulcrum + $w.c create poly $xy -fill $::C(fg) -outline $::C(fg) + set xy {628 335 660 383} ;# Strike box + $w.c create rect $xy -fill {} -outline $::C(fg) + for {set y 0} {$y < 3} {incr y} { + set yy [expr {335+$y*16}] + $w.c create bitmap 628 $yy -bitmap gray25 -anchor nw \ + -foreground $::C(fg) + $w.c create bitmap 644 $yy -bitmap gray25 -anchor nw \ + -foreground $::C(fg) + } + + set xy {702 366 798 366} ;# Lever + $w.c create line $xy -fill $::C(fg) -width 6 -tag I2_0 + set xy {712 363 712 355} ;# R strap + $w.c create line $xy -fill $::C(fg) -width 3 -tag I2_1 + set xy {705 363 705 355} ;# L strap + $w.c create line $xy -fill $::C(fg) -width 3 -tag I2_2 + set xy {679 356 679 360 717 360 717 356 679 356} ;# Match stick + $w.c create line $xy -fill $::C(fg) -tag I2_3 + + #set xy {662 352 680 365} ;# Match head + set xy { + 671 352 677.4 353.9 680 358.5 677.4 363.1 671 365 664.6 363.1 + 662 358.5 664.6 353.9 + } + $w.c create poly $xy -fill $color -outline $color -tag I2_4 +} +proc Move2 {w {step {}}} { + set step [GetStep 2 $step] + + set stages {0 0 1 2 0 2 1 0 1 2 0 2 1} + set xy(0) { + 686 333 692 323 682 316 674 309 671 295 668 307 662 318 662 328 + 671 336 + } + set xy(1) {687 331 698 322 703 295 680 320 668 297 663 311 661 327 671 335} + set xy(2) { + 686 331 704 322 688 300 678 283 678 283 674 298 666 309 660 324 + 672 336 + } + + if {$step >= [llength $stages]} { + $w.c delete I2 + return 0 + } + + if {$step == 0} { ;# Rotate the match + set beta 20 + lassign [Anchor $w I2_0 s] Ox Oy ;# Where to pivot + for {set i 0} {[$w.c find withtag I2_$i] ne ""} {incr i} { + RotateItem $w I2_$i $Ox $Oy $beta + } + $w.c create poly -tag I2 -smooth 1 -fill $::C(2) ;# For the flame + return 1 + } + $w.c coords I2 $xy([lindex $stages $step]) + return [expr {$step == 7 ? 3 : 1}] +} + +# Weight and pulleys +proc Draw3 {w} { + set color $::C(3a) + set color2 $::C(3b) + + set xy {602 296 577 174 518 174} + foreach {x y} $xy { ;# 3 Pulleys + $w.c create oval [box $x $y 13] -fill $color -outline $::C(fg) \ + -width 3 + $w.c create oval [box $x $y 2] -fill $::C(fg) -outline $::C(fg) + } + + set xy {750 309 670 309} ;# Wall to flame + $w.c create line $xy -tag I3_s -width 3 -fill $::C(fg) -smooth 1 + set xy {670 309 650 309} ;# Flame to pulley 1 + $w.c create line $xy -tag I3_0 -width 3 -fill $::C(fg) + set xy {650 309 600 309} ;# Flame to pulley 1 + $w.c create line $xy -tag I3_1 -width 3 -fill $::C(fg) + set xy {589 296 589 235} ;# Pulley 1 half way to 2 + $w.c create line $xy -tag I3_2 -width 3 -fill $::C(fg) + set xy {589 235 589 174} ;# Pulley 1 other half to 2 + $w.c create line $xy -width 3 -fill $::C(fg) + set xy {577 161 518 161} ;# Across the top + $w.c create line $xy -width 3 -fill $::C(fg) + set xy {505 174 505 205} ;# Down to weight + $w.c create line $xy -tag I3_w -width 3 -fill $::C(fg) + + # Draw the weight as 2 circles, two rectangles and 1 rounded rectangle + set xy {515 207 495 207} + foreach {x1 y1 x2 y2} $xy { + $w.c create oval [box $x1 $y1 6] -tag I3_ -fill $color2 \ + -outline $color2 + $w.c create oval [box $x2 $y2 6] -tag I3_ -fill $color2 \ + -outline $color2 + incr y1 -6; incr y2 6 + $w.c create rect $x1 $y1 $x2 $y2 -tag I3_ -fill $color2 \ + -outline $color2 + } + set xy {492 220 518 263} + set xy [RoundRect $w $xy 15] + $w.c create poly $xy -smooth 1 -tag I3_ -fill $color2 -outline $color2 + set xy {500 217 511 217} + $w.c create line $xy -tag I3_ -fill $color2 -width 10 + + set xy {502 393 522 393 522 465} ;# Bottom weight target + $w.c create line $xy -tag I3__ -fill $::C(fg) -join miter -width 10 +} +proc Move3 {w {step {}}} { + set step [GetStep 3 $step] + + set pos {{505 247} {505 297} {505 386.5} {505 386.5}} + set rope(0) {750 309 729 301 711 324 690 300} + set rope(1) {750 309 737 292 736 335 717 315 712 320} + set rope(2) {750 309 737 309 740 343 736 351 725 340} + set rope(3) {750 309 738 321 746 345 742 356} + + if {$step >= [llength $pos]} { + return 0 + } + + $w.c delete "I3_$step" ;# Delete part of the rope + MoveAbs $w I3_ [lindex $pos $step] ;# Move weight down + $w.c coords I3_s $rope($step) ;# Flapping rope end + $w.c coords I3_w [concat 505 174 [lindex $pos $step]] + if {$step == 2} { + $w.c move I3__ 0 30 + return 2 + } + return 1 +} + +# Cage and door +proc Draw4 {w} { + set color $::C(4) + lassign {527 356 611 464} x0 y0 x1 y1 + + for {set y $y0} {$y <= $y1} {incr y 12} { ;# Horizontal bars + $w.c create line $x0 $y $x1 $y -fill $color -width 1 + } + for {set x $x0} {$x <= $x1} {incr x 12} { ;# Vertical bars + $w.c create line $x $y0 $x $y1 -fill $color -width 1 + } + + set xy {518 464 518 428} ;# Swing gate + $w.c create line $xy -tag I4 -fill $color -width 3 +} +proc Move4 {w {step {}}} { + set step [GetStep 4 $step] + + set angles {-10 -20 -30 -30} + if {$step >= [llength $angles]} { + return 0 + } + RotateItem $w I4 518 464 [lindex $angles $step] + $w.c raise I4 + return [expr {$step == 3 ? 3 : 1}] +} + +# Mouse +proc Draw5 {w} { + set color $::C(5a) + set color2 $::C(5b) + set xy {377 248 410 248 410 465 518 465} ;# Mouse course + lappend xy 518 428 451 428 451 212 377 212 + $w.c create poly $xy -fill $color2 -outline $::C(fg) -width 3 + + set xy { + 534.5 445.5 541 440 552 436 560 436 569 440 574 446 575 452 574 454 + 566 456 554 456 545 456 537 454 530 452 + } + $w.c create poly $xy -tag {I5 I5_0} -fill $color + set xy {573 452 592 458 601 460 613 456} ;# Tail + $w.c create line $xy -tag {I5 I5_1} -fill $color -smooth 1 -width 3 + set xy [box 540 446 2] ;# Eye + set xy {540 444 541 445 541 447 540 448 538 447 538 445} + #.c create oval $xy -tag {I5 I5_2} -fill $::C(bg) -outline {} + $w.c create poly $xy -tag {I5 I5_2} -fill $::C(bg) -outline {} -smooth 1 + set xy {538 454 535 461} ;# Front leg + $w.c create line $xy -tag {I5 I5_3} -fill $color -width 2 + set xy {566 455 569 462} ;# Back leg + $w.c create line $xy -tag {I5 I5_4} -fill $color -width 2 + set xy {544 455 545 460} ;# 2nd front leg + $w.c create line $xy -tag {I5 I5_5} -fill $color -width 2 + set xy {560 455 558 460} ;# 2nd back leg + $w.c create line $xy -tag {I5 I5_6} -fill $color -width 2 +} +proc Move5 {w {step {}}} { + set step [GetStep 5 $step] + + set pos { + {553 452} {533 452} {513 452} {493 452} {473 452} + {463 442 30} {445.5 441.5 30} {425.5 434.5 30} {422 414} {422 394} + {422 374} {422 354} {422 334} {422 314} {422 294} + {422 274 -30} {422 260.5 -30 x} {422.5 248.5 -28} {425 237} + } + if {$step >= [llength $pos]} { + return 0 + } + + lassign [lindex $pos $step] x y beta next + MoveAbs $w I5 [list $x $y] + if {$beta ne ""} { + lassign [Centroid $w I5_0] Ox Oy + foreach id {0 1 2 3 4 5 6} { + RotateItem $w I5_$id $Ox $Oy $beta + } + } + if {$next eq "x"} { + return 3 + } + return 1 +} + +# Dropping gumballs +array set XY6 { + -1 {366 207} -2 {349 204} -3 {359 193} -4 {375 192} -5 {340 190} + -6 {349 177} -7 {366 177} -8 {380 176} -9 {332 172} -10 {342 161} + -11 {357 164} -12 {372 163} -13 {381 149} -14 {364 151} -15 {349 146} + -16 {333 148} 0 {357 219} + 1 {359 261} 2 {359 291} 3 {359 318} 4 {361 324} 5 {365 329} 6 {367 334} + 7 {367 340} 8 {366 346} 9 {364 350} 10 {361 355} 11 {359 370} 12 {359 391} + 13,0 {360 456} 13,1 {376 456} 13,2 {346 456} 13,3 {330 456} + 13,4 {353 444} 13,5 {368 443} 13,6 {339 442} 13,7 {359 431} + 13,8 {380 437} 13,9 {345 428} 13,10 {328 434} 13,11 {373 424} + 13,12 {331 420} 13,13 {360 417} 13,14 {345 412} 13,15 {376 410} + 13,16 {360 403} +} +proc Draw6 {w} { + set color $::C(6) + set xy {324 130 391 204} ;# Ball holder + set xy [RoundRect $w $xy 10] + $w.c create poly $xy -smooth 1 -outline $::C(fg) -width 3 -fill $color + set xy {339 204 376 253} ;# Below the ball holder + $w.c create rect $xy -fill {} -outline $::C(fg) -width 3 -fill $color \ + -tag I6c + set xy [box 346 339 28] + $w.c create oval $xy -fill $color -outline {} ;# Rotor + $w.c create arc $xy -outline $::C(fg) -width 2 -style arc \ + -start 80 -extent 205 + $w.c create arc $xy -outline $::C(fg) -width 2 -style arc \ + -start -41 -extent 85 + + set xy [box 346 339 15] ;# Center of rotor + $w.c create oval $xy -outline $::C(fg) -fill $::C(fg) -tag I6m + set xy {352 312 352 254 368 254 368 322} ;# Top drop to rotor + $w.c create poly $xy -fill $color -outline {} + $w.c create line $xy -fill $::C(fg) -width 2 + + set xy {353 240 367 300} ;# Poke bottom hole + $w.c create rect $xy -fill $color -outline {} + set xy {341 190 375 210} ;# Poke another hole + $w.c create rect $xy -fill $color -outline {} + + set xy {368 356 368 403 389 403 389 464 320 464 320 403 352 403 352 366} + $w.c create poly $xy -fill $color -outline {} -width 2 ;# Below rotor + $w.c create line $xy -fill $::C(fg) -width 2 + set xy [box 275 342 7] ;# On/off rotor + $w.c create oval $xy -outline $::C(fg) -fill $::C(fg) + set xy {276 334 342 325} ;# Fan belt top + $w.c create line $xy -fill $::C(fg) -width 3 + set xy {276 349 342 353} ;# Fan belt bottom + $w.c create line $xy -fill $::C(fg) -width 3 + + set xy {337 212 337 247} ;# What the mouse pushes + $w.c create line $xy -fill $::C(fg) -width 3 -tag I6_ + set xy {392 212 392 247} + $w.c create line $xy -fill $::C(fg) -width 3 -tag I6_ + set xy {337 230 392 230} + $w.c create line $xy -fill $::C(fg) -width 7 -tag I6_ + + set who -1 ;# All the balls + set colors {red cyan orange green blue darkblue} + lappend colors {*}$colors {*}$colors + + for {set i 0} {$i < 17} {incr i} { + set loc [expr {-1 * $i}] + set color [lindex $colors $i] + $w.c create oval [box {*}$::XY6($loc) 5] -fill $color \ + -outline $color -tag I6_b$i + } + Draw6a $w 12 ;# The wheel +} +proc Draw6a {w beta} { + $w.c delete I6_0 + lassign {346 339} Ox Oy + for {set i 0} {$i < 4} {incr i} { + set b [expr {$beta + $i * 45}] + lassign [RotateC 28 0 0 0 $b] x y + set xy [list [expr {$Ox+$x}] [expr {$Oy+$y}] \ + [expr {$Ox-$x}] [expr {$Oy-$y}]] + $w.c create line $xy -tag I6_0 -fill $::C(fg) -width 2 + } +} +proc Move6 {w {step {}}} { + set step [GetStep 6 $step] + if {$step > 62} { + return 0 + } + + if {$step < 2} { ;# Open gate for balls to drop + $w.c move I6_ -7 0 + if {$step == 1} { ;# Poke a hole + set xy {348 226 365 240} + $w.c create rect $xy -fill [$w.c itemcget I6c -fill] -outline {} + } + return 1 + } + + set s [expr {$step - 1}] ;# Do the gumball drop dance + for {set i 0} {$i <= int(($s-1) / 3)} {incr i} { + set tag "I6_b$i" + if {[$w.c find withtag $tag] eq ""} break + set loc [expr {$s - 3 * $i}] + + if {[info exists ::XY6($loc,$i)]} { + MoveAbs $w $tag $::XY6($loc,$i) + } elseif {[info exists ::XY6($loc)]} { + MoveAbs $w $tag $::XY6($loc) + } + } + if {($s % 3) == 1} { + set first [expr {($s + 2) / 3}] + for {set i $first} {1} {incr i} { + set tag "I6_b$i" + if {[$w.c find withtag $tag] eq ""} break + set loc [expr {$first - $i}] + MoveAbs $w $tag $::XY6($loc) + } + } + if {$s >= 3} { ;# Rotate the motor + set idx [expr {$s % 3}] + #Draw6a $w [lindex {12 35 64} $idx] + Draw6a $w [expr {12 + $s * 15}] + } + return [expr {$s == 3 ? 3 : 1}] +} + +# On/off switch +proc Draw7 {w} { + set color $::C(7) + set xy {198 306 277 374} ;# Box + $w.c create rect $xy -outline $::C(fg) -width 2 -fill $color -tag I7z + $w.c lower I7z + set xy {275 343 230 349} + $w.c create line $xy -tag I7 -fill $::C(fg) -arrow last \ + -arrowshape {23 23 8} -width 6 + set xy {225 324} ;# On button + $w.c create oval [box {*}$xy 3] -fill $::C(fg) -outline $::C(fg) + set xy {218 323} ;# On text + set font {{Times Roman} 8} + $w.c create text $xy -text "on" -anchor e -fill $::C(fg) -font $font + set xy {225 350} ;# Off button + $w.c create oval [box {*}$xy 3] -fill $::C(fg) -outline $::C(fg) + set xy {218 349} ;# Off button + $w.c create text $xy -text "off" -anchor e -fill $::C(fg) -font $font +} +proc Move7 {w {step {}}} { + set step [GetStep 7 $step] + set numsteps 30 + if {$step > $numsteps} { + return 0 + } + set beta [expr {30.0 / $numsteps}] + RotateItem $w I7 275 343 $beta + + return [expr {$step == $numsteps ? 3 : 1}] +} + +# Electricity to the fan +proc Draw8 {w} { + Sine $w 271 248 271 306 5 8 -tag I8_s -fill $::C(8) -width 3 +} +proc Move8 {w {step {}}} { + set step [GetStep 8 $step] + + if {$step > 3} { + return 0 + } + if {$step == 0} { + Sparkle $w [Anchor $w I8_s s] I8 + return 1 + + } elseif {$step == 1} { + MoveAbs $w I8 [Anchor $w I8_s c] + } elseif {$step == 2} { + MoveAbs $w I8 [Anchor $w I8_s n] + } else { + $w.c delete I8 + } + return [expr {$step == 2 ? 3 : 1}] +} + +# Fan +proc Draw9 {w} { + set color $::C(9) + set xy {266 194 310 220} + $w.c create oval $xy -outline $color -fill $color + set xy {280 209 296 248} + $w.c create oval $xy -outline $color -fill $color + set xy {288 249 252 249 260 240 280 234 296 234 316 240 324 249 288 249} + $w.c create poly $xy -fill $color -smooth 1 + + set xy {248 205 265 214 264 205 265 196} ;# Spinner + $w.c create poly $xy -fill $color + + set xy {255 206 265 234} ;# Fan blades + $w.c create oval $xy -fill {} -outline $::C(fg) -width 3 -tag I9_0 + set xy {255 176 265 204} + $w.c create oval $xy -fill {} -outline $::C(fg) -width 3 -tag I9_0 + set xy {255 206 265 220} + $w.c create oval $xy -fill {} -outline $::C(fg) -width 1 -tag I9_1 + set xy {255 190 265 204} + $w.c create oval $xy -fill {} -outline $::C(fg) -width 1 -tag I9_1 +} +proc Move9 {w {step {}}} { + set step [GetStep 9 $step] + + if {$step & 1} { + $w.c itemconfig I9_0 -width 4 + $w.c itemconfig I9_1 -width 1 + $w.c lower I9_1 I9_0 + } else { + $w.c itemconfig I9_0 -width 1 + $w.c itemconfig I9_1 -width 4 + $w.c lower I9_0 I9_1 + } + if {$step == 0} { + return 3 + } + return 1 +} + +# Boat +proc Draw10 {w} { + set color $::C(10a) + set color2 $::C(10b) + set xy {191 230 233 230 233 178 191 178} ;# Sail + $w.c create poly $xy -fill $color -width 3 -outline $::C(fg) -tag I10 + set xy [box 209 204 31] ;# Front + $w.c create arc $xy -outline {} -fill $color -style pie \ + -start 120 -extent 120 -tag I10 + $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ + -start 120 -extent 120 -tag I10 + set xy [box 249 204 31] ;# Back + $w.c create arc $xy -outline {} -fill $::C(bg) -width 3 -style pie \ + -start 120 -extent 120 -tag I10 + $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ + -start 120 -extent 120 -tag I10 + + set xy {200 171 200 249} ;# Mast + $w.c create line $xy -fill $::C(fg) -width 3 -tag I10 + set xy {159 234 182 234} ;# Bow sprit + $w.c create line $xy -fill $::C(fg) -width 3 -tag I10 + set xy {180 234 180 251 220 251} ;# Hull + $w.c create line $xy -fill $::C(fg) -width 6 -tag I10 + + set xy {92 255 221 255} ;# Waves + Sine $w {*}$xy 2 25 -fill $color2 -width 1 -tag I10w + + set xy [lrange [$w.c coords I10w] 4 end-4] ;# Water + set xy [concat $xy 222 266 222 277 99 277] + $w.c create poly $xy -fill $color2 -outline $color2 + set xy {222 266 222 277 97 277 97 266} ;# Water bottom + $w.c create line $xy -fill $::C(fg) -width 3 + + set xy [box 239 262 17] + $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ + -start 95 -extent 103 + set xy [box 76 266 21] + $w.c create arc $xy -outline $::C(fg) -width 3 -style arc -extent 190 +} +proc Move10 {w {step {}}} { + set step [GetStep 10 $step] + set pos { + {195 212} {193 212} {190 212} {186 212} {181 212} {176 212} + {171 212} {166 212} {161 212} {156 212} {151 212} {147 212} {142 212} + {137 212} {132 212 x} {127 212} {121 212} {116 212} {111 212} + } + + if {$step >= [llength $pos]} { + return 0 + } + set where [lindex $pos $step] + MoveAbs $w I10 $where + + if {[lindex $where 2] eq "x"} { + return 3 + } + return 1 +} + +# 2nd ball drop +proc Draw11 {w} { + set color $::C(11a) + set color2 $::C(11b) + set xy {23 264 55 591} ;# Color the down tube + $w.c create rect $xy -fill $color -outline {} + set xy [box 71 460 48] ;# Color the outer loop + $w.c create oval $xy -fill $color -outline {} + + set xy {55 264 55 458} ;# Top right side + $w.c create line $xy -fill $::C(fg) -width 3 + set xy {55 504 55 591} ;# Bottom right side + $w.c create line $xy -fill $::C(fg) -width 3 + set xy [box 71 460 48] ;# Outer loop + $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ + -start 110 -extent -290 -tag I11i + set xy [box 71 460 16] ;# Inner loop + $w.c create oval $xy -outline $::C(fg) -fill {} -width 3 -tag I11i + $w.c create oval $xy -outline $::C(fg) -fill $::C(bg) -width 3 + + set xy {23 264 23 591} ;# Left side + $w.c create line $xy -fill $::C(fg) -width 3 + set xy [box 1 266 23] ;# Top left curve + $w.c create arc $xy -outline $::C(fg) -width 3 -style arc -extent 90 + + set xy [box 75 235 9] ;# The ball + $w.c create oval $xy -fill $color2 -outline {} -width 3 -tag I11 +} +proc Move11 {w {step {}}} { + set step [GetStep 11 $step] + set pos { + {75 235} {70 235} {65 237} {56 240} {46 247} {38 266} {38 296} + {38 333} {38 399} {38 475} {74 496} {105 472} {100 437} {65 423} + {-100 -100} {38 505} {38 527 x} {38 591} + } + + if {$step >= [llength $pos]} { + return 0 + } + set where [lindex $pos $step] + MoveAbs $w I11 $where + if {[lindex $where 2] eq "x"} { + return 3 + } + return 1 +} + +# Hand +proc Draw12 {w} { + set xy {20 637 20 617 20 610 20 590 40 590 40 590 60 590 60 610 60 610} + lappend xy 60 610 65 620 60 631 ;# Thumb + lappend xy 60 631 60 637 60 662 60 669 52 669 56 669 50 669 50 662 50 637 + + set y0 637 ;# Bumps for fingers + set y1 645 + for {set x 50} {$x > 20} {incr x -10} { + set x1 [expr {$x - 5}] + set x2 [expr {$x - 10}] + lappend xy $x $y0 $x1 $y1 $x2 $y0 + } + $w.c create poly $xy -fill $::C(12) -outline $::C(fg) -smooth 1 -tag I12 \ + -width 3 +} +proc Move12 {w {step {}}} { + set step [GetStep 12 $step] + set pos {{42.5 641 x}} + if {$step >= [llength $pos]} { + return 0 + } + + set where [lindex $pos $step] + MoveAbs $w I12 $where + if {[lindex $where 2] eq "x"} { + return 3 + } + return 1 +} + +# Fax +proc Draw13 {w} { + set color $::C(13a) + set xy {86 663 149 663 149 704 50 704 50 681 64 681 86 671} + set xy2 {784 663 721 663 721 704 820 704 820 681 806 681 784 671} + set radii {2 9 9 8 5 5 2} + + RoundPoly $w.c $xy $radii -width 3 -outline $::C(fg) -fill $color + RoundPoly $w.c $xy2 $radii -width 3 -outline $::C(fg) -fill $color + + set xy {56 677} + $w.c create rect [box {*}$xy 4] -fill {} -outline $::C(fg) -width 3 \ + -tag I13 + set xy {809 677} + $w.c create rect [box {*}$xy 4] -fill {} -outline $::C(fg) -width 3 \ + -tag I13R + + set xy {112 687} ;# Label + $w.c create text $xy -text "FAX" -fill $::C(fg) \ + -font {{Times Roman} 12 bold} + set xy {762 687} + $w.c create text $xy -text "FAX" -fill $::C(fg) \ + -font {{Times Roman} 12 bold} + + set xy {138 663 148 636 178 636} ;# Paper guide + $w.c create line $xy -smooth 1 -fill $::C(fg) -width 3 + set xy {732 663 722 636 692 636} + $w.c create line $xy -smooth 1 -fill $::C(fg) -width 3 + + Sine $w 149 688 720 688 5 15 -tag I13_s -fill $::C(fg) -width 3 +} +proc Move13 {w {step {}}} { + set step [GetStep 13 $step] + set numsteps 7 + + if {$step == $numsteps+2} { + MoveAbs $w I13_star {-100 -100} + $w.c itemconfig I13R -fill $::C(13b) -width 2 + return 2 + } + if {$step == 0} { ;# Button down + $w.c delete I13 + Sparkle $w {-100 -100} I13_star ;# Create off screen + return 1 + } + lassign [Anchor $w I13_s w] x0 y0 + lassign [Anchor $w I13_s e] x1 y1 + set x [expr {$x0 + ($x1-$x0) * ($step - 1) / double($numsteps)}] + MoveAbs $w I13_star [list $x $y0] + return 1 +} + +# Paper in fax +proc Draw14 {w} { + set color $::C(14) + set xy {102 661 113 632 130 618} ;# Left paper edge + $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14L_0 + set xy {148 629 125 640 124 662} ;# Right paper edge + $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14L_1 + Draw14a $w L + + set xy { + 768.0 662.5 767.991316225 662.433786215 767.926187912 662.396880171 + } + $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14R_0 + $w.c lower I14R_0 + # NB. these numbers are VERY sensitive, you must start with final size + # and shrink down to get the values + set xy { + 745.947897349 662.428358855 745.997829056 662.452239237 746.0 662.5 + } + $w.c create line $xy -smooth 1 -fill $color -width 3 -tag I14R_1 + $w.c lower I14R_1 +} +proc Draw14a {w side} { + set color $::C(14) + set xy [$w.c coords I14${side}_0] + set xy2 [$w.c coords I14${side}_1] + lassign $xy x0 y0 x1 y1 x2 y2 + lassign $xy2 x3 y3 x4 y4 x5 y5 + set zz [concat \ + $x0 $y0 $x0 $y0 $xy $x2 $y2 $x2 $y2 \ + $x3 $y3 $x3 $y3 $xy2 $x5 $y5 $x5 $y5] + $w.c delete I14$side + $w.c create poly $zz -tag I14$side -smooth 1 -fill $color -outline $color \ + -width 3 + $w.c lower I14$side +} +proc Move14 {w {step {}}} { + set step [GetStep 14 $step] + + # Paper going down + set sc [expr {.9 - .05*$step}] + if {$sc < .3} { + $w.c delete I14L + return 0 + } + + lassign [$w.c coords I14L_0] Ox Oy + $w.c scale I14L_0 $Ox $Oy $sc $sc + lassign [lrange [$w.c coords I14L_1] end-1 end] Ox Oy + $w.c scale I14L_1 $Ox $Oy $sc $sc + Draw14a $w L + + # Paper going up + set sc [expr {.35 + .05*$step}] + set sc [expr {1 / $sc}] + + lassign [$w.c coords I14R_0] Ox Oy + $w.c scale I14R_0 $Ox $Oy $sc $sc + lassign [lrange [$w.c coords I14R_1] end-1 end] Ox Oy + $w.c scale I14R_1 $Ox $Oy $sc $sc + Draw14a $w R + + return [expr {$step == 10 ? 3 : 1}] +} + +# Light beam +proc Draw15 {w} { + set color $::C(15a) + set xy {824 599 824 585 820 585 829 585} + $w.c create line $xy -fill $::C(fg) -width 3 -tag I15a + set xy {789 599 836 643} + $w.c create rect $xy -fill $color -outline $::C(fg) -width 3 + set xy {778 610 788 632} + $w.c create rect $xy -fill $color -outline $::C(fg) -width 3 + set xy {766 617 776 625} + $w.c create rect $xy -fill $color -outline $::C(fg) -width 3 + + set xy {633 600 681 640} + $w.c create rect $xy -fill $color -outline $::C(fg) -width 3 + set xy {635 567 657 599} + $w.c create rect $xy -fill $color -outline $::C(fg) -width 2 + set xy {765 557 784 583} + $w.c create rect $xy -fill $color -outline $::C(fg) -width 2 + + Sine $w 658 580 765 580 3 15 -tag I15_s -fill $::C(fg) -width 3 +} +proc Move15a {w} { + set color $::C(15b) + $w.c scale I15a 824 599 1 .3 ;# Button down + set xy {765 621 681 621} + $w.c create line $xy -dash "-" -width 3 -fill $color -tag I15 +} +proc Move15 {w {step {}}} { + set step [GetStep 15 $step] + set numsteps 6 + + if {$step == $numsteps+2} { + MoveAbs $w I15_star {-100 -100} + return 2 + } + if {$step == 0} { ;# Break the light beam + Sparkle $w {-100 -100} I15_star + set xy {765 621 745 621} + $w.c coords I15 $xy + return 1 + } + lassign [Anchor $w I15_s w] x0 y0 + lassign [Anchor $w I15_s e] x1 y1 + set x [expr {$x0 + ($x1-$x0) * ($step - 1) / double($numsteps)}] + MoveAbs $w I15_star [list $x $y0] + return 1 +} + +# Bell +proc Draw16 {w} { + set color $::C(16) + set xy {722 485 791 556} + $w.c create rect $xy -fill {} -outline $::C(fg) -width 3 + set xy [box 752 515 25] ;# Bell + $w.c create oval $xy -fill $color -outline black -tag I16b -width 2 + set xy [box 752 515 5] ;# Bell button + $w.c create oval $xy -fill black -outline black -tag I16b + + set xy {784 523 764 549} ;# Clapper + $w.c create line $xy -width 3 -tag I16c -fill $::C(fg) + set xy [box 784 523 4] + $w.c create oval $xy -fill $::C(fg) -outline $::C(fg) -tag I16d +} +proc Move16 {w {step {}}} { + set step [GetStep 16 $step] + + # Note: we never stop + lassign {760 553} Ox Oy + if {$step & 1} { + set beta 12 + $w.c move I16b 3 0 + } else { + set beta -12 + $w.c move I16b -3 0 + } + RotateItem $w I16c $Ox $Oy $beta + RotateItem $w I16d $Ox $Oy $beta + + return [expr {$step == 1 ? 3 : 1}] +} + +# Cat +proc Draw17 {w} { + set color $::C(17) + + set xy {584 556 722 556} + $w.c create line $xy -fill $::C(fg) -width 3 + set xy {584 485 722 485} + $w.c create line $xy -fill $::C(fg) -width 3 + + set xy {664 523 717 549} ;# Body + $w.c create arc $xy -outline $::C(fg) -fill $color -width 3 \ + -style chord -start 128 -extent -260 -tag I17 + + set xy {709 554 690 543} ;# Paw + $w.c create oval $xy -outline $::C(fg) -fill $color -width 3 -tag I17 + set xy {657 544 676 555} + $w.c create oval $xy -outline $::C(fg) -fill $color -width 3 -tag I17 + + set xy [box 660 535 15] ;# Lower face + $w.c create arc $xy -outline $::C(fg) -width 3 -style arc \ + -start 150 -extent 240 -tag I17_ + $w.c create arc $xy -outline {} -fill $color -width 1 -style chord \ + -start 150 -extent 240 -tag I17_ + set xy {674 529 670 513 662 521 658 521 650 513 647 529} ;# Ears + $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ + $w.c create poly $xy -fill $color -outline {} -width 1 -tag {I17_ I17_c} + set xy {652 542 628 539} ;# Whiskers + $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ + set xy {652 543 632 545} + $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ + set xy {652 546 632 552} + $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ + + set xy {668 543 687 538} + $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w} + set xy {668 544 688 546} + $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w} + set xy {668 547 688 553} + $w.c create line $xy -fill $::C(fg) -width 3 -tag {I17_ I17w} + + set xy {649 530 654 538 659 530} ;# Left eye + $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17 + set xy {671 530 666 538 661 530} ;# Right eye + $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17 + set xy {655 543 660 551 665 543} ;# Mouth + $w.c create line $xy -fill $::C(fg) -width 2 -smooth 1 -tag I17 +} +proc Move17 {w {step {}}} { + set step [GetStep 17 $step] + + if {$step == 0} { + $w.c delete I17 ;# Delete most of the cat + set xy {655 543 660 535 665 543} ;# Mouth + $w.c create line $xy -fill $::C(fg) -width 3 -smooth 1 -tag I17_ + set xy [box 654 530 4] ;# Left eye + $w.c create oval $xy -outline $::C(fg) -width 3 -fill {} -tag I17_ + set xy [box 666 530 4] ;# Right eye + $w.c create oval $xy -outline $::C(fg) -width 3 -fill {} -tag I17_ + + $w.c move I17_ 0 -20 ;# Move face up + set xy {652 528 652 554} ;# Front leg + $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ + set xy {670 528 670 554} ;# 2nd front leg + $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ + + set xy { + 675 506 694 489 715 513 715 513 715 513 716 525 716 525 716 525 + 706 530 695 530 679 535 668 527 668 527 668 527 675 522 676 517 + 677 512 + } ;# Body + $w.c create poly $xy -fill [$w.c itemcget I17_c -fill] \ + -outline $::C(fg) -width 3 -smooth 1 -tag I17_ + set xy {716 514 716 554} ;# Back leg + $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ + set xy {694 532 694 554} ;# 2nd back leg + $w.c create line $xy -fill $::C(fg) -width 3 -tag I17_ + set xy {715 514 718 506 719 495 716 488};# Tail + $w.c create line $xy -fill $::C(fg) -width 3 -smooth 1 -tag I17_ + + $w.c raise I17w ;# Make whiskers visible + $w.c move I17_ -5 0 ;# Move away from wall a bit + return 2 + } + return 0 +} + +# Sling shot +proc Draw18 {w} { + set color $::C(18) + set xy {721 506 627 506} ;# Sling hold + $w.c create line $xy -width 4 -fill $::C(fg) -tag I18 + + set xy {607 500 628 513} ;# Sling rock + $w.c create oval $xy -fill $color -outline {} -tag I18a + + set xy {526 513 606 507 494 502} ;# Sling band + $w.c create line $xy -fill $::C(fg) -width 4 -tag I18b + set xy { 485 490 510 540 510 575 510 540 535 491 } ;# Sling + $w.c create line $xy -fill $::C(fg) -width 6 +} +proc Move18 {w {step {}}} { + set step [GetStep 18 $step] + + set pos { + {587 506} {537 506} {466 506} {376 506} {266 506 x} {136 506} + {16 506} {-100 -100} + } + + set b(0) {490 502 719 507 524 512} ;# Band collapsing + set b(1) { + 491 503 524 557 563 505 559 496 546 506 551 525 553 536 538 534 + 532 519 529 499 + } + set b(2) {491 503 508 563 542 533 551 526 561 539 549 550 530 500} + set b(3) {491 503 508 563 530 554 541 562 525 568 519 544 530 501} + + if {$step >= [llength $pos]} { + return 0 + } + + if {$step == 0} { + $w.c delete I18 + $w.c itemconfig I18b -smooth 1 + } + if {[info exists b($step)]} { + $w.c coords I18b $b($step) + } + + set where [lindex $pos $step] + MoveAbs $w I18a $where + if {[lindex $where 2] eq "x"} { + return 3 + } + return 1 +} + +# Water pipe +proc Draw19 {w} { + set color $::C(19) + set xx {249 181 155 118 86 55 22 0} + foreach {x1 x2} $xx { + $w.c create rect $x1 453 $x2 467 -fill $color -outline {} -tag I19 + $w.c create line $x1 453 $x2 453 -fill $::C(fg) -width 1;# Pipe top + $w.c create line $x1 467 $x2 467 -fill $::C(fg) -width 1;# Pipe bottom + } + $w.c raise I11i + + set xy [box 168 460 16] ;# Bulge by the joint + $w.c create oval $xy -fill $color -outline {} + $w.c create arc $xy -outline $::C(fg) -width 1 -style arc \ + -start 21 -extent 136 + $w.c create arc $xy -outline $::C(fg) -width 1 -style arc \ + -start -21 -extent -130 + + set xy {249 447 255 473} ;# First joint 26x6 + $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 + + set xy [box 257 433 34] ;# Bend up + $w.c create arc $xy -outline {} -fill $color -width 1 \ + -style pie -start 0 -extent -91 + $w.c create arc $xy -outline $::C(fg) -width 1 \ + -style arc -start 0 -extent -90 + set xy [box 257 433 20] + $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \ + -style pie -start 0 -extent -92 + $w.c create arc $xy -outline $::C(fg) -width 1 \ + -style arc -start 0 -extent -90 + set xy [box 257 421 34] ;# Bend left + $w.c create arc $xy -outline {} -fill $color -width 1 \ + -style pie -start 1 -extent 91 + $w.c create arc $xy -outline $::C(fg) -width 1 \ + -style arc -start 0 -extent 90 + set xy [box 257 421 20] + $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \ + -style pie -start 0 -extent 90 + $w.c create arc $xy -outline $::C(fg) -width 1 \ + -style arc -start 0 -extent 90 + set xy [box 243 421 34] ;# Bend down + $w.c create arc $xy -outline {} -fill $color -width 1 \ + -style pie -start 90 -extent 90 + $w.c create arc $xy -outline $::C(fg) -width 1 \ + -style arc -start 90 -extent 90 + set xy [box 243 421 20] + $w.c create arc $xy -outline {} -fill $::C(bg) -width 1 \ + -style pie -start 90 -extent 90 + $w.c create arc $xy -outline $::C(fg) -width 1 \ + -style arc -start 90 -extent 90 + + set xy {270 427 296 433} ;# 2nd joint bottom + $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 + set xy {270 421 296 427} ;# 2nd joint top + $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 + set xy {249 382 255 408} ;# Third joint right + $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 + set xy {243 382 249 408} ;# Third joint left + $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 + set xy {203 420 229 426} ;# Last joint + $w.c create rect $xy -fill $color -outline $::C(fg) -width 1 + + set xy [box 168 460 6] ;# Handle joint + $w.c create oval $xy -fill $::C(fg) -outline {} -tag I19a + set xy {168 460 168 512} ;# Handle bar + $w.c create line $xy -fill $::C(fg) -width 5 -tag I19b +} +proc Move19 {w {step {}}} { + set step [GetStep 19 $step] + + set angles {30 30 30} + if {$step == [llength $angles]} { + return 2 + } + + RotateItem $w I19b {*}[Centroid $w I19a] [lindex $angles $step] + return 1 +} + +# Water pouring +proc Draw20 {w} { +} +proc Move20 {w {step {}}} { + set step [GetStep 20 $step] + + set pos {451 462 473 484 496 504 513 523 532} + set freq {20 40 40 40 40 40 40 40 40} + set pos { + {451 20} {462 40} {473 40} {484 40} {496 40} {504 40} {513 40} + {523 40} {532 40 x} + } + if {$step >= [llength $pos]} { + return 0 + } + + $w.c delete I20 + set where [lindex $pos $step] + lassign $where y f + H2O $w $y $f + if {[lindex $where 2] eq "x"} { + return 3 + } + return 1 +} +proc H2O {w y f} { + set color $::C(20) + $w.c delete I20 + + Sine $w 208 428 208 $y 4 $f -tag {I20 I20s} -width 3 -fill $color \ + -smooth 1 + $w.c create line [$w.c coords I20s] -width 3 -fill $color -smooth 1 \ + -tag {I20 I20a} + $w.c create line [$w.c coords I20s] -width 3 -fill $color -smooth 1 \ + -tag {I20 I20b} + $w.c move I20a 8 0 + $w.c move I20b 16 0 +} + +# Bucket +proc Draw21 {w} { + set color $::C(21) + set xy {217 451 244 490} ;# Right handle + $w.c create line $xy -fill $::C(fg) -width 2 -tag I21_a + set xy {201 467 182 490} ;# Left handle + $w.c create line $xy -fill $::C(fg) -width 2 -tag I21_a + + set xy {245 490 237 535} ;# Right side + set xy2 {189 535 181 490} ;# Left side + $w.c create poly [concat $xy $xy2] -fill $color -outline {} \ + -tag {I21 I21f} + $w.c create line $xy -fill $::C(fg) -width 2 -tag I21 + $w.c create line $xy2 -fill $::C(fg) -width 2 -tag I21 + + set xy {182 486 244 498} ;# Top + $w.c create oval $xy -fill $color -outline {} -width 2 -tag {I21 I21f} + $w.c create oval $xy -fill {} -outline $::C(fg) -width 2 -tag {I21 I21t} + set xy {189 532 237 540} ;# Bottom + $w.c create oval $xy -fill $color -outline $::C(fg) -width 2 \ + -tag {I21 I21b} +} +proc Move21 {w {step {}}} { + set step [GetStep 21 $step] + + set numsteps 30 + if {$step >= $numsteps} { + return 0 + } + + lassign [$w.c coords I21b] x1 y1 x2 y2 + #lassign [$w.c coords I21t] X1 Y1 X2 Y2 + lassign {183 492 243 504} X1 Y1 X2 Y2 + + set f [expr {$step / double($numsteps)}] + set y2 [expr {$y2 - 3}] + set xx1 [expr {$x1 + ($X1 - $x1) * $f}] + set yy1 [expr {$y1 + ($Y1 - $y1) * $f}] + set xx2 [expr {$x2 + ($X2 - $x2) * $f}] + set yy2 [expr {$y2 + ($Y2 - $y2) * $f}] + #H2O $w $yy1 40 + + $w.c itemconfig I21b -fill $::C(20) + $w.c delete I21w + $w.c create poly $x2 $y2 $x1 $y1 $xx1 $yy1 $xx2 $yy1 -tag {I21 I21w} \ + -outline {} -fill $::C(20) + $w.c lower I21w I21 + $w.c raise I21b + $w.c lower I21f + + return [expr {$step == $numsteps-1 ? 3 : 1}] +} + +# Bucket drop +proc Draw22 {w} { +} +proc Move22 {w {step {}}} { + set step [GetStep 22 $step] + set pos {{213 513} {213 523} {213 543 x} {213 583} {213 593}} + + if {$step == 0} {$w.c itemconfig I21f -fill $::C(22)} + if {$step >= [llength $pos]} { + return 0 + } + set where [lindex $pos $step] + MoveAbs $w I21 $where + H2O $w [lindex $where 1] 40 + $w.c delete I21_a ;# Delete handles + + if {[lindex $where 2] eq "x"} { + return 3 + } + return 1 +} + +# Blow dart +proc Draw23 {w} { + set color $::C(23a) + set color2 $::C(23b) + set color3 $::C(23c) + + set xy {185 623 253 650} ;# Block + $w.c create rect $xy -fill black -outline $::C(fg) -width 2 -tag I23a + set xy {187 592 241 623} ;# Balloon + $w.c create oval $xy -outline {} -fill $color -tag I23b + $w.c create arc $xy -outline $::C(fg) -width 3 -tag I23b \ + -style arc -start 12 -extent 336 + set xy {239 604 258 589 258 625 239 610} ;# Balloon nozzle + $w.c create poly $xy -outline {} -fill $color -tag I23b + $w.c create line $xy -fill $::C(fg) -width 3 -tag I23b + + set xy {285 611 250 603} ;# Dart body + $w.c create oval $xy -fill $color2 -outline $::C(fg) -width 3 -tag I23d + set xy {249 596 249 618 264 607 249 596} ;# Dart tail + $w.c create poly $xy -fill $color3 -outline $::C(fg) -width 3 -tag I23d + set xy {249 607 268 607} ;# Dart detail + $w.c create line $xy -fill $::C(fg) -width 3 -tag I23d + set xy {285 607 305 607} ;# Dart needle + $w.c create line $xy -fill $::C(fg) -width 3 -tag I23d +} +proc Move23 {w {step {}}} { + set step [GetStep 23 $step] + + set pos { + {277 607} {287 607} {307 607 x} {347 607} {407 607} {487 607} + {587 607} {687 607} {787 607} {-100 -100} + } + + if {$step >= [llength $pos]} { + return 0 + } + if {$step <= 1} { + $w.c scale I23b {*}[Anchor $w I23a n] .9 .5 + } + set where [lindex $pos $step] + MoveAbs $w I23d $where + + if {[lindex $where 2] eq "x"} { + return 3 + } + return 1 +} + +# Balloon +proc Draw24 {w} { + set color $::C(24a) + set xy {366 518 462 665} ;# Balloon + $w.c create oval $xy -fill $color -outline $::C(fg) -width 3 -tag I24 + set xy {414 666 414 729} ;# String + $w.c create line $xy -fill $::C(fg) -width 3 -tag I24 + set xy {410 666 404 673 422 673 418 666} ;# Nozzle + $w.c create poly $xy -fill $color -outline $::C(fg) -width 3 -tag I24 + + set xy {387 567 390 549 404 542} ;# Reflections + $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24 + set xy {395 568 399 554 413 547} + $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24 + set xy {403 570 396 555 381 553} + $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24 + set xy {408 564 402 547 386 545} + $w.c create line $xy -fill $::C(fg) -smooth 1 -width 2 -tag I24 +} +proc Move24 {w {step {}}} { + global S + set step [GetStep 24 $step] + + if {$step > 4} { + return 0 + } elseif {$step == 4} { + return 2 + } + + if {$step == 0} { + $w.c delete I24 ;# Exploding balloon + set xy { + 347 465 361 557 271 503 272 503 342 574 259 594 259 593 362 626 + 320 737 320 740 398 691 436 738 436 739 476 679 528 701 527 702 + 494 627 548 613 548 613 480 574 577 473 577 473 474 538 445 508 + 431 441 431 440 400 502 347 465 347 465 + } + $w.c create poly $xy -tag I24 -fill $::C(24b) -outline $::C(24a) \ + -width 10 -smooth 1 + set msg [subst $S(message)] + $w.c create text [Centroid $w I24] -text $msg -tag {I24 I24t} \ + -justify center -font {{Times Roman} 18 bold} + return 1 + } + + $w.c itemconfig I24t -font [list {Times Roman} [expr {18 + 6*$step}] bold] + $w.c move I24 0 -60 + $w.c scale I24 {*}[Centroid $w I24] 1.25 1.25 + return 1 +} + +# Displaying the message +proc Move25 {w {step {}}} { + global S + set step [GetStep 25 $step] + if {$step == 0} { + set ::XY(25) [clock clicks -milliseconds] + return 1 + } + set elapsed [expr {[clock clicks -milliseconds] - $::XY(25)}] + if {$elapsed < 5000} { + return 1 + } + return 2 +} + +# Collapsing balloon +proc Move26 {w {step {}}} { + global S + set step [GetStep 26 $step] + + if {$step >= 3} { + $w.c delete I24 I26 + $w.c create text 430 755 -anchor s -tag I26 \ + -text "click to continue" -font {{Times Roman} 24 bold} + bind $w.c <1> [list Reset $w] + return 4 + } + + $w.c scale I24 {*}[Centroid $w I24] .8 .8 + $w.c move I24 0 60 + $w.c itemconfig I24t -font [list {Times Roman} [expr {30 - 6*$step}] bold] + return 1 +} + +################################################################ +# +# Helper functions +# + +proc box {x y r} { + return [list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]] +} + +proc MoveAbs {w item xy} { + lassign $xy x y + lassign [Centroid $w $item] Ox Oy + set dx [expr {$x - $Ox}] + set dy [expr {$y - $Oy}] + $w.c move $item $dx $dy +} + +proc RotateItem {w item Ox Oy beta} { + set xy [$w.c coords $item] + set xy2 {} + foreach {x y} $xy { + lappend xy2 {*}[RotateC $x $y $Ox $Oy $beta] + } + $w.c coords $item $xy2 +} + +proc RotateC {x y Ox Oy beta} { + # rotates vector (Ox,Oy)->(x,y) by beta degrees clockwise + + set x [expr {$x - $Ox}] ;# Shift to origin + set y [expr {$y - $Oy}] + + set beta [expr {$beta * atan(1) * 4 / 180.0}] ;# Radians + set xx [expr {$x * cos($beta) - $y * sin($beta)}] ;# Rotate + set yy [expr {$x * sin($beta) + $y * cos($beta)}] + + set xx [expr {$xx + $Ox}] ;# Shift back + set yy [expr {$yy + $Oy}] + + return [list $xx $yy] +} + +proc Reset {w} { + global S + DrawAll $w + bind $w.c <1> {} + set S(mode) $::MSTART + set S(active) 0 +} + +# Each Move## keeps its state info in STEP, this retrieves and increments it +proc GetStep {who step} { + global STEP + if {$step ne ""} { + set STEP($who) $step + } elseif {![info exists STEP($who)] || $STEP($who) eq ""} { + set STEP($who) 0 + } else { + incr STEP($who) + } + return $STEP($who) +} + +proc ResetStep {} { + global STEP + set ::S(cnt) 0 + foreach a [array names STEP] { + set STEP($a) "" + } +} + +proc Sine {w x0 y0 x1 y1 amp freq args} { + set PI [expr {4 * atan(1)}] + set step 2 + set xy {} + if {$y0 == $y1} { ;# Horizontal + for {set x $x0} {$x <= $x1} {incr x $step} { + set beta [expr {($x - $x0) * 2 * $PI / $freq}] + set y [expr {$y0 + $amp * sin($beta)}] + lappend xy $x $y + } + } else { + for {set y $y0} {$y <= $y1} {incr y $step} { + set beta [expr {($y - $y0) * 2 * $PI / $freq}] + set x [expr {$x0 + $amp * sin($beta)}] + lappend xy $x $y + } + } + return [$w.c create line $xy {*}$args] +} + +proc RoundRect {w xy radius args} { + lassign $xy x0 y0 x3 y3 + set r [winfo pixels $w.c $radius] + set d [expr {2 * $r}] + + # Make sure that the radius of the curve is less than 3/8 size of the box! + set maxr 0.75 + if {$d > $maxr * ($x3 - $x0)} { + set d [expr {$maxr * ($x3 - $x0)}] + } + if {$d > $maxr * ($y3 - $y0)} { + set d [expr {$maxr * ($y3 - $y0)}] + } + + set x1 [expr { $x0 + $d }] + set x2 [expr { $x3 - $d }] + set y1 [expr { $y0 + $d }] + set y2 [expr { $y3 - $d }] + + set xy [list $x0 $y0 $x1 $y0 $x2 $y0 $x3 $y0 $x3 $y1 $x3 $y2] + lappend xy $x3 $y3 $x2 $y3 $x1 $y3 $x0 $y3 $x0 $y2 $x0 $y1 + return $xy +} + +proc RoundPoly {canv xy radii args} { + set lenXY [llength $xy] + set lenR [llength $radii] + if {$lenXY != 2*$lenR} { + error "wrong number of vertices and radii" + } + + set knots {} + lassign [lrange $xy end-1 end] x0 y0 + lassign $xy x1 y1 + lappend xy {*}[lrange $xy 0 1] + + for {set i 0} {$i < $lenXY} {incr i 2} { + set radius [lindex $radii [expr {$i/2}]] + set r [winfo pixels $canv $radius] + + lassign [lrange $xy [expr {$i + 2}] [expr {$i + 3}]] x2 y2 + set z [_RoundPoly2 $x0 $y0 $x1 $y1 $x2 $y2 $r] + lappend knots {*}$z + + lassign [list $x1 $y1] x0 y0 + lassign [list $x2 $y2] x1 y1 + } + set n [$canv create polygon $knots -smooth 1 {*}$args] + return $n +} + +proc _RoundPoly2 {x0 y0 x1 y1 x2 y2 radius} { + set d [expr {2 * $radius}] + set maxr 0.75 + + set v1x [expr {$x0 - $x1}] + set v1y [expr {$y0 - $y1}] + set v2x [expr {$x2 - $x1}] + set v2y [expr {$y2 - $y1}] + + set vlen1 [expr {sqrt($v1x*$v1x + $v1y*$v1y)}] + set vlen2 [expr {sqrt($v2x*$v2x + $v2y*$v2y)}] + if {$d > $maxr * $vlen1} { + set d [expr {$maxr * $vlen1}] + } + if {$d > $maxr * $vlen2} { + set d [expr {$maxr * $vlen2}] + } + + lappend xy [expr {$x1 + $d * $v1x/$vlen1}] [expr {$y1 + $d * $v1y/$vlen1}] + lappend xy $x1 $y1 + lappend xy [expr {$x1 + $d * $v2x/$vlen2}] [expr {$y1 + $d * $v2y/$vlen2}] + + return $xy +} + +proc Sparkle {w Oxy tag} { + set xy {299 283 298 302 295 314 271 331 239 310 242 292 256 274 281 273} + foreach {x y} $xy { + $w.c create line 271 304 $x $y -fill white -width 3 -tag $tag + } + MoveAbs $w $tag $Oxy +} + +proc Centroid {w item} { + return [Anchor $w $item c] +} + +proc Anchor {w item where} { + lassign [$w.c bbox $item] x1 y1 x2 y2 + if {[string match *n* $where]} { + set y $y1 + } elseif {[string match *s* $where]} { + set y $y2 + } else { + set y [expr {($y1 + $y2) / 2.0}] + } + if {[string match *w* $where]} { + set x $x1 + } elseif {[string match *e* $where]} { + set x $x2 + } else { + set x [expr {($x1 + $x2) / 2.0}] + } + return [list $x $y] +} + +DoDisplay $w +Reset $w +Go $w ;# Start everything going diff --git a/library/demos/hello b/library/demos/hello index b9823f6..d10b8d5 100644 --- a/library/demos/hello +++ b/library/demos/hello @@ -5,7 +5,9 @@ exec wish "$0" ${1+"$@"} # hello -- # Simple Tk script to create a button that prints "Hello, world". # Click on the button to terminate the program. -# + +package require Tk + # The first line below creates the button, and the second line # asks the packer to shrink-wrap the application's main window # around the button. diff --git a/library/demos/hscale.tcl b/library/demos/hscale.tcl index 4902d8e..1df144d 100644 --- a/library/demos/hscale.tcl +++ b/library/demos/hscale.tcl @@ -6,6 +6,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .hscale catch {destroy $w} toplevel $w @@ -16,11 +18,9 @@ positionWindow $w label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a horizontal scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the length of the arrow." pack $w.msg -side top -padx .5c -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.frame -borderwidth 10 pack $w.frame -side top -fill x diff --git a/library/demos/icon.tcl b/library/demos/icon.tcl index 4452b91..224d8f9 100644 --- a/library/demos/icon.tcl +++ b/library/demos/icon.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .icon catch {destroy $w} toplevel $w @@ -17,18 +19,17 @@ positionWindow $w label $w.msg -font $font -wraplength 5i -justify left -text "This window shows three ways of using bitmaps or images in radiobuttons and checkbuttons. On the left are two radiobuttons, each of which displays a bitmap and an indicator. In the middle is a checkbutton that displays a different image depending on whether it is selected or not. On the right is a checkbutton that displays a single bitmap but changes its background color to indicate whether or not it is selected." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x +# Main widget program sets variable tk_demoDirectory image create bitmap flagup \ - -file [file join $tk_library demos images flagup.bmp] \ - -maskfile [file join $tk_library demos images flagup.bmp] + -file [file join $tk_demoDirectory images flagup.xbm] \ + -maskfile [file join $tk_demoDirectory images flagup.xbm] image create bitmap flagdown \ - -file [file join $tk_library demos images flagdown.bmp] \ - -maskfile [file join $tk_library demos images flagdown.bmp] + -file [file join $tk_demoDirectory images flagdown.xbm] \ + -maskfile [file join $tk_demoDirectory images flagdown.xbm] frame $w.frame -borderwidth 10 pack $w.frame -side top @@ -36,15 +37,15 @@ checkbutton $w.frame.b1 -image flagdown -selectimage flagup \ -indicatoron 0 $w.frame.b1 configure -selectcolor [$w.frame.b1 cget -background] checkbutton $w.frame.b2 \ - -bitmap @[file join $tk_library demos images letters.bmp] \ + -bitmap @[file join $tk_demoDirectory images letters.xbm] \ -indicatoron 0 -selectcolor SeaGreen1 frame $w.frame.left pack $w.frame.left $w.frame.b1 $w.frame.b2 -side left -expand yes -padx 5m radiobutton $w.frame.left.b3 \ - -bitmap @[file join $tk_library demos images letters.bmp] \ + -bitmap @[file join $tk_demoDirectory images letters.xbm] \ -variable letters -value full radiobutton $w.frame.left.b4 \ - -bitmap @[file join $tk_library demos images noletter.bmp] \ + -bitmap @[file join $tk_demoDirectory images noletter.xbm] \ -variable letters -value empty pack $w.frame.left.b3 $w.frame.left.b4 -side top -expand yes diff --git a/library/demos/image1.tcl b/library/demos/image1.tcl index a4226ac..0bd2f49 100644 --- a/library/demos/image1.tcl +++ b/library/demos/image1.tcl @@ -6,6 +6,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .image1 catch {destroy $w} toplevel $w @@ -16,19 +18,18 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration displays two images, each in a separate label widget." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x +# Main widget program sets variable tk_demoDirectory catch {image delete image1a} -image create photo image1a -file [file join $tk_library demos images earth.gif] +image create photo image1a -file [file join $tk_demoDirectory images earth.gif] label $w.l1 -image image1a -bd 1 -relief sunken catch {image delete image1b} image create photo image1b \ - -file [file join $tk_library demos images earthris.gif] + -file [file join $tk_demoDirectory images earthris.gif] label $w.l2 -image image1b -bd 1 -relief sunken pack $w.l1 $w.l2 -side top -padx .5m -pady .5m diff --git a/library/demos/image2.tcl b/library/demos/image2.tcl index 67560b3..7b3d748 100644 --- a/library/demos/image2.tcl +++ b/library/demos/image2.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + # loadDir -- # This procedure reloads the directory listbox from the directory # named in the demo's entry. @@ -18,7 +20,7 @@ proc loadDir w { global dirName $w.f.list delete 0 end - foreach i [lsort [glob -directory $dirName *]] { + foreach i [lsort [glob -type f -directory $dirName *]] { $w.f.list insert end [file tail $i] } } @@ -53,7 +55,12 @@ proc loadImage {w x y} { global dirName set file [file join $dirName [$w.f.list get @$x,$y]] - image2a configure -file $file + if {[catch { + image2a configure -file $file + }]} then { + # Mark the file as not loadable + $w.f.list itemconfigure @$x,$y -bg \#c00000 -selectbackground \#ff0000 + } } set w .image2 @@ -66,17 +73,16 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration allows you to view images using a Tk \"photo\" image. First type a directory name in the listbox, then type Return to load the directory into the listbox. Then double-click on a file name in the listbox to see that image." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.mid pack $w.mid -fill both -expand 1 labelframe $w.dir -text "Directory:" -set dirName [file join $tk_library demos images] +# Main widget program sets variable tk_demoDirectory +set dirName [file join $tk_demoDirectory images] entry $w.dir.e -width 30 -textvariable dirName button $w.dir.b -pady 0 -padx 2m -text "Select Dir." \ -command "selectAndLoadDir $w" diff --git a/library/demos/images/face.bmp b/library/demos/images/face.xbm index 03d829f..03d829f 100644 --- a/library/demos/images/face.bmp +++ b/library/demos/images/face.xbm diff --git a/library/demos/images/flagdown.bmp b/library/demos/images/flagdown.xbm index 55abc51..55abc51 100644 --- a/library/demos/images/flagdown.bmp +++ b/library/demos/images/flagdown.xbm diff --git a/library/demos/images/flagup.bmp b/library/demos/images/flagup.xbm index 6eb0d84..6eb0d84 100644 --- a/library/demos/images/flagup.bmp +++ b/library/demos/images/flagup.xbm diff --git a/library/demos/images/gray25.bmp b/library/demos/images/gray25.xbm index b234b3c..b234b3c 100644 --- a/library/demos/images/gray25.bmp +++ b/library/demos/images/gray25.xbm diff --git a/library/demos/images/letters.bmp b/library/demos/images/letters.xbm index 0f12568..0f12568 100644 --- a/library/demos/images/letters.bmp +++ b/library/demos/images/letters.xbm diff --git a/library/demos/images/noletter.bmp b/library/demos/images/noletter.xbm index 5774124..5774124 100644 --- a/library/demos/images/noletter.bmp +++ b/library/demos/images/noletter.xbm diff --git a/library/demos/images/pattern.bmp b/library/demos/images/pattern.xbm index df31baf..df31baf 100644 --- a/library/demos/images/pattern.bmp +++ b/library/demos/images/pattern.xbm diff --git a/library/demos/items.tcl b/library/demos/items.tcl index b4d91f8..85bf5f3 100644 --- a/library/demos/items.tcl +++ b/library/demos/items.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .items catch {destroy $w} toplevel $w @@ -18,11 +20,9 @@ set c $w.frame.c label $w.msg -font $font -wraplength 5i -justify left -text "This window contains a canvas widget with examples of the various kinds of items supported by canvases. The following operations are supported:\n Button-1 drag:\tmoves item under pointer.\n Button-2 drag:\trepositions view.\n Button-3 drag:\tstrokes out area.\n Ctrl+f:\t\tprints items under area." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.frame pack $w.frame -side top -fill both -expand yes @@ -75,8 +75,9 @@ $c create line 6.33c 1c 6.33c 4c -arrow both -tags item $c create line 5c 6c 9c 6c 9c 1c 8c 1c 8c 4.8c 8.8c 4.8c 8.8c 1.2c \ 8.2c 1.2c 8.2c 4.6c 8.6c 4.6c 8.6c 1.4c 8.4c 1.4c 8.4c 4.4c \ -width 3 -fill $red -tags item +# Main widget program sets variable tk_demoDirectory $c create line 1c 5c 7c 5c 7c 7c 9c 7c -width .5c \ - -stipple @[file join $tk_library demos images gray25.bmp] \ + -stipple @[file join $tk_demoDirectory images gray25.xbm] \ -arrow both -arrowshape {15 15 7} -tags item $c create line 1c 7c 1.75c 5.8c 2.5c 7c 3.25c 5.8c 4c 7c -width .5c \ -cap round -join round -tags item @@ -88,7 +89,7 @@ $c create line 15.5c 1c 19.5c 1.5c 15.5c 4.5c 19.5c 4c -smooth on \ -arrow both -width 3 -tags item $c create line 12c 6c 13.5c 4.5c 16.5c 7.5c 18c 6c \ 16.5c 4.5c 13.5c 7.5c 12c 6c -smooth on -width 3m -cap round \ - -stipple @[file join $tk_library demos images gray25.bmp] \ + -stipple @[file join $tk_demoDirectory images gray25.xbm] \ -fill $red -tags item $c create text 25c .2c -text Polygons -anchor n @@ -99,21 +100,21 @@ $c create polygon 25c 4c 25c 4c 25c 1c 26c 1c 27c 4c 28c 1c \ 29c 1c 29c 4c 29c 4c -fill $red -smooth on -tags item $c create polygon 22c 4.5c 25c 4.5c 25c 6.75c 28c 6.75c \ 28c 5.25c 24c 5.25c 24c 6.0c 26c 6c 26c 7.5c 22c 7.5c \ - -stipple @[file join $tk_library demos images gray25.bmp] \ + -stipple @[file join $tk_demoDirectory images gray25.xbm] \ -outline black -tags item $c create text 5c 8.2c -text Rectangles -anchor n $c create rectangle 1c 9.5c 4c 12.5c -outline $red -width 3m -tags item $c create rectangle 0.5c 13.5c 4.5c 15.5c -fill $green -tags item $c create rectangle 6c 10c 9c 15c -outline {} \ - -stipple @[file join $tk_library demos images gray25.bmp] \ + -stipple @[file join $tk_demoDirectory images gray25.xbm] \ -fill $blue -tags item $c create text 15c 8.2c -text Ovals -anchor n $c create oval 11c 9.5c 14c 12.5c -outline $red -width 3m -tags item $c create oval 10.5c 13.5c 14.5c 15.5c -fill $green -tags item $c create oval 16c 10c 19c 15c -outline {} \ - -stipple @[file join $tk_library demos images gray25.bmp] \ + -stipple @[file join $tk_demoDirectory images gray25.xbm] \ -fill $blue -tags item $c create text 25c 8.2c -text Text -anchor n @@ -133,7 +134,7 @@ $c create arc 0.5c 17c 7c 20c -fill $green -outline black \ -start 45 -extent 270 -style pieslice -tags item $c create arc 6.5c 17c 9.5c 20c -width 4m -style arc \ -outline $blue -start -135 -extent 270 -tags item \ - -outlinestipple @[file join $tk_library demos images gray25.bmp] + -outlinestipple @[file join $tk_demoDirectory images gray25.xbm] $c create arc 0.5c 20c 9.5c 24c -width 4m -style pieslice \ -fill {} -outline $red -start 225 -extent -90 -tags item $c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ @@ -141,11 +142,11 @@ $c create arc 5.5c 20.5c 9.5c 23.5c -width 4m -style chord \ $c create text 15c 16.2c -text Bitmaps -anchor n $c create bitmap 13c 20c -tags item \ - -bitmap @[file join $tk_library demos images face.bmp] + -bitmap @[file join $tk_demoDirectory images face.xbm] $c create bitmap 17c 18.5c -tags item \ - -bitmap @[file join $tk_library demos images noletter.bmp] + -bitmap @[file join $tk_demoDirectory images noletter.xbm] $c create bitmap 17c 21.5c -tags item \ - -bitmap @[file join $tk_library demos images letters.bmp] + -bitmap @[file join $tk_demoDirectory images letters.xbm] $c create text 25c 16.2c -text Windows -anchor n button $c.button -text "Press Me" -command "butPress $c $red" diff --git a/library/demos/ixset b/library/demos/ixset index 1677542..06b644d 100644 --- a/library/demos/ixset +++ b/library/demos/ixset @@ -9,6 +9,9 @@ exec wish "$0" ${1+"$@"} # 91/11/23 : pda@masi.ibp.fr, jt@ratp.fr : design # 92/08/01 : pda@masi.ibp.fr : cleaning +package require Tcl 8.4 +package require Tk + # # Button actions # @@ -53,38 +56,31 @@ proc readsettings {} { set xfd [open "|xset q" r] while {[gets $xfd line] > -1} { - set kw [lindex $line 0] - - case $kw in { - {auto} - { - set rpt [lindex $line 1] - if {[expr "{$rpt} == {repeat:}"]} then { - set kbdrep [lindex $line 2] - set kbdcli [lindex $line 6] - } - } - {bell} - { - set bellvol [lindex $line 2] - set bellpit [lindex $line 5] - set belldur [lindex $line 8] - } - {acceleration:} - { - set mouseacc [lindex $line 1] - set mousethr [lindex $line 3] - } - {prefer} - { - set bla [lindex $line 2] - set screenbla [expr "{$bla} == {yes} ? {blank} : {noblank}"] - } - {timeout:} - { - set screentim [lindex $line 1] - set screencyc [lindex $line 3] + switch -- [lindex $line 0] { + auto { + set rpt [lindex $line 1] + if {$rpt eq "repeat:"} { + set kbdrep [lindex $line 2] + set kbdcli [lindex $line 6] } + } + bell { + set bellvol [lindex $line 2] + set bellpit [lindex $line 5] + set belldur [lindex $line 8] + } + acceleration: { + set mouseacc [lindex $line 1] + set mousethr [lindex $line 3] + } + prefer { + set bla [lindex $line 2] + set screenbla [expr {$bla eq "yes" ? "blank" : "noblank"}] + } + timeout: { + set screentim [lindex $line 1] + set screencyc [lindex $line 3] + } } } close $xfd @@ -114,7 +110,7 @@ proc writesettings {} { set bellpit [.bell.val.pit.entry get] set belldur [.bell.val.dur.entry get] - if {[expr "{$kbdrep} == {on}"]} then { + if {$kbdrep eq "on"} { set kbdcli [.kbd.val.cli get] } else { set kbdcli "off" @@ -150,7 +146,7 @@ proc dispsettings {} { .bell.val.dur.entry delete 0 end .bell.val.dur.entry insert 0 $belldur - .kbd.val.onoff [expr "{$kbdrep} == {on} ? {select} : {deselect}"] + .kbd.val.onoff [expr {$kbdrep eq "on" ? "select" : "deselect"}] .kbd.val.cli set $kbdcli .mouse.hor.acc.entry delete 0 end @@ -158,8 +154,8 @@ proc dispsettings {} { .mouse.hor.thr.entry delete 0 end .mouse.hor.thr.entry insert 0 $mousethr - .screen.blank [expr "{$screenbla}=={blank} ? {select} : {deselect}"] - .screen.pat [expr "{$screenbla}!={blank} ? {select} : {deselect}"] + .screen.blank [expr {$screenbla eq "blank" ? "select" : "deselect"}] + .screen.pat [expr {$screenbla ne "blank" ? "select" : "deselect"}] .screen.tim.entry delete 0 end .screen.tim.entry insert 0 $screentim .screen.cyc.entry delete 0 end diff --git a/library/demos/knightstour.tcl b/library/demos/knightstour.tcl new file mode 100644 index 0000000..b52e38f --- /dev/null +++ b/library/demos/knightstour.tcl @@ -0,0 +1,255 @@ +# Copyright (C) 2008 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Calculate a Knight's tour of a chessboard. +# +# This uses Warnsdorff's rule to calculate the next square each +# time. This specifies that the next square should be the one that +# has the least number of available moves. +# +# Using this rule it is possible to get to a position where +# there are no squares available to move into. In this implementation +# this occurs when the starting square is d6. +# +# To solve this fault an enhancement to the rule is that if we +# have a choice of squares with an equal score, we should choose +# the one nearest the edge of the board. +# +# If the call to the Edgemost function is commented out you can see +# this occur. +# +# You can drag the knight to a specific square to start if you wish. +# If you let it repeat then it will choose random start positions +# for each new tour. + +package require Tk 8.5 + +# Return a list of accessible squares from a given square +proc ValidMoves {square} { + set moves {} + foreach pair {{-1 -2} {-2 -1} {-2 1} {-1 2} {1 2} {2 1} {2 -1} {1 -2}} { + set col [expr {($square % 8) + [lindex $pair 0]}] + set row [expr {($square / 8) + [lindex $pair 1]}] + if {$row > -1 && $row < 8 && $col > -1 && $col < 8} { + lappend moves [expr {$row * 8 + $col}] + } + } + return $moves +} + +# Return the number of available moves for this square +proc CheckSquare {square} { + variable visited + set moves 0 + foreach test [ValidMoves $square] { + if {[lsearch -exact -integer $visited $test] == -1} { + incr moves + } + } + return $moves +} + +# Select the next square to move to. Returns -1 if there are no available +# squares remaining that we can move to. +proc Next {square} { + variable visited + set minimum 9 + set nextSquare -1 + foreach testSquare [ValidMoves $square] { + if {[lsearch -exact -integer $visited $testSquare] == -1} { + set count [CheckSquare $testSquare] + if {$count < $minimum} { + set minimum $count + set nextSquare $testSquare + } elseif {$count == $minimum} { + set nextSquare [Edgemost $nextSquare $testSquare] + } + } + } + return $nextSquare +} + +# Select the square nearest the edge of the board +proc Edgemost {a b} { + set colA [expr {3-int(abs(3.5-($a%8)))}] + set colB [expr {3-int(abs(3.5-($b%8)))}] + set rowA [expr {3-int(abs(3.5-($a/8)))}] + set rowB [expr {3-int(abs(3.5-($b/8)))}] + return [expr {($colA * $rowA) < ($colB * $rowB) ? $a : $b}] +} + +# Display a square number as a standard chess square notation. +proc N {square} { + return [format %c%d [expr {97 + $square % 8}] \ + [expr {$square / 8 + 1}]] +} + +# Perform a Knight's move and schedule the next move. +proc MovePiece {dlg last square} { + variable visited + variable delay + variable continuous + $dlg.f.txt insert end "[llength $visited]. [N $last] .. [N $square]\n" {} + $dlg.f.txt see end + $dlg.f.c itemconfigure [expr {1+$last}] -state normal -outline black + $dlg.f.c itemconfigure [expr {1+$square}] -state normal -outline red + $dlg.f.c coords knight [lrange [$dlg.f.c coords [expr {1+$square}]] 0 1] + lappend visited $square + set next [Next $square] + if {$next ne -1} { + variable aid [after $delay [list MovePiece $dlg $square $next]] + } else { + $dlg.tf.b1 configure -state normal + if {[llength $visited] == 64} { + variable initial + if {$initial == $square} { + $dlg.f.txt insert end "Closed tour!" + } else { + $dlg.f.txt insert end "Success\n" {} + if {$continuous} { + after [expr {$delay * 2}] [namespace code \ + [list Tour $dlg [expr {int(rand() * 64)}]]] + } + } + } else { + $dlg.f.txt insert end "FAILED!\n" {} + } + } +} + +# Begin a new tour of the board given a random start position +proc Tour {dlg {square {}}} { + variable visited {} + $dlg.f.txt delete 1.0 end + $dlg.tf.b1 configure -state disabled + for {set n 0} {$n < 64} {incr n} { + $dlg.f.c itemconfigure $n -state disabled -outline black + } + if {$square eq {}} { + set square [expr {[$dlg.f.c find closest \ + {*}[$dlg.f.c coords knight] 0 65]-1}] + } + variable initial $square + after idle [list MovePiece $dlg $initial $initial] +} + +proc Stop {} { + variable aid + catch {after cancel $aid} +} + +proc Exit {dlg} { + Stop + destroy $dlg +} + +proc SetDelay {new} { + variable delay [expr {int($new)}] +} + +proc DragStart {w x y} { + $w dtag selected + $w addtag selected withtag current + variable dragging [list $x $y] +} +proc DragMotion {w x y} { + variable dragging + if {[info exists dragging]} { + $w move selected [expr {$x - [lindex $dragging 0]}] \ + [expr {$y - [lindex $dragging 1]}] + variable dragging [list $x $y] + } +} +proc DragEnd {w x y} { + set square [$w find closest $x $y 0 65] + $w coords selected [lrange [$w coords $square] 0 1] + $w dtag selected + variable dragging ; unset dragging +} + +proc CreateGUI {} { + catch {destroy .knightstour} + set dlg [toplevel .knightstour] + wm title $dlg "Knights tour" + wm withdraw $dlg + set f [ttk::frame $dlg.f] + set c [canvas $f.c -width 240 -height 240] + text $f.txt -width 10 -height 1 -background white \ + -yscrollcommand [list $f.vs set] -font {Arial 8} + ttk::scrollbar $f.vs -command [list $f.txt yview] + + variable delay 600 + variable continuous 0 + ttk::frame $dlg.tf + ttk::label $dlg.tf.ls -text Speed + ttk::scale $dlg.tf.sc -from 8 -to 2000 -command [list SetDelay] \ + -variable [namespace which -variable delay] + ttk::checkbutton $dlg.tf.cc -text Repeat \ + -variable [namespace which -variable continuous] + ttk::button $dlg.tf.b1 -text Start -command [list Tour $dlg] + ttk::button $dlg.tf.b2 -text Exit -command [list Exit $dlg] + set square 0 + for {set row 7} {$row != -1} {incr row -1} { + for {set col 0} {$col < 8} {incr col} { + if {(($col & 1) ^ ($row & 1))} { + set fill tan3 ; set dfill tan4 + } else { + set fill bisque ; set dfill bisque3 + } + set coords [list [expr {$col * 30 + 4}] [expr {$row * 30 + 4}] \ + [expr {$col * 30 + 30}] [expr {$row * 30 + 30}]] + $c create rectangle $coords -fill $fill -disabledfill $dfill \ + -width 2 -state disabled + } + } + catch {eval font create KnightFont -size -24} + $c create text 0 0 -font KnightFont -text "\u265e" \ + -anchor nw -tags knight -fill black -activefill "#600000" + $c coords knight [lrange [$c coords [expr {1 + int(rand() * 64)}]] 0 1] + $c bind knight <ButtonPress-1> [namespace code [list DragStart %W %x %y]] + $c bind knight <Motion> [namespace code [list DragMotion %W %x %y]] + $c bind knight <ButtonRelease-1> [namespace code [list DragEnd %W %x %y]] + + grid $c $f.txt $f.vs -sticky news + grid rowconfigure $f 0 -weight 1 + grid columnconfigure $f 1 -weight 1 + + grid $f - - - - - -sticky news + set things [list $dlg.tf.ls $dlg.tf.sc $dlg.tf.cc $dlg.tf.b1] + if {![info exists ::widgetDemo]} { + lappend things $dlg.tf.b2 + if {[tk windowingsystem] ne "aqua"} { + set things [linsert $things 0 [ttk::sizegrip $dlg.tf.sg]] + } + } + pack {*}$things -side right + if {[tk windowingsystem] eq "aqua"} { + pack configure {*}$things -padx {4 4} -pady {12 12} + pack configure [lindex $things 0] -padx {4 24} + pack configure [lindex $things end] -padx {16 4} + } + grid $dlg.tf - - - - - -sticky ew + if {[info exists ::widgetDemo]} { + grid [addSeeDismiss $dlg.buttons $dlg] - - - - - -sticky ew + } + + grid rowconfigure $dlg 0 -weight 1 + grid columnconfigure $dlg 0 -weight 1 + + bind $dlg <Control-F2> {console show} + bind $dlg <Return> [list $dlg.tf.b1 invoke] + bind $dlg <Escape> [list $dlg.tf.b2 invoke] + bind $dlg <Destroy> [namespace code [list Stop]] + wm protocol $dlg WM_DELETE_WINDOW [namespace code [list Exit $dlg]] + + wm deiconify $dlg + tkwait window $dlg +} + +if {![winfo exists .knightstour]} { + if {![info exists widgetDemo]} { wm withdraw . } + set r [catch [linsert $argv 0 CreateGUI] err] + if {$r} { + tk_messageBox -icon error -title "Error" -message $err + } + if {![info exists widgetDemo]} { exit $r } +} diff --git a/library/demos/label.tcl b/library/demos/label.tcl index c572c2d..a5cab10 100644 --- a/library/demos/label.tcl +++ b/library/demos/label.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .label catch {destroy $w} toplevel $w @@ -17,11 +19,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "Five labels are displayed below: three textual ones on the left, and a bitmap label and a text label on the right. Labels are pretty boring because you can't do anything with them." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.left frame $w.right @@ -32,7 +32,8 @@ label $w.left.l2 -text "Second label, raised" -relief raised label $w.left.l3 -text "Third label, sunken" -relief sunken pack $w.left.l1 $w.left.l2 $w.left.l3 -side top -expand yes -pady 2 -anchor w +# Main widget program sets variable tk_demoDirectory label $w.right.bitmap -borderwidth 2 -relief sunken \ - -bitmap @[file join $tk_library demos images face.bmp] + -bitmap @[file join $tk_demoDirectory images face.xbm] label $w.right.caption -text "Tcl/Tk Proprietor" pack $w.right.bitmap $w.right.caption -side top diff --git a/library/demos/labelframe.tcl b/library/demos/labelframe.tcl index 127852e..21d079f 100644 --- a/library/demos/labelframe.tcl +++ b/library/demos/labelframe.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .labelframe catch {destroy $w} toplevel $w @@ -21,13 +23,9 @@ label $w.msg -font $font -wraplength 4i -justify left -text "Labelframes are\ plain text or another widget." pack $w.msg -side top -# The bottom buttons - -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -width 15 -button $w.buttons.code -text "See Code" -command "showCode $w" -width 15 -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x # Demo area diff --git a/library/demos/mclist.tcl b/library/demos/mclist.tcl new file mode 100644 index 0000000..d1d3f47 --- /dev/null +++ b/library/demos/mclist.tcl @@ -0,0 +1,96 @@ +# mclist.tcl -- +# +# This demonstration script creates a toplevel window containing a Ttk +# tree widget configured as a multi-column listbox. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .mclist +catch {destroy $w} +toplevel $w +wm title $w "Multi-Column List" +wm iconname $w "mclist" +positionWindow $w + +## Explanatory text +ttk::label $w.msg -font $font -wraplength 4i -justify left -anchor n -padding {10 2 10 6} -text "Ttk is the new Tk themed widget set. One of the widgets it includes is a tree widget, which can be configured to display multiple columns of informational data without displaying the tree itself. This is a simple way to build a listbox that has multiple columns. Clicking on the heading for a column will sort the data by that column. You can also change the width of the columns by dragging the boundary between them." +pack $w.msg -fill x + +## See Code / Dismiss +pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x + +ttk::frame $w.container +ttk::treeview $w.tree -columns {country capital currency} -show headings \ + -yscroll "$w.vsb set" -xscroll "$w.hsb set" +if {[tk windowingsystem] ne "aqua"} { + ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview" + ttk::scrollbar $w.hsb -orient horizontal -command "$w.tree xview" +} else { + scrollbar $w.vsb -orient vertical -command "$w.tree yview" + scrollbar $w.hsb -orient horizontal -command "$w.tree xview" +} +pack $w.container -fill both -expand 1 +grid $w.tree $w.vsb -in $w.container -sticky nsew +grid $w.hsb -in $w.container -sticky nsew +grid column $w.container 0 -weight 1 +grid row $w.container 0 -weight 1 + +## The data we're going to insert +set data { + Argentina {Buenos Aires} ARS + Australia Canberra AUD + Brazil Brazilia BRL + Canada Ottawa CAD + China Beijing CNY + France Paris EUR + Germany Berlin EUR + India {New Delhi} INR + Italy Rome EUR + Japan Tokyo JPY + Mexico {Mexico City} MXN + Russia Moscow RUB + {South Africa} Pretoria ZAR + {United Kingdom} London GBP + {United States} {Washington, D.C.} USD +} + +## Code to insert the data nicely +set font [ttk::style lookup [$w.tree cget -style] -font] +foreach col {country capital currency} name {Country Capital Currency} { + $w.tree heading $col -command [list SortBy $w.tree $col 0] -text $name + $w.tree column $col -width [font measure $font $name] +} +foreach {country capital currency} $data { + $w.tree insert {} end -values [list $country $capital $currency] + foreach col {country capital currency} { + set len [font measure $font "[set $col] "] + if {[$w.tree column $col -width] < $len} { + $w.tree column $col -width $len + } + } +} + +## Code to do the sorting of the tree contents when clicked on +proc SortBy {tree col direction} { + # Build something we can sort + set data {} + foreach row [$tree children {}] { + lappend data [list [$tree set $row $col] $row] + } + + set dir [expr {$direction ? "-decreasing" : "-increasing"}] + set r -1 + + # Now reshuffle the rows into the sorted order + foreach info [lsort -dictionary -index 0 $dir $data] { + $tree move [lindex $info 1] {} [incr r] + } + + # Switch the heading so that it will sort in the opposite direction + $tree heading $col -command [list SortBy $tree $col [expr {!$direction}]] +} diff --git a/library/demos/menu.tcl b/library/demos/menu.tcl index 2c3e83e..e19df57 100644 --- a/library/demos/menu.tcl +++ b/library/demos/menu.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .menu catch {destroy $w} toplevel $w @@ -15,8 +17,7 @@ wm iconname $w "menu" positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { +if {[tk windowingsystem] eq "aqua"} { catch {set origUseCustomMDEF $::tk::mac::useCustomMDEF; set ::tk::mac::useCustomMDEF 1} $w.msg configure -text "This window has a menubar with cascaded menus. You can invoke entries with an accelerator by typing Command+x, where \"x\" is the character next to the command key symbol. The rightmost menu can be torn off into a palette by selecting the first item in the menu." } else { @@ -30,11 +31,9 @@ label $w.statusBar.label -textvariable menustatus -relief sunken -bd 1 -font "He pack $w.statusBar.label -side left -padx 2 -expand yes -fill both pack $w.statusBar -side bottom -fill x -pady 2 -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x menu $w.menu -tearoff 0 @@ -55,10 +54,9 @@ set m $w.menu.basic $w.menu add cascade -label "Basic" -menu $m -underline 0 menu $m -tearoff 0 $m add command -label "Long entry that does nothing" -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { +if {[tk windowingsystem] eq "aqua"} { set modifier Command -} elseif {$tcl_platform(platform) == "windows"} { +} elseif {[tk windowingsystem] == "win32"} { set modifier Control } else { set modifier Meta @@ -115,8 +113,9 @@ $m invoke 7 set m $w.menu.icon $w.menu add cascade -label "Icons" -menu $m -underline 0 menu $m -tearoff 0 -$m add command -bitmap @[file join $tk_library demos images pattern.bmp] \ - -hidemargin 1 -command [list \ +# Main widget program sets variable tk_demoDirectory +$m add command -bitmap @[file join $tk_demoDirectory images pattern.xbm] \ + -hidemargin 1 -command [list \ tk_dialog $w.pattern {Bitmap Menu Entry} \ "The menu entry you invoked displays a bitmap rather than\ a text string. Other than this, it is just like any other\ @@ -159,6 +158,4 @@ bind Menu <<MenuSelect>> { update idletasks } -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { - catch {set ::tk::mac::useCustomMDEF $origUseCustomMDEF} -} +if {[tk windowingsystem] eq "aqua"} {catch {set ::tk::mac::useCustomMDEF $origUseCustomMDEF}} diff --git a/library/demos/menubu.tcl b/library/demos/menubu.tcl index b506161..86326b5 100644 --- a/library/demos/menubu.tcl +++ b/library/demos/menubu.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .menubu catch {destroy $w} toplevel $w @@ -41,11 +43,9 @@ $w.body.above.m add command -label "Above menu: first item" -command "puts \"You $w.body.above.m add command -label "Above menu: second item" -command "puts \"You have selected the second item from the Above menu.\"" grid $w.body.above -row 2 -column 1 -sticky s -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode .menubu" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x set body $w.body.center label $body.label -wraplength 300 -font "Helvetica 14" -justify left -text "This is a demonstration of menubuttons. The \"Below\" menubutton pops its menu below the button; the \"Right\" button pops to the right, etc. There are two option menus directly below this text; one is just a standard menu and the other is a 16-color palette." @@ -55,8 +55,7 @@ pack $body.buttons -padx 25 -pady 25 tk_optionMenu $body.buttons.options menubuttonoptions one two three pack $body.buttons.options -side left -padx 25 -pady 25 set m [tk_optionMenu $body.buttons.colors paletteColor Black red4 DarkGreen NavyBlue gray75 Red Green Blue gray50 Yellow Cyan Magenta White Brown DarkSeaGreen DarkViolet] -if {[string equal [tk windowingsystem] "classic"] - || [string equal [tk windowingsystem] "aqua"]} { +if {[tk windowingsystem] eq "aqua"} { set topBorderColor Black set bottomBorderColor Black } else { diff --git a/library/demos/msgbox.tcl b/library/demos/msgbox.tcl index 51efde6..a8f7d17 100644 --- a/library/demos/msgbox.tcl +++ b/library/demos/msgbox.tcl @@ -6,6 +6,9 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk +package require Ttk + set w .msgbox catch {destroy $w} toplevel $w @@ -16,13 +19,10 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "Choose the icon and type option of the message box. Then press the \"Message Box\" button to see the message box." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -button $w.buttons.vars -text "Message Box" \ - -command "showMessageBox $w" -pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 +pack [addSeeDismiss $w.buttons $w {} { + ttk::button $w.buttons.vars -text "Message Box" -command "showMessageBox $w" +}] -side bottom -fill x +#pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 frame $w.left frame $w.right diff --git a/library/demos/nl.msg b/library/demos/nl.msg new file mode 100644 index 0000000..b17ceaa --- /dev/null +++ b/library/demos/nl.msg @@ -0,0 +1,125 @@ +::msgcat::mcset nl "Widget Demonstration" "Demonstratie van widgets" +::msgcat::mcset nl "tkWidgetDemo" "tkWidgetDemo" +::msgcat::mcset nl "&File" "&Bestand" +::msgcat::mcset nl "About..." "Info..." +::msgcat::mcset nl "&About..." "&Info..." +::msgcat::mcset nl "<F1>" "<F1>" +::msgcat::mcset nl "&Quit" "&Einde" +::msgcat::mcset nl "Meta+Q" "Meta+E" ;# Displayed hotkey +::msgcat::mcset nl "Meta-q" "Meta-e" ;# Actual binding sequence +::msgcat::mcset nl "Ctrl+Q" "Ctrl+E" ;# Displayed hotkey +::msgcat::mcset nl "Control-q" "Control-e" ;# Actual binding sequence +::msgcat::mcset nl "Dismiss" "Sluiten" +::msgcat::mcset nl "See Variables" "Bekijk Variabelen" +::msgcat::mcset nl "Variable Values" "Waarden Variabelen" +::msgcat::mcset nl "OK" "OK" +::msgcat::mcset nl "Run the \"%s\" sample program" "Start voorbeeld \"%s\"" +::msgcat::mcset nl "Print Code" "Code Afdrukken" +::msgcat::mcset nl "Demo code: %s" "Code van Demo %s" +::msgcat::mcset nl "About Widget Demo" "Over deze demonstratie" +::msgcat::mcset nl "Tk widget demonstration" "Demonstratie van Tk widgets" +::msgcat::mcset nl "Copyright (c) %s" "Copyright (c) %s" + +::msgcat::mcset nl "Tk Widget Demonstrations" "Demostratie van Tk widgets" +::msgcat::mcset nl "This application provides a front end for several short scripts" \ + "Dit programma is een schil rond enkele korte scripts waarmee" +::msgcat::mcset nl "that demonstrate what you can do with Tk widgets. Each of the" \ + "gedemonstreerd wordt wat je kunt doen met Tk widgets. Elk van de" +::msgcat::mcset nl "numbered lines below describes a demonstration; you can click on" \ + "genummerde regels hieronder omschrijft een demonstratie; je kunt de" +::msgcat::mcset nl "it to invoke the demonstration. Once the demonstration window" \ + "demonstratie starten door op de regel te klikken." +::msgcat::mcset nl "appears, you can click the" \ + "Zodra het nieuwe venster verschijnt, kun je op de knop" +::msgcat::mcset nl "See Code" "Bekijk Code" ;# This is also button text! +::msgcat::mcset nl "button to see the Tcl/Tk code that created the demonstration. If" \ + "drukken om de achterliggende Tcl/Tk code te zien. Als je dat wilt," +::msgcat::mcset nl "you wish, you can edit the code and click the" \ + "kun je de code wijzigen en op de knop" +::msgcat::mcset nl "Rerun Demo" "Herstart Demo" ;# This is also button text! +::msgcat::mcset nl "button in the code window to reinvoke the demonstration with the" \ + "drukken in het codevenster om de demonstratie uit te voeren met de" +::msgcat::mcset nl "modified code." \ + "nieuwe code." + +::msgcat::mcset nl "Labels, buttons, checkbuttons, and radiobuttons" \ + "Labels, knoppen, vinkjes/aankruishokjes en radioknoppen" + +::msgcat::mcset nl "Labels (text and bitmaps)" "Labels (tekst en plaatjes)" +::msgcat::mcset nl "Labels and UNICODE text" "Labels en tekst in UNICODE" +::msgcat::mcset nl "Buttons" "Buttons (drukknoppen)" +::msgcat::mcset nl "Check-buttons (select any of a group)" \ + "Check-buttons (een of meer uit een groep)" +::msgcat::mcset nl "Radio-buttons (select one of a group)" \ + "Radio-buttons (een van een groep)" +::msgcat::mcset nl "A 15-puzzle game made out of buttons" \ + "Een schuifpuzzel van buttons" +::msgcat::mcset nl "Iconic buttons that use bitmaps" \ + "Buttons met pictogrammen" +::msgcat::mcset nl "Two labels displaying images" \ + "Twee labels met plaatjes in plaats van tekst" +::msgcat::mcset nl "A simple user interface for viewing images" \ + "Een eenvoudige user-interface voor het bekijken van plaatjes" +::msgcat::mcset nl "Labelled frames" \ + "Kaders met bijschrift" + +::msgcat::mcset nl "Listboxes" "Keuzelijsten" +::msgcat::mcset nl "The 50 states" "De 50 staten van de VS" +::msgcat::mcset nl "Colors: change the color scheme for the application" \ + "Kleuren: verander het kleurenschema voor het programma" +::msgcat::mcset nl "A collection of famous and infamous sayings" \ + "Beroemde en beruchte citaten en gezegden" + +::msgcat::mcset nl "Entries and Spin-boxes" "Invulvelden en Spinboxen" +::msgcat::mcset nl "Entries without scrollbars" "Invulvelden zonder schuifbalk" +::msgcat::mcset nl "Entries with scrollbars" "Invulvelden met schuifbalk" +::msgcat::mcset nl "Validated entries and password fields" \ + "Invulvelden met controle of wachtwoorden" +::msgcat::mcset nl "Spin-boxes" "Spinboxen" +::msgcat::mcset nl "Simple Rolodex-like form" "Simpel kaartsysteem" + +::msgcat::mcset nl "Text" "Tekst" +::msgcat::mcset nl "Basic editable text" "Voorbeeld met te wijzigen tekst" +::msgcat::mcset nl "Text display styles" "Tekst met verschillende stijlen" +::msgcat::mcset nl "Hypertext (tag bindings)" \ + "Hypertext (verwijzingen via \"tags\")" +::msgcat::mcset nl "A text widget with embedded windows" \ + "Tekstwidget met windows erin" +::msgcat::mcset nl "A search tool built with a text widget" \ + "Zoeken in tekst met behulp van een tekstwidget" + +::msgcat::mcset nl "Canvases" "Canvaswidgets" +::msgcat::mcset nl "The canvas item types" "Objecten in een canvas" +::msgcat::mcset nl "A simple 2-D plot" "Eenvoudige 2D-grafiek" +::msgcat::mcset nl "Text items in canvases" "Tekstobjecten in een canvas" +::msgcat::mcset nl "An editor for arrowheads on canvas lines" \ + "Editor voor de vorm van de pijl (begin/eind van een lijn)" +::msgcat::mcset nl "A ruler with adjustable tab stops" \ + "Een meetlat met aanpasbare ruiters" +::msgcat::mcset nl "A building floor plan" "Plattegrond van een gebouw" +::msgcat::mcset nl "A simple scrollable canvas" "Een schuifbaar canvas" + +::msgcat::mcset nl "Scales" "Schaalverdelingen" +::msgcat::mcset nl "Horizontal scale" "Horizontale schaal" +::msgcat::mcset nl "Vertical scale" "Verticale schaal" + +::msgcat::mcset nl "Paned Windows" "Vensters opgedeeld in stukken" +::msgcat::mcset nl "Horizontal paned window" "Horizontaal gedeeld venster" +::msgcat::mcset nl "Vertical paned window" "Verticaal gedeeld venster" + +::msgcat::mcset nl "Menus" "Menu's" +::msgcat::mcset nl "Menus and cascades (sub-menus)" \ + "Menu's en cascades (submenu's)" +::msgcat::mcset nl "Menu-buttons" "Menu-buttons" + +::msgcat::mcset nl "Common Dialogs" "Veel voorkomende dialoogvensters" +::msgcat::mcset nl "Message boxes" "Mededeling (message box)" +::msgcat::mcset nl "File selection dialog" "Selectie van bestanden" +::msgcat::mcset nl "Color picker" "Kleurenpalet" + +::msgcat::mcset nl "Miscellaneous" "Diversen" +::msgcat::mcset nl "The built-in bitmaps" "Ingebouwde plaatjes" +::msgcat::mcset nl "A dialog box with a local grab" \ + "Een dialoogvenster met een locale \"grab\"" +::msgcat::mcset nl "A dialog box with a global grab" \ + "Een dialoogvenster met een globale \"grab\"" diff --git a/library/demos/paned1.tcl b/library/demos/paned1.tcl index 2e01a22..783b7f3 100644 --- a/library/demos/paned1.tcl +++ b/library/demos/paned1.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .paned1 catch {destroy $w} toplevel $w @@ -17,11 +19,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "The sash between the two coloured windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)" pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x panedwindow $w.pane pack $w.pane -side top -expand yes -fill both -pady 2 -padx 2m diff --git a/library/demos/paned2.tcl b/library/demos/paned2.tcl index 9f6f22a..f481d14 100644 --- a/library/demos/paned2.tcl +++ b/library/demos/paned2.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .paned2 catch {destroy $w} toplevel $w @@ -17,11 +19,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "The sash between the two scrolled windows below can be used to divide the area between them. Use the left mouse button to resize without redrawing by just moving the sash, and use the middle mouse button to resize opaquely (always redrawing the windows in each position.)" pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x # Create the pane itself panedwindow $w.pane -orient vertical @@ -61,7 +61,7 @@ pack $f.list -fill both -expand 1 # The bottom window is a text widget with scrollbar set f [frame $w.pane.bottom] text $f.text -xscrollcommand "$f.xscr set" -yscrollcommand "$f.yscr set" \ - -width 30 -wrap none + -width 30 -height 8 -wrap none scrollbar $f.xscr -orient horizontal -command "$f.text xview" scrollbar $f.yscr -orient vertical -command "$f.text yview" grid $f.text $f.yscr -sticky nsew diff --git a/library/demos/pendulum.tcl b/library/demos/pendulum.tcl new file mode 100644 index 0000000..2e3d459 --- /dev/null +++ b/library/demos/pendulum.tcl @@ -0,0 +1,197 @@ +# pendulum.tcl -- +# +# This demonstration illustrates how Tcl/Tk can be used to construct +# simulations of physical systems. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk + +set w .pendulum +catch {destroy $w} +toplevel $w +wm title $w "Pendulum Animation Demonstration" +wm iconname $w "pendulum" +positionWindow $w + +label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration shows how Tcl/Tk can be used to carry out animations that are linked to simulations of physical systems. In the left canvas is a graphical representation of the physical system itself, a simple pendulum, and in the right canvas is a graph of the phase space of the system, which is a plot of the angle (relative to the vertical) against the angular velocity. The pendulum bob may be repositioned by clicking and dragging anywhere on the left canvas." +pack $w.msg + +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x + +# Create some structural widgets +pack [panedwindow $w.p] -fill both -expand 1 +$w.p add [labelframe $w.p.l1 -text "Pendulum Simulation"] +$w.p add [labelframe $w.p.l2 -text "Phase Space"] + +# Create the canvas containing the graphical representation of the +# simulated system. +canvas $w.c -width 320 -height 200 -background white -bd 2 -relief sunken +$w.c create text 5 5 -anchor nw -text "Click to Adjust Bob Start Position" +# Coordinates of these items don't matter; they will be set properly below +$w.c create line 0 25 320 25 -tags plate -fill grey50 -width 2 +$w.c create oval 155 20 165 30 -tags pivot -fill grey50 -outline {} +$w.c create line 1 1 1 1 -tags rod -fill black -width 3 +$w.c create oval 1 1 2 2 -tags bob -fill yellow -outline black +pack $w.c -in $w.p.l1 -fill both -expand true + +# Create the canvas containing the phase space graph; this consists of +# a line that gets gradually paler as it ages, which is an extremely +# effective visual trick. +canvas $w.k -width 320 -height 200 -background white -bd 2 -relief sunken +$w.k create line 160 200 160 0 -fill grey75 -arrow last -tags y_axis +$w.k create line 0 100 320 100 -fill grey75 -arrow last -tags x_axis +for {set i 90} {$i>=0} {incr i -10} { + # Coordinates of these items don't matter; they will be set properly below + $w.k create line 0 0 1 1 -smooth true -tags graph$i -fill grey$i +} +# FIXME: UNICODE labels +$w.k create text 0 0 -anchor ne -text "q" -font {Symbol 8} -tags label_theta +$w.k create text 0 0 -anchor ne -text "dq" -font {Symbol 8} -tags label_dtheta +pack $w.k -in $w.p.l2 -fill both -expand true + +# Initialize some variables +set points {} +set Theta 45.0 +set dTheta 0.0 +set pi 3.1415926535897933 +set length 150 +set home 160 + +# This procedure makes the pendulum appear at the correct place on the +# canvas. If the additional arguments "at $x $y" are passed (the 'at' +# is really just syntactic sugar) instead of computing the position of +# the pendulum from the length of the pendulum rod and its angle, the +# length and angle are computed in reverse from the given location +# (which is taken to be the centre of the pendulum bob.) +proc showPendulum {canvas {at {}} {x {}} {y {}}} { + global Theta dTheta pi length home + if {$at eq "at" && ($x!=$home || $y!=25)} { + set dTheta 0.0 + set x2 [expr {$x - $home}] + set y2 [expr {$y - 25}] + set length [expr {hypot($x2, $y2)}] + set Theta [expr {atan2($x2, $y2) * 180/$pi}] + } else { + set angle [expr {$Theta * $pi/180}] + set x [expr {$home + $length*sin($angle)}] + set y [expr {25 + $length*cos($angle)}] + } + $canvas coords rod $home 25 $x $y + $canvas coords bob \ + [expr {$x-15}] [expr {$y-15}] [expr {$x+15}] [expr {$y+15}] +} +showPendulum $w.c + +# Update the phase-space graph according to the current angle and the +# rate at which the angle is changing (the first derivative with +# respect to time.) +proc showPhase {canvas} { + global Theta dTheta points psw psh + lappend points [expr {$Theta+$psw}] [expr {-20*$dTheta+$psh}] + if {[llength $points] > 100} { + set points [lrange $points end-99 end] + } + for {set i 0} {$i<100} {incr i 10} { + set list [lrange $points end-[expr {$i-1}] end-[expr {$i-12}]] + if {[llength $list] >= 4} { + $canvas coords graph$i $list + } + } +} + +# Set up some bindings on the canvases. Note that when the user +# clicks we stop the animation until they release the mouse +# button. Also note that both canvases are sensitive to <Configure> +# events, which allows them to find out when they have been resized by +# the user. +bind $w.c <Destroy> { + after cancel $animationCallbacks(pendulum) + unset animationCallbacks(pendulum) +} +bind $w.c <1> { + after cancel $animationCallbacks(pendulum) + showPendulum %W at %x %y +} +bind $w.c <B1-Motion> { + showPendulum %W at %x %y +} +bind $w.c <ButtonRelease-1> { + showPendulum %W at %x %y + set animationCallbacks(pendulum) [after 15 repeat [winfo toplevel %W]] +} +bind $w.c <Configure> { + %W coords plate 0 25 %w 25 + set home [expr %w/2] + %W coords pivot [expr $home-5] 20 [expr $home+5] 30 +} +bind $w.k <Configure> { + set psh [expr %h/2] + set psw [expr %w/2] + %W coords x_axis 2 $psh [expr %w-2] $psh + %W coords y_axis $psw [expr %h-2] $psw 2 + %W coords label_dtheta [expr $psw-4] 6 + %W coords label_theta [expr %w-6] [expr $psh+4] +} + +# This procedure is the "business" part of the simulation that does +# simple numerical integration of the formula for a simple rotational +# pendulum. +proc recomputeAngle {} { + global Theta dTheta pi length + set scaling [expr {3000.0/$length/$length}] + + # To estimate the integration accurately, we really need to + # compute the end-point of our time-step. But to do *that*, we + # need to estimate the integration accurately! So we try this + # technique, which is inaccurate, but better than doing it in a + # single step. What we really want is bound up in the + # differential equation: + # .. - sin theta + # theta + theta = ----------- + # length + # But my math skills are not good enough to solve this! + + # first estimate + set firstDDTheta [expr {-sin($Theta * $pi/180)*$scaling}] + set midDTheta [expr {$dTheta + $firstDDTheta}] + set midTheta [expr {$Theta + ($dTheta + $midDTheta)/2}] + # second estimate + set midDDTheta [expr {-sin($midTheta * $pi/180)*$scaling}] + set midDTheta [expr {$dTheta + ($firstDDTheta + $midDDTheta)/2}] + set midTheta [expr {$Theta + ($dTheta + $midDTheta)/2}] + # Now we do a double-estimate approach for getting the final value + # first estimate + set midDDTheta [expr {-sin($midTheta * $pi/180)*$scaling}] + set lastDTheta [expr {$midDTheta + $midDDTheta}] + set lastTheta [expr {$midTheta + ($midDTheta + $lastDTheta)/2}] + # second estimate + set lastDDTheta [expr {-sin($lastTheta * $pi/180)*$scaling}] + set lastDTheta [expr {$midDTheta + ($midDDTheta + $lastDDTheta)/2}] + set lastTheta [expr {$midTheta + ($midDTheta + $lastDTheta)/2}] + # Now put the values back in our globals + set dTheta $lastDTheta + set Theta $lastTheta +} + +# This method ties together the simulation engine and the graphical +# display code that visualizes it. +proc repeat w { + global animationCallbacks + + # Simulate + recomputeAngle + + # Update the display + showPendulum $w.c + showPhase $w.k + + # Reschedule ourselves + set animationCallbacks(pendulum) [after 15 [list repeat $w]] +} +# Start the simulation after a short pause +set animationCallbacks(pendulum) [after 500 [list repeat $w]] diff --git a/library/demos/plot.tcl b/library/demos/plot.tcl index cd7fbd8..e7f0361 100644 --- a/library/demos/plot.tcl +++ b/library/demos/plot.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .plot catch {destroy $w} toplevel $w @@ -18,11 +20,9 @@ set c $w.c label $w.msg -font $font -wraplength 4i -justify left -text "This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x canvas $c -relief raised -width 450 -height 300 pack $w.c -side top -fill x diff --git a/library/demos/puzzle.tcl b/library/demos/puzzle.tcl index 4273926..fb8ab4c 100644 --- a/library/demos/puzzle.tcl +++ b/library/demos/puzzle.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + # puzzleSwitch -- # This procedure is invoked when the user clicks on a particular button; # if the button is next to the empty space, it moves the button into th @@ -42,11 +44,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "A 15-puzzle appears below as a collection of buttons. Click on any of the pieces next to the space, and that piece will slide over the space. Continue this until the pieces are arranged in numerical order from upper-left to lower-right." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x # Special trick: select a darker color for the space by creating a # scrollbar widget and using its trough color. diff --git a/library/demos/radio.tcl b/library/demos/radio.tcl index a9a2a73..5c73703 100644 --- a/library/demos/radio.tcl +++ b/library/demos/radio.tcl @@ -7,31 +7,37 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .radio catch {destroy $w} toplevel $w wm title $w "Radiobutton Demonstration" wm iconname $w "radio" positionWindow $w -label $w.msg -font $font -wraplength 5i -justify left -text "Three groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. Click the \"See Variables\" button to see the current values of the variables." -pack $w.msg -side top +label $w.msg -font $font -wraplength 5i -justify left -text "Three groups of radiobuttons are displayed below. If you click on a button then the button will become selected exclusively among all the buttons in its group. A Tcl variable is associated with each group to indicate which of the group's buttons is selected. When the 'Tristate' button is pressed, the radio buttons will display the tri-state mode. Selecting any radio button will return the buttons to their respective on/off state. Click the \"See Variables\" button to see the current values of the variables." +grid $w.msg -row 0 -column 0 -columnspan 3 -sticky nsew -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -button $w.buttons.vars -text "See Variables" \ - -command "showVars $w.dialog size color align" -pack $w.buttons.dismiss $w.buttons.code $w.buttons.vars -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w [list size color align]] +grid $btns -row 3 -column 0 -columnspan 3 -sticky ew labelframe $w.left -pady 2 -text "Point Size" -padx 2 labelframe $w.mid -pady 2 -text "Color" -padx 2 labelframe $w.right -pady 2 -text "Alignment" -padx 2 -pack $w.left $w.mid $w.right -side left -expand yes -pady .5c -padx .5c +button $w.tristate -text Tristate -command "set size multi; set color multi" \ + -pady 2 -padx 2 +if {[tk windowingsystem] eq "aqua"} { + $w.tristate configure -padx 10 +} +grid $w.left -column 0 -row 1 -pady .5c -padx .5c -rowspan 2 +grid $w.mid -column 1 -row 1 -pady .5c -padx .5c -rowspan 2 +grid $w.right -column 2 -row 1 -pady .5c -padx .5c +grid $w.tristate -column 2 -row 2 -pady .5c -padx .5c foreach i {10 12 14 18 24} { radiobutton $w.left.b$i -text "Point Size $i" -variable size \ - -relief flat -value $i + -relief flat -value $i -tristatevalue "multi" pack $w.left.b$i -side top -pady 2 -anchor w -fill x } @@ -39,10 +45,12 @@ foreach c {Red Green Blue Yellow Orange Purple} { set lower [string tolower $c] radiobutton $w.mid.$lower -text $c -variable color \ -relief flat -value $lower -anchor w \ - -command "$w.mid configure -fg \$color" + -command "$w.mid configure -fg \$color" \ + -tristatevalue "multi" pack $w.mid.$lower -side top -pady 2 -fill x } + label $w.right.l -text "Label" -bitmap questhead -compound left $w.right.l configure -width [winfo reqwidth $w.right.l] -compound top $w.right.l configure -height [winfo reqheight $w.right.l] @@ -52,6 +60,7 @@ foreach a {Top Left Right Bottom} { -relief flat -value $lower -indicatoron 0 -width 7 \ -command "$w.right.l configure -compound \$align" } + grid x $w.right.top grid $w.right.left $w.right.l $w.right.right grid x $w.right.bottom diff --git a/library/demos/rmt b/library/demos/rmt index 423c4a6..51886de 100644 --- a/library/demos/rmt +++ b/library/demos/rmt @@ -7,6 +7,9 @@ exec wish "$0" ${1+"$@"} # Tk applications. It allows you to select an application and # then type commands to that application. +package require Tcl 8.4 +package require Tk + wm title . "Tk Remote Controller" wm iconname . "Tk Remote" wm minsize . 1 1 @@ -40,7 +43,7 @@ menu .menu.file.apps -postcommand fillAppsMenu # Create text window and scrollbar. -text .t -relief sunken -bd 2 -yscrollcommand ".s set" -setgrid true +text .t -yscrollcommand ".s set" -setgrid true scrollbar .s -command ".t yview" grid .t .s -sticky nsew grid rowconfigure . 0 -weight 1 @@ -60,58 +63,60 @@ bind .t <Return> { } bind .t <Delete> { catch {.t tag remove sel sel.first promptEnd} - if {[.t tag nextrange sel 1.0 end] == ""} { - if [.t compare insert < promptEnd] { + if {[.t tag nextrange sel 1.0 end] eq ""} { + if {[.t compare insert < promptEnd]} { break } } } bind .t <BackSpace> { catch {.t tag remove sel sel.first promptEnd} - if {[.t tag nextrange sel 1.0 end] == ""} { - if [.t compare insert <= promptEnd] { + if {[.t tag nextrange sel 1.0 end] eq ""} { + if {[.t compare insert <= promptEnd]} { break } } } bind .t <Control-d> { - if [.t compare insert < promptEnd] { + if {[.t compare insert < promptEnd]} { break } } bind .t <Control-k> { - if [.t compare insert < promptEnd] { + if {[.t compare insert < promptEnd]} { .t mark set insert promptEnd } } bind .t <Control-t> { - if [.t compare insert < promptEnd] { + if {[.t compare insert < promptEnd]} { break } } bind .t <Meta-d> { - if [.t compare insert < promptEnd] { + if {[.t compare insert < promptEnd]} { break } } bind .t <Meta-BackSpace> { - if [.t compare insert <= promptEnd] { + if {[.t compare insert <= promptEnd]} { break } } bind .t <Control-h> { - if [.t compare insert <= promptEnd] { + if {[.t compare insert <= promptEnd]} { break } } -auto_load tkTextInsert -proc tkTextInsert {w s} { - if {$s == ""} { +### This next bit *isn't* nice - DKF ### +auto_load tk::TextInsert +proc tk::TextInsert {w s} { + if {$s eq ""} { return } catch { - if {[$w compare sel.first <= insert] - && [$w compare sel.last >= insert]} { + if { + [$w compare sel.first <= insert] && [$w compare sel.last >= insert] + } then { $w tag remove sel sel.first promptEnd $w delete sel.first sel.last } @@ -143,23 +148,21 @@ proc invoke {} { global app executing lastCommand set cmd [.t get promptEnd insert] incr executing 1 - if [info complete $cmd] { - if {$cmd == "!!\n"} { + if {[info complete $cmd]} { + if {$cmd eq "!!\n"} { set cmd $lastCommand } else { set lastCommand $cmd } - if {$app == "local"} { + if {$app eq "local"} { set result [catch [list uplevel #0 $cmd] msg] } else { set result [catch [list send $app $cmd] msg] } if {$result != 0} { .t insert insert "Error: $msg\n" - } else { - if {$msg != ""} { - .t insert insert $msg\n - } + } elseif {$msg ne ""} { + .t insert insert $msg\n } prompt .t mark set promptEnd insert @@ -177,14 +180,14 @@ proc invoke {} { proc newApp appName { global app executing set app $appName - if !$executing { + if {!$executing} { .t mark gravity promptEnd right .t delete "promptEnd linestart" promptEnd .t insert promptEnd "$appName: " .t tag add bold "promptEnd linestart" promptEnd .t mark gravity promptEnd left } - return {} + return } # The procedure below will fill in the applications sub-menu with a list diff --git a/library/demos/rolodex b/library/demos/rolodex index 50ac590..8941570 100644 --- a/library/demos/rolodex +++ b/library/demos/rolodex @@ -8,6 +8,8 @@ exec wish "$0" ${1+"$@"} # feel of a rolodex program, although it's lifeless and doesn't # actually do the rolodex application. +package require Tk + foreach i [winfo child .] { catch {destroy $i} } @@ -41,6 +43,10 @@ pack .buttons.clear .buttons.add .buttons.search .buttons.delete \ # Phase 1: Add menus, dialog boxes #------------------------------------------ +# DKF - note that this is an old-style menu bar; I just have not yet +# got around to converting the context help code to work with the new +# menu system and its <<MenuSelect>> virtual event. + frame .menu -relief raised -borderwidth 1 pack .menu -before .frame -side top -fill x @@ -192,3 +198,7 @@ set helpTopics(version) "This is version $version." -underline 3 .menu.help.m add command -label "On Version..." -command {Help version} \ -underline 3 + +# Local Variables: +# mode: tcl +# End: diff --git a/library/demos/ruler.tcl b/library/demos/ruler.tcl index ccdb1fc..557b680 100644 --- a/library/demos/ruler.tcl +++ b/library/demos/ruler.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + # rulerMkTab -- # This procedure creates a new triangular polygon in a canvas to # represent a tab stop. @@ -22,7 +24,6 @@ proc rulerMkTab {c x y} { } set w .ruler -global tk_library catch {destroy $w} toplevel $w wm title $w "Ruler Demonstration" @@ -33,11 +34,9 @@ set c $w.c label $w.msg -font $font -wraplength 5i -justify left -text "This canvas widget shows a mock-up of a ruler. You can create tab stops by dragging them out of the well to the right of the ruler. You can also drag existing tab stops. If you drag a tab stop far enough up or down so that it turns dim, it will be deleted when you release the mouse button." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x canvas $c -width 14.8c -height 2.5c pack $w.c -side top -fill x @@ -49,14 +48,15 @@ set demo_rulerInfo(top) [winfo fpixels $c 1c] set demo_rulerInfo(bottom) [winfo fpixels $c 1.5c] set demo_rulerInfo(size) [winfo fpixels $c .2c] set demo_rulerInfo(normalStyle) "-fill black" +# Main widget program sets variable tk_demoDirectory if {[winfo depth $c] > 1} { set demo_rulerInfo(activeStyle) "-fill red -stipple {}" set demo_rulerInfo(deleteStyle) [list -fill red \ - -stipple @[file join $tk_library demos images gray25.bmp]] + -stipple @[file join $tk_demoDirectory images gray25.xbm]] } else { set demo_rulerInfo(activeStyle) "-fill black -stipple {}" set demo_rulerInfo(deleteStyle) [list -fill black \ - -stipple @[file join $tk_library demos images gray25.bmp]] + -stipple @[file join $tk_demoDirectory images gray25.xbm]] } $c create line 1c 0.5c 1c 1c 13c 1c 13c 0.5c -width 1 diff --git a/library/demos/sayings.tcl b/library/demos/sayings.tcl index 72c141c..4d26ffe 100644 --- a/library/demos/sayings.tcl +++ b/library/demos/sayings.tcl @@ -8,6 +8,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .sayings catch {destroy $w} toplevel $w @@ -18,14 +20,12 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "The listbox below contains a collection of well-known sayings. You can scan the list using either of the scrollbars or by dragging in the listbox window with button 2 pressed." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.frame -borderwidth 10 -pack $w.frame -side top -expand yes -fill y +pack $w.frame -side top -expand yes -fill both -padx 1c scrollbar $w.frame.yscroll -command "$w.frame.list yview" @@ -41,4 +41,4 @@ grid rowconfig $w.frame 0 -weight 1 -minsize 0 grid columnconfig $w.frame 0 -weight 1 -minsize 0 -$w.frame.list insert 0 "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" +$w.frame.list insert 0 "Don't speculate, measure" "Waste not, want not" "Early to bed and early to rise makes a man healthy, wealthy, and wise" "Ask not what your country can do for you, ask what you can do for your country" "I shall return" "NOT" "A picture is worth a thousand words" "User interfaces are hard to build" "Thou shalt not steal" "A penny for your thoughts" "Fool me once, shame on you; fool me twice, shame on me" "Every cloud has a silver lining" "Where there's smoke there's fire" "It takes one to know one" "Curiosity killed the cat" "Take this job and shove it" "Up a creek without a paddle" "I'm mad as hell and I'm not going to take it any more" "An apple a day keeps the doctor away" "Don't look a gift horse in the mouth" "Measure twice, cut once" diff --git a/library/demos/search.tcl b/library/demos/search.tcl index 3a5e9bc..9f44e16 100644 --- a/library/demos/search.tcl +++ b/library/demos/search.tcl @@ -8,6 +8,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + # textLoadFile -- # This procedure below loads a file into a text widget, discarding # the previous contents of the widget. Tags for the old widget are @@ -80,11 +82,9 @@ wm title $w "Text Demonstration - Search and Highlight" wm iconname $w "search" positionWindow $w -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.file label $w.file.label -text "File name:" -width 13 -anchor w diff --git a/library/demos/spin.tcl b/library/demos/spin.tcl index b31d76d..d897e6d 100644 --- a/library/demos/spin.tcl +++ b/library/demos/spin.tcl @@ -6,6 +6,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .spin catch {destroy $w} toplevel $w @@ -26,11 +28,9 @@ label $w.msg -font $font -wraplength 5i -justify left -text "Three different\ Australian cities." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x set australianCities { Canberra Sydney Melbourne Perth Adelaide Brisbane diff --git a/library/demos/square b/library/demos/square index ca7b42a..08c362b 100644 --- a/library/demos/square +++ b/library/demos/square @@ -11,6 +11,9 @@ exec wish "$0" ${1+"$@"} # Button-1 press/drag: moves square to mouse # "a": toggle size animation on/off +package require Tk ;# We use Tk generally, and... +package require Tktest ;# ... we use the square widget too. + square .s pack .s -expand yes -fill both wm minsize . 1 1 @@ -51,3 +54,7 @@ proc timer {} { .s size [expr {$s+$inc}] after 30 timer } + +# Local Variables: +# mode: tcl +# End: diff --git a/library/demos/states.tcl b/library/demos/states.tcl index 2455cf9..e76540d 100644 --- a/library/demos/states.tcl +++ b/library/demos/states.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .states catch {destroy $w} toplevel $w @@ -17,11 +19,9 @@ positionWindow $w label $w.msg -font $font -wraplength 4i -justify left -text "A listbox containing the 50 states is displayed below, along with a scrollbar. You can scan the list either using the scrollbar or by scanning. To scan, press button 2 in the widget and drag up or down." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.frame -borderwidth .5c pack $w.frame -side top -expand yes -fill y diff --git a/library/demos/style.tcl b/library/demos/style.tcl index 52b7dc1..614ea1f 100644 --- a/library/demos/style.tcl +++ b/library/demos/style.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .style catch {destroy $w} toplevel $w @@ -14,23 +16,26 @@ wm title $w "Text Demonstration - Display Styles" wm iconname $w "style" positionWindow $w -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x + +# Only set the font family in one place for simplicity and consistency + +set family Courier text $w.text -yscrollcommand "$w.scroll set" -setgrid true \ - -width 70 -height 32 -wrap word + -width 70 -height 32 -wrap word -font "$family 12" scrollbar $w.scroll -command "$w.text yview" pack $w.scroll -side right -fill y pack $w.text -expand yes -fill both # Set up display styles -$w.text tag configure bold -font {Courier 12 bold italic} -$w.text tag configure big -font {Courier 14 bold} -$w.text tag configure verybig -font {Helvetica 24 bold} +$w.text tag configure bold -font "$family 12 bold italic" +$w.text tag configure big -font "$family 14 bold" +$w.text tag configure verybig -font "Helvetica 24 bold" +$w.text tag configure tiny -font "Times 8 bold" if {[winfo depth $w] > 1} { $w.text tag configure color1 -background #a0b7ce $w.text tag configure color2 -foreground red @@ -51,8 +56,8 @@ $w.text tag configure underline -underline on $w.text tag configure overstrike -overstrike on $w.text tag configure right -justify right $w.text tag configure center -justify center -$w.text tag configure super -offset 4p -font {Courier 10} -$w.text tag configure sub -offset -2p -font {Courier 10} +$w.text tag configure super -offset 4p -font "$family 10" +$w.text tag configure sub -offset -2p -font "$family 10" $w.text tag configure margins -lmargin1 12m -lmargin2 6m -rmargin 10m $w.text tag configure spacing -spacing1 10p -spacing2 2p \ -lmargin1 12m -lmargin2 6m -rmargin 10m @@ -61,17 +66,17 @@ $w.text insert end {Text widgets like this one allow you to display information variety of styles. Display styles are controlled using a mechanism called } $w.text insert end tags bold -$w.text insert end {. Tags are just textual names that you can apply to one +$w.text insert end {. Tags are just textual names that you can apply to one or more ranges of characters within a text widget. You can configure tags with various display styles. If you do this, then the tagged characters will be displayed with the styles you chose. The available display styles are: } $w.text insert end "\n1. Font." big -$w.text insert end " You can choose any X font, " +$w.text insert end " You can choose any system font, " $w.text insert end large verybig $w.text insert end " or " -$w.text insert end "small.\n" +$w.text insert end "small" tiny ".\n" $w.text insert end "\n2. Color." big $w.text insert end " You can change either the " $w.text insert end background color1 diff --git a/library/demos/tcolor b/library/demos/tcolor index 4dd61bb..6e50c61 100644 --- a/library/demos/tcolor +++ b/library/demos/tcolor @@ -7,6 +7,7 @@ exec wish "$0" ${1+"$@"} # create colors using either the RGB, HSB, or CYM color spaces # and apply the color to existing applications. +package require Tk 8.4 wm title . "Color Editor" # Global variables that control the program: @@ -39,10 +40,6 @@ set updating 0 set autoUpdate 1 set name "" -if {$tcl_platform(platform) eq "unix"} { - option add *Entry.background white -} - # Create the menu bar at the top of the window. . configure -menu [menu .menu] @@ -66,8 +63,7 @@ menu .menu.file # with the update button. labelframe .command -text "Command:" -padx {1m 0} -entry .command.e -relief sunken -borderwidth 2 -textvariable command \ - -font {Courier 12} +entry .command.e -textvariable command button .command.update -text Update -command doUpdate pack .command.update -side right -pady .1c -padx {.25c 0} pack .command.e -expand yes -fill x -ipadx 0.25c @@ -93,12 +89,11 @@ foreach i { grid .names -row 0 -column 0 -sticky nsew -padx .15c -pady .15c -rowspan 2 grid columnconfigure . 0 -weight 1 listbox .names.lb -width 20 -height 12 -yscrollcommand ".names.s set" \ - -relief sunken -borderwidth 2 -exportselection false + -exportselection false bind .names.lb <Double-1> { tc_loadNamedColor [.names.lb get [.names.lb curselection]] } - scrollbar .names.s -orient vertical -command ".names.lb yview" \ - -relief sunken -borderwidth 2 + scrollbar .names.s -orient vertical -command ".names.lb yview" pack .names.lb .names.s -side left -fill y -expand 1 while {[gets $f line] >= 0} { if {[regexp {^\s*\d+\s+\d+\s+\d+\s+(\S+)$} $line -> col]} { @@ -124,8 +119,7 @@ foreach i {1 2 3} { grid .adjust -row 0 -column 1 -sticky nsew -padx .15c -pady .15c labelframe .name -text "Name:" -padx 1m -pady 1m -entry .name.e -relief sunken -borderwidth 2 -textvariable name -width 10 \ - -font {Courier 12} +entry .name.e -textvariable name -width 10 pack .name.e -side right -expand 1 -fill x bind .name.e <Return> {tc_loadNamedColor $name} grid .name -column 1 -row 1 -sticky nsew -padx .15c -pady .15c diff --git a/library/demos/text.tcl b/library/demos/text.tcl index 52d6030..1b5f3b9 100644 --- a/library/demos/text.tcl +++ b/library/demos/text.tcl @@ -7,6 +7,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .text catch {destroy $w} toplevel $w @@ -14,15 +16,13 @@ wm title $w "Text Demonstration - Basic Facilities" wm iconname $w "text" positionWindow $w -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x -text $w.text -relief sunken -bd 2 -yscrollcommand "$w.scroll set" -setgrid 1 \ +text $w.text -yscrollcommand [list $w.scroll set] -setgrid 1 \ -height 30 -undo 1 -autosep 1 -scrollbar $w.scroll -command "$w.text yview" +scrollbar $w.scroll -command [list $w.text yview] pack $w.scroll -side right -fill y pack $w.text -expand yes -fill both $w.text insert 0.0 \ @@ -67,11 +67,11 @@ cursor. Control-t transposes the two characters on either side of the insertion cursor. Control-z undoes the last editing action performed, and } -switch $tcl_platform(platform) { - "unix" - "macintosh" { +switch [tk windowingsystem] { + "aqua" - "x11" { $w.text insert end "Control-Shift-z" } - "windows" { + "win32" { $w.text insert end "Control-y" } } diff --git a/library/demos/textpeer.tcl b/library/demos/textpeer.tcl new file mode 100644 index 0000000..e94284e --- /dev/null +++ b/library/demos/textpeer.tcl @@ -0,0 +1,62 @@ +# textpeer.tcl -- +# +# This demonstration script creates a pair of text widgets that can edit a +# single logical buffer. This is particularly useful when editing related text +# in two (or more) parts of the same file. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk + +set w .textpeer +catch {destroy $w} +toplevel $w +wm title $w "Text Widget Peering Demonstration" +wm iconname $w "textpeer" +positionWindow $w + +set count 0 + +## Define a widget that we peer from; it won't ever actually be shown though +set first [text $w.text[incr count]] +$first insert end "This is a coupled pair of text widgets; they are peers to " +$first insert end "each other. They have the same underlying data model, but " +$first insert end "can show different locations, have different current edit " +$first insert end "locations, and have different selections. You can also " +$first insert end "create additional peers of any of these text widgets using " +$first insert end "the Make Peer button beside the text widget to clone, and " +$first insert end "delete a particular peer widget using the Delete Peer " +$first insert end "button." + +## Procedures to make and kill clones; most of this is just so that the demo +## looks nice... +proc makeClone {w parent} { + global count + set t [$parent peer create $w.text[incr count] -yscroll "$w.sb$count set"\ + -height 10 -wrap word] + set sb [scrollbar $w.sb$count -command "$t yview" -orient vertical] + set b1 [button $w.clone$count -command "makeClone $w $t" \ + -text "Make Peer"] + set b2 [button $w.kill$count -command "killClone $w $count" \ + -text "Delete Peer"] + set row [expr {$count * 2}] + grid $t $sb $b1 -sticky nsew -row $row + grid ^ ^ $b2 -row [incr row] + grid configure $b1 $b2 -sticky new + grid rowconfigure $w $b2 -weight 1 +} +proc killClone {w count} { + destroy $w.text$count $w.sb$count + destroy $w.clone$count $w.kill$count +} + +## Now set up the GUI +makeClone $w $first +makeClone $w $first +destroy $first + +## See Code / Dismiss buttons +grid [addSeeDismiss $w.buttons $w] - - -sticky ew -row 5000 +grid columnconfigure $w 0 -weight 1 diff --git a/library/demos/timer b/library/demos/timer index 320cd0e..e10b840 100644 --- a/library/demos/timer +++ b/library/demos/timer @@ -5,6 +5,9 @@ exec wish "$0" ${1+"$@"} # timer -- # This script generates a counter with start and stop buttons. +package require Tcl 8.4 +package require Tk + label .counter -text 0.00 -relief raised -width 10 -padx 2m -pady 1m button .start -text Start -command { if {$stopped} { diff --git a/library/demos/toolbar.tcl b/library/demos/toolbar.tcl new file mode 100644 index 0000000..541e8ba --- /dev/null +++ b/library/demos/toolbar.tcl @@ -0,0 +1,104 @@ +# toolbar.tcl -- +# +# This demonstration script creates a toolbar that can be torn off. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .toolbar +destroy $w +toplevel $w +wm title $w "Toolbar Demonstration" +wm iconname $w "toolbar" +positionWindow $w + +if {[tk windowingsystem] ne "aqua"} { + ttk::label $w.msg -wraplength 4i -text "This is a demonstration of how to do\ + a toolbar that is styled correctly and which can be torn off. The\ + buttons are configured to be \u201Ctoolbar style\u201D buttons by\ + telling them that they are to use the Toolbutton style. At the left\ + end of the toolbar is a simple marker that the cursor changes to a\ + movement icon over; drag that away from the toolbar to tear off the\ + whole toolbar into a separate toplevel widget. When the dragged-off\ + toolbar is no longer needed, just close it like any normal toplevel\ + and it will reattach to the window it was torn off from." +} else { +ttk::label $w.msg -wraplength 4i -text "This is a demonstration of how to do\ + a toolbar that is styled correctly. The buttons are configured to\ + be \u201Ctoolbar style\u201D buttons by telling them that they are\ + to use the Toolbutton style." +} + +## Set up the toolbar hull +set t [frame $w.toolbar] ;# Must be a frame! +ttk::separator $w.sep +ttk::frame $t.tearoff -cursor fleur +if {[tk windowingsystem] ne "aqua"} { + ttk::separator $t.tearoff.to -orient vertical + ttk::separator $t.tearoff.to2 -orient vertical + pack $t.tearoff.to -fill y -expand 1 -padx 2 -side left + pack $t.tearoff.to2 -fill y -expand 1 -side left +} +ttk::frame $t.contents +grid $t.tearoff $t.contents -sticky nsew +grid columnconfigure $t $t.contents -weight 1 +grid columnconfigure $t.contents 1000 -weight 1 + +if {[tk windowingsystem] ne "aqua"} { + ## Bindings so that the toolbar can be torn off and reattached + bind $t.tearoff <B1-Motion> [list tearoff $t %X %Y] + bind $t.tearoff.to <B1-Motion> [list tearoff $t %X %Y] + bind $t.tearoff.to2 <B1-Motion> [list tearoff $t %X %Y] + proc tearoff {w x y} { + if {[string match $w* [winfo containing $x $y]]} { + return + } + grid remove $w + grid remove $w.tearoff + wm manage $w + wm protocol $w WM_DELETE_WINDOW [list untearoff $w] + } + proc untearoff {w} { + wm forget $w + grid $w.tearoff + grid $w + } +} + +## Toolbar contents +ttk::button $t.button -text "Button" -style Toolbutton -command [list \ + $w.txt insert end "Button Pressed\n"] +ttk::checkbutton $t.check -text "Check" -variable check -style Toolbutton \ + -command [concat [list $w.txt insert end] {"check is $check\n"}] +ttk::menubutton $t.menu -text "Menu" -menu $t.menu.m +ttk::combobox $t.combo -value [lsort [font families]] -state readonly +menu $t.menu.m +$t.menu.m add command -label "Just" -command [list $w.txt insert end Just\n] +$t.menu.m add command -label "An" -command [list $w.txt insert end An\n] +$t.menu.m add command -label "Example" \ + -command [list $w.txt insert end Example\n] +bind $t.combo <<ComboboxSelected>> [list changeFont $w.txt $t.combo] +proc changeFont {txt combo} { + $txt configure -font [list [$combo get] 10] +} + +## Some content for the rest of the toplevel +text $w.txt -width 40 -height 10 +interp alias {} doInsert {} $w.txt insert end ;# Make bindings easy to write + +## Arrange contents +grid $t.button $t.check $t.menu $t.combo -in $t.contents -padx 2 -sticky ns +grid $t -sticky ew +grid $w.sep -sticky ew +grid $w.msg -sticky ew +grid $w.txt -sticky nsew +grid rowconfigure $w $w.txt -weight 1 +grid columnconfigure $w $w.txt -weight 1 + +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +grid $btns -sticky ew diff --git a/library/demos/tree.tcl b/library/demos/tree.tcl new file mode 100644 index 0000000..14d5db8 --- /dev/null +++ b/library/demos/tree.tcl @@ -0,0 +1,94 @@ +# tree.tcl -- +# +# This demonstration script creates a toplevel window containing a Ttk +# tree widget. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .tree +catch {destroy $w} +toplevel $w +wm title $w "Directory Browser" +wm iconname $w "tree" +positionWindow $w + +## Explanatory text +ttk::label $w.msg -font $font -wraplength 4i -justify left -anchor n -padding {10 2 10 6} -text "Ttk is the new Tk themed widget set. One of the widgets it includes is a tree widget, which allows the user to browse a hierarchical data-set such as a filesystem. The tree widget not only allows for the tree part itself, but it also supports an arbitrary number of additional columns which can show additional data (in this case, the size of the files found in your filesystem). You can also change the width of the columns by dragging the boundary between them." +pack $w.msg -fill x + +## See Code / Dismiss +pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x + +## Code to populate the roots of the tree (can be more than one on Windows) +proc populateRoots {tree} { + foreach dir [lsort -dictionary [file volumes]] { + populateTree $tree [$tree insert {} end -text $dir \ + -values [list $dir directory]] + } +} + +## Code to populate a node of the tree +proc populateTree {tree node} { + if {[$tree set $node type] ne "directory"} { + return + } + set path [$tree set $node fullpath] + $tree delete [$tree children $node] + foreach f [lsort -dictionary [glob -nocomplain -dir $path *]] { + set type [file type $f] + set id [$tree insert $node end -text [file tail $f] \ + -values [list $f $type]] + + if {$type eq "directory"} { + ## Make it so that this node is openable + $tree insert $id 0 -text dummy ;# a dummy + $tree item $id -text [file tail $f]/ + + } elseif {$type eq "file"} { + set size [file size $f] + ## Format the file size nicely + if {$size >= 1024*1024*1024} { + set size [format %.1f\ GB [expr {$size/1024/1024/1024.}]] + } elseif {$size >= 1024*1024} { + set size [format %.1f\ MB [expr {$size/1024/1024.}]] + } elseif {$size >= 1024} { + set size [format %.1f\ kB [expr {$size/1024.}]] + } else { + append size " bytes" + } + $tree set $id size $size + } + } + + # Stop this code from rerunning on the current node + $tree set $node type processedDirectory +} + +## Create the tree and set it up +ttk::treeview $w.tree -columns {fullpath type size} -displaycolumns {size} \ + -yscroll "$w.vsb set" -xscroll "$w.hsb set" +if {[tk windowingsystem] ne "aqua"} { + ttk::scrollbar $w.vsb -orient vertical -command "$w.tree yview" + ttk::scrollbar $w.hsb -orient horizontal -command "$w.tree xview" +} else { + scrollbar $w.vsb -orient vertical -command "$w.tree yview" + scrollbar $w.hsb -orient horizontal -command "$w.tree xview" +} +$w.tree heading \#0 -text "Directory Structure" +$w.tree heading size -text "File Size" +$w.tree column size -stretch 0 -width 70 +populateRoots $w.tree +bind $w.tree <<TreeviewOpen>> {populateTree %W [%W focus]} + +## Arrange the tree and its scrollbars in the toplevel +lower [ttk::frame $w.dummy] +pack $w.dummy -fill both -expand 1 +grid $w.tree $w.vsb -sticky nsew -in $w.dummy +grid $w.hsb -sticky nsew -in $w.dummy +grid columnconfigure $w.dummy 0 -weight 1 +grid rowconfigure $w.dummy 0 -weight 1 diff --git a/library/demos/ttkbut.tcl b/library/demos/ttkbut.tcl new file mode 100644 index 0000000..66ff1d7 --- /dev/null +++ b/library/demos/ttkbut.tcl @@ -0,0 +1,85 @@ +# ttkbut.tcl -- +# +# This demonstration script creates a toplevel window containing several +# simple Ttk widgets, such as labels, labelframes, buttons, checkbuttons and +# radiobuttons. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .ttkbut +catch {destroy $w} +toplevel $w +wm title $w "Simple Ttk Widgets" +wm iconname $w "ttkbut" +positionWindow $w + +ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set. This is a Ttk themed label, and below are three groups of Ttk widgets in Ttk labelframes. The first group are all buttons that set the current application theme when pressed. The second group contains three sets of checkbuttons, with a separator widget between the sets. Note that the \u201cEnabled\u201d button controls whether all the other themed widgets in this toplevel are in the disabled state. The third group has a collection of linked radiobuttons." +pack $w.msg -side top -fill x + +## See Code / Dismiss +pack [addSeeDismiss $w.seeDismiss $w {enabled cheese tomato basil oregano happyness}]\ + -side bottom -fill x + +## Add buttons for setting the theme +ttk::labelframe $w.buttons -text "Buttons" +foreach theme [ttk::themes] { + ttk::button $w.buttons.$theme -text $theme \ + -command [list ttk::setTheme $theme] + pack $w.buttons.$theme -pady 2 +} + +## Helper procedure for the top checkbutton +proc setState {rootWidget exceptThese value} { + if {$rootWidget in $exceptThese} { + return + } + ## Non-Ttk widgets (e.g. the toplevel) will fail, so make it silent + catch { + $rootWidget state $value + } + ## Recursively invoke on all children of this root that are in the same + ## toplevel widget + foreach w [winfo children $rootWidget] { + if {[winfo toplevel $w] eq [winfo toplevel $rootWidget]} { + setState $w $exceptThese $value + } + } +} + +## Set up the checkbutton group +ttk::labelframe $w.checks -text "Checkbuttons" +ttk::checkbutton $w.checks.e -text Enabled -variable enabled -command { + setState .ttkbut .ttkbut.checks.e \ + [expr {$enabled ? "!disabled" : "disabled"}] +} +set enabled 1 +## See ttk_widget(n) for other possible state flags +ttk::separator $w.checks.sep1 +ttk::checkbutton $w.checks.c1 -text Cheese -variable cheese +ttk::checkbutton $w.checks.c2 -text Tomato -variable tomato +ttk::separator $w.checks.sep2 +ttk::checkbutton $w.checks.c3 -text Basil -variable basil +ttk::checkbutton $w.checks.c4 -text Oregano -variable oregano +pack $w.checks.e $w.checks.sep1 $w.checks.c1 $w.checks.c2 $w.checks.sep2 \ + $w.checks.c3 $w.checks.c4 -fill x -pady 2 + +## Set up the radiobutton group +ttk::labelframe $w.radios -text "Radiobuttons" +ttk::radiobutton $w.radios.r1 -text "Great" -variable happyness -value great +ttk::radiobutton $w.radios.r2 -text "Good" -variable happyness -value good +ttk::radiobutton $w.radios.r3 -text "OK" -variable happyness -value ok +ttk::radiobutton $w.radios.r4 -text "Poor" -variable happyness -value poor +ttk::radiobutton $w.radios.r5 -text "Awful" -variable happyness -value awful +pack $w.radios.r1 $w.radios.r2 $w.radios.r3 $w.radios.r4 $w.radios.r5 \ + -fill x -padx 3 -pady 2 + +## Arrange things neatly +pack [ttk::frame $w.f] -fill both -expand 1 +lower $w.f +grid $w.buttons $w.checks $w.radios -in $w.f -sticky nwe -pady 2 -padx 3 +grid columnconfigure $w.f {0 1 2} -weight 1 -uniform yes diff --git a/library/demos/ttkmenu.tcl b/library/demos/ttkmenu.tcl new file mode 100644 index 0000000..c01c9af --- /dev/null +++ b/library/demos/ttkmenu.tcl @@ -0,0 +1,54 @@ +# ttkmenu.tcl -- +# +# This demonstration script creates a toplevel window containing several Ttk +# menubutton widgets. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .ttkmenu +catch {destroy $w} +toplevel $w +wm title $w "Ttk Menu Buttons" +wm iconname $w "ttkmenu" +positionWindow $w + +ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Ttk is the new Tk themed widget set, and one widget that is available in themed form is the menubutton. Below are some themed menu buttons that allow you to pick the current theme in use. Notice how picking a theme changes the way that the menu buttons themselves look, and that the central menu button is styled differently (in a way that is normally suitable for toolbars). However, there are no themed menus; the standard Tk menus were judged to have a sufficiently good look-and-feel on all platforms, especially as they are implemented as native controls in many places." +pack $w.msg [ttk::separator $w.msgSep] -side top -fill x + +## See Code / Dismiss +pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x + +ttk::menubutton $w.m1 -menu $w.m1.menu -text "Select a theme" -direction above +ttk::menubutton $w.m2 -menu $w.m1.menu -text "Select a theme" -direction left +ttk::menubutton $w.m3 -menu $w.m1.menu -text "Select a theme" -direction right +ttk::menubutton $w.m4 -menu $w.m1.menu -text "Select a theme" \ + -direction flush -style TMenubutton.Toolbutton +ttk::menubutton $w.m5 -menu $w.m1.menu -text "Select a theme" -direction below + +menu $w.m1.menu -tearoff 0 +menu $w.m2.menu -tearoff 0 +menu $w.m3.menu -tearoff 0 +menu $w.m4.menu -tearoff 0 +menu $w.m5.menu -tearoff 0 + +foreach theme [ttk::themes] { + $w.m1.menu add command -label $theme -command [list ttk::setTheme $theme] + $w.m2.menu add command -label $theme -command [list ttk::setTheme $theme] + $w.m3.menu add command -label $theme -command [list ttk::setTheme $theme] + $w.m4.menu add command -label $theme -command [list ttk::setTheme $theme] + $w.m5.menu add command -label $theme -command [list ttk::setTheme $theme] +} + +pack [ttk::frame $w.f] -fill x +pack [ttk::frame $w.f1] -fill both -expand yes +lower $w.f + +grid anchor $w.f center +grid x $w.m1 x -in $w.f -padx 3 -pady 2 +grid $w.m2 $w.m4 $w.m3 -in $w.f -padx 3 -pady 2 +grid x $w.m5 x -in $w.f -padx 3 -pady 2 diff --git a/library/demos/ttknote.tcl b/library/demos/ttknote.tcl new file mode 100644 index 0000000..5683892 --- /dev/null +++ b/library/demos/ttknote.tcl @@ -0,0 +1,62 @@ +# ttknote.tcl -- +# +# This demonstration script creates a toplevel window containing a Ttk +# notebook widget. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .ttknote +catch {destroy $w} +toplevel $w +wm title $w "Ttk Notebook Widget" +wm iconname $w "ttknote" +positionWindow $w + +## See Code / Dismiss +pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x + +ttk::frame $w.f +pack $w.f -fill both -expand 1 +set w $w.f + +## Make the notebook and set up Ctrl+Tab traversal +ttk::notebook $w.note +pack $w.note -fill both -expand 1 -padx 2 -pady 3 +ttk::notebook::enableTraversal $w.note + +## Popuplate the first pane +ttk::frame $w.note.msg +ttk::label $w.note.msg.m -font $font -wraplength 4i -justify left -anchor n -text "Ttk is the new Tk themed widget set. One of the widgets it includes is the notebook widget, which provides a set of tabs that allow the selection of a group of panels, each with distinct content. They are a feature of many modern user interfaces. Not only can the tabs be selected with the mouse, but they can also be switched between using Ctrl+Tab when the notebook page heading itself is selected. Note that the second tab is disabled, and cannot be selected." +ttk::button $w.note.msg.b -text "Neat!" -underline 0 -command { + set neat "Yeah, I know..." + after 500 {set neat {}} +} +bind $w <Alt-n> "focus $w.note.msg.b; $w.note.msg.b invoke" +ttk::label $w.note.msg.l -textvariable neat +$w.note add $w.note.msg -text "Description" -underline 0 -padding 2 +grid $w.note.msg.m - -sticky new -pady 2 +grid $w.note.msg.b $w.note.msg.l -pady {2 4} +grid rowconfigure $w.note.msg 1 -weight 1 +grid columnconfigure $w.note.msg {0 1} -weight 1 -uniform 1 + +## Populate the second pane. Note that the content doesn't really matter +ttk::frame $w.note.disabled +$w.note add $w.note.disabled -text "Disabled" -state disabled + +## Popuplate the third pane +ttk::frame $w.note.editor +$w.note add $w.note.editor -text "Text Editor" -underline 0 +text $w.note.editor.t -width 40 -height 10 -wrap char \ + -yscroll "$w.note.editor.s set" +if {[tk windowingsystem] ne "aqua"} { + ttk::scrollbar $w.note.editor.s -orient vertical -command "$w.note.editor.t yview" +} else { + scrollbar $w.note.editor.s -orient vertical -command "$w.note.editor.t yview" +} +pack $w.note.editor.s -side right -fill y -padx {0 2} -pady 2 +pack $w.note.editor.t -fill both -expand 1 -pady 2 -padx {2 0} diff --git a/library/demos/ttkpane.tcl b/library/demos/ttkpane.tcl new file mode 100644 index 0000000..a4d5738 --- /dev/null +++ b/library/demos/ttkpane.tcl @@ -0,0 +1,107 @@ +# ttkpane.tcl -- +# +# This demonstration script creates a Ttk pane with some content. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .ttkpane +catch {destroy $w} +toplevel $w +wm title $w "Themed Nested Panes" +wm iconname $w "ttkpane" +positionWindow $w + +ttk::label $w.msg -font $font -wraplength 4i -justify left -text "This demonstration shows off a nested set of themed paned windows. Their sizes can be changed by grabbing the area between each contained pane and dragging the divider." +pack $w.msg [ttk::separator $w.msgSep] -side top -fill x + +## See Code / Dismiss +pack [addSeeDismiss $w.seeDismiss $w] -side bottom -fill x + +ttk::frame $w.f +pack $w.f -fill both -expand 1 +set w $w.f +ttk::panedwindow $w.outer -orient horizontal +$w.outer add [ttk::panedwindow $w.outer.inLeft -orient vertical] +$w.outer add [ttk::panedwindow $w.outer.inRight -orient vertical] +$w.outer.inLeft add [ttk::labelframe $w.outer.inLeft.top -text Button] +$w.outer.inLeft add [ttk::labelframe $w.outer.inLeft.bot -text Clocks] +$w.outer.inRight add [ttk::labelframe $w.outer.inRight.top -text Progress] +$w.outer.inRight add [ttk::labelframe $w.outer.inRight.bot -text Text] +if {[tk windowingsystem] eq "aqua"} { + foreach i [list inLeft.top inLeft.bot inRight.top inRight.bot] { + $w.outer.$i configure -padding 3 + } +} + +# Fill the button pane +ttk::button $w.outer.inLeft.top.b -text "Press Me" -command { + tk_messageBox -type ok -icon info -message "Ouch!" -detail "That hurt..." \ + -parent .ttkpane -title "Button Pressed" +} +pack $w.outer.inLeft.top.b -padx 2 -pady 5 + +# Fill the clocks pane +set i 0 +proc every {delay script} { + uplevel #0 $script + after $delay [list every $delay $script] +} +set zones { + :Europe/Berlin + :America/Argentina/Buenos_Aires + :Africa/Johannesburg + :Europe/London + :America/Los_Angeles + :Europe/Moscow + :America/New_York + :Asia/Singapore + :Australia/Sydney + :Asia/Tokyo +} +# Force a pre-load of all the timezones needed; otherwise can end up +# poor-looking synch problems! +foreach zone $zones {clock format 0 -timezone $zone} +foreach zone $zones { + set city [string map {_ " "} [regexp -inline {[^/]+$} $zone]] + if {$i} { + pack [ttk::separator $w.outer.inLeft.bot.s$i] -fill x + } + ttk::label $w.outer.inLeft.bot.l$i -text $city -anchor w + ttk::label $w.outer.inLeft.bot.t$i -textvariable time($zone) -anchor w + pack $w.outer.inLeft.bot.l$i $w.outer.inLeft.bot.t$i -fill x + every 1000 "set time($zone) \[clock format \[clock seconds\] -timezone $zone -format %T\]" + incr i +} + +# Fill the progress pane +ttk::progressbar $w.outer.inRight.top.progress -mode indeterminate +pack $w.outer.inRight.top.progress -fill both -expand 1 +$w.outer.inRight.top.progress start + +# Fill the text pane +if {[tk windowingsystem] ne "aqua"} { + # The trick with the ttk::frame makes the text widget look like it fits with + # the current Ttk theme despite not being a themed widget itself. It is done + # by styling the frame like an entry, turning off the border in the text + # widget, and putting the text widget in the frame with enough space to allow + # the surrounding border to show through (2 pixels seems to be enough). + ttk::frame $w.outer.inRight.bot.f -style TEntry + text $w.txt -wrap word -yscroll "$w.sb set" -width 30 -borderwidth 0 + pack $w.txt -fill both -expand 1 -in $w.outer.inRight.bot.f -pady 2 -padx 2 + ttk::scrollbar $w.sb -orient vertical -command "$w.txt yview" + pack $w.sb -side right -fill y -in $w.outer.inRight.bot + pack $w.outer.inRight.bot.f -fill both -expand 1 + pack $w.outer -fill both -expand 1 +} else { + text $w.txt -wrap word -yscroll "$w.sb set" -width 30 -borderwidth 0 + scrollbar $w.sb -orient vertical -command "$w.txt yview" + pack $w.sb -side right -fill y -in $w.outer.inRight.bot + pack $w.txt -fill both -expand 1 -in $w.outer.inRight.bot + pack $w.outer -fill both -expand 1 -padx 10 -pady {6 10} +} + diff --git a/library/demos/ttkprogress.tcl b/library/demos/ttkprogress.tcl new file mode 100644 index 0000000..87765d7 --- /dev/null +++ b/library/demos/ttkprogress.tcl @@ -0,0 +1,47 @@ +# ttkprogress.tcl -- +# +# This demonstration script creates several progress bar widgets. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk +package require Ttk + +set w .ttkprogress +catch {destroy $w} +toplevel $w +wm title $w "Progress Bar Demonstration" +wm iconname $w "ttkprogress" +positionWindow $w + +ttk::label $w.msg -font $font -wraplength 4i -justify left -text "Below are two progress bars. The top one is a \u201Cdeterminate\u201D progress bar, which is used for showing how far through a defined task the program has got. The bottom one is an \u201Cindeterminate\u201D progress bar, which is used to show that the program is busy but does not know how long for. Both are run here in self-animated mode, which can be turned on and off using the buttons underneath." +pack $w.msg -side top -fill x + +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x + +ttk::frame $w.f +pack $w.f -fill both -expand 1 +set w $w.f + +proc doBars {op args} { + foreach w $args { + $w $op + } +} +ttk::progressbar $w.p1 -mode determinate +ttk::progressbar $w.p2 -mode indeterminate +ttk::button $w.start -text "Start Progress" -command [list \ + doBars start $w.p1 $w.p2] +ttk::button $w.stop -text "Stop Progress" -command [list \ + doBars stop $w.p1 $w.p2] + +grid $w.p1 - -pady 5 -padx 10 +grid $w.p2 - -pady 5 -padx 10 +grid $w.start $w.stop -padx 10 -pady 5 +grid configure $w.start -sticky e +grid configure $w.stop -sticky w +grid columnconfigure $w all -weight 1 diff --git a/library/demos/ttkscale.tcl b/library/demos/ttkscale.tcl new file mode 100644 index 0000000..1a95416 --- /dev/null +++ b/library/demos/ttkscale.tcl @@ -0,0 +1,39 @@ +# ttkscale.tcl -- +# +# This demonstration script shows an example with a horizontal scale. + +if {![info exists widgetDemo]} { + error "This script should be run from the \"widget\" demo." +} + +package require Tk + +set w .ttkscale +catch {destroy $w} +toplevel $w -bg [ttk::style lookup TLabel -background] +wm title $w "Themed Scale Demonstration" +wm iconname $w "ttkscale" +positionWindow $w + +pack [ttk::frame [set w $w.contents]] -fill both -expand 1 + +ttk::label $w.msg -font $font -wraplength 3.5i -justify left -text "A label tied to a horizontal scale is displayed below. If you click or drag mouse button 1 in the scale, you can change the contents of the label; a callback command is used to couple the slider to both the text and the coloring of the label." +pack $w.msg -side top -padx .5c + +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons [winfo toplevel $w]] +pack $btns -side bottom -fill x + +ttk::frame $w.frame -borderwidth 10 +pack $w.frame -side top -fill x + +# List of colors from rainbox; "Indigo" is not a standard color +set colorList {Red Orange Yellow Green Blue Violet} +ttk::label $w.frame.label +ttk::scale $w.frame.scale -from 0 -to 5 -command [list apply {{w idx} { + set c [lindex $::colorList [tcl::mathfunc::int $idx]] + $w.frame.label configure -foreground $c -text "Color: $c" +}} $w] +# Trigger the setting of the label's text +$w.frame.scale set 0 +pack $w.frame.label $w.frame.scale diff --git a/library/demos/twind.tcl b/library/demos/twind.tcl index 7f5b9b7..e1d0b5b 100644 --- a/library/demos/twind.tcl +++ b/library/demos/twind.tcl @@ -7,27 +7,32 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .twind catch {destroy $w} toplevel $w -wm title $w "Text Demonstration - Embedded Windows" +wm title $w "Text Demonstration - Embedded Windows and Other Features" wm iconname $w "Embedded Windows" positionWindow $w -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x -frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken +frame $w.f -highlightthickness 1 -borderwidth 1 -relief sunken set t $w.f.text text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \ -height 35 -wrap word -highlightthickness 0 -borderwidth 0 pack $t -expand yes -fill both scrollbar $w.scroll -command "$t yview" pack $w.scroll -side right -fill y -pack $w.f -expand yes -fill both +panedwindow $w.pane +pack $w.pane -expand yes -fill both +$w.pane add $w.f +# Import to raise given creation order above +raise $w.f + $t tag configure center -justify center -spacing1 5m -spacing3 5m $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \ -spacing1 3m -spacing2 0 -spacing3 0 @@ -36,10 +41,12 @@ button $t.on -text "Turn On" -command "textWindOn $w" \ -cursor top_left_arrow button $t.off -text "Turn Off" -command "textWindOff $w" \ -cursor top_left_arrow -button $t.click -text "Click Here" -command "textWindPlot $t" \ - -cursor top_left_arrow -button $t.delete -text "Delete" -command "textWindDel $w" \ - -cursor top_left_arrow + +$t insert end "A text widget can contain many different kinds of items, " +$t insert end "both active and passive. It can lay these out in various " +$t insert end "ways, with wrapping, tabs, centering, etc. In addition, " +$t insert end "when the contents are too big for the window, smooth " +$t insert end "scrolling in all directions is provided.\n\n" $t insert end "A text widget can contain other widgets embedded " $t insert end "it. These are called \"embedded windows\", " @@ -54,15 +61,44 @@ $t window create end -window $t.off $t insert end " horizontal scrolling and turn back on word wrapping.\n\n" $t insert end "Or, here is another example. If you " -$t window create end -window $t.click +$t window create end -create { + button %W.click -text "Click Here" -command "textWindPlot %W" \ + -cursor top_left_arrow} + $t insert end " a canvas displaying an x-y plot will appear right here." $t mark set plot insert $t mark gravity plot left $t insert end " You can drag the data points around with the mouse, " $t insert end "or you can click here to " -$t window create end -window $t.delete +$t window create end -create { + button %W.delete -text "Delete" -command "textWindDel %W" \ + -cursor top_left_arrow +} $t insert end " the plot again.\n\n" +$t insert end "You can also create multiple text widgets each of which " +$t insert end "display the same underlying text. Click this button to " +$t window create end \ + -create {button %W.peer -text "Make A Peer" -command "textMakePeer %W" \ + -cursor top_left_arrow} -padx 3 +$t insert end " widget. Notice how peer widgets can have different " +$t insert end "font settings, and by default contain all the images " +$t insert end "of the 'parent', but many of the embedded windows, " +$t insert end "such as buttons will not be there. The easiest way " +$t insert end "to ensure they are in all peers is to use '-create' " +$t insert end "embedded window creation scripts " +$t insert end "(the plot above and the 'Make A Peer' button are " +$t insert end "designed to show up in all peers). A good use of " +$t insert end "peers is for " +$t window create end \ + -create {button %W.split -text "Split Windows" -command "textSplitWindow %W" \ + -cursor top_left_arrow} -padx 3 +$t insert end " \n\n" + +$t insert end "Users of previous versions of Tk will also be interested " +$t insert end "to note that now cursor movement is now by visual line by " +$t insert end "default, and that all scrolling of this widget is by pixel.\n\n" + $t insert end "You may also find it useful to put embedded windows in " $t insert end "a text without any actual text. In this case the " $t insert end "text widget acts like a geometry manager. For " @@ -97,6 +133,63 @@ foreach color {AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4 } $t tag add buttons $t.default end +button $t.bigB -text "Big borders" -command "textWindBigB $t" \ + -cursor top_left_arrow +button $t.smallB -text "Small borders" -command "textWindSmallB $t" \ + -cursor top_left_arrow +button $t.bigH -text "Big highlight" -command "textWindBigH $t" \ + -cursor top_left_arrow +button $t.smallH -text "Small highlight" -command "textWindSmallH $t" \ + -cursor top_left_arrow +button $t.bigP -text "Big pad" -command "textWindBigP $t" \ + -cursor top_left_arrow +button $t.smallP -text "Small pad" -command "textWindSmallP $t" \ + -cursor top_left_arrow + +set text_normal(border) [$t cget -borderwidth] +set text_normal(highlight) [$t cget -highlightthickness] +set text_normal(pad) [$t cget -padx] + +$t insert end "\nYou can also change the usual border width and " +$t insert end "highlightthickness and padding.\n" +$t window create end -window $t.bigB +$t window create end -window $t.smallB +$t window create end -window $t.bigH +$t window create end -window $t.smallH +$t window create end -window $t.bigP +$t window create end -window $t.smallP + +$t insert end "\n\nFinally, images fit comfortably in text widgets too:" + +$t image create end -image \ + [image create bitmap -file [file join $tk_demoDirectory images face.xbm]] + + +proc textWindBigB w { + $w configure -borderwidth 15 +} + +proc textWindBigH w { + $w configure -highlightthickness 15 +} + +proc textWindBigP w { + $w configure -padx 15 -pady 15 +} + +proc textWindSmallB w { + $w configure -borderwidth $::text_normal(border) +} + +proc textWindSmallH w { + $w configure -highlightthickness $::text_normal(highlight) +} + +proc textWindSmallP w { + $w configure -padx $::text_normal(pad) -pady $::text_normal(pad) +} + + proc textWindOn w { catch {destroy $w.scroll2} set t $w.f.text @@ -116,6 +209,20 @@ proc textWindPlot t { if {[winfo exists $c]} { return } + + while {[string first [$t get plot] " \t\n"] >= 0} { + $t delete plot + } + $t insert plot "\n" + + $t window create plot -create {createPlot %W} + $t tag add center plot + $t insert plot "\n" +} + +proc createPlot {t} { + set c $t.c + canvas $c -relief sunken -width 450 -height 300 -cursor top_left_arrow set font {Helvetica 18} @@ -151,13 +258,7 @@ proc textWindPlot t { $c bind point <1> "embPlotDown $c %x %y" $c bind point <ButtonRelease-1> "$c dtag selected" bind $c <B1-Motion> "embPlotMove $c %x %y" - while {[string first [$t get plot] " \t\n"] >= 0} { - $t delete plot - } - $t insert plot "\n" - $t window create plot -window $c - $t tag add center plot - $t insert plot "\n" + return $c } set embPlot(lastX) 0 @@ -179,8 +280,7 @@ proc embPlotMove {w x y} { set embPlot(lastY) $y } -proc textWindDel w { - set t $w.f.text +proc textWindDel t { if {[winfo exists $t.c]} { $t delete $t.c while {[string first [$t get plot] " \t\n"] >= 0} { @@ -193,3 +293,33 @@ proc textWindDel w { proc embDefBg t { $t configure -background [lindex [$t configure -background] 3] } + +proc textMakePeer {parent} { + set n 1 + while {[winfo exists .peer$n]} { incr n } + set w [toplevel .peer$n] + wm title $w "Text Peer #$n" + frame $w.f -highlightthickness 1 -borderwidth 1 -relief sunken + set t [$parent peer create $w.f.text -yscrollcommand "$w.scroll set" \ + -borderwidth 0 -highlightthickness 0] + pack $t -expand yes -fill both + scrollbar $w.scroll -command "$t yview" + pack $w.scroll -side right -fill y + pack $w.f -expand yes -fill both +} + +proc textSplitWindow {textW} { + if {$textW eq ".twind.f.text"} { + if {[winfo exists .twind.peer]} { + destroy .twind.peer + } else { + set parent [winfo parent $textW] + set w [winfo parent $parent] + set t [$textW peer create $w.peer \ + -yscrollcommand "$w.scroll set"] + $w.pane add $t + } + } else { + return + } +} diff --git a/library/demos/unicodeout.tcl b/library/demos/unicodeout.tcl index ec0b7d0..11cc933 100644 --- a/library/demos/unicodeout.tcl +++ b/library/demos/unicodeout.tcl @@ -7,6 +7,28 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + +# On Windows, we need to determine whether the font system will render +# right-to-left text. + +if {[tk windowingsystem] eq {win32}} { + set rkey [join { + HKEY_LOCAL_MACHINE + SOFTWARE + Microsoft + {Windows NT} + CurrentVersion + LanguagePack + } \\] + set w32langs {} + if {![catch {package require registry}]} { + if {[catch {registry values $rkey} w32langs]} { + set w32langs {} + } + } +} + set w .unicodeout catch {destroy $w} toplevel $w @@ -14,7 +36,7 @@ wm title $w "Unicode Label Demonstration" wm iconname $w "unicodeout" positionWindow $w -label $w.msg -font $font -wraplength 4i -justify left \ +label $w.msg -font $font -wraplength 4i -anchor w -justify left \ -text "This is a sample of Tk's support for languages that use\ non-Western character sets. However, what you will actually see\ below depends largely on what character sets you have installed,\ @@ -24,11 +46,9 @@ label $w.msg -font $font -wraplength 4i -justify left \ portable fashion." pack $w.msg -side top -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x pack [label $w.wait -text "Please wait while loading fonts..." \ -font {Helvetica 12 italic}] @@ -53,17 +73,35 @@ set oldCursor [$w cget -cursor] $w conf -cursor watch update -addSample $w Arabic \ - "\uFE94\uFEF4\uFE91\uFEAE\uFECC\uFEDF\uFE8D\uFE94" \ - "\uFEE4\uFEE0\uFEDC\uFEDF\uFE8D" +if {[tk windowingsystem] eq {x11} + || (([tk windowingsystem] eq {win32}) && ({ARABIC} ni $w32langs))} { + # Using presentation forms (pre-layouted) + addSample $w Arabic \ + "\uFE94\uFEF4\uFE91\uFEAE\uFECC\uFEDF\uFE8D " \ + "\uFE94\uFEE4\uFEE0\uFEDC\uFEDF\uFE8D" +} else { + # Using standard text characters + addSample $w Arabic \ + "\u0627\u0644\u0643\u0644\u0645\u0629 " \ + "\u0627\u0644\u0639\u0631\u0628\u064A\u0629" +} addSample $w "Trad. Chinese" "\u4E2D\u570B\u7684\u6F22\u5B57" addSample $w "Simpl. Chinese" "\u6C49\u8BED" addSample $w Greek \ "\u0395\u03BB\u03BB\u03B7\u03BD\u03B9\u03BA\u03AE " \ "\u03B3\u03BB\u03CE\u03C3\u03C3\u03B1" -addSample $w Hebrew \ - "\u05DD\u05D9\u05DC\u05E9\u05D5\u05E8\u05D9 " \ - "\u05DC\u05D9\u05D0\u05E8\u05E9\u05D9" +if {[tk windowingsystem] eq {x11} + || (([tk windowingsystem] eq {win32}) && ({HEBREW} ni $w32langs))} { + # Visual order (pre-layouted) + addSample $w Hebrew \ + "\u05EA\u05D9\u05E8\u05D1\u05E2 " \ + "\u05D1\u05EA\u05DB" +} else { + # Standard logical order + addSample $w Hebrew \ + "\u05DB\u05EA\u05D1 " \ + "\u05E2\u05D1\u05E8\u05D9\u05EA" +} addSample $w Japanese \ "\u65E5\u672C\u8A9E\u306E\u3072\u3089\u304C\u306A, " \ "\u6F22\u5B57\u3068\u30AB\u30BF\u30AB\u30CA" diff --git a/library/demos/vscale.tcl b/library/demos/vscale.tcl index b04201d..2c7ea76 100644 --- a/library/demos/vscale.tcl +++ b/library/demos/vscale.tcl @@ -6,6 +6,8 @@ if {![info exists widgetDemo]} { error "This script should be run from the \"widget\" demo." } +package require Tk + set w .vscale catch {destroy $w} toplevel $w @@ -16,11 +18,9 @@ positionWindow $w label $w.msg -font $font -wraplength 3.5i -justify left -text "An arrow and a vertical scale are displayed below. If you click or drag mouse button 1 in the scale, you can change the size of the arrow." pack $w.msg -side top -padx .5c -frame $w.buttons -pack $w.buttons -side bottom -fill x -pady 2m -button $w.buttons.dismiss -text Dismiss -command "destroy $w" -button $w.buttons.code -text "See Code" -command "showCode $w" -pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 +## See Code / Dismiss buttons +set btns [addSeeDismiss $w.buttons $w] +pack $btns -side bottom -fill x frame $w.frame -borderwidth 10 pack $w.frame diff --git a/library/demos/widget b/library/demos/widget index d4ec511..d58f086 100644 --- a/library/demos/widget +++ b/library/demos/widget @@ -3,99 +3,180 @@ exec wish "$0" ${1+"$@"} # widget -- -# This script demonstrates the various widgets provided by Tk, -# along with many of the features of the Tk toolkit. This file -# only contains code to generate the main window for the -# application, which invokes individual demonstrations. The -# code for the actual demonstrations is contained in separate -# ".tcl" files is this directory, which are sourced by this script -# as needed. +# This script demonstrates the various widgets provided by Tk, along with many +# of the features of the Tk toolkit. This file only contains code to generate +# the main window for the application, which invokes individual +# demonstrations. The code for the actual demonstrations is contained in +# separate ".tcl" files is this directory, which are sourced by this script as +# needed. + +package require Tcl 8.5 +package require Tk 8.5 +package require msgcat +package require Ttk eval destroy [winfo child .] -wm title . "Widget Demonstration" +set tk_demoDirectory [file join [pwd] [file dirname [info script]]] +::msgcat::mcload $tk_demoDirectory +namespace import ::msgcat::mc +wm title . [mc "Widget Demonstration"] if {[tk windowingsystem] eq "x11"} { - # This won't work everywhere, but there's no other way in core Tk - # at the moment to display a coloured icon. + # This won't work everywhere, but there's no other way in core Tk at the + # moment to display a coloured icon. image create photo TclPowered \ -file [file join $tk_library images logo64.gif] wm iconwindow . [toplevel ._iconWindow] pack [label ._iconWindow.i -image TclPowered] - wm iconname . "tkWidgetDemo" + wm iconname . [mc "tkWidgetDemo"] } -array set widgetFont { - main {Helvetica 12} - bold {Helvetica 12 bold} - title {Helvetica 18 bold} - status {Helvetica 10} - vars {Helvetica 14} +if {"defaultFont" ni [font names]} { + # TIP #145 defines some standard named fonts + if {"TkDefaultFont" in [font names] && "TkFixedFont" in [font names]} { + # FIX ME: the following technique of cloning the font to copy it works + # fine but means that if the system font is changed by Tk + # cannot update the copied font. font alias might be useful + # here -- or fix the app to use TkDefaultFont etc. + font create mainFont {*}[font configure TkDefaultFont] + font create fixedFont {*}[font configure TkFixedFont] + font create boldFont {*}[font configure TkDefaultFont] -weight bold + font create titleFont {*}[font configure TkDefaultFont] -weight bold + font create statusFont {*}[font configure TkDefaultFont] + font create varsFont {*}[font configure TkDefaultFont] + if {[tk windowingsystem] eq "aqua"} { + font configure titleFont -size 17 + } + } else { + font create mainFont -family Helvetica -size 12 + font create fixedFont -family Courier -size 10 + font create boldFont -family Helvetica -size 12 -weight bold + font create titleFont -family Helvetica -size 18 -weight bold + font create statusFont -family Helvetica -size 10 + font create varsFont -family Helvetica -size 14 + } } set widgetDemo 1 -set font $widgetFont(main) +set font mainFont + +image create photo ::img::refresh -format GIF -data { + R0lGODlhEAAQAJEDAP///wAAACpnKv///yH5BAEAAAMALAAAAAAQABAAAAI63IKp + xgcPH2ouwgBCw1HIxHCQ4F3hSJKmwZXqWrmWxj7lKJ2dndcon9EBUq+gz3brVXAR + 2tICU0gXBQA7 +} + +image create photo ::img::view -format GIF -data { + R0lGODlhEAAQAKIHAP///wwMDAAAAMDAwNnZ2SYmJmZmZv///yH5BAEAAAcALAAA + AAAQABAAAANMKLos90+ASamDRxJCgw9YVnlDOXiQBgRDBRgHKE6sW8QR3doPKK27 + yg33q/GIOhdg6OsEJzeZykiBSUcs06e56Xx6np8ScIkFGuhQAgA7 +} + +image create photo ::img::delete -format GIF -data { + R0lGODlhEAAQAIABAIQAAP///yH5BAEAAAEALAAAAAAQABAAAAIjjI+pmwAc3HGy + PUSvqYpuvWQg40FfSVacBa5nN6JYDI3mzRQAOw== +} + +image create photo ::img::print -format GIF -data { + R0lGODlhEAAQALMKAAAAAP///52VunNkl8C82Yl+qldBgq+pyrOzs1fYAP///wAA + AAAAAAAAAAAAAAAAACH5BAEAAAoALAAAAAAQABAAAARGUMlJKwU4AztB+ODGeUiJ + fGLlgeEYmGWQXmx7aXgmAUTv/74N4EAsGhOJg1DAbDqbwoJ0Sp0KB9isNis0eL/g + ryhH5pgnEQA7 +} + +# Note that this is run through the message catalog! This is because this is +# actually an image of a word. +image create photo ::img::new -format GIF -data [mc { + R0lGODlhHgAOALMPALMAANyIiOu7u8dEROaqqvru7sxVVeGZmbgREfXd3b0iItZ3 + d8IzM9FmZvDMzP///yH5BAEAAA8ALAAAAAAeAA4AAASa8MlJq7046827WVOCHEkw + nANhUgJlEBIABJIwL3K+4IcUALCHjfbItYZDSgJgkBiYPmBMAUAkkLPKs/BAyLgM + wAQwOAAY2ByCaw4QAFQSoDEePJ6DmU1xInYZTw5nOEFFdgVUelkVDTIMd3AKFGQ1 + MgI2AwEmQW8APZ0gdRONAks5nhIFVVxdAAkUAS2pAVwFl7ITB4UqHb0XEQA7 +}] #---------------------------------------------------------------- -# The code below create the main window, consisting of a menu bar -# and a text widget that explains how to use the program, plus lists -# all of the demos as hypertext items. +# The code below create the main window, consisting of a menu bar and a text +# widget that explains how to use the program, plus lists all of the demos as +# hypertext items. #---------------------------------------------------------------- menu .menuBar -tearoff 0 -if {[tk windowingsystem] ne "classic" && [tk windowingsystem] ne "aqua"} { - .menuBar add cascade -menu .menuBar.file -label "File" -underline 0 +if {[tk windowingsystem] ne "aqua"} { + # This is a tk-internal procedure to make i18n easier + ::tk::AmpMenuArgs .menuBar add cascade -label [mc "&File"] \ + -menu .menuBar.file menu .menuBar.file -tearoff 0 - .menuBar.file add command -label "About..." -command "tkAboutDialog" \ - -underline 0 -accelerator "<F1>" + ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&About..."] \ + -command {tkAboutDialog} -accelerator [mc "<F1>"] + bind . <F1> {tkAboutDialog} .menuBar.file add sep - .menuBar.file add command -label "Quit" -command "exit" -underline 0 \ - -accelerator "Meta-Q" - bind . <F1> tkAboutDialog + if {[string match win* [tk windowingsystem]]} { + # Windows doesn't usually have a Meta key + ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \ + -command {exit} -accelerator [mc "Ctrl+Q"] + bind . <[mc "Control-q"]> {exit} + } else { + ::tk::AmpMenuArgs .menuBar.file add command -label [mc "&Quit"] \ + -command {exit} -accelerator [mc "Meta-Q"] + bind . <[mc "Meta-q"]> {exit} + } } . configure -menu .menuBar -frame .statusBar -label .statusBar.lab -text " " -relief sunken -bd 1 \ - -font $widgetFont(status) -anchor w -label .statusBar.foo -width 8 -relief sunken -bd 1 \ - -font $widgetFont(status) -anchor w +ttk::frame .statusBar +ttk::label .statusBar.lab -text " " -anchor w +if {[tk windowingsystem] eq "aqua"} { + ttk::separator .statusBar.sep + pack .statusBar.sep -side top -expand yes -fill x -pady 0 +} pack .statusBar.lab -side left -padx 2 -expand yes -fill both -pack .statusBar.foo -side left -padx 2 +if {[tk windowingsystem] ne "aqua"} { + ttk::sizegrip .statusBar.foo + pack .statusBar.foo -side left -padx 2 +} pack .statusBar -side bottom -fill x -pady 2 set textheight 30 catch { set textheight [expr { - ([winfo screenheight .] - 200) / - [font metrics $widgetFont(main) -displayof . -linespace] + ([winfo screenheight .] * 0.7) / + [font metrics mainFont -displayof . -linespace] }] } -frame .textFrame -scrollbar .s -orient vertical -command {.t yview} -highlightthickness 0 \ - -takefocus 1 +ttk::frame .textFrame +scrollbar .s -orient vertical -command {.t yview} -takefocus 1 pack .s -in .textFrame -side right -fill y -text .t -yscrollcommand {.s set} -wrap word -width 70 -height $textheight \ - -font $widgetFont(main) -setgrid 1 -highlightthickness 0 \ - -padx 4 -pady 2 -takefocus 0 +text .t -yscrollcommand {.s set} -wrap word -width 70 -height $textheight \ + -font mainFont -setgrid 1 -highlightthickness 0 \ + -padx 4 -pady 2 -takefocus 0 pack .t -in .textFrame -expand y -fill both -padx 1 -pack .textFrame -expand yes -fill both +pack .textFrame -expand yes -fill both +if {[tk windowingsystem] eq "aqua"} { + pack configure .statusBar.lab -padx {10 18} -pady {4 6} + pack configure .statusBar -pady 0 + .t configure -padx 10 -pady 0 +} -# Create a bunch of tags to use in the text widget, such as those for -# section titles and demo descriptions. Also define the bindings for -# tags. +# Create a bunch of tags to use in the text widget, such as those for section +# titles and demo descriptions. Also define the bindings for tags. -.t tag configure title -font $widgetFont(title) -.t tag configure bold -font $widgetFont(bold) +.t tag configure title -font titleFont +.t tag configure subtitle -font titleFont +.t tag configure bold -font boldFont +if {[tk windowingsystem] eq "aqua"} { + .t tag configure title -spacing1 8 + .t tag configure subtitle -spacing3 3 +} -# We put some "space" characters to the left and right of each demo description -# so that the descriptions are highlighted only when the mouse cursor -# is right over them (but not when the cursor is to their left or right) +# We put some "space" characters to the left and right of each demo +# description so that the descriptions are highlighted only when the mouse +# cursor is right over them (but not when the cursor is to their left or +# right). # .t tag configure demospace -lmargin1 1c -lmargin2 1c - if {[winfo depth .] == 1} { .t tag configure demo -lmargin1 1c -lmargin2 1c \ -underline 1 @@ -116,17 +197,17 @@ set lastLine "" .t tag bind demo <Enter> { set lastLine [.t index {@%x,%y linestart}] .t tag add hot "$lastLine +1 chars" "$lastLine lineend -1 chars" - .t config -cursor hand2 + .t config -cursor [::ttk::cursor link] showStatus [.t index {@%x,%y}] } .t tag bind demo <Leave> { .t tag remove hot 1.0 end - .t config -cursor xterm + .t config -cursor [::ttk::cursor text] .statusBar.lab config -text "" } .t tag bind demo <Motion> { set newLine [.t index {@%x,%y linestart}] - if {[string compare $newLine $lastLine] != 0} { + if {$newLine ne $lastLine} { .t tag remove hot 1.0 end set lastLine $newLine @@ -138,97 +219,239 @@ set lastLine "" } showStatus [.t index {@%x,%y}] } - + +############################################################################## # Create the text for the text widget. -proc addDemoSection {title demos} { - .t insert end "\n" {} $title title " \n " demospace - set num 0 - foreach {name description} $demos { - .t insert end "[incr num]. $description." [list demo demo-$name] - .t insert end " \n " demospace +# addFormattedText -- +# +# Add formatted text (but not hypertext) to the text widget after first +# passing it through the message catalog to allow for localization. +# Lines starting with @@ are formatting directives (insert title, insert +# demo hyperlink, begin newline, or change style) and all other lines +# are literal strings to be inserted. Substitutions are performed, +# allowing processing pieces through the message catalog. Blank lines +# are ignored. +# +proc addFormattedText {formattedText} { + set style normal + set isNL 1 + set demoCount 0 + set new 0 + foreach line [split $formattedText \n] { + set line [string trim $line] + if {$line eq ""} { + continue + } + if {[string match @@* $line]} { + set data [string range $line 2 end] + set key [lindex $data 0] + set values [lrange $data 1 end] + switch -exact -- $key { + title { + .t insert end [mc $values]\n title \n normal + } + newline { + .t insert end \n $style + set isNL 1 + } + subtitle { + .t insert end "\n" {} [mc $values] subtitle \ + " \n " demospace + set demoCount 0 + } + demo { + set description [lassign $values name] + .t insert end "[incr demoCount]. [mc $description]" \ + [list demo demo-$name] + if {$new} { + .t image create end -image ::img::new -padx 5 + set new 0 + } + .t insert end " \n " demospace + } + new { + set new 1 + } + default { + set style $key + } + } + continue + } + if {!$isNL} { + .t insert end " " $style + } + set isNL 0 + .t insert end [mc $line] $style } } -.t insert end "Tk Widget Demonstrations\n" title -.t insert end "\nThis application provides a front end for several short\ - scripts that demonstrate what you can do with Tk widgets. Each of\ - the numbered lines below describes a demonstration; you can click\ - on it to invoke the demonstration. Once the demonstration window\ - appears, you can click the " {} "See Code" bold " button to see the\ - Tcl/Tk code that created the demonstration. If you wish, you can\ - edit the code and click the " {} "Rerun Demo" bold " button in the\ - code window to reinvoke the demonstration with the modified code.\n" - -addDemoSection "Labels, buttons, checkbuttons, and radiobuttons" { - label "Labels (text and bitmaps)" - unicodeout "Labels and UNICODE text" - button "Buttons" - check "Check-buttons (select any of a group)" - radio "Radio-buttons (select one of a group)" - puzzle "A 15-puzzle game made out of buttons" - icon "Iconic buttons that use bitmaps" - image1 "Two labels displaying images" - image2 "A simple user interface for viewing images" - labelframe "Labelled frames" -} -addDemoSection "Listboxes" { - states "The 50 states" - colors "Colors: change the color scheme for the application" - sayings "A collection of famous and infamous sayings" -} -addDemoSection "Entries and Spin-boxes" { - entry1 "Entries without scrollbars" - entry2 "Entries with scrollbars" - entry3 "Validated entries and password fields" - spin "Spin-boxes" - form "Simple Rolodex-like form" -} -addDemoSection "Text" { - text "Basic editable text" - style "Text display styles" - bind "Hypertext (tag bindings)" - twind "A text widget with embedded windows" - search "A search tool built with a text widget" -} -addDemoSection "Canvases" { - items "The canvas item types" - plot "A simple 2-D plot" - ctext "Text items in canvases" - arrow "An editor for arrowheads on canvas lines" - ruler "A ruler with adjustable tab stops" - floor "A building floor plan" - cscroll "A simple scrollable canvas" -} -addDemoSection "Scales" { - hscale "Horizontal scale" - vscale "Vertical scale" -} -addDemoSection "Paned Windows" { - paned1 "Horizontal paned window" - paned2 "Vertical paned window" -} -addDemoSection "Menus" { - menu "Menus and cascades (sub-menus)" - menubu "Menu-buttons" -} -addDemoSection "Common Dialogs" { - msgbox "Message boxes" - filebox "File selection dialog" - clrpick "Color picker" -} -addDemoSection "Miscellaneous" { - bitmap "The built-in bitmaps" - dialog1 "A dialog box with a local grab" - dialog2 "A dialog box with a global grab" +addFormattedText { + @@title Tk Widget Demonstrations + + This application provides a front end for several short scripts + that demonstrate what you can do with Tk widgets. Each of the + numbered lines below describes a demonstration; you can click on + it to invoke the demonstration. Once the demonstration window + appears, you can click the + @@bold + See Code + @@normal + button to see the Tcl/Tk code that created the demonstration. If + you wish, you can edit the code and click the + @@bold + Rerun Demo + @@normal + button in the code window to reinvoke the demonstration with the + modified code. + @@newline + + @@subtitle Labels, buttons, checkbuttons, and radiobuttons + @@demo label Labels (text and bitmaps) + @@demo unicodeout Labels and UNICODE text + @@demo button Buttons + @@demo check Check-buttons (select any of a group) + @@demo radio Radio-buttons (select one of a group) + @@demo puzzle A 15-puzzle game made out of buttons + @@demo icon Iconic buttons that use bitmaps + @@demo image1 Two labels displaying images + @@demo image2 A simple user interface for viewing images + @@demo labelframe Labelled frames + @@new + @@demo ttkbut The simple Themed Tk widgets + + @@subtitle Listboxes and Trees + @@demo states The 50 states + @@demo colors Colors: change the color scheme for the application + @@demo sayings A collection of famous and infamous sayings + @@new + @@demo mclist A multi-column list of countries + @@new + @@demo tree A directory browser tree + + @@subtitle Entries, Spin-boxes and Combo-boxes + @@demo entry1 Entries without scrollbars + @@demo entry2 Entries with scrollbars + @@demo entry3 Validated entries and password fields + @@demo spin Spin-boxes + @@new + @@demo combo Combo-boxes + @@demo form Simple Rolodex-like form + + @@subtitle Text + @@demo text Basic editable text + @@demo style Text display styles + @@demo bind Hypertext (tag bindings) + @@demo twind A text widget with embedded windows and other features + @@demo search A search tool built with a text widget + @@new + @@demo textpeer Peering text widgets + + @@subtitle Canvases + @@demo items The canvas item types + @@demo plot A simple 2-D plot + @@demo ctext Text items in canvases + @@demo arrow An editor for arrowheads on canvas lines + @@demo ruler A ruler with adjustable tab stops + @@demo floor A building floor plan + @@demo cscroll A simple scrollable canvas + @@new + @@demo knightstour A Knight's tour of the chess board + + @@subtitle Scales and Progress Bars + @@demo hscale Horizontal scale + @@demo vscale Vertical scale + @@new + @@demo ttkscale Themed scale linked to a label with traces + @@new + @@demo ttkprogress Progress bar + + @@subtitle Paned Windows and Notebooks + @@demo paned1 Horizontal paned window + @@demo paned2 Vertical paned window + @@new + @@demo ttkpane Themed nested panes + @@new + @@demo ttknote Notebook widget + + @@subtitle Menus and Toolbars + @@demo menu Menus and cascades (sub-menus) + @@demo menubu Menu-buttons + @@new + @@demo ttkmenu Themed menu buttons + @@new + @@demo toolbar Themed toolbar + + @@subtitle Common Dialogs + @@demo msgbox Message boxes + @@demo filebox File selection dialog + @@demo clrpick Color picker + + @@subtitle Animation + @@new + @@demo anilabel Animated labels + @@new + @@demo aniwave Animated wave + @@new + @@demo pendulum Pendulum simulation + @@new + @@demo goldberg A celebration of Rube Goldberg + + @@subtitle Miscellaneous + @@demo bitmap The built-in bitmaps + @@demo dialog1 A dialog box with a local grab + @@demo dialog2 A dialog box with a global grab } + +############################################################################## .t configure -state disabled focus .s +# addSeeDismiss -- +# Add "See Code" and "Dismiss" button frame, with optional "See Vars" +# +# Arguments: +# w - The name of the frame to use. + +proc addSeeDismiss {w show {vars {}} {extra {}}} { + ## See Code / Dismiss buttons + ttk::frame $w + ttk::separator $w.sep + #ttk::frame $w.sep -height 2 -relief sunken + grid $w.sep -columnspan 4 -row 0 -sticky ew -pady 2 + ttk::button $w.dismiss -text [mc "Dismiss"] \ + -image ::img::delete -compound left \ + -command [list destroy [winfo toplevel $w]] + ttk::button $w.code -text [mc "See Code"] \ + -image ::img::view -compound left \ + -command [list showCode $show] + set buttons [list x $w.code $w.dismiss] + if {[llength $vars]} { + ttk::button $w.vars -text [mc "See Variables"] \ + -image ::img::view -compound left \ + -command [concat [list showVars $w.dialog] $vars] + set buttons [linsert $buttons 1 $w.vars] + } + if {$extra ne ""} { + set buttons [linsert $buttons 1 [uplevel 1 $extra]] + } + grid {*}$buttons -padx 4 -pady 4 + grid columnconfigure $w 0 -weight 1 + if {[tk windowingsystem] eq "aqua"} { + foreach b [lrange $buttons 1 end] {$b configure -takefocus 0} + grid configure $w.sep -pady 0 + grid configure {*}$buttons -pady {10 12} + grid configure [lindex $buttons 1] -padx {16 4} + grid configure [lindex $buttons end] -padx {4 18} + } + return $w +} + # positionWindow -- -# This procedure is invoked by most of the demos to position a -# new demo window. +# This procedure is invoked by most of the demos to position a new demo +# window. # # Arguments: # w - The name of the window to position. @@ -238,59 +461,66 @@ proc positionWindow w { } # showVars -- -# Displays the values of one or more variables in a window, and -# updates the display whenever any of the variables changes. +# Displays the values of one or more variables in a window, and updates the +# display whenever any of the variables changes. # # Arguments: # w - Name of new window to create for display. # args - Any number of names of variables. proc showVars {w args} { - global widgetFont catch {destroy $w} toplevel $w - wm title $w "Variable values" - label $w.title -text "Variable values:" -width 20 -anchor center \ - -font $widgetFont(vars) - pack $w.title -side top -fill x - set len 1 - foreach i $args { - if {[string length $i] > $len} { - set len [string length $i] - } + if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog} + wm title $w [mc "Variable values"] + + set b [ttk::frame $w.frame] + grid $b -sticky news + set f [ttk::labelframe $b.title -text [mc "Variable values:"]] + foreach var $args { + ttk::label $f.n$var -text "$var:" -anchor w + ttk::label $f.v$var -textvariable $var -anchor w + grid $f.n$var $f.v$var -padx 2 -pady 2 -sticky w } - foreach i $args { - frame $w.$i - label $w.$i.name -text "$i: " -width [expr $len + 2] -anchor w - label $w.$i.value -textvar $i -anchor w - pack $w.$i.name -side left - pack $w.$i.value -side left -expand 1 -fill x - pack $w.$i -side top -anchor w -fill x + ttk::button $b.ok -text [mc "OK"] \ + -command [list destroy $w] -default active + bind $w <Return> [list $b.ok invoke] + bind $w <Escape> [list $b.ok invoke] + + grid $f -sticky news -padx 4 + grid $b.ok -sticky e -padx 4 -pady {6 4} + if {[tk windowingsystem] eq "aqua"} { + $b.ok configure -takefocus 0 + grid configure $b.ok -pady {10 12} -padx {16 18} + grid configure $f -padx 10 -pady {10 0} } - button $w.ok -text OK -command "destroy $w" -default active - bind $w <Return> "tkButtonInvoke $w.ok" - pack $w.ok -side bottom -pady 2 + grid columnconfig $f 1 -weight 1 + grid rowconfigure $f 100 -weight 1 + grid columnconfig $b 0 -weight 1 + grid rowconfigure $b 0 -weight 1 + grid columnconfig $w 0 -weight 1 + grid rowconfigure $w 0 -weight 1 } # invoke -- -# This procedure is called when the user clicks on a demo description. -# It is responsible for invoking the demonstration. +# This procedure is called when the user clicks on a demo description. It is +# responsible for invoking the demonstration. # # Arguments: # index - The index of the character that the user clicked on. proc invoke index { - global tk_library + global tk_demoDirectory set tags [.t tag names $index] set i [lsearch -glob $tags demo-*] if {$i < 0} { return } set cursor [.t cget -cursor] - .t configure -cursor watch + .t configure -cursor [::ttk::cursor busy] update set demo [string range [lindex $tags $i] 5 end] - uplevel [list source [file join $tk_library demos $demo.tcl]] + uplevel 1 [list source [file join $tk_demoDirectory $demo.tcl]] update .t configure -cursor $cursor @@ -299,97 +529,205 @@ proc invoke index { # showStatus -- # -# Show the name of the demo program in the status bar. This procedure -# is called when the user moves the cursor over a demo description. +# Show the name of the demo program in the status bar. This procedure is +# called when the user moves the cursor over a demo description. # proc showStatus index { - global tk_library set tags [.t tag names $index] set i [lsearch -glob $tags demo-*] set cursor [.t cget -cursor] if {$i < 0} { .statusBar.lab config -text " " - set newcursor xterm + set newcursor [::ttk::cursor text] } else { set demo [string range [lindex $tags $i] 5 end] - .statusBar.lab config -text "Run the \"$demo\" sample program" - set newcursor hand2 + .statusBar.lab config -text [mc "Run the \"%s\" sample program" $demo] + set newcursor [::ttk::cursor link] } - if [string compare $cursor $newcursor] { + if {$cursor ne $newcursor} { .t config -cursor $newcursor } } +# evalShowCode -- +# +# Arguments: +# w - Name of text widget containing code to eval + +proc evalShowCode {w} { + set code [$w get 1.0 end-1c] + uplevel #0 $code +} # showCode -- -# This procedure creates a toplevel window that displays the code for -# a demonstration and allows it to be edited and reinvoked. +# This procedure creates a toplevel window that displays the code for a +# demonstration and allows it to be edited and reinvoked. # # Arguments: -# w - The name of the demonstration's window, which can be -# used to derive the name of the file containing its code. +# w - The name of the demonstration's window, which can be used to +# derive the name of the file containing its code. proc showCode w { - global tk_library + global tk_demoDirectory set file [string range $w 1 end].tcl - if ![winfo exists .code] { - toplevel .code - frame .code.buttons - pack .code.buttons -side bottom -fill x - button .code.buttons.dismiss -text Dismiss \ - -default active -command "destroy .code" - button .code.buttons.rerun -text "Rerun Demo" -command { - eval [.code.text get 1.0 end] + set top .code + if {![winfo exists $top]} { + toplevel $top + if {[tk windowingsystem] eq "x11"} {wm attributes $top -type dialog} + + set t [frame $top.f] + set text [text $t.text -font fixedFont -height 24 -wrap word \ + -xscrollcommand [list $t.xscroll set] \ + -yscrollcommand [list $t.yscroll set] \ + -setgrid 1 -highlightthickness 0 -pady 2 -padx 3] + scrollbar $t.xscroll -command [list $t.text xview] -orient horizontal + scrollbar $t.yscroll -command [list $t.text yview] -orient vertical + + grid $t.text $t.yscroll -sticky news + #grid $t.xscroll + grid rowconfigure $t 0 -weight 1 + grid columnconfig $t 0 -weight 1 + + set btns [ttk::frame $top.btns] + ttk::separator $btns.sep + grid $btns.sep -columnspan 4 -row 0 -sticky ew -pady 2 + ttk::button $btns.dismiss -text [mc "Dismiss"] \ + -default active -command [list destroy $top] \ + -image ::img::delete -compound left + ttk::button $btns.print -text [mc "Print Code"] \ + -command [list printCode $text $file] \ + -image ::img::print -compound left + ttk::button $btns.rerun -text [mc "Rerun Demo"] \ + -command [list evalShowCode $text] \ + -image ::img::refresh -compound left + set buttons [list x $btns.rerun $btns.print $btns.dismiss] + grid {*}$buttons -padx 4 -pady 4 + grid columnconfigure $btns 0 -weight 1 + if {[tk windowingsystem] eq "aqua"} { + foreach b [lrange $buttons 1 end] {$b configure -takefocus 0} + grid configure $btns.sep -pady 0 + grid configure {*}$buttons -pady {10 12} + grid configure [lindex $buttons 1] -padx {16 4} + grid configure [lindex $buttons end] -padx {4 18} } - pack .code.buttons.dismiss .code.buttons.rerun -side left \ - -expand 1 -pady 2 - frame .code.frame - pack .code.frame -expand yes -fill both -padx 1 -pady 1 - text .code.text -height 40 -wrap word\ - -xscrollcommand ".code.xscroll set" \ - -yscrollcommand ".code.yscroll set" \ - -setgrid 1 -highlightthickness 0 -pady 2 -padx 3 - scrollbar .code.xscroll -command ".code.text xview" \ - -highlightthickness 0 -orient horizontal - scrollbar .code.yscroll -command ".code.text yview" \ - -highlightthickness 0 -orient vertical - - grid .code.text -in .code.frame -padx 1 -pady 1 \ - -row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news - grid .code.yscroll -in .code.frame -padx 1 -pady 1 \ - -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news -# grid .code.xscroll -in .code.frame -padx 1 -pady 1 \ -# -row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news - grid rowconfig .code.frame 0 -weight 1 -minsize 0 - grid columnconfig .code.frame 0 -weight 1 -minsize 0 + grid $t -sticky news + grid $btns -sticky ew + grid rowconfigure $top 0 -weight 1 + grid columnconfig $top 0 -weight 1 + + bind $top <Return> { + if {[winfo class %W] ne "Text"} { .code.btns.dismiss invoke } + } + bind $top <Escape> [bind $top <Return>] } else { - wm deiconify .code - raise .code + wm deiconify $top + raise $top } - wm title .code "Demo code: [file join $tk_library demos $file]" - wm iconname .code $file - set id [open [file join $tk_library demos $file]] - .code.text delete 1.0 end - .code.text insert 1.0 [read $id] - .code.text mark set insert 1.0 + wm title $top [mc "Demo code: %s" [file join $tk_demoDirectory $file]] + wm iconname $top $file + set id [open [file join $tk_demoDirectory $file]] + $top.f.text delete 1.0 end + $top.f.text insert 1.0 [read $id] + $top.f.text mark set insert 1.0 close $id } -# tkAboutDialog -- +# printCode -- +# Prints the source code currently displayed in the See Code dialog. Much +# thanks to Arjen Markus for this. # -# Pops up a message box with an "about" message -# -proc tkAboutDialog {} { - tk_messageBox -icon info -type ok -title "About Widget Demo" -message \ -"Tk widget demonstration +# Arguments: +# w - Name of text widget containing code to print +# file - Name of the original file (implicitly for title) + +proc printCode {w file} { + set code [$w get 1.0 end-1c] + + set dir "." + if {[info exists ::env(HOME)]} { + set dir "$::env(HOME)" + } + if {[info exists ::env(TMP)]} { + set dir $::env(TMP) + } + if {[info exists ::env(TEMP)]} { + set dir $::env(TEMP) + } -Copyright (c) 1996-1997 Sun Microsystems, Inc. + set filename [file join $dir "tkdemo-$file"] + set outfile [open $filename "w"] + puts $outfile $code + close $outfile + + switch -- $::tcl_platform(platform) { + unix { + if {[catch {exec lp -c $filename} msg]} { + tk_messageBox -title "Print spooling failure" \ + -message "Print spooling probably failed: $msg" + } + } + windows { + if {[catch {PrintTextWin32 $filename} msg]} { + tk_messageBox -title "Print spooling failure" \ + -message "Print spooling probably failed: $msg" + } + } + default { + tk_messageBox -title "Operation not Implemented" \ + -message "Wow! Unknown platform: $::tcl_platform(platform)" + } + } -Copyright (c) 1997-2000 Ajuba Solutions, Inc. + # + # Be careful to throw away the temporary file in a gentle manner ... + # + if {[file exists $filename]} { + catch {file delete $filename} + } +} -Copyright (c) 2001-2002 Donal K. Fellows +# PrintTextWin32 -- +# Print a file under Windows using all the "intelligence" necessary +# +# Arguments: +# filename - Name of the file +# +# Note: +# Taken from the Wiki page by Keith Vetter, "Printing text files under +# Windows". +# Note: +# Do not execute the command in the background: that way we can dispose of the +# file smoothly. +# +proc PrintTextWin32 {filename} { + package require registry + set app [auto_execok notepad.exe] + set pcmd "$app /p %1" + catch { + set app [registry get {HKEY_CLASSES_ROOT\.txt} {}] + set pcmd [registry get \ + {HKEY_CLASSES_ROOT\\$app\\shell\\print\\command} {}] + } + + regsub -all {%1} $pcmd $filename pcmd + puts $pcmd -Copyright (c) 2002-2007 Daniel A. Steffen" + regsub -all {\\} $pcmd {\\\\} pcmd + set command "[auto_execok start] /min $pcmd" + eval exec $command +} + +# tkAboutDialog -- +# +# Pops up a message box with an "about" message +# +proc tkAboutDialog {} { + tk_messageBox -icon info -type ok -title [mc "About Widget Demo"] \ + -message [mc "Tk widget demonstration application"] -detail \ +"[mc {Copyright (c) %s} {1996-1997 Sun Microsystems, Inc.}] +[mc {Copyright (c) %s} {1997-2000 Ajuba Solutions, Inc.}] +[mc {Copyright (c) %s} {2001-2007 Donal K. Fellows}] +[mc {Copyright (c) %s} {2002-2007 Daniel A. Steffen}]" } # Local Variables: diff --git a/library/dialog.tcl b/library/dialog.tcl index 1ec578e..26ec7e0 100644 --- a/library/dialog.tcl +++ b/library/dialog.tcl @@ -37,7 +37,6 @@ proc ::tk_dialog {w title text bitmap default args} { return -code error "default button index greater than number of\ buttons specified for tk_dialog" } - # Never call if -strict option is omitted in previous test ! } elseif {"" eq $default} { set default -1 } else { @@ -45,7 +44,7 @@ proc ::tk_dialog {w title text bitmap default args} { } set windowingsystem [tk windowingsystem] - if {$tcl_platform(platform) eq "macintosh" || $windowingsystem eq "aqua"} { + if {$windowingsystem eq "aqua"} { option add *Dialog*background systemDialogBackgroundActive widgetDefault option add *Dialog*Button.highlightBackground \ systemDialogBackgroundActive widgetDefault @@ -71,7 +70,7 @@ proc ::tk_dialog {w title text bitmap default args} { wm transient $w [winfo toplevel [winfo parent $w]] } - if {$tcl_platform(platform) eq "macintosh" || $windowingsystem eq "aqua"} { + if {$windowingsystem eq "aqua"} { ::tk::unsupported::MacWindowStyle style $w moveableModal {} } elseif {$windowingsystem eq "x11"} { wm attributes $w -type dialog @@ -85,23 +84,19 @@ proc ::tk_dialog {w title text bitmap default args} { } pack $w.bot -side bottom -fill both pack $w.top -side top -fill both -expand 1 + grid anchor $w.bot center # 2. Fill the top part with bitmap and message (use the option # database for -wraplength and -font so that they can be # overridden by the caller). option add *Dialog.msg.wrapLength 3i widgetDefault - if {$tcl_platform(platform) eq "macintosh" || $windowingsystem eq "aqua"} { - option add *Dialog.msg.font system widgetDefault - } else { - option add *Dialog.msg.font {Times 12} widgetDefault - } + option add *Dialog.msg.font TkCaptionFont widgetDefault label $w.msg -justify left -text $text pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m if {$bitmap ne ""} { - if {($tcl_platform(platform) eq "macintosh" - || $windowingsystem eq "aqua") && ($bitmap eq "error")} { + if {$windowingsystem eq "aqua" && $bitmap eq "error"} { set bitmap "stop" } label $w.bitmap -bitmap $bitmap @@ -122,7 +117,7 @@ proc ::tk_dialog {w title text bitmap default args} { -padx 10 -pady 4 grid columnconfigure $w.bot $i # We boost the size of some Mac buttons for l&f - if {$tcl_platform(platform) eq "macintosh" || $windowingsystem eq "aqua"} { + if {$windowingsystem eq "aqua"} { set tmp [string tolower $but] if {$tmp eq "ok" || $tmp eq "cancel"} { grid columnconfigure $w.bot $i -minsize 90 @@ -134,15 +129,14 @@ proc ::tk_dialog {w title text bitmap default args} { # 4. Create a binding for <Return> on the dialog if there is a # default button. + # Convention also dictates that if the keyboard focus moves among the + # the buttons that the <Return> binding affects the button with the focus. if {$default >= 0} { - bind $w <Return> " - [list $w.button$default] configure -state active -relief sunken - update idletasks - after 100 - set ::tk::Priv(button) $default - " + bind $w <Return> [list $w.button$default invoke] } + bind $w <<PrevWindow>> [list bind $w <Return> {[tk_focusPrev %W] invoke}] + bind $w <Tab> [list bind $w <Return> {[tk_focusNext %W] invoke}] # 5. Create a <Destroy> binding for the window that sets the # button variable to -1; this is needed in case something happens @@ -159,17 +153,12 @@ proc ::tk_dialog {w title text bitmap default args} { # 7. Set a grab and claim the focus too. - set oldFocus [focus] - set oldGrab [grab current $w] - if {$oldGrab ne ""} { - set grabStatus [grab status $oldGrab] - } - grab $w if {$default >= 0} { - focus $w.button$default + set focus $w.button$default } else { - focus $w + set focus $w } + tk::SetFocusGrab $w $focus # 8. Wait for the user to respond, then restore the focus and # return the index of the selected button. Restore the focus @@ -178,21 +167,14 @@ proc ::tk_dialog {w title text bitmap default args} { # restore any grab that was in effect. vwait ::tk::Priv(button) - catch {focus $oldFocus} + catch { # It's possible that the window has already been destroyed, # hence this "catch". Delete the Destroy handler so that # Priv(button) doesn't get reset by it. bind $w <Destroy> {} - destroy $w - } - if {$oldGrab ne ""} { - if {$grabStatus ne "global"} { - grab $oldGrab - } else { - grab -global $oldGrab - } } + tk::RestoreFocusGrab $w $focus return $Priv(button) } diff --git a/library/entry.tcl b/library/entry.tcl index 93812b7..382cc88 100644 --- a/library/entry.tcl +++ b/library/entry.tcl @@ -68,6 +68,11 @@ bind Entry <<PasteSelection>> { } } +bind Entry <<TraverseIn>> { + %W selection range 0 end + %W icursor end +} + # Standard Motif bindings: bind Entry <1> { @@ -203,8 +208,8 @@ bind Entry <Escape> {# nothing} bind Entry <Return> {# nothing} bind Entry <KP_Enter> {# nothing} bind Entry <Tab> {# nothing} -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { - bind Entry <Command-KeyPress> {# nothing} +if {[tk windowingsystem] eq "aqua"} { + bind Entry <Command-KeyPress> {# nothing} } # On Windows, paste is done using Shift-Insert. Shift-Insert already @@ -331,7 +336,9 @@ proc ::tk::EntryButton1 {w x} { set Priv(pressX) $x $w icursor [EntryClosestGap $w $x] $w selection from insert - if {"disabled" ne [$w cget -state]} {focus $w} + if {"disabled" ne [$w cget -state]} { + focus $w + } } # ::tk::EntryMouseSelect -- @@ -402,7 +409,9 @@ proc ::tk::EntryMouseSelect {w x} { proc ::tk::EntryPaste {w x} { $w icursor [EntryClosestGap $w $x] catch {$w insert insert [::tk::GetSelection $w PRIMARY]} - if {"disabled" ne [$w cget -state]} {focus $w} + if {"disabled" ne [$w cget -state]} { + focus $w + } } # ::tk::EntryAutoScan -- @@ -418,7 +427,9 @@ proc ::tk::EntryPaste {w x} { proc ::tk::EntryAutoScan {w} { variable ::tk::Priv set x $Priv(x) - if {![winfo exists $w]} return + if {![winfo exists $w]} { + return + } if {$x >= [winfo width $w]} { $w xview scroll 2 units EntryMouseSelect $w $x @@ -486,7 +497,9 @@ proc ::tk::EntryBackspace w { $w delete sel.first sel.last } else { set x [expr {[$w index insert] - 1}] - if {$x >= 0} {$w delete $x} + if {$x >= 0} { + $w delete $x + } if {[$w index @0] >= [$w index insert]} { set range [$w xview] set left [lindex $range 0] diff --git a/library/focus.tcl b/library/focus.tcl index 9be0e9a..640406e 100644 --- a/library/focus.tcl +++ b/library/focus.tcl @@ -36,7 +36,7 @@ proc ::tk_focusNext w { incr i if {$i < [llength $children]} { set cur [lindex $children $i] - if {[winfo toplevel $cur] eq $cur} { + if {[winfo toplevel $cur] eq $cur} { continue } else { break @@ -163,8 +163,7 @@ proc ::tk::FocusOK w { proc ::tk_focusFollowsMouse {} { set old [bind all <Enter>] set script { - if {"%d" eq "NotifyAncestor" \ - || "%d" eq "NotifyNonlinear" \ + if {"%d" eq "NotifyAncestor" || "%d" eq "NotifyNonlinear" \ || "%d" eq "NotifyInferior"} { if {[tk::FocusOK %W]} { focus %W diff --git a/library/listbox.tcl b/library/listbox.tcl index 9fd86e4..f3434a5 100644 --- a/library/listbox.tcl +++ b/library/listbox.tcl @@ -33,7 +33,7 @@ bind Listbox <1> { if {[winfo exists %W]} { - tk::ListboxBeginSelect %W [%W index @%x,%y] + tk::ListboxBeginSelect %W [%W index @%x,%y] 1 } } @@ -176,7 +176,8 @@ bind Listbox <B2-Motion> { # The MouseWheel will typically only fire on Windows and Mac OS X. # However, someone could use the "event generate" command to produce # one on other platforms. -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { + +if {[tk windowingsystem] eq "aqua"} { bind Listbox <MouseWheel> { %W yview scroll [expr {- (%D)}] units } @@ -224,7 +225,7 @@ if {"x11" eq [tk windowingsystem]} { # el - The element for the selection operation (typically the # one under the pointer). Must be in numerical form. -proc ::tk::ListboxBeginSelect {w el} { +proc ::tk::ListboxBeginSelect {w el {focus 1}} { variable ::tk::Priv if {[$w cget -selectmode] eq "multiple"} { if {[$w selection includes $el]} { @@ -240,6 +241,10 @@ proc ::tk::ListboxBeginSelect {w el} { set Priv(listboxPrev) $el } event generate $w <<ListboxSelect>> + # check existence as ListboxSelect may destroy us + if {$focus && [winfo exists $w] && [$w cget -state] eq "normal"} { + focus $w + } } # ::tk::ListboxMotion -- @@ -477,7 +482,7 @@ proc ::tk::ListboxCancel w { } set first [$w index anchor] set last $Priv(listboxPrev) - if { $last eq "" } { + if {$last eq ""} { # Not actually doing any selection right now return } diff --git a/library/menu.tcl b/library/menu.tcl index 4ce0d8c..cc57532 100644 --- a/library/menu.tcl +++ b/library/menu.tcl @@ -259,8 +259,10 @@ proc ::tk::MbPost {w {x {}} {y {}}} { if {$cur ne ""} { MenuUnpost {} } - set Priv(cursor) [$w cget -cursor] - $w configure -cursor arrow + if {$::tk_strictMotif} { + set Priv(cursor) [$w cget -cursor] + $w configure -cursor arrow + } if {[tk windowingsystem] ne "aqua"} { set Priv(relief) [$w cget -relief] $w configure -relief raised @@ -402,12 +404,19 @@ proc ::tk::MenuUnpost menu { # Unpost menu(s) and restore some stuff that's dependent on # what was posted. + after cancel [array get Priv menuActivatedTimer] + unset -nocomplain Priv(menuActivated) + after cancel [array get Priv menuDeactivatedTimer] + unset -nocomplain Priv(menuDeactivated) + catch { if {$mb ne ""} { set menu [$mb cget -menu] $menu unpost set Priv(postedMb) {} - $mb configure -cursor $Priv(cursor) + if {$::tk_strictMotif} { + $mb configure -cursor $Priv(cursor) + } if {[tk windowingsystem] ne "aqua"} { $mb configure -relief $Priv(relief) } else { @@ -453,7 +462,9 @@ proc ::tk::MenuUnpost menu { } RestoreOldGrab if {$Priv(menuBar) ne ""} { - $Priv(menuBar) configure -cursor $Priv(cursor) + if {$::tk_strictMotif} { + $Priv(menuBar) configure -cursor $Priv(cursor) + } set Priv(menuBar) {} } if {[tk windowingsystem] ne "x11"} { @@ -537,6 +548,7 @@ proc ::tk::MbButtonUp w { proc ::tk::MenuMotion {menu x y state} { variable ::tk::Priv if {$menu eq $Priv(window)} { + set activeindex [$menu index active] if {[$menu cget -type] eq "menubar"} { if {[info exists Priv(focus)] && $menu ne $Priv(focus)} { $menu activate @$x,$y @@ -546,9 +558,22 @@ proc ::tk::MenuMotion {menu x y state} { $menu activate @$x,$y GenerateMenuSelect $menu } - } - if {($state & 0x1f00) != 0} { - $menu postcascade active + set index [$menu index @$x,$y] + if {[info exists Priv(menuActivated)] \ + && $index ne "none" \ + && $index ne $activeindex} { + set mode [option get $menu clickToFocus ClickToFocus] + if {[string is false $mode]} { + set delay [expr {[$menu cget -type] eq "menubar" ? 0 : 50}] + if {[$menu type $index] eq "cascade"} { + set Priv(menuActivatedTimer) \ + [after $delay [list $menu postcascade active]] + } else { + set Priv(menuDeactivatedTimer) \ + [after $delay [list $menu postcascade none]] + } + } + } } } @@ -586,8 +611,13 @@ proc ::tk::MenuButtonDown menu { if {$Priv(menuBar) eq {}} { set Priv(menuBar) $menu - set Priv(cursor) [$menu cget -cursor] - $menu configure -cursor arrow + if {$::tk_strictMotif} { + set Priv(cursor) [$menu cget -cursor] + $menu configure -cursor arrow + } + if {[$menu type active] eq "cascade"} { + set Priv(menuActivated) 1 + } } # Don't update grab information if the grab window isn't changing. @@ -1307,6 +1337,7 @@ proc ::tk_popup {menu x y {entry {}}} { tk::SaveGrabInfo $menu grab -global $menu set Priv(popup) $menu + set Priv(menuActivated) 1 tk_menuSetFocus $menu } } diff --git a/library/msgbox.tcl b/library/msgbox.tcl index e5a363d..572510a 100644 --- a/library/msgbox.tcl +++ b/library/msgbox.tcl @@ -143,6 +143,7 @@ proc ::tk::MessageBox {args} { # set specs { {-default "" "" ""} + {-detail "" "" ""} {-icon "" "" "info"} {-message "" "" ""} {-parent "" "" .} @@ -156,7 +157,7 @@ proc ::tk::MessageBox {args} { error "bad -icon value \"$data(-icon)\": must be error, info, question, or warning" } set windowingsystem [tk windowingsystem] - if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { + if {$windowingsystem eq "aqua"} { switch -- $data(-icon) { "error" {set data(-icon) "stop"} "warning" {set data(-icon) "caution"} @@ -241,16 +242,17 @@ proc ::tk::MessageBox {args} { set w .__tk__messagebox } + # There is only one background colour for the whole dialog + set bg [ttk::style lookup . -background] + # 3. Create the top-level window and divide it into top # and bottom parts. catch {destroy $w} - toplevel $w -class Dialog + toplevel $w -class Dialog -bg $bg wm title $w $data(-title) wm iconname $w Dialog wm protocol $w WM_DELETE_WINDOW [list $w.$cancel invoke] - # There is only one background colour for the whole dialog - set bg [$w cget -background] # Message boxes should be transient with respect to their parent so that # they always stay on top of the parent window. But some window managers @@ -263,38 +265,42 @@ proc ::tk::MessageBox {args} { wm transient $w $data(-parent) } - if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { + if {$windowingsystem eq "aqua"} { ::tk::unsupported::MacWindowStyle style $w moveableModal {} } elseif {$windowingsystem eq "x11"} { wm attributes $w -type dialog } - frame $w.bot -background $bg + ttk::frame $w.bot;# -background $bg + grid anchor $w.bot center pack $w.bot -side bottom -fill both - frame $w.top -background $bg + ttk::frame $w.top;# -background $bg pack $w.top -side top -fill both -expand 1 - if {$windowingsystem ne "classic" && $windowingsystem ne "aqua"} { - $w.bot configure -relief raised -bd 1 - $w.top configure -relief raised -bd 1 + if {$windowingsystem ne "aqua"} { + #$w.bot configure -relief raised -bd 1 + #$w.top configure -relief raised -bd 1 } - # 4. Fill the top part with bitmap and message (use the option - # database for -wraplength and -font so that they can be + # 4. Fill the top part with bitmap, message and detail (use the + # option database for -wraplength and -font so that they can be # overridden by the caller). option add *Dialog.msg.wrapLength 3i widgetDefault - if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { - option add *Dialog.msg.font system widgetDefault - } else { - option add *Dialog.msg.font {Times 14} widgetDefault + option add *Dialog.dtl.wrapLength 3i widgetDefault + option add *Dialog.msg.font TkCaptionFont widgetDefault + option add *Dialog.dtl.font TkDefaultFont widgetDefault + + ttk::label $w.msg -anchor nw -justify left -text $data(-message) + #-background $bg + if {$data(-detail) ne ""} { + ttk::label $w.dtl -anchor nw -justify left -text $data(-detail) + #-background $bg } - - label $w.msg -anchor nw -justify left -text $data(-message) \ - -background $bg if {$data(-icon) ne ""} { - if {($windowingsystem eq "classic" || $windowingsystem eq "aqua") + if {$windowingsystem eq "aqua" || ([winfo depth $w] < 4) || $tk_strictMotif} { - label $w.bitmap -bitmap $data(-icon) -background $bg + # ttk::label has no -bitmap option + label $w.bitmap -bitmap $data(-icon);# -background $bg } else { canvas $w.bitmap -width 32 -height 32 -highlightthickness 0 \ -background $bg @@ -333,7 +339,12 @@ proc ::tk::MessageBox {args} { } grid $w.bitmap $w.msg -in $w.top -sticky news -padx 2m -pady 2m grid columnconfigure $w.top 1 -weight 1 - grid rowconfigure $w.top 0 -weight 1 + if {$data(-detail) ne ""} { + grid ^ $w.dtl -in $w.top -sticky news -padx 2m -pady {0 2m} + grid rowconfigure $w.top 1 -weight 1 + } else { + grid rowconfigure $w.top 0 -weight 1 + } # 5. Create a row of buttons at the bottom of the dialog. @@ -347,8 +358,9 @@ proc ::tk::MessageBox {args} { set opts [list -text $capName] } - eval [list tk::AmpWidget button $w.$name -padx 3m] $opts \ + eval [list tk::AmpWidget ttk::button $w.$name] $opts \ [list -command [list set tk::Priv(button) $name]] + # -padx 3m if {$name eq $data(-default)} { $w.$name configure -default active @@ -358,7 +370,7 @@ proc ::tk::MessageBox {args} { grid $w.$name -in $w.bot -row 0 -column $i -padx 3m -pady 2m -sticky ew grid columnconfigure $w.bot $i -uniform buttons # We boost the size of some Mac buttons for l&f - if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { + if {$windowingsystem eq "aqua"} { set tmp [string tolower $name] if {$tmp eq "ok" || $tmp eq "cancel" || $tmp eq "yes" || $tmp eq "no" || $tmp eq "abort" || $tmp eq "retry" || @@ -382,28 +394,31 @@ proc ::tk::MessageBox {args} { if {$data(-default) ne ""} { bind $w <FocusIn> { - if {"Button" eq [winfo class %W]} { + if {[winfo class %W] in "Button TButton"} { %W configure -default active } } bind $w <FocusOut> { - if {"Button" eq [winfo class %W]} { + if {[winfo class %W] in "Button TButton"} { %W configure -default normal } } } - # 6. Create bindings for <Return> and <Escape> on the dialog + # 6. Create bindings for <Return>, <Escape> and <Destroy> on the dialog bind $w <Return> { - if {"Button" eq [winfo class %W]} { - tk::ButtonInvoke %W + if {[winfo class %W] in "Button TButton"} { + %W invoke } } # Invoke the designated cancelling operation bind $w <Escape> [list $w.$cancel invoke] + # At <Destroy> the buttons have vanished, so must do this directly. + bind $w.msg <Destroy> [list set tk::Priv(button) $cancel] + # 7. Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the # display (Motif style) and de-iconify it. @@ -426,8 +441,11 @@ proc ::tk::MessageBox {args} { # restore any grab that was in effect. vwait ::tk::Priv(button) + # Copy the result now so any <Destroy> that happens won't cause + # trouble + set result $Priv(button) ::tk::RestoreFocusGrab $w $focus - return $Priv(button) + return $result } diff --git a/library/msgs/cs.msg b/library/msgs/cs.msg index e4014a3..cd86ca9 100644 --- a/library/msgs/cs.msg +++ b/library/msgs/cs.msg @@ -1,61 +1,75 @@ namespace eval ::tk { ::msgcat::mcset cs "&Abort" "&P\u0159eru\u0161it" + ::msgcat::mcset cs "&About..." "&O programu..." + ::msgcat::mcset cs "&Blue" "&Modr\341" + ::msgcat::mcset cs "&Cancel" "&Zru\u0161it" + ::msgcat::mcset cs "&Clear Console" "&Smazat konzolu" + ::msgcat::mcset cs "&Copy" "&Kop\355rovat" + ::msgcat::mcset cs "&Delete" "&Smazat" + ::msgcat::mcset cs "&Directory:" "&Adres\341\u0159:" + ::msgcat::mcset cs "&Edit" "&\332pravy" + ::msgcat::mcset cs "&File" "&Soubor" + ::msgcat::mcset cs "&Filter" "&Filtr" + ::msgcat::mcset cs "&Green" "Ze&len\341" + ::msgcat::mcset cs "&Help" "&N\341pov\u011bda" + ::msgcat::mcset cs "&Hide Console" "&Schovat Konzolu" + ::msgcat::mcset cs "&Ignore" "&Ignorovat" + ::msgcat::mcset cs "&No" "&Ne" + ::msgcat::mcset cs "&OK" + ::msgcat::mcset cs "&Open" "&Otev\u0159\355t" + ::msgcat::mcset cs "&Quit" "&Ukon\u010dit" + ::msgcat::mcset cs "&Red" "\u010ce&rven\341" + ::msgcat::mcset cs "&Retry" "Z&novu" + ::msgcat::mcset cs "&Save" "&Ulo\u017eit" + ::msgcat::mcset cs "&Selection:" "&V\375b\u011br:" + ::msgcat::mcset cs "&Source..." "&Zdroj..." + ::msgcat::mcset cs "&Yes" "&Ano" ::msgcat::mcset cs "About..." "O programu..." ::msgcat::mcset cs "All Files" "V\u0161echny soubory" ::msgcat::mcset cs "Application Error" "Chyba programu" - ::msgcat::mcset cs "&Blue" "&Modr\341" - ::msgcat::mcset cs "&Cancel" "&Zru\u0161it" ::msgcat::mcset cs "Cannot change to the directory \"%1\$s\".\nPermission denied." "Nemohu zm\u011bnit atku\341ln\355 adres\341\u0159 na \"%1\$s\".\nP\u0159\355stup odm\355tnut." ::msgcat::mcset cs "Choose Directory" "V\375b\u011br adres\341\u0159e" + ::msgcat::mcset cs "Cl&ear" "Sma&zat" ::msgcat::mcset cs "Clear" "Smazat" ::msgcat::mcset cs "Color" "Barva" ::msgcat::mcset cs "Console" "Konzole" ::msgcat::mcset cs "Copy" "Kop\355rovat" + ::msgcat::mcset cs "Cu&t" "V&y\u0159\355znout" ::msgcat::mcset cs "Cut" "Vy\u0159\355znout" ::msgcat::mcset cs "Delete" "Smazat" ::msgcat::mcset cs "Details >>" "Detaily >>" ::msgcat::mcset cs "Directory \"%1\$s\" does not exist." "Adres\341\u0159 \"%1\$s\" neexistuje." - ::msgcat::mcset cs "&Directory:" "&Adres\341\u0159:" + ::msgcat::mcset cs "E&xit" "&Konec" ::msgcat::mcset cs "Error: %1\$s" "Chyba: %1\$s" ::msgcat::mcset cs "Exit" "Konec" + ::msgcat::mcset cs "Fi&les:" "Sou&bory:" + ::msgcat::mcset cs "Fil&ter:" "Fil&tr:" ::msgcat::mcset cs "File \"%1\$s\" already exists.\n\n" "Soubor \"%1\$s\" ji\u017e existuje.\n\n" ::msgcat::mcset cs "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Soubor \"%1\$s\" ji\u017e existuje.\nChcete jej p\u0159epsat?" ::msgcat::mcset cs "File \"%1\$s\" does not exist." "Soubor \"%1\$s\" neexistuje." ::msgcat::mcset cs "File &name:" "&Jm\351no souboru:" ::msgcat::mcset cs "File &names:" "&Jm\351na soubor\u016f:" ::msgcat::mcset cs "Files of &type:" "&Typy soubor\u016f:" - ::msgcat::mcset cs "Fi&les:" "Sou&bory:" - ::msgcat::mcset cs "&Filter" "&Filtr" - ::msgcat::mcset cs "Fil&ter:" "Fil&tr:" - ::msgcat::mcset cs "&Green" "Ze&len\341" - ::msgcat::mcset cs "Hi" + ::msgcat::mcset cs "Hi" "Ahoj" ::msgcat::mcset cs "Hide Console" "Skr\375t konsolu" - ::msgcat::mcset cs "&Ignore" "&Ignorovat" ::msgcat::mcset cs "Invalid file name \"%1\$s\"." "\u0160patn\351 jm\351no souboru \"%1\$s\"." ::msgcat::mcset cs "Log Files" "Log soubory" - ::msgcat::mcset cs "&No" "&Ne" - ::msgcat::mcset cs "&OK" ::msgcat::mcset cs "Ok" ::msgcat::mcset cs "Open" "Otev\u0159\355t" - ::msgcat::mcset cs "&Open" "&Otev\u0159\355t" ::msgcat::mcset cs "Open Multiple Files" "Otev\u0159\355t v\355ce soubor\u016f" + ::msgcat::mcset cs "P&aste" "&Vlo\u017eit" ::msgcat::mcset cs "Paste" "Vlo\u017eit" ::msgcat::mcset cs "Quit" "Skon\u010dit" - ::msgcat::mcset cs "&Red" " \u010ce&rven\341" ::msgcat::mcset cs "Replace existing file?" "Nahradit st\341vaj\355c\355 soubor?" - ::msgcat::mcset cs "&Retry" "Z&novu" - ::msgcat::mcset cs "&Save" "&Ulo\u017eit" ::msgcat::mcset cs "Save As" "Ulo\u017eit jako" ::msgcat::mcset cs "Save To Log" "Ulo\u017eit do logu" ::msgcat::mcset cs "Select Log File" "Vybrat log soubor" ::msgcat::mcset cs "Select a file to source" "Vybrat soubor k nahr\341n\355" - ::msgcat::mcset cs "&Selection:" "&V\375b\u011br:" ::msgcat::mcset cs "Skip Messages" "P\u0159esko\u010dit zpr\341vy" ::msgcat::mcset cs "Source..." "Nahr\341t..." ::msgcat::mcset cs "Tcl Scripts" "Tcl skripty" ::msgcat::mcset cs "Tcl for Windows" "Tcl pro Windows" ::msgcat::mcset cs "Text Files" "Textov\351 soubory" - ::msgcat::mcset cs "&Yes" "&Ano" ::msgcat::mcset cs "abort" "p\u0159eru\u0161it" ::msgcat::mcset cs "blue" "modr\341" ::msgcat::mcset cs "cancel" "zru\u0161it" diff --git a/library/msgs/da.msg b/library/msgs/da.msg new file mode 100644 index 0000000..c749608 --- /dev/null +++ b/library/msgs/da.msg @@ -0,0 +1,77 @@ +namespace eval ::tk { + ::msgcat::mcset da "&Abort" "&Afbryd" + ::msgcat::mcset da "&About..." "&Om..." + ::msgcat::mcset da "All Files" "Alle filer" + ::msgcat::mcset da "Application Error" "Programfejl" + ::msgcat::mcset da "&Blue" "&Bl\u00E5" + ::msgcat::mcset da "&Cancel" "&Annuller" + ::msgcat::mcset da "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kan ikke skifte til katalog \"%1\$s\".\nIngen rettigheder." + ::msgcat::mcset da "Choose Directory" "V\u00E6lg katalog" + ::msgcat::mcset da "&Clear" "&Ryd" + ::msgcat::mcset da "&Clear Console" "&Ryd konsolen" + ::msgcat::mcset da "Color" "Farve" + ::msgcat::mcset da "Console" "Konsol" + ::msgcat::mcset da "&Copy" "&Kopier" + ::msgcat::mcset da "Cu&t" "Kli&p" + ::msgcat::mcset da "&Delete" "&Slet" + ::msgcat::mcset da "Details >>" "Detailer" + ::msgcat::mcset da "Directory \"%1\$s\" does not exist." "Katalog \"%1\$s\" findes ikke." + ::msgcat::mcset da "&Directory:" "&Katalog:" + ::msgcat::mcset da "&Edit" "&Rediger" + ::msgcat::mcset da "Error: %1\$s" "Fejl: %1\$s" + ::msgcat::mcset da "E&xit" "&Afslut" + ::msgcat::mcset da "&File" "&Fil" + ::msgcat::mcset da "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Filen \"%1\$s\" findes allerede.\nSkal den overskrives?" + ::msgcat::mcset da "File \"%1\$s\" already exists.\n\n" "Filen \"%1\$s\" findes allerede.\n\n" + ::msgcat::mcset da "File \"%1\$s\" does not exist." "Filen \"%1\$s\" findes ikke." + ::msgcat::mcset da "File &name:" "Fil&navn:" + ::msgcat::mcset da "File &names:" "Fil&navne:" + ::msgcat::mcset da "Files of &type:" "Fil&typer:" + ::msgcat::mcset da "Fi&les:" "Fi&ler:" + ::msgcat::mcset da "&Filter" + ::msgcat::mcset da "Fil&ter:" + ::msgcat::mcset da "&Green" "&Gr\u00F8n" + ::msgcat::mcset da "&Help" "&Hj\u00E6lp" + ::msgcat::mcset da "Hi" "Hej" + ::msgcat::mcset da "&Hide Console" "Skjul &konsol" + ::msgcat::mcset da "&Ignore" "&Ignorer" + ::msgcat::mcset da "Invalid file name \"%1\$s\"." "Ugyldig fil navn \"%1\$s\"." + ::msgcat::mcset da "Log Files" "Logfiler" + ::msgcat::mcset da "&No" "&Nej" + ::msgcat::mcset da "OK" "O.K." + ::msgcat::mcset da "&OK" "&O.K." + ::msgcat::mcset da "Ok" + ::msgcat::mcset da "Open" "\u00C5bn" + ::msgcat::mcset da "&Open" "&\u00C5bn" + ::msgcat::mcset da "Open Multiple Files" "\u00C5bn flere filer" + ::msgcat::mcset da "P&aste" "&Inds\u00E6t" + ::msgcat::mcset da "&Quit" "&Afslut" + ::msgcat::mcset da "&Red" "&R\u00F8d" + ::msgcat::mcset da "Replace existing file?" "Erstat eksisterende fil?" + ::msgcat::mcset da "&Retry" "&Gentag" + ::msgcat::mcset da "&Save" "&Gem" + ::msgcat::mcset da "Save As" "Gem som" + ::msgcat::mcset da "Save To Log" "Gem i log" + ::msgcat::mcset da "Select Log File" "V\u00E6lg logfil" + ::msgcat::mcset da "Select a file to source" "V\u00E6lg k\u00F8rbar fil" + ::msgcat::mcset da "&Selection:" "&Udvalg:" + ::msgcat::mcset da "Show &Hidden Directories" "Vis &skjulte kataloger" + ::msgcat::mcset da "Show &Hidden Files and Directories" "Vis &skjulte filer og kataloger" + ::msgcat::mcset da "Skip Messages" "Overspring beskeder" + ::msgcat::mcset da "&Source..." "&K\u00F8r..." + ::msgcat::mcset da "Tcl Scripts" "Tcl-Skripter" + ::msgcat::mcset da "Tcl for Windows" "Tcl for Windows" + ::msgcat::mcset da "Text Files" "Tekstfiler" + ::msgcat::mcset da "&Yes" "&Ja" + ::msgcat::mcset da "abort" "afbryd" + ::msgcat::mcset da "blue" "bl\u00E5" + ::msgcat::mcset da "cancel" "afbryd" + ::msgcat::mcset da "extension" + ::msgcat::mcset da "extensions" + ::msgcat::mcset da "green" "gr\u00F8n" + ::msgcat::mcset da "ignore" "ignorer" + ::msgcat::mcset da "ok" + ::msgcat::mcset da "red" "r\u00F8d" + ::msgcat::mcset da "retry" "gentag" + ::msgcat::mcset da "yes" "ja" +} diff --git a/library/msgs/de.msg b/library/msgs/de.msg index c5ae689..7750313 100644 --- a/library/msgs/de.msg +++ b/library/msgs/de.msg @@ -1,23 +1,26 @@ namespace eval ::tk { ::msgcat::mcset de "&Abort" "&Abbruch" - ::msgcat::mcset de "About..." "\u00dcber..." + ::msgcat::mcset de "&About..." "&\u00dcber..." ::msgcat::mcset de "All Files" "Alle Dateien" ::msgcat::mcset de "Application Error" "Applikationsfehler" ::msgcat::mcset de "&Blue" "&Blau" ::msgcat::mcset de "&Cancel" "&Abbruch" ::msgcat::mcset de "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kann nicht in das Verzeichnis \"%1\$s\" wechseln.\nKeine Rechte vorhanden." ::msgcat::mcset de "Choose Directory" "W\u00e4hle Verzeichnis" - ::msgcat::mcset de "Clear" "R\u00fccksetzen" + ::msgcat::mcset de "Cl&ear" "&R\u00fccksetzen" + ::msgcat::mcset de "&Clear Console" "&Konsole l\u00f6schen" ::msgcat::mcset de "Color" "Farbe" ::msgcat::mcset de "Console" "Konsole" - ::msgcat::mcset de "Copy" "Kopieren" - ::msgcat::mcset de "Cut" "Ausschneiden" - ::msgcat::mcset de "Delete" "L\u00f6schen" + ::msgcat::mcset de "&Copy" "&Kopieren" + ::msgcat::mcset de "Cu&t" "Aus&schneiden" + ::msgcat::mcset de "&Delete" "&L\u00f6schen" ::msgcat::mcset de "Details >>" ::msgcat::mcset de "Directory \"%1\$s\" does not exist." "Das Verzeichnis \"%1\$s\" existiert nicht." ::msgcat::mcset de "&Directory:" "&Verzeichnis:" + ::msgcat::mcset de "&Edit" "&Bearbeiten" ::msgcat::mcset de "Error: %1\$s" "Fehler: %1\$s" - ::msgcat::mcset de "Exit" "Ende" + ::msgcat::mcset de "E&xit" "&Ende" + ::msgcat::mcset de "&File" "&Datei" ::msgcat::mcset de "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Die Datei \"%1\$s\" ist bereits vorhanden.\nWollen sie diese Datei \u00fcberschreiben ?" ::msgcat::mcset de "File \"%1\$s\" already exists.\n\n" "Die Datei \"%1\$s\" ist bereits vorhanden.\n\n" ::msgcat::mcset de "File \"%1\$s\" does not exist." "Die Datei \"%1\$s\" existiert nicht." @@ -28,19 +31,20 @@ namespace eval ::tk { ::msgcat::mcset de "&Filter" ::msgcat::mcset de "Fil&ter:" ::msgcat::mcset de "&Green" "&Gr\u00fcn" + ::msgcat::mcset de "&Help" "&Hilfe" ::msgcat::mcset de "Hi" "Hallo" - ::msgcat::mcset de "Hide Console" "Konsole unsichtbar machen" + ::msgcat::mcset de "&Hide Console" "&Konsole unsichtbar machen" ::msgcat::mcset de "&Ignore" "&Ignorieren" ::msgcat::mcset de "Invalid file name \"%1\$s\"." "Ung\u00fcltiger Dateiname \"%1\$s\"." ::msgcat::mcset de "Log Files" "Protokolldatei" ::msgcat::mcset de "&No" "&Nein" - ::msgcat::mcset de "OK" + ::msgcat::mcset de "&OK" ::msgcat::mcset de "Ok" ::msgcat::mcset de "Open" "\u00d6ffnen" ::msgcat::mcset de "&Open" "\u00d6&ffnen" - ::msgcat::mcset de "Open Multiple Files" - ::msgcat::mcset de "Paste" "Einf\u00fcgen" - ::msgcat::mcset de "Quit" "Beenden" + ::msgcat::mcset de "Open Multiple Files" "Mehrere Dateien \u00F6ffnen" + ::msgcat::mcset de "P&aste" "E&inf\u00fcgen" + ::msgcat::mcset de "&Quit" "&Beenden" ::msgcat::mcset de "&Red" "&Rot" ::msgcat::mcset de "Replace existing file?" "Existierende Datei ersetzen?" ::msgcat::mcset de "&Retry" "&Wiederholen" @@ -50,8 +54,10 @@ namespace eval ::tk { ::msgcat::mcset de "Select Log File" "Protokolldatei ausw\u00e4hlen" ::msgcat::mcset de "Select a file to source" "Auszuf\u00fchrende Datei ausw\u00e4hlen" ::msgcat::mcset de "&Selection:" "Auswah&l:" + ::msgcat::mcset de "Show &Hidden Directories" "Zeige versteckte Dateien" + ::msgcat::mcset de "Show &Hidden Files and Directories" "Zeige versteckte Dateien und Verzeichnisse" ::msgcat::mcset de "Skip Messages" "Weitere Nachrichten \u00fcberspringen" - ::msgcat::mcset de "Source..." "Ausf\u00fchren..." + ::msgcat::mcset de "&Source..." "&Ausf\u00fchren..." ::msgcat::mcset de "Tcl Scripts" "Tcl-Skripte" ::msgcat::mcset de "Tcl for Windows" "Tcl f\u00fcr Windows" ::msgcat::mcset de "Text Files" "Textdateien" diff --git a/library/msgs/el.msg b/library/msgs/el.msg index 2e96cd9..1dcc451 100644 --- a/library/msgs/el.msg +++ b/library/msgs/el.msg @@ -65,7 +65,7 @@ namespace eval ::tk { ::msgcat::mcset el "Select a file to source" \ "\u0395\u03c0\u03b9\u03bb\u03ad\u03be\u03c4\u03b5 \u03b1\u03c1\u03c7\u03b5\u03af\u03bf \u03b3\u03b9\u03b1 \u03b5\u03ba\u03c4\u03ad\u03bb\u03b5\u03c3\u03b7" ::msgcat::mcset el "&Selection:" "\u0395\u03c0\u03b9\u03bb\u03bf\u03b3\u03ae:" - ::msgcat::mcset el "Skip Messages" "\u0391\u03c0\u03bf\u03c6\u03c5\u03b3\u03ae \u03bc\u03c5\u03bd\u03b7\u03bc\u03ac\u03c4\u03c9\u03bd" + ::msgcat::mcset el "Skip Messages" "\u0391\u03c0\u03bf\u03c6\u03c5\u03b3\u03ae\u03bc\u03b7\u03bd\u03c5\u03bc\u03ac\u03c4\u03c9\u03bd" ::msgcat::mcset el "Source..." "\u0395\u03ba\u03c4\u03ad\u03bb\u03b5\u03c3\u03b7..." ::msgcat::mcset el "Tcl Scripts" "Tcl Scripts" ::msgcat::mcset el "Tcl for Windows" "Tcl \u03b3\u03b9\u03b1 Windows" diff --git a/library/msgs/en.msg b/library/msgs/en.msg index 7242f91..b4e51bf 100644 --- a/library/msgs/en.msg +++ b/library/msgs/en.msg @@ -1,23 +1,26 @@ namespace eval ::tk { ::msgcat::mcset en "&Abort" - ::msgcat::mcset en "About..." + ::msgcat::mcset en "&About..." ::msgcat::mcset en "All Files" ::msgcat::mcset en "Application Error" ::msgcat::mcset en "&Blue" ::msgcat::mcset en "&Cancel" ::msgcat::mcset en "Cannot change to the directory \"%1\$s\".\nPermission denied." ::msgcat::mcset en "Choose Directory" - ::msgcat::mcset en "Clear" + ::msgcat::mcset en "Cl&ear" + ::msgcat::mcset en "&Clear Console" ::msgcat::mcset en "Color" ::msgcat::mcset en "Console" - ::msgcat::mcset en "Copy" - ::msgcat::mcset en "Cut" - ::msgcat::mcset en "Delete" + ::msgcat::mcset en "&Copy" + ::msgcat::mcset en "Cu&t" + ::msgcat::mcset en "&Delete" ::msgcat::mcset en "Details >>" ::msgcat::mcset en "Directory \"%1\$s\" does not exist." ::msgcat::mcset en "&Directory:" + ::msgcat::mcset en "&Edit" ::msgcat::mcset en "Error: %1\$s" - ::msgcat::mcset en "Exit" + ::msgcat::mcset en "E&xit" + ::msgcat::mcset en "&File" ::msgcat::mcset en "File \"%1\$s\" already exists.\nDo you want to overwrite it?" ::msgcat::mcset en "File \"%1\$s\" already exists.\n\n" ::msgcat::mcset en "File \"%1\$s\" does not exist." @@ -28,8 +31,9 @@ namespace eval ::tk { ::msgcat::mcset en "&Filter" ::msgcat::mcset en "Fil&ter:" ::msgcat::mcset en "&Green" + ::msgcat::mcset en "&Help" ::msgcat::mcset en "Hi" - ::msgcat::mcset en "Hide Console" + ::msgcat::mcset en "&Hide Console" ::msgcat::mcset en "&Ignore" ::msgcat::mcset en "Invalid file name \"%1\$s\"." ::msgcat::mcset en "Log Files" @@ -39,8 +43,8 @@ namespace eval ::tk { ::msgcat::mcset en "Open" ::msgcat::mcset en "&Open" ::msgcat::mcset en "Open Multiple Files" - ::msgcat::mcset en "Paste" - ::msgcat::mcset en "Quit" + ::msgcat::mcset en "P&aste" + ::msgcat::mcset en "&Quit" ::msgcat::mcset en "&Red" ::msgcat::mcset en "Replace existing file?" ::msgcat::mcset en "&Retry" @@ -50,8 +54,10 @@ namespace eval ::tk { ::msgcat::mcset en "Select Log File" ::msgcat::mcset en "Select a file to source" ::msgcat::mcset en "&Selection:" + ::msgcat::mcset en "Show &Hidden Directories" + ::msgcat::mcset en "Show &Hidden Files and Directories" ::msgcat::mcset en "Skip Messages" - ::msgcat::mcset en "Source..." + ::msgcat::mcset en "&Source..." ::msgcat::mcset en "Tcl Scripts" ::msgcat::mcset en "Tcl for Windows" ::msgcat::mcset en "Text Files" diff --git a/library/msgs/es.msg b/library/msgs/es.msg index 29e5cc6..ceb12d6 100644 --- a/library/msgs/es.msg +++ b/library/msgs/es.msg @@ -1,24 +1,27 @@ namespace eval ::tk { ::msgcat::mcset es "&Abort" "&Abortar" - ::msgcat::mcset es "About..." "Acerca de ..." - ::msgcat::mcset es "All Files" "Todos los archivos" + ::msgcat::mcset es "&About..." "&Acerca de ..." + ::msgcat::mcset es "All Files" "Todos los archivos" ::msgcat::mcset es "Application Error" "Error de la aplicaci\u00f3n" ::msgcat::mcset es "&Blue" "&Azul" ::msgcat::mcset es "&Cancel" "&Cancelar" ::msgcat::mcset es "Cannot change to the directory \"%1\$s\".\nPermission denied." "No es posible acceder al directorio \"%1\$s\".\nPermiso denegado." ::msgcat::mcset es "Choose Directory" "Elegir directorio" - ::msgcat::mcset es "Clear" "Borrar" + ::msgcat::mcset es "Cl&ear" "&Borrar" + ::msgcat::mcset es "&Clear Console" "&Borrar consola" ::msgcat::mcset es "Color" "Color" ::msgcat::mcset es "Console" "Consola" - ::msgcat::mcset es "Copy" "Copiar" - ::msgcat::mcset es "Cut" "Cortar" - ::msgcat::mcset es "Delete" "Borrar" + ::msgcat::mcset es "&Copy" "&Copiar" + ::msgcat::mcset es "Cu&t" "Cor&tar" + ::msgcat::mcset es "&Delete" "&Borrar" ::msgcat::mcset es "Details >>" "Detalles >>" ::msgcat::mcset es "Directory \"%1\$s\" does not exist." "El directorio \"%1\$s\" no existe." ::msgcat::mcset es "&Directory:" "&Directorio:" + ::msgcat::mcset es "&Edit" "&Editar" ::msgcat::mcset es "Error: %1\$s" "Error: %1\$s" - ::msgcat::mcset es "Exit" "Salir" - ::msgcat::mcset es "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "El archivo \"%1\$s\" ya existe.\nDesea sobreescribirlo?" + ::msgcat::mcset es "E&xit" "Salir" + ::msgcat::mcset es "&File" "&Archivo" + ::msgcat::mcset es "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "El archivo \"%1\$s\" ya existe.\n\u00bfDesea sobreescribirlo?" ::msgcat::mcset es "File \"%1\$s\" already exists.\n\n" "El archivo \"%1\$s\" ya existe.\n\n" ::msgcat::mcset es "File \"%1\$s\" does not exist." "El archivo \"%1\$s\" no existe." ::msgcat::mcset es "File &name:" "&Nombre de archivo:" @@ -28,30 +31,31 @@ namespace eval ::tk { ::msgcat::mcset es "&Filter" "&Filtro" ::msgcat::mcset es "Fil&ter:" "Fil&tro:" ::msgcat::mcset es "&Green" "&Verde" - ::msgcat::mcset es "Hi" "Hola" - ::msgcat::mcset es "Hide Console" "Esconder la consola" + ::msgcat::mcset es "&Help" "&Ayuda" + ::msgcat::mcset es "Hi" "Hola" + ::msgcat::mcset es "&Hide Console" "&Esconder la consola" ::msgcat::mcset es "&Ignore" "&Ignorar" ::msgcat::mcset es "Invalid file name \"%1\$s\"." "Nombre de archivo inv\u00e1lido \"%1\$s\"." - ::msgcat::mcset es "Log Files" "Ficheros de traza" + ::msgcat::mcset es "Log Files" "Ficheros de traza" ::msgcat::mcset es "&No" "&No" ::msgcat::mcset es "&OK" "&OK" ::msgcat::mcset es "Ok" "Ok" ::msgcat::mcset es "Open" "Abrir" ::msgcat::mcset es "&Open" "&Abrir" ::msgcat::mcset es "Open Multiple Files" "Abrir m\u00faltiples archivos" - ::msgcat::mcset es "Paste" "Pegar" - ::msgcat::mcset es "Quit" "Abandonar" + ::msgcat::mcset es "P&aste" "Peg&ar" + ::msgcat::mcset es "&Quit" "&Abandonar" ::msgcat::mcset es "&Red" "&Rojo" - ::msgcat::mcset es "Replace existing file?" "Reemplazar el archivo existente?" + ::msgcat::mcset es "Replace existing file?" "\u00bfReemplazar el archivo existente?" ::msgcat::mcset es "&Retry" "&Reintentar" ::msgcat::mcset es "&Save" "&Guardar" ::msgcat::mcset es "Save As" "Guardar como" ::msgcat::mcset es "Save To Log" "Guardar al archivo de traza" - ::msgcat::mcset es "Select Log File" "Elegir un archivo de traza" + ::msgcat::mcset es "Select Log File" "Elegir un archivo de traza" ::msgcat::mcset es "Select a file to source" "Seleccionar un archivo a evaluar" ::msgcat::mcset es "&Selection:" "&Selecci\u00f3n:" ::msgcat::mcset es "Skip Messages" "Omitir los mensajes" - ::msgcat::mcset es "Source..." "Evaluar..." + ::msgcat::mcset es "&Source..." "E&valuar..." ::msgcat::mcset es "Tcl Scripts" "Scripts Tcl" ::msgcat::mcset es "Tcl for Windows" "Tcl para Windows" ::msgcat::mcset es "Text Files" "Archivos de texto" @@ -59,7 +63,7 @@ namespace eval ::tk { ::msgcat::mcset es "abort" "abortar" ::msgcat::mcset es "blue" "azul" ::msgcat::mcset es "cancel" "cancelar" - ::msgcat::mcset es "extension" "extensi\u00f3n" + ::msgcat::mcset es "extension" "extensi\u00f3n" ::msgcat::mcset es "extensions" "extensiones" ::msgcat::mcset es "green" "verde" ::msgcat::mcset es "ignore" "ignorar" diff --git a/library/msgs/hu.msg b/library/msgs/hu.msg index 636c2cd..fc4700f 100644 --- a/library/msgs/hu.msg +++ b/library/msgs/hu.msg @@ -9,16 +9,19 @@ namespace eval ::tk { ::msgcat::mcset hu "Cannot change to the directory \"%1\$s\".\nPermission denied." "A k\u00f6nyvt\u00e1rv\u00e1lt\u00e1s nem siker\u00fclt: \"%1\$s\".\nHozz\u00e1f\u00e9r\u00e9s megtagadva." ::msgcat::mcset hu "Choose Directory" "K\u00f6nyvt\u00e1r kiv\u00e1laszt\u00e1sa" ::msgcat::mcset hu "Clear" "T\u00f6rl\u00e9s" + ::msgcat::mcset hu "&Clear Console" "&T\u00f6rl\u00e9s Konzol" ::msgcat::mcset hu "Color" "Sz\u00edn" ::msgcat::mcset hu "Console" "Konzol" - ::msgcat::mcset hu "Copy" "M\u00e1sol\u00e1s" - ::msgcat::mcset hu "Cut" "Kiv\u00e1g\u00e1s" - ::msgcat::mcset hu "Delete" "T\u00f6rl\u00e9s" + ::msgcat::mcset hu "&Copy" "&M\u00e1sol\u00e1s" + ::msgcat::mcset hu "Cu&t" "&Kiv\u00e1g\u00e1s" + ::msgcat::mcset hu "&Delete" "&T\u00f6rl\u00e9s" ::msgcat::mcset hu "Details >>" "R\u00e9szletek >>" ::msgcat::mcset hu "Directory \"%1\$s\" does not exist." "\"%1\$s\" k\u00f6nyvt\u00e1r nem l\u00e9tezik." ::msgcat::mcset hu "&Directory:" "&K\u00f6nyvt\u00e1r:" + #::msgcat::mcset hu "&Edit" ::msgcat::mcset hu "Error: %1\$s" "Hiba: %1\$s" - ::msgcat::mcset hu "Exit" "Kil\u00e9p\u00e9s" + ::msgcat::mcset hu "E&xit" "Kil\u00e9p\u00e9s" + ::msgcat::mcset hu "&File" "&F\u00e1jl" ::msgcat::mcset hu "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "\"%1\$s\" f\u00e1jl m\u00e1r l\u00e9tezik.\nFel\u00fcl\u00edrjam?" ::msgcat::mcset hu "File \"%1\$s\" already exists.\n\n" "\"%1\$s\" f\u00e1jl m\u00e1r l\u00e9tezik.\n\n" ::msgcat::mcset hu "File \"%1\$s\" does not exist." "\"%1\$s\" f\u00e1jl nem l\u00e9tezik." @@ -29,20 +32,20 @@ namespace eval ::tk { ::msgcat::mcset hu "&Filter" "&Sz\u0171r\u0151" ::msgcat::mcset hu "Fil&ter:" "S&z\u0171r\u0151:" ::msgcat::mcset hu "&Green" "&Z\u00f6ld" + #::msgcat::mcset hu "&Help" ::msgcat::mcset hu "Hi" "\u00dcdv" - ::msgcat::mcset hu "Hide Console" "Konzol elrejt\u00e9se" + ::msgcat::mcset hu "&Hide Console" "Konzol &elrejt\u00e9se" ::msgcat::mcset hu "&Ignore" "K&ihagy\u00e1s" ::msgcat::mcset hu "Invalid file name \"%1\$s\"." "\u00c9rv\u00e9nytelen f\u00e1jln\u00e9v: \"%1\$s\"." ::msgcat::mcset hu "Log Files" "Log f\u00e1jlok" ::msgcat::mcset hu "&No" "&Nem" ::msgcat::mcset hu "&OK" ::msgcat::mcset hu "OK" - ::msgcat::mcset hu "Ok" ::msgcat::mcset hu "Open" "Megnyit\u00e1s" ::msgcat::mcset hu "&Open" "&Megnyit\u00e1s" ::msgcat::mcset hu "Open Multiple Files" "T\u00f6bb f\u00e1jl megnyit\u00e1sa" - ::msgcat::mcset hu "Paste" "Beilleszt\u00e9s" - ::msgcat::mcset hu "Quit" "Kil\u00e9p\u00e9s" + ::msgcat::mcset hu "P&aste" "&Beilleszt\u00e9s" + ::msgcat::mcset hu "&Quit" "&Kil\u00e9p\u00e9s" ::msgcat::mcset hu "&Red" "&V\u00f6r\u00f6s" ::msgcat::mcset hu "Replace existing file?" "Megl\u00e9v\u0151 f\u00e1jl cser\u00e9je?" ::msgcat::mcset hu "&Retry" "\u00daj&ra" @@ -55,7 +58,7 @@ namespace eval ::tk { ::msgcat::mcset hu "Show &Hidden Directories" "&Rejtett k\u00f6nyvt\u00e1rak megjelen\u00edt\u00e9se" ::msgcat::mcset hu "Show &Hidden Files and Directories" "&Rejtett f\u00e1jlok \u00e9s k\u00f6nyvt\u00e1rak megjelen\u00edt\u00e9se" ::msgcat::mcset hu "Skip Messages" "\u00dczenetek kihagy\u00e1sa" - ::msgcat::mcset hu "Source..." "Forr\u00e1s..." + ::msgcat::mcset hu "&Source..." "&Forr\u00e1s..." ::msgcat::mcset hu "Tcl Scripts" "Tcl scriptek" ::msgcat::mcset hu "Tcl for Windows" "Tcl Windows-hoz" ::msgcat::mcset hu "Text Files" "Sz\u00f6vegf\u00e1jlok" diff --git a/library/msgs/pl.msg b/library/msgs/pl.msg index 02e6ffc..debebcb 100644 --- a/library/msgs/pl.msg +++ b/library/msgs/pl.msg @@ -1,66 +1,66 @@ namespace eval ::tk { - ::msgcat::mcset pl "&Abort" "&Anuluj" - ::msgcat::mcset pl "&About..." "O Programie..." + ::msgcat::mcset pl "&Abort" "&Przerwij" + ::msgcat::mcset pl "&About..." "O programie..." ::msgcat::mcset pl "All Files" "Wszystkie pliki" - ::msgcat::mcset pl "Application Error" "Bl\u0105d w Programie" + ::msgcat::mcset pl "Application Error" "B\u0142\u0105d w programie" ::msgcat::mcset pl "&Blue" "&Niebieski" ::msgcat::mcset pl "&Cancel" "&Anuluj" - ::msgcat::mcset pl "Cannot change to the directory \"%1\$s\".\nPermission denied." "Katalog \"%1\$s\" nie mo\u017ce zosta\u0107 odczytany lub nie istnieje." + ::msgcat::mcset pl "Cannot change to the directory \"%1\$s\".\nPermission denied." "Nie mo\u017cna otworzy\u0107 katalogu \"%1\$s\".\nOdmowa dost\u0119pu." ::msgcat::mcset pl "Choose Directory" "Wybierz katalog" - ::msgcat::mcset pl "&Clear" "&Wyczy\u015b\u0107" + ::msgcat::mcset pl "Cl&ear" "&Wyczy\u015b\u0107" ::msgcat::mcset pl "&Clear Console" "&Wyczy\u015b\u0107 konsol\u0119" ::msgcat::mcset pl "Color" "Kolor" ::msgcat::mcset pl "Console" "Konsola" ::msgcat::mcset pl "&Copy" "&Kopiuj" ::msgcat::mcset pl "Cu&t" "&Wytnij" ::msgcat::mcset pl "&Delete" "&Usu\u0144" - ::msgcat::mcset pl "Details >>" "Detale >>" - ::msgcat::mcset pl "Directory \"%1\$s\" does not exist." "Katalog \"%1\$s\" nie istniej." + ::msgcat::mcset pl "Details >>" "Szczeg\u00f3\u0142y >>" + ::msgcat::mcset pl "Directory \"%1\$s\" does not exist." "Katalog \"%1\$s\" nie istnieje." ::msgcat::mcset pl "&Directory:" "&Katalog:" ::msgcat::mcset pl "&Edit" "&Edytuj" ::msgcat::mcset pl "Error: %1\$s" "B\u0142\u0105d: %1\$s" - ::msgcat::mcset pl "E&xit" "&Zako\u0144cz" + ::msgcat::mcset pl "E&xit" "&Wyjd\u017a" ::msgcat::mcset pl "&File" "&Plik" - ::msgcat::mcset pl "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Plik \"%1\$s\" ju\u017c istnieje.\nCzy chcesz go zast\u0105pi\u0107?" - ::msgcat::mcset pl "File \"%1\$s\" already exists.\n\n" "Plik \"%1\$s\" ju\u017c istnieje. \n\n" + ::msgcat::mcset pl "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Plik \"%1\$s\" ju\u017c istnieje.\nCzy chcesz go nadpisa\u0107?" + ::msgcat::mcset pl "File \"%1\$s\" already exists.\n\n" "Plik \"%1\$s\" ju\u017c istnieje.\n\n" ::msgcat::mcset pl "File \"%1\$s\" does not exist." "Plik \"%1\$s\" nie istnieje." ::msgcat::mcset pl "File &name:" "Nazwa &pliku:" ::msgcat::mcset pl "File &names:" "Nazwy &plik\u00f3w:" ::msgcat::mcset pl "Files of &type:" "Pliki &typu:" ::msgcat::mcset pl "Fi&les:" "Pli&ki:" - ::msgcat::mcset pl "&Filter" "&Filter" - ::msgcat::mcset pl "Fil&ter:" "&Filter:" + ::msgcat::mcset pl "&Filter" "&Filtr" + ::msgcat::mcset pl "Fil&ter:" "&Filtr:" ::msgcat::mcset pl "&Green" "&Zielony" ::msgcat::mcset pl "&Help" "&Pomoc" ::msgcat::mcset pl "Hi" "Witaj" - ::msgcat::mcset pl "&Hide Console" "&Schowaj konsol\u0119" + ::msgcat::mcset pl "&Hide Console" "&Ukryj konsol\u0119" ::msgcat::mcset pl "&Ignore" "&Ignoruj" ::msgcat::mcset pl "Invalid file name \"%1\$s\"." "Niew\u0142a\u015bciwa nazwa pliku \"%1\$s\"." - ::msgcat::mcset pl "Log Files" "Protoko\u0142uj" + ::msgcat::mcset pl "Log Files" "Pliki dziennika" ::msgcat::mcset pl "&No" "&Nie" - ::msgcat::mcset pl "OK" - ::msgcat::mcset pl "Ok" - ::msgcat::mcset pl "Open" "Wczytaj" - ::msgcat::mcset pl "&Open" "&Wczytaj" - ::msgcat::mcset pl "Open Multiple Files" "Wczytuj wiele plik\u00f3w" + ::msgcat::mcset pl "OK" "OK" + ::msgcat::mcset pl "Ok" "Ok" + ::msgcat::mcset pl "Open" "Otw\u00f3rz" + ::msgcat::mcset pl "&Open" "&Otw\u00f3rz" + ::msgcat::mcset pl "Open Multiple Files" "Otw\u00f3rz wiele plik\u00f3w" ::msgcat::mcset pl "P&aste" "&Wklej" ::msgcat::mcset pl "&Quit" "&Zako\u0144cz" - ::msgcat::mcset pl "&Red" "&Czerwonz" - ::msgcat::mcset pl "Replace existing file?" "Czy zost\u0105pi\u0107 instniej\u0105cy plik?" - ::msgcat::mcset pl "&Retry" "&Powt\u00f3rz" + ::msgcat::mcset pl "&Red" "&Czerwony" + ::msgcat::mcset pl "Replace existing file?" "Czy zast\u0105pi\u0107 istniej\u0105cy plik?" + ::msgcat::mcset pl "&Retry" "&Pon\u00f3w" ::msgcat::mcset pl "&Save" "&Zapisz" ::msgcat::mcset pl "Save As" "Zapisz jako" - ::msgcat::mcset pl "Save To Log" "Wpisz do protoko\u0142u" - ::msgcat::mcset pl "Select Log File" "Wybierz plik proko\u0142u" + ::msgcat::mcset pl "Save To Log" "Wpisz do dziennika" + ::msgcat::mcset pl "Select Log File" "Wybierz plik dziennika" ::msgcat::mcset pl "Select a file to source" "Wybierz plik do wykonania" ::msgcat::mcset pl "&Selection:" "&Wyb\u00f3r:" - ::msgcat::mcset pl "Skip Messages" "Omi\u0144 pozosta\u0142e komunikaty" + ::msgcat::mcset pl "Skip Messages" "Pomi\u0144 pozosta\u0142e komunikaty" ::msgcat::mcset pl "&Source..." "&Kod \u017ar\u00f3d\u0142owy..." - ::msgcat::mcset pl "Tcl Scripts" "Tcl-skrypty" - ::msgcat::mcset pl "Tcl for Windows" "Tcl dla Okienek (Windows)" - ::msgcat::mcset pl "Text Files" "Pliki Tekstowe" + ::msgcat::mcset pl "Tcl Scripts" "Skrypty Tcl" + ::msgcat::mcset pl "Tcl for Windows" "Tcl dla Windows" + ::msgcat::mcset pl "Text Files" "Pliki tekstowe" ::msgcat::mcset pl "&Yes" "&Tak" - ::msgcat::mcset pl "abort" "zako\u0144cz" + ::msgcat::mcset pl "abort" "przerwij" ::msgcat::mcset pl "blue" "niebieski" ::msgcat::mcset pl "cancel" "anuluj" ::msgcat::mcset pl "extension" "rozszerzenie" @@ -68,6 +68,6 @@ namespace eval ::tk { ::msgcat::mcset pl "green" "zielony" ::msgcat::mcset pl "ignore" "ignoruj" ::msgcat::mcset pl "red" "czerwony" - ::msgcat::mcset pl "retry" "potw\u00f3rz" + ::msgcat::mcset pl "retry" "pon\u00f3w" ::msgcat::mcset pl "yes" "tak" } diff --git a/library/msgs/sv.msg b/library/msgs/sv.msg new file mode 100644 index 0000000..14ce14d --- /dev/null +++ b/library/msgs/sv.msg @@ -0,0 +1,74 @@ +namespace eval ::tk { + ::msgcat::mcset sv "&Abort" "&Avsluta" + ::msgcat::mcset sv "&About..." "&Om..." + ::msgcat::mcset sv "All Files" "Samtliga filer" + ::msgcat::mcset sv "Application Error" "Programfel" + ::msgcat::mcset sv "&Blue" "&Bl\u00e5" + ::msgcat::mcset sv "&Cancel" "&Avbryt" + ::msgcat::mcset sv "Cannot change to the directory \"%1\$s\".\nPermission denied." "Kan ej n\u00e5 mappen \"%1\$s\".\nSaknar r\u00e4ttigheter." + ::msgcat::mcset sv "Choose Directory" "V\u00e4lj mapp" + ::msgcat::mcset sv "&Clear" "&Radera" + ::msgcat::mcset sv "&Clear Console" "&Radera konsollen" + ::msgcat::mcset sv "Color" "F\u00e4rg" + ::msgcat::mcset sv "Console" "Konsoll" + ::msgcat::mcset sv "&Copy" "&Kopiera" + ::msgcat::mcset sv "Cu&t" "Klipp u&t" + ::msgcat::mcset sv "&Delete" "&Radera" + ::msgcat::mcset sv "Details >>" "Detaljer >>" + ::msgcat::mcset sv "Directory \"%1\$s\" does not exist." "Mappen \"%1\$s\" finns ej." + ::msgcat::mcset sv "&Directory:" "&Mapp:" + ::msgcat::mcset sv "&Edit" "R&edigera" + ::msgcat::mcset sv "Error: %1\$s" "Fel: %1\$s" + ::msgcat::mcset sv "E&xit" "&Avsluta" + ::msgcat::mcset sv "&File" "&Fil" + ::msgcat::mcset sv "File \"%1\$s\" already exists.\nDo you want to overwrite it?" "Filen \"%1\$s\" finns redan.\nVill du skriva \u00f6ver den?" + ::msgcat::mcset sv "File \"%1\$s\" already exists.\n\n" "Filen \"%1\$s\" finns redan.\n\n" + ::msgcat::mcset sv "File \"%1\$s\" does not exist." "Filen \"%1\$s\" finns ej." + ::msgcat::mcset sv "File &name:" "Fil&namn:" + ::msgcat::mcset sv "File &names:" "Fil&namn:" + ::msgcat::mcset sv "Files of &type:" "Filer av &typ:" + ::msgcat::mcset sv "Fi&les:" "Fi&ler:" + ::msgcat::mcset sv "&Filter" + ::msgcat::mcset sv "Fil&ter:" + ::msgcat::mcset sv "&Green" "&Gr\u00f6n" + ::msgcat::mcset sv "&Help" "&Hj\u00e4lp" + ::msgcat::mcset sv "Hi" "Hej" + ::msgcat::mcset sv "&Hide Console" "&G\u00f6m konsollen" + ::msgcat::mcset sv "&Ignore" "&Ignorera" + ::msgcat::mcset sv "Invalid file name \"%1\$s\"." "Ogiltigt filnamn \"%1\$s\"." + ::msgcat::mcset sv "Log Files" "Loggfiler" + ::msgcat::mcset sv "&No" "&Nej" + ::msgcat::mcset sv "OK" + ::msgcat::mcset sv "Ok" + ::msgcat::mcset sv "Open" "\u00d6ppna" + ::msgcat::mcset sv "&Open" "&\u00d6ppna" + ::msgcat::mcset sv "Open Multiple Files" "\u00d6ppna flera filer" + ::msgcat::mcset sv "P&aste" "&Klistra in" + ::msgcat::mcset sv "&Quit" "&Avsluta" + ::msgcat::mcset sv "&Red" "&R\u00f6d" + ::msgcat::mcset sv "Replace existing file?" "Ers\u00e4tt existerande fil?" + ::msgcat::mcset sv "&Retry" "&F\u00f6rs\u00f6k igen" + ::msgcat::mcset sv "&Save" "&Spara" + ::msgcat::mcset sv "Save As" "Spara som" + ::msgcat::mcset sv "Save To Log" "Spara till logg" + ::msgcat::mcset sv "Select Log File" "V\u00e4lj loggfil" + ::msgcat::mcset sv "Select a file to source" "V\u00e4lj k\u00e4llfil" + ::msgcat::mcset sv "&Selection:" "&Val:" + ::msgcat::mcset sv "Skip Messages" "Hoppa \u00f6ver meddelanden" + ::msgcat::mcset sv "&Source..." "&K\u00e4lla..." + ::msgcat::mcset sv "Tcl Scripts" "Tcl skript" + ::msgcat::mcset sv "Tcl for Windows" "Tcl f\u00f6r Windows" + ::msgcat::mcset sv "Text Files" "Textfiler" + ::msgcat::mcset sv "&Yes" "&Ja" + ::msgcat::mcset sv "abort" "avbryt" + ::msgcat::mcset sv "blue" "bl\u00e5" + ::msgcat::mcset sv "cancel" "avbryt" + ::msgcat::mcset sv "extension" "utvidgning" + ::msgcat::mcset sv "extensions" "utvidgningar" + ::msgcat::mcset sv "green" "gr\u00f6n" + ::msgcat::mcset sv "ignore" "ignorera" + ::msgcat::mcset sv "ok" + ::msgcat::mcset sv "red" "r\u00f6d" + ::msgcat::mcset sv "retry" "f\u00f6rs\u00f6k igen" + ::msgcat::mcset sv "yes" "ja" +} diff --git a/library/obsolete.tcl b/library/obsolete.tcl index 9a60c78..3ee7f28 100644 --- a/library/obsolete.tcl +++ b/library/obsolete.tcl @@ -17,3 +17,162 @@ proc tk_menuBar args {} proc tk_bindForTraversal args {} + +# ::tk::classic::restore -- +# +# Restore the pre-8.5 (Tk classic) look as the widget defaults for classic +# Tk widgets. +# +# The value following an 'option add' call is the new 8.5 value. +# +namespace eval ::tk::classic { + # This may need to be adjusted for some window managers that are + # more aggressive with their own Xdefaults (like KDE and CDE) + variable prio "widgetDefault" +} + +proc ::tk::classic::restore {args} { + # Restore classic (8.4) look to classic Tk widgets + variable prio + + if {[llength $args]} { + foreach what $args { + ::tk::classic::restore_$what + } + } else { + foreach cmd [info procs restore_*] { + $cmd + } + } +} + +proc ::tk::classic::restore_font {args} { + # Many widgets were adjusted from hard-coded defaults to using the + # TIP#145 fonts defined in fonts.tcl (eg TkDefaultFont, TkFixedFont, ...) + # For restoring compatibility, we only correct size and weighting changes, + # as the fonts themselves remained mostly the same. + if {[tk windowingsystem] eq "x11"} { + font configure TkDefaultFont -weight bold ; # normal + font configure TkFixedFont -size -12 ; # -10 + } + # Add these with prio 21 to override value in dialog/msgbox.tcl + if {[tk windowingsystem] eq "aqua"} { + option add *Dialog.msg.font system 21; # TkCaptionFont + option add *Dialog.dtl.font system 21; # TkCaptionFont + option add *ErrorDialog*Label.font system 21; # TkCaptionFont + } else { + option add *Dialog.msg.font {Times 12} 21; # TkCaptionFont + option add *Dialog.dtl.font {Times 10} 21; # TkCaptionFont + option add *ErrorDialog*Label.font {Times -18} 21; # TkCaptionFont + } +} + +proc ::tk::classic::restore_button {args} { + variable prio + if {[tk windowingsystem] eq "x11"} { + foreach cls {Button Radiobutton Checkbutton} { + option add *$cls.borderWidth 2 $prio; # 1 + } + } +} + +proc ::tk::classic::restore_entry {args} { + variable prio + # Entry and Spinbox share core defaults + foreach cls {Entry Spinbox} { + if {[tk windowingsystem] ne "aqua"} { + option add *$cls.borderWidth 2 $prio; # 1 + } + if {[tk windowingsystem] eq "x11"} { + option add *$cls.background "#d9d9d9" $prio; # "white" + option add *$cls.selectBorderWidth 1 $prio; # 0 + } + } +} + +proc ::tk::classic::restore_listbox {args} { + variable prio + if {[tk windowingsystem] ne "win32"} { + option add *Listbox.background "#d9d9d9" $prio; # "white" + option add *Listbox.activeStyle "underline" $prio; # "dotbox" + } + if {[tk windowingsystem] ne "aqua"} { + option add *Listbox.borderWidth 2 $prio; # 1 + } + if {[tk windowingsystem] eq "x11"} { + option add *Listbox.selectBorderWidth 1 $prio; # 0 + } + # Remove focus into Listbox added for 8.5 + bind Listbox <1> { + if {[winfo exists %W]} { + tk::ListboxBeginSelect %W [%W index @%x,%y] + } + } +} + +proc ::tk::classic::restore_menu {args} { + variable prio + if {[tk windowingsystem] eq "x11"} { + option add *Menu.activeBorderWidth 2 $prio; # 1 + option add *Menu.borderWidth 2 $prio; # 1 + option add *Menu.clickToFocus true $prio + option add *Menu.useMotifHelp true $prio + } + if {[tk windowingsystem] ne "aqua"} { + option add *Menu.font "TkDefaultFont" $prio; # "TkMenuFont" + } +} + +proc ::tk::classic::restore_menubutton {args} { + variable prio + option add *Menubutton.borderWidth 2 $prio; # 1 +} + +proc ::tk::classic::restore_message {args} { + variable prio + option add *Message.borderWidth 2 $prio; # 1 +} + +proc ::tk::classic::restore_panedwindow {args} { + variable prio + option add *Panedwindow.borderWidth 2 $prio; # 1 + option add *Panedwindow.sashWidth 2 $prio; # 3 + option add *Panedwindow.sashPad 2 $prio; # 0 + option add *Panedwindow.sashRelief raised $prio; # flat + option add *Panedwindow.opaqueResize 0 $prio; # 1 + if {[tk windowingsystem] ne "win32"} { + option add *Panedwindow.showHandle 1 $prio; # 0 + } +} + +proc ::tk::classic::restore_scale {args} { + variable prio + option add *Scale.borderWidth 2 $prio; # 1 + if {[tk windowingsystem] eq "x11"} { + option add *Scale.troughColor "#c3c3c3" $prio; # "#b3b3b3" + } +} + +proc ::tk::classic::restore_scrollbar {args} { + variable prio + if {[tk windowingsystem] eq "x11"} { + option add *Scrollbar.borderWidth 2 $prio; # 1 + option add *Scrollbar.highlightThickness 1 $prio; # 0 + option add *Scrollbar.width 15 $prio; # 11 + option add *Scrollbar.troughColor "#c3c3c3" $prio; # "#b3b3b3" + } +} + +proc ::tk::classic::restore_text {args} { + variable prio + if {[tk windowingsystem] ne "aqua"} { + option add *Text.borderWidth 2 $prio; # 1 + } + if {[tk windowingsystem] eq "win32"} { + option add *Text.font "TkDefaultFont" $prio; # "TkFixedFont" + } + if {[tk windowingsystem] eq "x11"} { + option add *Text.background "#d9d9d9" $prio; # white + option add *Text.selectBorderWidth 1 $prio; # 0 + } +} diff --git a/library/optMenu.tcl b/library/optMenu.tcl index 984436f..7cfdaa0 100644 --- a/library/optMenu.tcl +++ b/library/optMenu.tcl @@ -32,7 +32,7 @@ proc ::tk_optionMenu {w varName firstValue args} { set var $firstValue } menubutton $w -textvariable $varName -indicatoron 1 -menu $w.menu \ - -relief raised -bd 2 -highlightthickness 2 -anchor c \ + -relief raised -highlightthickness 1 -anchor c \ -direction flush menu $w.menu -tearoff 0 $w.menu add radiobutton -label $firstValue -variable $varName diff --git a/library/palette.tcl b/library/palette.tcl index 1838514..21be8dc 100644 --- a/library/palette.tcl +++ b/library/palette.tcl @@ -50,13 +50,11 @@ proc ::tk_setPalette {args} { set new(foreground) white } } - - # To avoir too many lindex... - foreach {fg_r fg_g fg_b} [winfo rgb . $new(foreground)] {break} - foreach {bg_r bg_g bg_b} $bg {break} - + lassign [winfo rgb . $new(foreground)] fg_r fg_g fg_b + lassign $bg bg_r bg_g bg_b set darkerBg [format #%02x%02x%02x [expr {(9*$bg_r)/2560}] \ [expr {(9*$bg_g)/2560}] [expr {(9*$bg_b)/2560}]] + foreach i {activeForeground insertBackground selectForeground \ highlightColor} { if {![info exists new($i)]} { @@ -78,7 +76,7 @@ proc ::tk_setPalette {args} { # up by 15% or 1/3 of the way to full white, whichever is # greater. - foreach i {0 1 2} color "$bg_r $bg_g $bg_b" { + foreach i {0 1 2} color $bg { set light($i) [expr {$color/256}] set inc1 [expr {($light($i)*15)/100}] set inc2 [expr {(255-$light($i))/3}] @@ -100,9 +98,6 @@ proc ::tk_setPalette {args} { if {![info exists new(troughColor)]} { set new(troughColor) $darkerBg } - if {![info exists new(selectColor)]} { - set new(selectColor) #b03060 - } # let's make one of each of the widgets so we know what the # defaults are currently for this platform. @@ -176,16 +171,16 @@ proc ::tk::RecolorTree {w colors} { # dbOption, then use it, otherwise use the defaults # for the widget. set defaultcolor [option get $w $dbOption $class] - if {[string match {} $defaultcolor] || \ + if {$defaultcolor eq "" || \ ([info exists prototype] && \ [$prototype cget $option] ne "$defaultcolor")} { set defaultcolor [lindex $value 3] } - if {![string match {} $defaultcolor]} { + if {$defaultcolor ne ""} { set defaultcolor [winfo rgb . $defaultcolor] } set chosencolor [lindex $value 4] - if {![string match {} $chosencolor]} { + if {$chosencolor ne ""} { set chosencolor [winfo rgb . $chosencolor] } if {[string match $defaultcolor $chosencolor]} { @@ -242,7 +237,7 @@ proc ::tk_bisque {} { tk_setPalette activeBackground #e6ceb1 activeForeground black \ background #ffe4c4 disabledForeground #b0b0b0 foreground black \ highlightBackground #ffe4c4 highlightColor black \ - insertBackground black selectColor #b03060 \ + insertBackground black \ selectBackground #e6ceb1 selectForeground black \ troughColor #cdb79e } diff --git a/library/panedwindow.tcl b/library/panedwindow.tcl index 58b0bae..d3dfabc 100644 --- a/library/panedwindow.tcl +++ b/library/panedwindow.tcl @@ -32,16 +32,21 @@ namespace eval ::tk::panedwindow {} # None # proc ::tk::panedwindow::MarkSash {w x y proxy} { - if {[$w cget -opaqueresize]} { set proxy 0 } + variable ::tk::Priv + if {[$w cget -opaqueresize]} { + set proxy 0 + } set what [$w identify $x $y] if { [llength $what] == 2 } { - foreach {index which} $what break - if { !$::tk_strictMotif || $which eq "handle" } { - if {!$proxy} { $w sash mark $index $x $y } - set ::tk::Priv(sash) $index - foreach {sx sy} [$w sash coord $index] break - set ::tk::Priv(dx) [expr {$sx-$x}] - set ::tk::Priv(dy) [expr {$sy-$y}] + lassign $what index which + if {!$::tk_strictMotif || $which eq "handle"} { + if {!$proxy} { + $w sash mark $index $x $y + } + set Priv(sash) $index + lassign [$w sash coord $index] sx sy + set Priv(dx) [expr {$sx-$x}] + set Priv(dy) [expr {$sy-$y}] # Do this to init the proxy location DragSash $w $x $y $proxy } @@ -61,14 +66,16 @@ proc ::tk::panedwindow::MarkSash {w x y proxy} { # Moves sash # proc ::tk::panedwindow::DragSash {w x y proxy} { - if {[$w cget -opaqueresize]} { set proxy 0 } - if { [info exists ::tk::Priv(sash)] } { + variable ::tk::Priv + if {[$w cget -opaqueresize]} { + set proxy 0 + } + if {[info exists Priv(sash)]} { if {$proxy} { - $w proxy place \ - [expr {$x+$::tk::Priv(dx)}] [expr {$y+$::tk::Priv(dy)}] + $w proxy place [expr {$x+$Priv(dx)}] [expr {$y+$Priv(dy)}] } else { - $w sash place $::tk::Priv(sash) \ - [expr {$x+$::tk::Priv(dx)}] [expr {$y+$::tk::Priv(dy)}] + $w sash place $Priv(sash) \ + [expr {$x+$Priv(dx)}] [expr {$y+$Priv(dy)}] } } } @@ -84,14 +91,17 @@ proc ::tk::panedwindow::DragSash {w x y proxy} { # Returns ... # proc ::tk::panedwindow::ReleaseSash {w proxy} { - if {[$w cget -opaqueresize]} { set proxy 0 } - if { [info exists ::tk::Priv(sash)] } { + variable ::tk::Priv + if {[$w cget -opaqueresize]} { + set proxy 0 + } + if {[info exists Priv(sash)]} { if {$proxy} { - foreach {x y} [$w proxy coord] break - $w sash place $::tk::Priv(sash) $x $y + lassign [$w proxy coord] x y + $w sash place $Priv(sash) $x $y $w proxy forget } - unset ::tk::Priv(sash) ::tk::Priv(dx) ::tk::Priv(dy) + unset Priv(sash) Priv(dx) Priv(dy) } } @@ -113,16 +123,14 @@ proc ::tk::panedwindow::Motion {w x y} { set id [$w identify $x $y] if {([llength $id] == 2) && \ (!$::tk_strictMotif || [lindex $id 1] eq "handle")} { - if { ![info exists Priv($w,panecursor)] } { + if {![info exists Priv($w,panecursor)]} { set Priv($w,panecursor) [$w cget -cursor] - if { [$w cget -sashcursor] eq "" } { - if { [$w cget -orient] eq "horizontal" } { - $w configure -cursor sb_h_double_arrow - } else { - $w configure -cursor sb_v_double_arrow - } - } else { + if {[$w cget -sashcursor] ne ""} { $w configure -cursor [$w cget -sashcursor] + } elseif {[$w cget -orient] eq "horizontal"} { + $w configure -cursor sb_h_double_arrow + } else { + $w configure -cursor sb_v_double_arrow } if {[info exists Priv($w,pwAfterId)]} { after cancel $Priv($w,pwAfterId) @@ -132,7 +140,7 @@ proc ::tk::panedwindow::Motion {w x y} { } return } - if { [info exists Priv($w,panecursor)] } { + if {[info exists Priv($w,panecursor)]} { $w configure -cursor $Priv($w,panecursor) unset Priv($w,panecursor) } @@ -178,8 +186,9 @@ proc ::tk::panedwindow::Cursor {w} { # Restores the default cursor # proc ::tk::panedwindow::Leave {w} { - if {[info exists ::tk::Priv($w,panecursor)]} { - $w configure -cursor $::tk::Priv($w,panecursor) - unset ::tk::Priv($w,panecursor) + variable ::tk::Priv + if {[info exists Priv($w,panecursor)]} { + $w configure -cursor $Priv($w,panecursor) + unset Priv($w,panecursor) } } diff --git a/library/prolog.ps b/library/prolog.ps deleted file mode 100644 index bf87d31..0000000 --- a/library/prolog.ps +++ /dev/null @@ -1,283 +0,0 @@ -%%BeginProlog -50 dict begin - -% This is a standard prolog for Postscript generated by Tk's canvas -% widget. - -% The definitions below just define all of the variables used in -% any of the procedures here. This is needed for obscure reasons -% explained on p. 716 of the Postscript manual (Section H.2.7, -% "Initializing Variables," in the section on Encapsulated Postscript). - -/baseline 0 def -/stipimage 0 def -/height 0 def -/justify 0 def -/lineLength 0 def -/spacing 0 def -/stipple 0 def -/strings 0 def -/xoffset 0 def -/yoffset 0 def -/tmpstip null def - -% Define the array ISOLatin1Encoding (which specifies how characters are -% encoded for ISO-8859-1 fonts), if it isn't already present (Postscript -% level 2 is supposed to define it, but level 1 doesn't). - -systemdict /ISOLatin1Encoding known not { - /ISOLatin1Encoding [ - /space /space /space /space /space /space /space /space - /space /space /space /space /space /space /space /space - /space /space /space /space /space /space /space /space - /space /space /space /space /space /space /space /space - /space /exclam /quotedbl /numbersign /dollar /percent /ampersand - /quoteright - /parenleft /parenright /asterisk /plus /comma /minus /period /slash - /zero /one /two /three /four /five /six /seven - /eight /nine /colon /semicolon /less /equal /greater /question - /at /A /B /C /D /E /F /G - /H /I /J /K /L /M /N /O - /P /Q /R /S /T /U /V /W - /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore - /quoteleft /a /b /c /d /e /f /g - /h /i /j /k /l /m /n /o - /p /q /r /s /t /u /v /w - /x /y /z /braceleft /bar /braceright /asciitilde /space - /space /space /space /space /space /space /space /space - /space /space /space /space /space /space /space /space - /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent - /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron - /space /exclamdown /cent /sterling /currency /yen /brokenbar /section - /dieresis /copyright /ordfeminine /guillemotleft /logicalnot /hyphen - /registered /macron - /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph - /periodcentered - /cedillar /onesuperior /ordmasculine /guillemotright /onequarter - /onehalf /threequarters /questiondown - /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla - /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex - /Idieresis - /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply - /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn - /germandbls - /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla - /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex - /idieresis - /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide - /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn - /ydieresis - ] def -} if - -% font ISOEncode font -% This procedure changes the encoding of a font from the default -% Postscript encoding to ISOLatin1. It's typically invoked just -% before invoking "setfont". The body of this procedure comes from -% Section 5.6.1 of the Postscript book. - -/ISOEncode { - dup length dict begin - {1 index /FID ne {def} {pop pop} ifelse} forall - /Encoding ISOLatin1Encoding def - currentdict - end - - % I'm not sure why it's necessary to use "definefont" on this new - % font, but it seems to be important; just use the name "Temporary" - % for the font. - - /Temporary exch definefont -} bind def - -% StrokeClip -% -% This procedure converts the current path into a clip area under -% the assumption of stroking. It's a bit tricky because some Postscript -% interpreters get errors during strokepath for dashed lines. If -% this happens then turn off dashes and try again. - -/StrokeClip { - {strokepath} stopped { - (This Postscript printer gets limitcheck overflows when) = - (stippling dashed lines; lines will be printed solid instead.) = - [] 0 setdash strokepath} if - clip -} bind def - -% desiredSize EvenPixels closestSize -% -% The procedure below is used for stippling. Given the optimal size -% of a dot in a stipple pattern in the current user coordinate system, -% compute the closest size that is an exact multiple of the device's -% pixel size. This allows stipple patterns to be displayed without -% aliasing effects. - -/EvenPixels { - % Compute exact number of device pixels per stipple dot. - dup 0 matrix currentmatrix dtransform - dup mul exch dup mul add sqrt - - % Round to an integer, make sure the number is at least 1, and compute - % user coord distance corresponding to this. - dup round dup 1 lt {pop 1} if - exch div mul -} bind def - -% width height string StippleFill -- -% -% Given a path already set up and a clipping region generated from -% it, this procedure will fill the clipping region with a stipple -% pattern. "String" contains a proper image description of the -% stipple pattern and "width" and "height" give its dimensions. Each -% stipple dot is assumed to be about one unit across in the current -% user coordinate system. This procedure trashes the graphics state. - -/StippleFill { - % The following code is needed to work around a NeWSprint bug. - - /tmpstip 1 index def - - % Change the scaling so that one user unit in user coordinates - % corresponds to the size of one stipple dot. - 1 EvenPixels dup scale - - % Compute the bounding box occupied by the path (which is now - % the clipping region), and round the lower coordinates down - % to the nearest starting point for the stipple pattern. Be - % careful about negative numbers, since the rounding works - % differently on them. - - pathbbox - 4 2 roll - 5 index div dup 0 lt {1 sub} if cvi 5 index mul 4 1 roll - 6 index div dup 0 lt {1 sub} if cvi 6 index mul 3 2 roll - - % Stack now: width height string y1 y2 x1 x2 - % Below is a doubly-nested for loop to iterate across this area - % in units of the stipple pattern size, going up columns then - % across rows, blasting out a stipple-pattern-sized rectangle at - % each position - - 6 index exch { - 2 index 5 index 3 index { - % Stack now: width height string y1 y2 x y - - gsave - 1 index exch translate - 5 index 5 index true matrix tmpstip imagemask - grestore - } for - pop - } for - pop pop pop pop pop -} bind def - -% -- AdjustColor -- -% Given a color value already set for output by the caller, adjusts -% that value to a grayscale or mono value if requested by the CL -% variable. - -/AdjustColor { - CL 2 lt { - currentgray - CL 0 eq { - .5 lt {0} {1} ifelse - } if - setgray - } if -} bind def - -% x y strings spacing xoffset yoffset justify stipple DrawText -- -% This procedure does all of the real work of drawing text. The -% color and font must already have been set by the caller, and the -% following arguments must be on the stack: -% -% x, y - Coordinates at which to draw text. -% strings - An array of strings, one for each line of the text item, -% in order from top to bottom. -% spacing - Spacing between lines. -% xoffset - Horizontal offset for text bbox relative to x and y: 0 for -% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se. -% yoffset - Vertical offset for text bbox relative to x and y: 0 for -% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se. -% justify - 0 for left justification, 0.5 for center, 1 for right justify. -% stipple - Boolean value indicating whether or not text is to be -% drawn in stippled fashion. If text is stippled, -% procedure StippleText must have been defined to call -% StippleFill in the right way. -% -% Also, when this procedure is invoked, the color and font must already -% have been set for the text. - -/DrawText { - /stipple exch def - /justify exch def - /yoffset exch def - /xoffset exch def - /spacing exch def - /strings exch def - - % First scan through all of the text to find the widest line. - - /lineLength 0 def - strings { - stringwidth pop - dup lineLength gt {/lineLength exch def} {pop} ifelse - newpath - } forall - - % Compute the baseline offset and the actual font height. - - 0 0 moveto (TXygqPZÄ) false charpath - pathbbox dup /baseline exch def - exch pop exch sub /height exch def pop - newpath - - % Translate coordinates first so that the origin is at the upper-left - % corner of the text's bounding box. Remember that x and y for - % positioning are still on the stack. - - translate - lineLength xoffset mul - strings length 1 sub spacing mul height add yoffset mul translate - - % Now use the baseline and justification information to translate so - % that the origin is at the baseline and positioning point for the - % first line of text. - - justify lineLength mul baseline neg translate - - % Iterate over each of the lines to output it. For each line, - % compute its width again so it can be properly justified, then - % display it. - - strings { - dup stringwidth pop - justify neg mul 0 moveto - stipple { - - % The text is stippled, so turn it into a path and print - % by calling StippledText, which in turn calls StippleFill. - % Unfortunately, many Postscript interpreters will get - % overflow errors if we try to do the whole string at - % once, so do it a character at a time. - - gsave - /char (X) def - { - char 0 3 -1 roll put - currentpoint - gsave - char true charpath clip StippleText - grestore - char stringwidth translate - moveto - } forall - grestore - } {show} ifelse - 0 spacing neg translate - } forall -} bind def - -%%EndProlog diff --git a/library/safetk.tcl b/library/safetk.tcl index cba854c..c975fd6 100644 --- a/library/safetk.tcl +++ b/library/safetk.tcl @@ -25,57 +25,51 @@ package require opt 0.4.1; namespace eval ::safe { # counter for safe toplevels - variable tkSafeId 0; - - # - # tkInterpInit : prepare the slave interpreter for tk loading - # most of the real job is done by loadTk - # returns the slave name (tkInterpInit does) - # - proc ::safe::tkInterpInit {slave argv} { - global env tk_library - - # We have to make sure that the tk_library variable uses a file - # pathname that works better in Tk (of the style returned by - # [file join], ie C:/path/to/tk/lib, not C:\path\to\tk\lib - set tk_library [file join $tk_library] - - # Clear Tk's access for that interp (path). - allowTk $slave $argv - - # there seems to be an obscure case where the tk_library - # variable value is changed to point to a sym link destination - # dir instead of the sym link itself, and thus where the $tk_library - # would then not be anymore one of the auto_path dir, so we use - # the addToAccessPath which adds if it's not already in instead - # of the more conventional findInAccessPath. - # Might be usefull for masters without Tk really loaded too. - ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]] - return $slave + variable tkSafeId 0 +} + +# +# tkInterpInit : prepare the slave interpreter for tk loading +# most of the real job is done by loadTk +# returns the slave name (tkInterpInit does) +# +proc ::safe::tkInterpInit {slave argv} { + global env tk_library + + # We have to make sure that the tk_library variable is normalized. + set tk_library [file normalize $tk_library] + + # Clear Tk's access for that interp (path). + allowTk $slave $argv + + # Ensure tk_library and subdirs (eg, ttk) are on the access path + ::interp eval $slave [list set tk_library [::safe::interpAddToAccessPath $slave $tk_library]] + foreach subdir [::safe::AddSubDirs [list $tk_library]] { + ::safe::interpAddToAccessPath $slave $subdir } + return $slave +} -# tkInterpLoadTk : -# Do additional configuration as needed (calling tkInterpInit) +# tkInterpLoadTk: +# Do additional configuration as needed (calling tkInterpInit) # and actually load Tk into the slave. -# +# # Either contained in the specified windowId (-use) or # creating a decorated toplevel for it. # empty definition for auto_mkIndex proc ::safe::loadTk {} {} - -::tcl::OptProc loadTk { + +::tcl::OptProc ::safe::loadTk { {slave -interp "name of the slave interpreter"} {-use -windowId {} "window Id to use (new toplevel otherwise)"} {-display -displayName {} "display name to use (current one otherwise)"} } { set displayGiven [::tcl::OptProcArgGiven "-display"] if {!$displayGiven} { - # Try to get the current display from "." # (which might not exist if the master is tk-less) - if {[catch {set display [winfo screen .]}]} { if {[info exists ::env(DISPLAY)]} { set display $::env(DISPLAY) @@ -85,42 +79,38 @@ proc ::safe::loadTk {} {} } } } + + # Get state for access to the cleanupHook. + namespace upvar ::safe S$slave state + if {![::tcl::OptProcArgGiven "-use"]} { - # create a decorated toplevel - ::tcl::Lassign [tkTopLevel $slave $display] w use # set our delete hook (slave arg is added by interpDelete) # to clean up both window related code and tkInit(slave) - Set [DeleteHookName $slave] [list tkDelete {} $w] + set state(cleanupHook) [list tkDelete {} $w] } else { # set our delete hook (slave arg is added by interpDelete) # to clean up tkInit(slave) - - Set [DeleteHookName $slave] [list disallowTk] + set state(cleanupHook) [list disallowTk] # Let's be nice and also accept tk window names instead of ids - if {[string match ".*" $use]} { set windowName $use set use [winfo id $windowName] set nDisplay [winfo screen $windowName] } else { - # Check for a better -display value # (works only for multi screens on single host, but not # cross hosts, for that a tk window name would be better # but embeding is also usefull for non tk names) - if {![catch {winfo pathname $use} name]} { set nDisplay [winfo screen $name] } else { - # Can't have a better one - set nDisplay $display } } @@ -135,9 +125,8 @@ proc ::safe::loadTk {} {} } # Prepares the slave for tk with those parameters - tkInterpInit $slave [list "-use" $use "-display" $display] - + load {} Tk $slave return $slave @@ -221,7 +210,7 @@ proc ::safe::tkDelete {W window slave} { Log $slave "Destroy toplevel $window" NOTICE destroy $window } - + # clean up tkInit(slave) disallowTk $slave return @@ -240,36 +229,36 @@ proc ::safe::tkTopLevel {slave display} { set msg "Untrusted Tcl applet ($slave)" wm title $w $msg - # Control frame + # Control frame (we must create a style for it) + ttk::style layout TWarningFrame {WarningFrame.border -sticky nswe} + ttk::style configure TWarningFrame -background red + set wc $w.fc - frame $wc -bg red -borderwidth 3 -relief ridge + ttk::frame $wc -relief ridge -borderwidth 4 -style TWarningFrame # We will destroy the interp when the window is destroyed bindtags $wc [concat Safe$wc [bindtags $wc]] bind Safe$wc <Destroy> [list ::safe::tkDelete %W $w $slave] - label $wc.l -text $msg -padx 2 -pady 0 -anchor w + ttk::label $wc.l -text $msg -anchor w # We want the button to be the last visible item # (so be packed first) and at the right and not resizing horizontally # frame the button so it does not expand horizontally # but still have the default background instead of red one from the parent - frame $wc.fb -bd 0 - button $wc.fb.b -text "Delete" \ - -bd 1 -padx 2 -pady 0 -highlightthickness 0 \ + ttk::frame $wc.fb -borderwidth 0 + ttk::button $wc.fb.b -text "Delete" \ -command [list ::safe::tkDelete $w $w $slave] pack $wc.fb.b -side right -fill both pack $wc.fb -side right -fill both -expand 1 - pack $wc.l -side left -fill both -expand 1 + pack $wc.l -side left -fill both -expand 1 -ipady 2 pack $wc -side bottom -fill x # Container frame frame $w.c -container 1 pack $w.c -fill both -expand 1 - + # return both the toplevel window name and the id to use for embedding list $w [winfo id $w.c] } - -} diff --git a/library/scale.tcl b/library/scale.tcl index d5de754..b4da824 100644 --- a/library/scale.tcl +++ b/library/scale.tcl @@ -270,8 +270,9 @@ proc ::tk::ScaleButton2Down {w x y} { variable ::tk::Priv if {[$w cget -state] eq "disabled"} { - return + return } + $w configure -state active $w set [$w get $x $y] set Priv(dragging) 1 diff --git a/library/scrlbar.tcl b/library/scrlbar.tcl index f048922..4cb95bd 100644 --- a/library/scrlbar.tcl +++ b/library/scrlbar.tcl @@ -128,7 +128,7 @@ bind Scrollbar <End> { tk::ScrollToPos %W 1 } } -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { +if {[tk windowingsystem] eq "aqua"} { bind Scrollbar <MouseWheel> { tk::ScrollByUnits %W v [expr {- (%D)}] } @@ -314,7 +314,8 @@ proc ::tk::ScrollEndDrag {w x y} { proc ::tk::ScrollByUnits {w orient amount} { set cmd [$w cget -command] - if {$cmd eq "" || ([string first [string index [$w cget -orient] 0] $orient] < 0)} { + if {$cmd eq "" || ([string first \ + [string index [$w cget -orient] 0] $orient] < 0)} { return } set info [$w get] @@ -338,7 +339,8 @@ proc ::tk::ScrollByUnits {w orient amount} { proc ::tk::ScrollByPages {w orient amount} { set cmd [$w cget -command] - if {$cmd eq "" || ([string first [string index [$w cget -orient] 0] $orient] < 0)} { + if {$cmd eq "" || ([string first \ + [string index [$w cget -orient] 0] $orient] < 0)} { return } set info [$w get] diff --git a/library/spinbox.tcl b/library/spinbox.tcl index 9b63e09..cb501ee 100644 --- a/library/spinbox.tcl +++ b/library/spinbox.tcl @@ -73,6 +73,11 @@ bind Spinbox <<PasteSelection>> { } } +bind Spinbox <<TraverseIn>> { + %W selection range 0 end + %W icursor end +} + # Standard Motif bindings: bind Spinbox <1> { @@ -210,9 +215,8 @@ bind Spinbox <Escape> {# nothing} bind Spinbox <Return> {# nothing} bind Spinbox <KP_Enter> {# nothing} bind Spinbox <Tab> {# nothing} - -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { - bind Spinbox <Command-KeyPress> {# nothing} +if {[tk windowingsystem] eq "aqua"} { + bind Spinbox <Command-KeyPress> {# nothing} } # On Windows, paste is done using Shift-Insert. Shift-Insert already @@ -494,7 +498,9 @@ proc ::tk::spinbox::MouseSelect {w x {cursor {}}} { proc ::tk::spinbox::Paste {w x} { $w icursor [::tk::spinbox::ClosestGap $w $x] catch {$w insert insert [::tk::GetSelection $w PRIMARY]} - if {"disabled" eq [$w cget -state]} {focus $w} + if {"disabled" eq [$w cget -state]} { + focus $w + } } # ::tk::spinbox::Motion -- diff --git a/library/tclIndex b/library/tclIndex index 6b3547d..e7f5b81 100644 --- a/library/tclIndex +++ b/library/tclIndex @@ -122,6 +122,7 @@ set auto_index(::tk::ensure_psenc_is_loaded) [list source [file join $dir mkpsen set auto_index(::tk::MessageBox) [list source [file join $dir msgbox.tcl]] set auto_index(tk_menuBar) [list source [file join $dir obsolete.tcl]] set auto_index(tk_bindForTraversal) [list source [file join $dir obsolete.tcl]] +set auto_index(::tk::classic::restore) [list source [file join $dir obsolete.tcl]] set auto_index(tk_optionMenu) [list source [file join $dir optMenu.tcl]] set auto_index(tk_setPalette) [list source [file join $dir palette.tcl]] set auto_index(::tk::RecolorTree) [list source [file join $dir palette.tcl]] @@ -200,7 +201,7 @@ set auto_index(::tk::TabToWindow) [list source [file join $dir tk.tcl]] set auto_index(::tk::IconList) [list source [file join $dir tkfbox.tcl]] set auto_index(::tk::IconList_Index) [list source [file join $dir tkfbox.tcl]] set auto_index(::tk::IconList_Selection) [list source [file join $dir tkfbox.tcl]] -set auto_index(::tk::IconList_Curselection) [list source [file join $dir tkfbox.tcl]] +set auto_index(::tk::IconList_CurSelection) [list source [file join $dir tkfbox.tcl]] set auto_index(::tk::IconList_DrawSelection) [list source [file join $dir tkfbox.tcl]] set auto_index(::tk::IconList_Get) [list source [file join $dir tkfbox.tcl]] set auto_index(::tk::IconList_Config) [list source [file join $dir tkfbox.tcl]] diff --git a/library/tearoff.tcl b/library/tearoff.tcl index 297a203..6da2a0f 100644 --- a/library/tearoff.tcl +++ b/library/tearoff.tcl @@ -44,7 +44,8 @@ proc ::tk::TearOffMenu {w {x 0} {y 0}} { } set parent [winfo parent $w] - while {[winfo toplevel $parent] ne $parent || [winfo class $parent] eq "Menu"} { + while {[winfo toplevel $parent] ne $parent \ + || [winfo class $parent] eq "Menu"} { set parent [winfo parent $parent] } if {$parent eq "."} { @@ -67,7 +68,7 @@ proc ::tk::TearOffMenu {w {x 0} {y 0}} { if {[$menu cget -title] ne ""} { wm title $menu [$menu cget -title] } else { - switch [winfo class $parent] { + switch -- [winfo class $parent] { Menubutton { wm title $menu [$parent cget -text] } @@ -77,6 +78,16 @@ proc ::tk::TearOffMenu {w {x 0} {y 0}} { } } + if {[tk windowingsystem] eq "win32"} { + # [Bug 3181181]: Find the toplevel window for the menu + set parent [winfo toplevel $parent] + while {[winfo class $parent] eq "Menu"} { + set parent [winfo toplevel [winfo parent $parent]] + } + wm transient $menu [winfo toplevel $parent] + wm attributes $menu -toolwindow 1 + } + $menu post $x $y if {[winfo exists $menu] == 0} { diff --git a/library/text.tcl b/library/text.tcl index 3b32991..0e43e61 100644 --- a/library/text.tcl +++ b/library/text.tcl @@ -31,6 +31,7 @@ # char, word, or line. # x, y - Last known mouse coordinates for scanning # and auto-scanning. +# #------------------------------------------------------------------------- #------------------------------------------------------------------------- @@ -51,12 +52,12 @@ bind Text <B1-Motion> { bind Text <Double-1> { set tk::Priv(selectMode) word tk::TextSelectTo %W %x %y - catch {%W mark set insert sel.last} + catch {%W mark set insert sel.first} } bind Text <Triple-1> { set tk::Priv(selectMode) line tk::TextSelectTo %W %x %y - catch {%W mark set insert sel.last} + catch {%W mark set insert sel.first} } bind Text <Shift-1> { tk::TextResetAnchor %W @%x,%y @@ -86,10 +87,10 @@ bind Text <Control-1> { %W mark set insert @%x,%y } bind Text <Left> { - tk::TextSetCursor %W insert-1c + tk::TextSetCursor %W insert-1displayindices } bind Text <Right> { - tk::TextSetCursor %W insert+1c + tk::TextSetCursor %W insert+1displayindices } bind Text <Up> { tk::TextSetCursor %W [tk::TextUpDownLine %W -1] @@ -98,10 +99,10 @@ bind Text <Down> { tk::TextSetCursor %W [tk::TextUpDownLine %W 1] } bind Text <Shift-Left> { - tk::TextKeySelect %W [%W index {insert - 1c}] + tk::TextKeySelect %W [%W index {insert - 1displayindices}] } bind Text <Shift-Right> { - tk::TextKeySelect %W [%W index {insert + 1c}] + tk::TextKeySelect %W [%W index {insert + 1displayindices}] } bind Text <Shift-Up> { tk::TextKeySelect %W [tk::TextUpDownLine %W -1] @@ -153,16 +154,16 @@ bind Text <Control-Next> { } bind Text <Home> { - tk::TextSetCursor %W {insert linestart} + tk::TextSetCursor %W {insert display linestart} } bind Text <Shift-Home> { - tk::TextKeySelect %W {insert linestart} + tk::TextKeySelect %W {insert display linestart} } bind Text <End> { - tk::TextSetCursor %W {insert lineend} + tk::TextSetCursor %W {insert display lineend} } bind Text <Shift-End> { - tk::TextKeySelect %W {insert lineend} + tk::TextKeySelect %W {insert display lineend} } bind Text <Control-Home> { tk::TextSetCursor %W 1.0 @@ -171,14 +172,14 @@ bind Text <Control-Shift-Home> { tk::TextKeySelect %W 1.0 } bind Text <Control-End> { - tk::TextSetCursor %W {end - 1 char} + tk::TextSetCursor %W {end - 1 indices} } bind Text <Control-Shift-End> { - tk::TextKeySelect %W {end - 1 char} + tk::TextKeySelect %W {end - 1 indices} } bind Text <Tab> { - if { [%W cget -state] eq "normal" } { + if {[%W cget -state] eq "normal"} { tk::TextInsert %W \t focus %W break @@ -200,30 +201,32 @@ bind Text <Control-i> { } bind Text <Return> { tk::TextInsert %W \n - if {[%W cget -autoseparators]} {%W edit separator} + if {[%W cget -autoseparators]} { + %W edit separator + } } bind Text <Delete> { - if {[%W tag nextrange sel 1.0 end] ne ""} { + if {[tk::TextCursorInSelection %W]} { %W delete sel.first sel.last - } else { + } elseif {[%W compare end != insert+1c]} { %W delete insert - %W see insert } + %W see insert } bind Text <BackSpace> { - if {[%W tag nextrange sel 1.0 end] ne ""} { + if {[tk::TextCursorInSelection %W]} { %W delete sel.first sel.last } elseif {[%W compare insert != 1.0]} { %W delete insert-1c - %W see insert } + %W see insert } bind Text <Control-space> { - %W mark set anchor insert + %W mark set [tk::TextAnchor %W] insert } bind Text <Select> { - %W mark set anchor insert + %W mark set [tk::TextAnchor %W] insert } bind Text <Control-Shift-space> { set tk::Priv(selectMode) char @@ -253,7 +256,7 @@ bind Text <<Clear>> { } bind Text <<PasteSelection>> { if {$tk_strictMotif || ![info exists tk::Priv(mouseMoved)] - || !$tk::Priv(mouseMoved)} { + || !$tk::Priv(mouseMoved)} { tk::TextPasteSelection %W %x %y } } @@ -274,8 +277,7 @@ bind Text <Meta-KeyPress> {# nothing} bind Text <Control-KeyPress> {# nothing} bind Text <Escape> {# nothing} bind Text <KP_Enter> {# nothing} - -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { +if {[tk windowingsystem] eq "aqua"} { bind Text <Command-KeyPress> {# nothing} } @@ -283,31 +285,31 @@ if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { bind Text <Control-a> { if {!$tk_strictMotif} { - tk::TextSetCursor %W {insert linestart} + tk::TextSetCursor %W {insert display linestart} } } bind Text <Control-b> { if {!$tk_strictMotif} { - tk::TextSetCursor %W insert-1c + tk::TextSetCursor %W insert-1displayindices } } bind Text <Control-d> { - if {!$tk_strictMotif} { + if {!$tk_strictMotif && [%W compare end != insert+1c]} { %W delete insert } } bind Text <Control-e> { if {!$tk_strictMotif} { - tk::TextSetCursor %W {insert lineend} + tk::TextSetCursor %W {insert display lineend} } } bind Text <Control-f> { if {!$tk_strictMotif} { - tk::TextSetCursor %W insert+1c + tk::TextSetCursor %W insert+1displayindices } } bind Text <Control-k> { - if {!$tk_strictMotif} { + if {!$tk_strictMotif && [%W compare end != insert+1c]} { if {[%W compare insert == {insert lineend}]} { %W delete insert } else { @@ -345,21 +347,13 @@ bind Text <<Redo>> { catch { %W edit redo } } -if {[tk windowingsystem] ne "win32"} { -bind Text <Control-v> { - if {!$tk_strictMotif} { - tk::TextScrollPages %W 1 - } -} -} - bind Text <Meta-b> { if {!$tk_strictMotif} { tk::TextSetCursor %W [tk::TextPrevPos %W insert tcl_startOfPreviousWord] } } bind Text <Meta-d> { - if {!$tk_strictMotif} { + if {!$tk_strictMotif && [%W compare end != insert+1c]} { %W delete insert [tk::TextNextWord %W insert] } } @@ -391,13 +385,7 @@ bind Text <Meta-Delete> { # Macintosh only bindings: -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { -bind Text <FocusIn> { - %W configure -selectbackground systemHighlight -selectforeground systemHighlightText -} -bind Text <FocusOut> { - %W configure -selectbackground systemHighlightSecondary -selectforeground systemHighlightText -} +if {[tk windowingsystem] eq "aqua"} { bind Text <Option-Left> { tk::TextSetCursor %W [tk::TextPrevPos %W insert tcl_startOfPreviousWord] } @@ -422,6 +410,9 @@ bind Text <Shift-Option-Up> { bind Text <Shift-Option-Down> { tk::TextKeySelect %W [tk::TextNextPara %W insert] } +bind Text <Control-v> { + tk::TextScrollPages %W 1 +} # End of Mac only bindings } @@ -429,11 +420,9 @@ bind Text <Shift-Option-Down> { # A few additional bindings of my own. bind Text <Control-h> { - if {!$tk_strictMotif} { - if {[%W compare insert != 1.0]} { - %W delete insert-1c - %W see insert - } + if {!$tk_strictMotif && [%W compare insert != 1.0]} { + %W delete insert-1c + %W see insert } } bind Text <2> { @@ -449,25 +438,36 @@ bind Text <B2-Motion> { set ::tk::Priv(prevPos) {} # The MouseWheel will typically only fire on Windows and MacOS X. -# However, someone could use the "event generate" command to produce -# one on other platforms. +# However, someone could use the "event generate" command to produce one +# on other platforms. We must be careful not to round -ve values of %D +# down to zero. -if {[tk windowingsystem] eq "classic" || [tk windowingsystem] eq "aqua"} { +if {[tk windowingsystem] eq "aqua"} { bind Text <MouseWheel> { - %W yview scroll [expr {- (%D)}] units + %W yview scroll [expr {-15 * (%D)}] pixels } bind Text <Option-MouseWheel> { - %W yview scroll [expr {-10 * (%D)}] units + %W yview scroll [expr {-150 * (%D)}] pixels } bind Text <Shift-MouseWheel> { - %W xview scroll [expr {- (%D)}] units + %W xview scroll [expr {-15 * (%D)}] pixels } bind Text <Shift-Option-MouseWheel> { - %W xview scroll [expr {-10 * (%D)}] units + %W xview scroll [expr {-150 * (%D)}] pixels } } else { + # We must make sure that positive and negative movements are rounded + # equally to integers, avoiding the problem that + # (int)1/3 = 0, + # but + # (int)-1/3 = -1 + # The following code ensure equal +/- behaviour. bind Text <MouseWheel> { - %W yview scroll [expr {- (%D / 120) * 4}] units + if {%D >= 0} { + %W yview scroll [expr {-%D/3}] pixels + } else { + %W yview scroll [expr {(2-%D)/3}] pixels + } } } @@ -478,12 +478,12 @@ if {"x11" eq [tk windowingsystem]} { # http://www.inria.fr/koala/colas/mouse-wheel-scroll/ bind Text <4> { if {!$tk_strictMotif} { - %W yview scroll -5 units + %W yview scroll -50 pixels } } bind Text <5> { if {!$tk_strictMotif} { - %W yview scroll 5 units + %W yview scroll 50 pixels } } } @@ -526,12 +526,26 @@ proc ::tk::TextButton1 {w x y} { set Priv(selectMode) char set Priv(mouseMoved) 0 set Priv(pressX) $x + set anchorname [tk::TextAnchor $w] $w mark set insert [TextClosestGap $w $x $y] - $w mark set anchor insert + $w mark set $anchorname insert + # Set the anchor mark's gravity depending on the click position + # relative to the gap + set bbox [$w bbox [$w index $anchorname]] + if {$x > [lindex $bbox 0]} { + $w mark gravity $anchorname right + } else { + $w mark gravity $anchorname left + } # Allow focus in any case on Windows, because that will let the # selection be displayed even for state disabled text widgets. - if {[tk windowingsystem] eq "win32" || [$w cget -state] eq "normal"} {focus $w} - if {[$w cget -autoseparators]} {$w edit separator} + if {[tk windowingsystem] eq "win32" \ + || [$w cget -state] eq "normal"} { + focus $w + } + if {[$w cget -autoseparators]} { + $w edit separator + } } # ::tk::TextSelectTo -- @@ -541,61 +555,85 @@ proc ::tk::TextButton1 {w x y} { # ignores mouse motions initially until the mouse has moved from # one character to another or until there have been multiple clicks. # +# Note that the 'anchor' is implemented programmatically using +# a text widget mark, and uses a name that will be unique for each +# text widget (even when there are multiple peers). Currently the +# anchor is considered private to Tk, hence the name 'tk::anchor$w'. +# # Arguments: # w - The text window in which the button was pressed. # x - Mouse x position. # y - Mouse y position. +set ::tk::Priv(textanchoruid) 0 + +proc ::tk::TextAnchor {w} { + variable Priv + if {![info exists Priv(textanchor,$w)]} { + set Priv(textanchor,$w) tk::anchor[incr Priv(textanchoruid)] + } + return $Priv(textanchor,$w) +} + proc ::tk::TextSelectTo {w x y {extend 0}} { global tcl_platform variable ::tk::Priv + set anchorname [tk::TextAnchor $w] set cur [TextClosestGap $w $x $y] - if {[catch {$w index anchor}]} { - $w mark set anchor $cur + if {[catch {$w index $anchorname}]} { + $w mark set $anchorname $cur } - set anchor [$w index anchor] + set anchor [$w index $anchorname] if {[$w compare $cur != $anchor] || (abs($Priv(pressX) - $x) >= 3)} { set Priv(mouseMoved) 1 } - switch $Priv(selectMode) { + switch -- $Priv(selectMode) { char { - if {[$w compare $cur < anchor]} { + if {[$w compare $cur < $anchorname]} { set first $cur - set last anchor + set last $anchorname } else { - set first anchor + set first $anchorname set last $cur } } word { - if {[$w compare $cur < anchor]} { - set first [TextPrevPos $w "$cur + 1c" tcl_wordBreakBefore] - if { !$extend } { - set last [TextNextPos $w "anchor" tcl_wordBreakAfter] - } else { - set last anchor - } + # Set initial range based only on the anchor (1 char min width) + if {[$w mark gravity $anchorname] eq "right"} { + set first $anchorname + set last "$anchorname + 1c" } else { - set last [TextNextPos $w "$cur - 1c" tcl_wordBreakAfter] - if { !$extend } { - set first [TextPrevPos $w anchor tcl_wordBreakBefore] - } else { - set first anchor - } + set first "$anchorname - 1c" + set last $anchorname } + # Extend range (if necessary) based on the current point + if {[$w compare $cur < $first]} { + set first $cur + } elseif {[$w compare $cur > $last]} { + set last $cur + } + + # Now find word boundaries + set first [TextPrevPos $w "$first + 1c" tcl_wordBreakBefore] + set last [TextNextPos $w "$last - 1c" tcl_wordBreakAfter] } line { - if {[$w compare $cur < anchor]} { - set first [$w index "$cur linestart"] - set last [$w index "anchor - 1c lineend + 1c"] - } else { - set first [$w index "anchor linestart"] - set last [$w index "$cur lineend + 1c"] + # Set initial range based only on the anchor + set first "$anchorname linestart" + set last "$anchorname lineend" + + # Extend range (if necessary) based on the current point + if {[$w compare $cur < $first]} { + set first "$cur linestart" + } elseif {[$w compare $cur > $last]} { + set last "$cur lineend" } + set first [$w index $first] + set last [$w index "$last + 1c"] } } - if {$Priv(mouseMoved) || $Priv(selectMode) ne "char"} { + if {$Priv(mouseMoved) || ($Priv(selectMode) ne "char")} { $w tag remove sel 0.0 end $w mark set insert $cur $w tag add sel $first $last @@ -615,16 +653,17 @@ proc ::tk::TextSelectTo {w x y {extend 0}} { proc ::tk::TextKeyExtend {w index} { + set anchorname [tk::TextAnchor $w] set cur [$w index $index] - if {[catch {$w index anchor}]} { - $w mark set anchor $cur + if {[catch {$w index $anchorname}]} { + $w mark set $anchorname $cur } - set anchor [$w index anchor] - if {[$w compare $cur < anchor]} { + set anchor [$w index $anchorname] + if {[$w compare $cur < $anchorname]} { set first $cur - set last anchor + set last $anchorname } else { - set first anchor + set first $anchorname set last $cur } $w tag remove sel 0.0 $first @@ -654,7 +693,9 @@ proc ::tk::TextPasteSelection {w x y} { $w configure -autoseparators 1 } } - if {[$w cget -state] eq "normal"} {focus $w} + if {[$w cget -state] eq "normal"} { + focus $w + } } # ::tk::TextAutoScan -- @@ -670,11 +711,13 @@ proc ::tk::TextPasteSelection {w x y} { proc ::tk::TextAutoScan {w} { variable ::tk::Priv - if {![winfo exists $w]} return + if {![winfo exists $w]} { + return + } if {$Priv(y) >= [winfo height $w]} { - $w yview scroll 2 units + $w yview scroll [expr {1 + $Priv(y) - [winfo height $w]}] pixels } elseif {$Priv(y) < 0} { - $w yview scroll -2 units + $w yview scroll [expr {-1 + $Priv(y)}] pixels } elseif {$Priv(x) >= [winfo width $w]} { $w xview scroll 2 units } elseif {$Priv(x) < 0} { @@ -697,14 +740,15 @@ proc ::tk::TextAutoScan {w} { # pos - The desired new position for the cursor in the window. proc ::tk::TextSetCursor {w pos} { - if {[$w compare $pos == end]} { set pos {end - 1 chars} } $w mark set insert $pos $w tag remove sel 1.0 end $w see insert - if {[$w cget -autoseparators]} {$w edit separator} + if {[$w cget -autoseparators]} { + $w edit separator + } } # ::tk::TextKeySelect @@ -718,20 +762,20 @@ proc ::tk::TextSetCursor {w pos} { # actually been moved to this position yet). proc ::tk::TextKeySelect {w new} { - + set anchorname [tk::TextAnchor $w] if {[$w tag nextrange sel 1.0 end] eq ""} { if {[$w compare $new < insert]} { $w tag add sel $new insert } else { $w tag add sel insert $new } - $w mark set anchor insert + $w mark set $anchorname insert } else { - if {[$w compare $new < anchor]} { + if {[$w compare $new < $anchorname]} { set first $new - set last anchor + set last $anchorname } else { - set first anchor + set first $anchorname set last $new } $w tag remove sel 1.0 $first @@ -758,23 +802,23 @@ proc ::tk::TextKeySelect {w new} { # which end of selection should be used as anchor point. proc ::tk::TextResetAnchor {w index} { - if {[$w tag ranges sel] eq ""} { - # Don't move the anchor if there is no selection now; this makes - # the widget behave "correctly" when the user clicks once, then - # shift-clicks somewhere -- ie, the area between the two clicks will be - # selected. [Bug: 5929]. + # Don't move the anchor if there is no selection now; this + # makes the widget behave "correctly" when the user clicks + # once, then shift-clicks somewhere -- ie, the area between + # the two clicks will be selected. [Bug: 5929]. return } + set anchorname [tk::TextAnchor $w] set a [$w index $index] set b [$w index sel.first] set c [$w index sel.last] if {[$w compare $a < $b]} { - $w mark set anchor sel.last + $w mark set $anchorname sel.last return } if {[$w compare $a > $c]} { - $w mark set anchor sel.first + $w mark set $anchorname sel.first return } scan $a "%d.%d" lineA chA @@ -786,16 +830,31 @@ proc ::tk::TextResetAnchor {w index} { return } if {[string length [$w get $b $a]] < ($total/2)} { - $w mark set anchor sel.last + $w mark set $anchorname sel.last } else { - $w mark set anchor sel.first + $w mark set $anchorname sel.first } return } if {($lineA-$lineB) < ($lineC-$lineA)} { - $w mark set anchor sel.last + $w mark set $anchorname sel.last } else { - $w mark set anchor sel.first + $w mark set $anchorname sel.first + } +} + +# ::tk::TextCursorInSelection -- +# Check whether the selection exists and contains the insertion cursor. Note +# that it assumes that the selection is contiguous. +# +# Arguments: +# w - The text widget whose selection is to be checked + +proc ::tk::TextCursorInSelection {w} { + expr { + [llength [$w tag ranges sel]] + && [$w compare sel.first <= insert] + && [$w compare sel.last >= insert] } } @@ -813,49 +872,47 @@ proc ::tk::TextInsert {w s} { return } set compound 0 - catch { - if {[$w compare sel.first <= insert] \ - && [$w compare sel.last >= insert]} { - set oldSeparator [$w cget -autoseparators] - if { $oldSeparator } { - $w configure -autoseparators 0 - $w edit separator - set compound 1 - } - $w delete sel.first sel.last + if {[TextCursorInSelection $w]} { + set compound [$w cget -autoseparators] + if {$compound} { + $w configure -autoseparators 0 + $w edit separator } + $w delete sel.first sel.last } $w insert insert $s $w see insert - if { $compound && $oldSeparator } { - $w edit separator - $w configure -autoseparators 1 + if {$compound} { + $w edit separator + $w configure -autoseparators 1 } } # ::tk::TextUpDownLine -- -# Returns the index of the character one line above or below the -# insertion cursor. There are two tricky things here. First, -# we want to maintain the original column across repeated operations, -# even though some lines that will get passed through don't have -# enough characters to cover the original column. Second, don't -# try to scroll past the beginning or end of the text. +# Returns the index of the character one display line above or below the +# insertion cursor. There are two tricky things here. First, we want to +# maintain the original x position across repeated operations, even though +# some lines that will get passed through don't have enough characters to +# cover the original column. Second, don't try to scroll past the +# beginning or end of the text. # # Arguments: # w - The text window in which the cursor is to move. -# n - The number of lines to move: -1 for up one line, +# n - The number of display lines to move: -1 for up one line, # +1 for down one line. proc ::tk::TextUpDownLine {w n} { variable ::tk::Priv set i [$w index insert] - scan $i "%d.%d" line char if {$Priv(prevPos) ne $i} { - set Priv(char) $char + set Priv(textPosOrig) $i } - set new [$w index [expr {$line + $n}].$Priv(char)] - if {[$w compare $new == end] || [$w compare $new == "insert linestart"]} { + set lines [$w count -displaylines $Priv(textPosOrig) $i] + set new [$w index \ + "$Priv(textPosOrig) + [expr {$lines + $n}] displaylines"] + if {[$w compare $new == end] \ + || [$w compare $new == "insert display linestart"]} { set new $i } set Priv(prevPos) $new @@ -874,13 +931,13 @@ proc ::tk::TextUpDownLine {w n} { proc ::tk::TextPrevPara {w pos} { set pos [$w index "$pos linestart"] while {1} { - if {([$w get "$pos - 1 line"] eq "\n" \ - && [$w get $pos] ne "\n") || $pos eq "1.0"} { - if {[regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ - dummy index]} { + if {([$w get "$pos - 1 line"] eq "\n" && ([$w get $pos] ne "\n")) \ + || $pos eq "1.0"} { + if {[regexp -indices -- {^[ \t]+(.)} \ + [$w get $pos "$pos lineend"] -> index]} { set pos [$w index "$pos + [lindex $index 0] chars"] } - if {[$w compare $pos != insert] || [lindex [split $pos .] 0] == 1} { + if {[$w compare $pos != insert] || [lindex [split $pos .] 0]==1} { return $pos } } @@ -911,8 +968,8 @@ proc ::tk::TextNextPara {w start} { return [$w index "end - 1c"] } } - if {[regexp -indices {^[ ]+(.)} [$w get $pos "$pos lineend"] \ - dummy index]} { + if {[regexp -indices -- {^[ \t]+(.)} \ + [$w get $pos "$pos lineend"] -> index]} { return [$w index "$pos + [lindex $index 0] chars"] } return $pos @@ -1013,9 +1070,8 @@ proc ::tk_textCut w { proc ::tk_textPaste w { global tcl_platform if {![catch {::tk::GetSelection $w CLIPBOARD} sel]} { - # ensure this is seen as an atomic op to undo set oldSeparator [$w cget -autoseparators] - if { $oldSeparator } { + if {$oldSeparator} { $w configure -autoseparators 0 $w edit separator } @@ -1023,7 +1079,7 @@ proc ::tk_textPaste w { catch { $w delete sel.first sel.last } } $w insert insert $sel - if { $oldSeparator } { + if {$oldSeparator} { $w edit separator $w configure -autoseparators 1 } @@ -1043,7 +1099,7 @@ proc ::tk_textPaste w { if {[tk windowingsystem] eq "win32"} { proc ::tk::TextNextWord {w start} { TextNextPos $w [TextNextPos $w $start tcl_endOfWord] \ - tcl_startOfNextWord + tcl_startOfNextWord } } else { proc ::tk::TextNextWord {w start} { @@ -1064,16 +1120,10 @@ proc ::tk::TextNextPos {w start op} { set text "" set cur $start while {[$w compare $cur < end]} { - set text $text[$w get $cur "$cur lineend + 1c"] + set text $text[$w get -displaychars $cur "$cur lineend + 1c"] set pos [$op $text 0] if {$pos >= 0} { - ## Adjust for embedded windows and images - ## dump gives us 3 items per window/image - set dump [$w dump -image -window $start "$start + $pos c"] - if {[llength $dump]} { - set pos [expr {$pos + ([llength $dump]/3)}] - } - return [$w index "$start + $pos c"] + return [$w index "$start + $pos display chars"] } set cur [$w index "$cur lineend +1c"] } @@ -1093,22 +1143,10 @@ proc ::tk::TextPrevPos {w start op} { set text "" set cur $start while {[$w compare $cur > 0.0]} { - set text [$w get "$cur linestart - 1c" $cur]$text + set text [$w get -displaychars "$cur linestart - 1c" $cur]$text set pos [$op $text end] if {$pos >= 0} { - ## Adjust for embedded windows and images - ## dump gives us 3 items per window/image - set dump [$w dump -image -window "$cur linestart" "$start - 1c"] - if {[llength $dump]} { - ## This is a hokey extra hack for control-arrow movement - ## that should be in a while loop to be correct (hobbs) - if {[$w compare [lindex $dump 2] > \ - "$cur linestart - 1c + $pos c"]} { - incr pos -1 - } - set pos [expr {$pos + ([llength $dump]/3)}] - } - return [$w index "$cur linestart - 1c + $pos c"] + return [$w index "$cur linestart - 1c + $pos display chars"] } set cur [$w index "$cur linestart - 1c"] } @@ -1125,10 +1163,11 @@ proc ::tk::TextPrevPos {w start op} { # y - y location on screen proc ::tk::TextScanMark {w x y} { + variable ::tk::Priv $w scan mark $x $y - set ::tk::Priv(x) $x - set ::tk::Priv(y) $y - set ::tk::Priv(mouseMoved) 0 + set Priv(x) $x + set Priv(y) $y + set Priv(mouseMoved) 0 } # ::tk::TextScanDrag -- @@ -1141,14 +1180,19 @@ proc ::tk::TextScanMark {w x y} { # y - y location on screen proc ::tk::TextScanDrag {w x y} { + variable ::tk::Priv # Make sure these exist, as some weird situations can trigger the # motion binding without the initial press. [Bug #220269] - if {![info exists ::tk::Priv(x)]} { set ::tk::Priv(x) $x } - if {![info exists ::tk::Priv(y)]} { set ::tk::Priv(y) $y } - if {($x != $::tk::Priv(x)) || ($y != $::tk::Priv(y))} { - set ::tk::Priv(mouseMoved) 1 + if {![info exists Priv(x)]} { + set Priv(x) $x + } + if {![info exists Priv(y)]} { + set Priv(y) $y + } + if {($x != $Priv(x)) || ($y != $Priv(y))} { + set Priv(mouseMoved) 1 } - if {[info exists ::tk::Priv(mouseMoved)] && $::tk::Priv(mouseMoved)} { + if {[info exists Priv(mouseMoved)] && $Priv(mouseMoved)} { $w scan dragto $x $y } } diff --git a/library/tk.tcl b/library/tk.tcl index a09cd9c..99ab97b 100644 --- a/library/tk.tcl +++ b/library/tk.tcl @@ -1,18 +1,21 @@ # tk.tcl -- # -# Initialization script normally executed in the interpreter for each -# Tk-based application. Arranges class bindings for widgets. +# Initialization script normally executed in the interpreter for each Tk-based +# application. Arranges class bindings for widgets. # # Copyright (c) 1992-1994 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. # Copyright (c) 1998-2000 Ajuba Solutions. # -# See the file "license.terms" for information on usage and redistribution -# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. -# Insist on running with compatible versions of Tcl and Tk. -package require -exact Tk 8.4 -package require -exact Tcl 8.4 +package require Tcl 8.5 ;# Guard against [source] in an 8.4- interp before + ;# using 8.5 [package] features. +# Insist on running with compatible version of Tcl +package require Tcl 8.5.0 +# Verify that we have Tk binary and script components from the same release +package require -exact Tk 8.5.12 # Create a ::tk namespace namespace eval ::tk { @@ -20,10 +23,10 @@ namespace eval ::tk { namespace eval msgcat { namespace export mc mcmax if {[interp issafe] || [catch {package require msgcat}]} { - # The msgcat package is not available. Supply our own - # minimal replacement. + # The msgcat package is not available. Supply our own minimal + # replacement. proc mc {src args} { - return [eval [list format $src] $args] + return [format $src {*}$args] } proc mcmax {args} { set max 0 @@ -44,26 +47,33 @@ namespace eval ::tk { } namespace import ::tk::msgcat::* } +# and a ::ttk namespace +namespace eval ::ttk { + if {$::tk_library ne ""} { + # avoid file join to work in safe interps, but this is also x-plat ok + variable library $::tk_library/ttk + } +} -# Add Tk's directory to the end of the auto-load search path, if it +# Add Ttk & Tk's directory to the end of the auto-load search path, if it # isn't already on the path: -if {[info exists ::auto_path] && $::tk_library ne "" && \ - [lsearch -exact $::auto_path $::tk_library] < 0} { - lappend ::auto_path $::tk_library +if {[info exists ::auto_path] && ($::tk_library ne "") + && ($::tk_library ni $::auto_path)} { + lappend ::auto_path $::tk_library $::ttk::library } # Turn off strict Motif look and feel as a default. set ::tk_strictMotif 0 -# Turn on useinputmethods (X Input Methods) by default. -# We catch this because safe interpreters may not allow the call. +# Turn on useinputmethods (X Input Methods) by default. We catch this because +# safe interpreters may not allow the call. catch {tk useinputmethods 1} - + # ::tk::PlaceWindow -- -# place a toplevel at a particular position +# Place a toplevel at a particular position # Arguments: # toplevel name of toplevel window # ?placement? pointer ?center? ; places $w centered on the pointer @@ -77,12 +87,11 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { wm withdraw $w update idletasks set checkBounds 1 - set place_len [string length $place] if {$place eq ""} { set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}] set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] set checkBounds 0 - } elseif {[string equal -length $place_len $place "pointer"]} { + } elseif {[string equal -length [string length $place] $place "pointer"]} { ## place at POINTER (centered if $anchor == center) if {[string equal -length [string length $anchor] $anchor "center"]} { set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}] @@ -91,7 +100,7 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { set x [winfo pointerx $w] set y [winfo pointery $w] } - } elseif {[string equal -length $place_len $place "widget"] && \ + } elseif {[string equal -length [string length $place] $place "widget"] && \ [winfo exists $anchor] && [winfo ismapped $anchor]} { ## center about WIDGET $anchor, widget must be mapped set x [expr {[winfo rootx $anchor] + \ @@ -103,9 +112,6 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}] set checkBounds 0 } - - set windowingsystem [tk windowingsystem] - if {$checkBounds} { if {$x < [winfo vrootx $w]} { set x [winfo vrootx $w] @@ -117,7 +123,7 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { } elseif {$y > ([winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w])} { set y [expr {[winfo vrooty $w]+[winfo vrootheight $w]-[winfo reqheight $w]}] } - if {$windowingsystem eq "classic" || $windowingsystem eq "aqua"} { + if {[tk windowingsystem] eq "aqua"} { # Avoid the native menu bar which sits on top of everything. if {$y < 22} { set y 22 } } @@ -126,9 +132,9 @@ proc ::tk::PlaceWindow {w {place ""} {anchor ""}} { wm geometry $w +$x+$y wm deiconify $w } - + # ::tk::SetFocusGrab -- -# swap out current focus and grab temporarily (for dialogs) +# Swap out current focus and grab temporarily (for dialogs) # Arguments: # grab new window to grab # focus window to give focus to @@ -145,8 +151,8 @@ proc ::tk::SetFocusGrab {grab {focus {}}} { if {[winfo exists $oldGrab]} { lappend data [grab status $oldGrab] } - # The "grab" command will fail if another application - # already holds the grab. So catch it. + # The "grab" command will fail if another application already holds the + # grab. So catch it. catch {grab $grab} if {[winfo exists $focus]} { focus $focus @@ -154,7 +160,7 @@ proc ::tk::SetFocusGrab {grab {focus {}}} { } # ::tk::RestoreFocusGrab -- -# restore old focus and grab (for dialogs) +# Restore old focus and grab (for dialogs) # Arguments: # grab window that had taken grab # focus window that had taken focus @@ -186,12 +192,12 @@ proc ::tk::RestoreFocusGrab {grab focus {destroy destroy}} { } } } - + # ::tk::GetSelection -- -# This tries to obtain the default selection. On Unix, we first try -# and get a UTF8_STRING, a type supported by modern Unix apps for -# passing Unicode data safely. We fall back on the default STRING -# type otherwise. On Windows, only the STRING type is necessary. +# This tries to obtain the default selection. On Unix, we first try and get +# a UTF8_STRING, a type supported by modern Unix apps for passing Unicode +# data safely. We fall back on the default STRING type otherwise. On +# Windows, only the STRING type is necessary. # Arguments: # w The widget for which the selection will be retrieved. # Important for the -displayof property. @@ -218,18 +224,18 @@ if {[tk windowingsystem] ne "win32"} { } } } - + # ::tk::ScreenChanged -- -# This procedure is invoked by the binding mechanism whenever the -# "current" screen is changing. The procedure does two things. -# First, it uses "upvar" to make variable "::tk::Priv" point at an -# array variable that holds state for the current display. Second, -# it initializes the array if it didn't already exist. +# This procedure is invoked by the binding mechanism whenever the "current" +# screen is changing. The procedure does two things. First, it uses "upvar" +# to make variable "::tk::Priv" point at an array variable that holds state +# for the current display. Second, it initializes the array if it didn't +# already exist. # # Arguments: # screen - The name of the new screen. -proc ::tk::ScreenChanged screen { +proc ::tk::ScreenChanged {screen} { set x [string last . $screen] if {$x > 0} { set disp [string range $screen 0 [expr {$x - 1}]] @@ -242,7 +248,7 @@ proc ::tk::ScreenChanged screen { # display names. [Bug 2912473] set disp [string map {:: _doublecolon_} $disp] - uplevel #0 upvar #0 ::tk::Priv.$disp ::tk::Priv + uplevel #0 [list upvar #0 ::tk::Priv.$disp ::tk::Priv] variable ::tk::Priv global tcl_platform @@ -282,11 +288,10 @@ proc ::tk::ScreenChanged screen { # value, which will cause trouble later). tk::ScreenChanged [winfo screen .] - + # ::tk::EventMotifBindings -- -# This procedure is invoked as a trace whenever ::tk_strictMotif is -# changed. It is used to turn on or turn off the motif virtual -# bindings. +# This procedure is invoked as a trace whenever ::tk_strictMotif is changed. +# It is used to turn on or turn off the motif virtual bindings. # # Arguments: # n1 - the name of the variable being changed ("::tk_strictMotif"). @@ -305,119 +310,102 @@ proc ::tk::EventMotifBindings {n1 dummy dummy} { event $op <<Paste>> <Control-Key-y> event $op <<Undo>> <Control-underscore> } - + #---------------------------------------------------------------------- -# Define common dialogs on platforms where they are not implemented -# using compiled code. +# Define common dialogs on platforms where they are not implemented using +# compiled code. #---------------------------------------------------------------------- -if {[info commands tk_chooseColor] eq ""} { +if {![llength [info commands tk_chooseColor]]} { proc ::tk_chooseColor {args} { - return [eval tk::dialog::color:: $args] + return [tk::dialog::color:: {*}$args] } } -if {[info commands tk_getOpenFile] eq ""} { +if {![llength [info commands tk_getOpenFile]]} { proc ::tk_getOpenFile {args} { if {$::tk_strictMotif} { - return [eval tk::MotifFDialog open $args] + return [tk::MotifFDialog open {*}$args] } else { - return [eval ::tk::dialog::file:: open $args] + return [::tk::dialog::file:: open {*}$args] } } } -if {[info commands tk_getSaveFile] eq ""} { +if {![llength [info commands tk_getSaveFile]]} { proc ::tk_getSaveFile {args} { if {$::tk_strictMotif} { - return [eval tk::MotifFDialog save $args] + return [tk::MotifFDialog save {*}$args] } else { - return [eval ::tk::dialog::file:: save $args] + return [::tk::dialog::file:: save {*}$args] } } } -if {[info commands tk_messageBox] eq ""} { +if {![llength [info commands tk_messageBox]]} { proc ::tk_messageBox {args} { - return [eval tk::MessageBox $args] + return [tk::MessageBox {*}$args] } } -if {[info command tk_chooseDirectory] eq ""} { +if {![llength [info command tk_chooseDirectory]]} { proc ::tk_chooseDirectory {args} { - return [eval ::tk::dialog::file::chooseDir:: $args] + return [::tk::dialog::file::chooseDir:: {*}$args] } } - + #---------------------------------------------------------------------- # Define the set of common virtual events. #---------------------------------------------------------------------- -switch [tk windowingsystem] { +switch -exact -- [tk windowingsystem] { "x11" { - event add <<Cut>> <Control-Key-x> <Key-F20> - event add <<Copy>> <Control-Key-c> <Key-F16> - event add <<Paste>> <Control-Key-v> <Key-F18> + event add <<Cut>> <Control-Key-x> <Key-F20> <Control-Lock-Key-X> + event add <<Copy>> <Control-Key-c> <Key-F16> <Control-Lock-Key-C> + event add <<Paste>> <Control-Key-v> <Key-F18> <Control-Lock-Key-V> event add <<PasteSelection>> <ButtonRelease-2> - event add <<Undo>> <Control-Key-z> - event add <<Redo>> <Control-Key-Z> - # Some OS's define a goofy (as in, not <Shift-Tab>) keysym - # that is returned when the user presses <Shift-Tab>. In order for - # tab traversal to work, we have to add these keysyms to the - # PrevWindow event. - # We use catch just in case the keysym isn't recognized. - # This is needed for XFree86 systems + event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z> + event add <<Redo>> <Control-Key-Z> <Control-Lock-Key-z> + # Some OS's define a goofy (as in, not <Shift-Tab>) keysym that is + # returned when the user presses <Shift-Tab>. In order for tab + # traversal to work, we have to add these keysyms to the PrevWindow + # event. We use catch just in case the keysym isn't recognized. This + # is needed for XFree86 systems catch { event add <<PrevWindow>> <ISO_Left_Tab> } # This seems to be correct on *some* HP systems. catch { event add <<PrevWindow>> <hpBackTab> } trace add variable ::tk_strictMotif write ::tk::EventMotifBindings set ::tk_strictMotif $::tk_strictMotif - # On unix, we want to always display entry/text selection, - # regardless of which window has focus + # On unix, we want to always display entry/text selection, regardless + # of which window has focus set ::tk::AlwaysShowSelection 1 } "win32" { - event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> - event add <<Copy>> <Control-Key-c> <Control-Key-Insert> - event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> + event add <<Cut>> <Control-Key-x> <Shift-Key-Delete> \ + <Control-Lock-Key-X> + event add <<Copy>> <Control-Key-c> <Control-Key-Insert> \ + <Control-Lock-Key-C> + event add <<Paste>> <Control-Key-v> <Shift-Key-Insert> \ + <Control-Lock-Key-V> event add <<PasteSelection>> <ButtonRelease-2> - event add <<Undo>> <Control-Key-z> - event add <<Redo>> <Control-Key-y> + event add <<Undo>> <Control-Key-z> <Control-Lock-Key-Z> + event add <<Redo>> <Control-Key-y> <Control-Lock-Key-Y> } "aqua" { - event add <<Cut>> <Command-Key-x> <Key-F2> - event add <<Copy>> <Command-Key-c> <Key-F3> - event add <<Paste>> <Command-Key-v> <Key-F4> + event add <<Cut>> <Command-Key-x> <Key-F2> <Control-Lock-Key-X> + event add <<Copy>> <Command-Key-c> <Key-F3> <Control-Lock-Key-C> + event add <<Paste>> <Command-Key-v> <Key-F4> <Control-Lock-Key-V> event add <<PasteSelection>> <ButtonRelease-2> event add <<Clear>> <Clear> - event add <<Undo>> <Command-Key-z> - event add <<Redo>> <Command-Key-y> - } - "classic" { - event add <<Cut>> <Control-Key-x> <Key-F2> - event add <<Copy>> <Control-Key-c> <Key-F3> - event add <<Paste>> <Control-Key-v> <Key-F4> - event add <<PasteSelection>> <ButtonRelease-2> - event add <<Clear>> <Clear> - event add <<Undo>> <Control-Key-z> <Key-F1> - event add <<Redo>> <Control-Key-Z> + event add <<Undo>> <Command-Key-z> <Control-Lock-Key-Z> + event add <<Redo>> <Command-Key-y> <Control-Lock-Key-Y> } } + # ---------------------------------------------------------------------- # Read in files that define all of the class bindings. # ---------------------------------------------------------------------- if {$::tk_library ne ""} { - if {[tk windowingsystem] eq "classic"} { - proc ::tk::SourceLibFile {file} { - if {[catch { - namespace eval :: \ - [list source [file join $::tk_library $file.tcl]] - }]} { - namespace eval :: [list source -rsrc $file] - } - } - } else { - proc ::tk::SourceLibFile {file} { - namespace eval :: [list source [file join $::tk_library $file.tcl]] - } + proc ::tk::SourceLibFile {file} { + namespace eval :: [list source [file join $::tk_library $file.tcl]] } namespace eval ::tk { SourceLibFile button @@ -431,6 +419,7 @@ if {$::tk_library ne ""} { SourceLibFile text } } + # ---------------------------------------------------------------------- # Default bindings for keyboard traversal. # ---------------------------------------------------------------------- @@ -438,12 +427,11 @@ if {$::tk_library ne ""} { event add <<PrevWindow>> <Shift-Tab> bind all <Tab> {tk::TabToWindow [tk_focusNext %W]} bind all <<PrevWindow>> {tk::TabToWindow [tk_focusPrev %W]} - + # ::tk::CancelRepeat -- -# This procedure is invoked to cancel an auto-repeat action described -# by ::tk::Priv(afterId). It's used by several widgets to auto-scroll -# the widget when the mouse is dragged out of the widget with a -# button pressed. +# This procedure is invoked to cancel an auto-repeat action described by +# ::tk::Priv(afterId). It's used by several widgets to auto-scroll the widget +# when the mouse is dragged out of the widget with a button pressed. # # Arguments: # None. @@ -453,102 +441,103 @@ proc ::tk::CancelRepeat {} { after cancel $Priv(afterId) set Priv(afterId) {} } - + # ::tk::TabToWindow -- -# This procedure moves the focus to the given widget. If the widget -# is an entry or a spinbox, it selects the entire contents of the widget. +# This procedure moves the focus to the given widget. +# It sends a <<TraverseOut>> virtual event to the previous focus window, if +# any, before changing the focus, and a <<TraverseIn>> event to the new focus +# window afterwards. # # Arguments: # w - Window to which focus should be set. proc ::tk::TabToWindow {w} { - set wclass [winfo class $w] - - if {$wclass eq "Entry" || $wclass eq "Spinbox"} { - $w selection range 0 end - $w icursor end + set focus [focus] + if {$focus ne ""} { + event generate $focus <<TraverseOut>> } focus $w + event generate $w <<TraverseIn>> } - + # ::tk::UnderlineAmpersand -- -# This procedure takes some text with ampersand and returns -# text w/o ampersand and position of the ampersand. -# Double ampersands are converted to single ones. -# Position returned is -1 when there is no ampersand. +# This procedure takes some text with ampersand and returns text w/o ampersand +# and position of the ampersand. Double ampersands are converted to single +# ones. Position returned is -1 when there is no ampersand. # proc ::tk::UnderlineAmpersand {text} { - set idx [string first "&" $text] - if {$idx >= 0} { - set underline $idx - # ignore "&&" - while {[string match "&" [string index $text [expr {$idx + 1}]]]} { - set base [expr {$idx + 2}] - set idx [string first "&" [string range $text $base end]] - if {$idx < 0} { - break - } else { - set underline [expr {$underline + $idx + 1}] - incr idx $base - } - } - } - if {$idx >= 0} { - regsub -all -- {&([^&])} $text {\1} text - } - return [list $text $idx] + set s [string map {&& & & \ufeff} $text] + set idx [string first \ufeff $s] + return [list [string map {\ufeff {}} $s] $idx] } # ::tk::SetAmpText -- -# Given widget path and text with "magic ampersands", -# sets -text and -underline options for the widget +# Given widget path and text with "magic ampersands", sets -text and +# -underline options for the widget # proc ::tk::SetAmpText {widget text} { - foreach {newtext under} [::tk::UnderlineAmpersand $text] { - $widget configure -text $newtext -underline $under - } + lassign [UnderlineAmpersand $text] newtext under + $widget configure -text $newtext -underline $under } # ::tk::AmpWidget -- -# Creates new widget, turning -text option into -text and -# -underline options, returned by ::tk::UnderlineAmpersand. +# Creates new widget, turning -text option into -text and -underline options, +# returned by ::tk::UnderlineAmpersand. # proc ::tk::AmpWidget {class path args} { - set wcmd [list $class $path] + set options {} foreach {opt val} $args { if {$opt eq "-text"} { - foreach {newtext under} [::tk::UnderlineAmpersand $val] { - lappend wcmd -text $newtext -underline $under - } + lassign [UnderlineAmpersand $val] newtext under + lappend options -text $newtext -underline $under } else { - lappend wcmd $opt $val + lappend options $opt $val } } - eval $wcmd - if {$class eq "button"} { + set result [$class $path {*}$options] + if {[string match "*button" $class]} { bind $path <<AltUnderlined>> [list $path invoke] } - return $path + return $result } +# ::tk::AmpMenuArgs -- +# Processes arguments for a menu entry, turning -label option into -label and +# -underline options, returned by ::tk::UnderlineAmpersand. +# +proc ::tk::AmpMenuArgs {widget add type args} { + set options {} + foreach {opt val} $args { + if {$opt eq "-label"} { + lassign [UnderlineAmpersand $val] newlabel under + lappend options -label $newlabel -underline $under + } else { + lappend options $opt $val + } + } + $widget add $type {*}$options +} + # ::tk::FindAltKeyTarget -- -# search recursively through the hierarchy of visible widgets -# to find button or label which has $char as underlined character +# Search recursively through the hierarchy of visible widgets to find button +# or label which has $char as underlined character # proc ::tk::FindAltKeyTarget {path char} { - switch [winfo class $path] { - Button - - Label { + switch -- [winfo class $path] { + Button - Label - + TButton - TLabel - TCheckbutton { if {[string equal -nocase $char \ - [string index [$path cget -text] \ - [$path cget -underline]]]} {return $path} else {return {}} + [string index [$path cget -text] [$path cget -underline]]]} { + return $path + } else { + return {} + } } default { - foreach child \ - [concat [grid slaves $path] \ - [pack slaves $path] \ - [place slaves $path] ] { - if {"" ne [set target [::tk::FindAltKeyTarget $child $char]]} { + foreach child [concat [grid slaves $path] \ + [pack slaves $path] [place slaves $path]] { + set target [FindAltKeyTarget $child $char] + if {$target ne ""} { return $target } } @@ -558,15 +547,15 @@ proc ::tk::FindAltKeyTarget {path char} { } # ::tk::AltKeyInDialog -- -# <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>> -# to button or label which has appropriate underlined character +# <Alt-Key> event handler for standard dialogs. Sends <<AltUnderlined>> to +# button or label which has appropriate underlined character # proc ::tk::AltKeyInDialog {path key} { - set target [::tk::FindAltKeyTarget $path $key] + set target [FindAltKeyTarget $path $key] if { $target eq ""} return event generate $target <<AltUnderlined>> } - + # ::tk::mcmaxamp -- # Replacement for mcmax, used for texts with "magic ampersand" in it. # @@ -574,17 +563,30 @@ proc ::tk::AltKeyInDialog {path key} { proc ::tk::mcmaxamp {args} { set maxlen 0 foreach arg $args { - set length [string length [lindex [::tk::UnderlineAmpersand [mc $arg]] 0]] - if {$length>$maxlen} { + # Should we run [mc] in caller's namespace? + lassign [UnderlineAmpersand [mc $arg]] msg + set length [string length $msg] + if {$length > $maxlen} { set maxlen $length } } return $maxlen } + # For now, turn off the custom mdef proc for the mac: if {[tk windowingsystem] eq "aqua"} { namespace eval ::tk::mac { - set useCustomMDEF 0 + variable useCustomMDEF 0 } } + +# Run the Ttk themed widget set initialization +if {$::ttk::library ne ""} { + uplevel \#0 [list source [file join $::ttk::library ttk.tcl]] +} + +# Local Variables: +# mode: tcl +# fill-column: 78 +# End: diff --git a/library/tkfbox.tcl b/library/tkfbox.tcl index bf6cf87..bbea5c6 100644 --- a/library/tkfbox.tcl +++ b/library/tkfbox.tcl @@ -17,11 +17,13 @@ # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # +package require Ttk + #---------------------------------------------------------------------- # # I C O N L I S T # -# This is a pseudo-widget that implements the icon list inside the +# This is a pseudo-widget that implements the icon list inside the # ::tk::dialog::file:: dialog box. # #---------------------------------------------------------------------- @@ -36,15 +38,16 @@ proc ::tk::IconList {w args} { } proc ::tk::IconList_Index {w i} { - upvar #0 ::tk::$w data - upvar #0 ::tk::$w:itemList itemList - if {![info exists data(list)]} {set data(list) {}} + upvar #0 ::tk::$w data ::tk::$w:itemList itemList + if {![info exists data(list)]} { + set data(list) {} + } switch -regexp -- $i { "^-?[0-9]+$" { - if { $i < 0 } { + if {$i < 0} { set i 0 } - if { $i >= [llength $data(list)] } { + if {$i >= [llength $data(list)]} { set i [expr {[llength $data(list)] - 1}] } return $i @@ -62,7 +65,8 @@ proc ::tk::IconList_Index {w i} { foreach {x y} [scan $i "@%d,%d"] { break } - set item [$data(canvas) find closest $x $y] + set item [$data(canvas) find closest \ + [$data(canvas) canvasx $x] [$data(canvas) canvasy $y]] return [lindex [$data(canvas) itemcget $item -tags] 1] } } @@ -72,18 +76,18 @@ proc ::tk::IconList_Selection {w op args} { upvar ::tk::$w data switch -exact -- $op { "anchor" { - if { [llength $args] == 1 } { + if {[llength $args] == 1} { set data(index,anchor) [tk::IconList_Index $w [lindex $args 0]] } else { return $data(index,anchor) } } "clear" { - if { [llength $args] == 2 } { + if {[llength $args] == 2} { foreach {first last} $args { break } - } elseif { [llength $args] == 1 } { + } elseif {[llength $args] == 1} { set first [set last [lindex $args 0]] } else { error "wrong # args: should be [lindex [info level 0] 0] path\ @@ -91,7 +95,7 @@ proc ::tk::IconList_Selection {w op args} { } set first [IconList_Index $w $first] set last [IconList_Index $w $last] - if { $first > $last } { + if {$first > $last} { set tmp $first set first $last set last $tmp @@ -102,6 +106,7 @@ proc ::tk::IconList_Selection {w op args} { set first $ind break } + incr ind } set ind [expr {[llength $data(selection)] - 1}] for {} {$ind >= 0} {incr ind -1} { @@ -152,7 +157,7 @@ proc ::tk::IconList_Selection {w op args} { } } -proc ::tk::IconList_Curselection {w} { +proc ::tk::IconList_CurSelection {w} { upvar ::tk::$w data return $data(selection) } @@ -162,6 +167,10 @@ proc ::tk::IconList_DrawSelection {w} { upvar ::tk::$w:itemList itemList $data(canvas) delete selection + $data(canvas) itemconfigure selectionText -fill black + $data(canvas) dtag selectionText + set cbg [ttk::style lookup TEntry -selectbackground focus] + set cfg [ttk::style lookup TEntry -selectforeground focus] foreach item $data(selection) { set rTag [lindex [lindex $data(list) $item] 2] foreach {iTag tTag text serial} $itemList($rTag) { @@ -169,8 +178,9 @@ proc ::tk::IconList_DrawSelection {w} { } set bbox [$data(canvas) bbox $tTag] - $data(canvas) create rect $bbox -fill \#a0a0ff -outline \#a0a0ff \ + $data(canvas) create rect $bbox -fill $cbg -outline $cbg \ -tags selection + $data(canvas) itemconfigure $tTag -fill $cfg -tags selectionText } $data(canvas) lower selection return @@ -214,13 +224,15 @@ proc ::tk::IconList_Config {w argList} { proc ::tk::IconList_Create {w} { upvar ::tk::$w data - frame $w - set data(sbar) [scrollbar $w.sbar -orient horizontal -takefocus 0] + ttk::frame $w + ttk::entry $w.cHull -takefocus 0 -cursor {} + set data(sbar) [ttk::scrollbar $w.cHull.sbar -orient horizontal -takefocus 0] catch {$data(sbar) configure -highlightthickness 0} - set data(canvas) [canvas $w.canvas -bd 2 -relief sunken \ - -width 400 -height 120 -takefocus 1] - pack $data(sbar) -side bottom -fill x -padx 2 - pack $data(canvas) -expand yes -fill both + set data(canvas) [canvas $w.cHull.canvas -highlightthick 0 \ + -width 400 -height 120 -takefocus 1 -background white] + pack $data(sbar) -side bottom -fill x -padx 2 -in $w.cHull -pady {0 2} + pack $data(canvas) -expand yes -fill both -padx 2 -pady {2 0} + pack $w.cHull -expand yes -fill both -ipadx 2 -ipady 2 $data(sbar) configure -command [list $data(canvas) xview] $data(canvas) configure -xscrollcommand [list $data(sbar) set] @@ -232,7 +244,6 @@ proc ::tk::IconList_Create {w} { set data(maxTW) 1 set data(maxTH) 1 set data(numItems) 0 - set data(curItem) {} set data(noScroll) 1 set data(selection) {} set data(index,anchor) "" @@ -257,6 +268,10 @@ proc ::tk::IconList_Create {w} { bind $data(canvas) <Double-ButtonRelease-1> \ [list tk::IconList_Double1 $w %x %y] + bind $data(canvas) <Control-B1-Motion> {;} + bind $data(canvas) <Shift-B1-Motion> \ + [list tk::IconList_ShiftMotion1 $w %x %y] + bind $data(canvas) <Up> [list tk::IconList_UpDown $w -1] bind $data(canvas) <Down> [list tk::IconList_UpDown $w 1] bind $data(canvas) <Left> [list tk::IconList_LeftRight $w -1] @@ -324,7 +339,6 @@ proc ::tk::IconList_DeleteAll {w} { set data(maxTW) 1 set data(maxTH) 1 set data(numItems) 0 - set data(curItem) {} set data(noScroll) 1 set data(selection) {} set data(index,anchor) "" @@ -347,7 +361,7 @@ proc ::tk::IconList_Add {w image items} { -tags [list text $data(numItems) item$data(numItems)]] set rTag [$data(canvas) create rect 0 0 0 0 -fill "" -outline "" \ -tags [list rect $data(numItems) item$data(numItems)]] - + foreach {x1 y1 x2 y2} [$data(canvas) bbox $iTag] { break } @@ -359,7 +373,7 @@ proc ::tk::IconList_Add {w image items} { if {$data(maxIH) < $iH} { set data(maxIH) $iH } - + foreach {x1 y1 x2 y2} [$data(canvas) bbox $tTag] { break } @@ -371,7 +385,7 @@ proc ::tk::IconList_Add {w image items} { if {$data(maxTH) < $tH} { set data(maxTH) $tH } - + lappend data(list) [list $iTag $tTag $rTag $iW $iH $tW \ $tH $data(numItems)] set itemList($rTag) [list $iTag $tTag $text $data(numItems)] @@ -459,9 +473,7 @@ proc ::tk::IconList_Arrange {w} { set data(itemsPerColumn) 1 } - if {$data(curItem) ne ""} { - IconList_Select $w [lindex [lindex $data(list) $data(curItem)] 2] 0 - } + IconList_DrawSelection $w } # Gets called when the user invokes the IconList (usually by double-clicking @@ -531,10 +543,10 @@ proc ::tk::IconList_Btn1 {w x y} { upvar ::tk::$w data focus $data(canvas) - set x [expr {int([$data(canvas) canvasx $x])}] - set y [expr {int([$data(canvas) canvasy $y])}] - set i [IconList_Index $w @${x},${y}] - if {$i eq ""} return + set i [IconList_Index $w @$x,$y] + if {$i eq ""} { + return + } IconList_Selection $w clear 0 end IconList_Selection $w set $i IconList_Selection $w anchor $i @@ -542,13 +554,13 @@ proc ::tk::IconList_Btn1 {w x y} { proc ::tk::IconList_CtrlBtn1 {w x y} { upvar ::tk::$w data - + if { $data(-multiple) } { focus $data(canvas) - set x [expr {int([$data(canvas) canvasx $x])}] - set y [expr {int([$data(canvas) canvasy $y])}] - set i [IconList_Index $w @${x},${y}] - if {$i eq ""} return + set i [IconList_Index $w @$x,$y] + if {$i eq ""} { + return + } if { [IconList_Selection $w includes $i] } { IconList_Selection $w clear $i } else { @@ -560,37 +572,48 @@ proc ::tk::IconList_CtrlBtn1 {w x y} { proc ::tk::IconList_ShiftBtn1 {w x y} { upvar ::tk::$w data - + if { $data(-multiple) } { focus $data(canvas) - set x [expr {int([$data(canvas) canvasx $x])}] - set y [expr {int([$data(canvas) canvasy $y])}] - set i [IconList_Index $w @${x},${y}] - if {$i eq ""} return - set a [IconList_Index $w anchor] - if { $a eq "" } { - set a $i + set i [IconList_Index $w @$x,$y] + if {$i eq ""} { + return + } + if {[IconList_Index $w anchor] eq ""} { + IconList_Selection $w anchor $i } IconList_Selection $w clear 0 end - IconList_Selection $w set $a $i + IconList_Selection $w set anchor $i } } # Gets called on button-1 motions # proc ::tk::IconList_Motion1 {w x y} { - upvar ::tk::$w data variable ::tk::Priv set Priv(x) $x set Priv(y) $y - set x [expr {int([$data(canvas) canvasx $x])}] - set y [expr {int([$data(canvas) canvasy $y])}] - set i [IconList_Index $w @${x},${y}] - if {$i eq ""} return + set i [IconList_Index $w @$x,$y] + if {$i eq ""} { + return + } IconList_Selection $w clear 0 end IconList_Selection $w set $i } +proc ::tk::IconList_ShiftMotion1 {w x y} { + upvar ::tk::$w data + variable ::tk::Priv + set Priv(x) $x + set Priv(y) $y + set i [IconList_Index $w @$x,$y] + if {$i eq ""} { + return + } + IconList_Selection $w clear 0 end + IconList_Selection $w set anchor $i +} + proc ::tk::IconList_Double1 {w x y} { upvar ::tk::$w data @@ -614,6 +637,7 @@ proc ::tk::IconList_Leave1 {w x y} { proc ::tk::IconList_FocusIn {w} { upvar ::tk::$w data + $w.cHull state focus if {![info exists data(list)]} { return } @@ -624,6 +648,7 @@ proc ::tk::IconList_FocusIn {w} { } proc ::tk::IconList_FocusOut {w} { + $w.cHull state !focus IconList_Selection $w clear 0 end } @@ -642,12 +667,14 @@ proc ::tk::IconList_UpDown {w amount} { return } - set curr [tk::IconList_Curselection $w] + set curr [tk::IconList_CurSelection $w] if { [llength $curr] == 0 } { set i 0 } else { set i [tk::IconList_Index $w anchor] - if {$i eq ""} return + if {$i eq ""} { + return + } incr i $amount } IconList_Selection $w clear 0 end @@ -671,12 +698,14 @@ proc ::tk::IconList_LeftRight {w amount} { return } - set curr [IconList_Curselection $w] + set curr [IconList_CurSelection $w] if { [llength $curr] == 0 } { set i 0 } else { set i [IconList_Index $w anchor] - if {$i eq ""} return + if {$i eq ""} { + return + } incr i [expr {$amount*$data(itemsPerColumn)}] } IconList_Selection $w clear 0 end @@ -716,24 +745,22 @@ proc ::tk::IconList_Goto {w text} { return } - if {$data(curItem) eq "" || $data(curItem) == 0} { - set start 0 + if {[llength [IconList_CurSelection $w]]} { + set start [IconList_Index $w anchor] } else { - set start $data(curItem) + set start 0 } - set text [string tolower $text] set theIndex -1 set less 0 set len [string length $text] set len0 [expr {$len-1}] set i $start - # Search forward until we find a filename whose prefix is an exact match - # with $text + # Search forward until we find a filename whose prefix is a + # case-insensitive match with $text while {1} { - set sub [string range $textList($i) 0 $len0] - if {$text eq $sub} { + if {[string equal -nocase -length $len0 $textList($i) $text]} { set theIndex $i break } @@ -789,34 +816,34 @@ proc ::tk::dialog::file:: {type args} { set dataName __tk_filedialog upvar ::tk::dialog::file::$dataName data - ::tk::dialog::file::Config $dataName $type $args + Config $dataName $type $args if {$data(-parent) eq "."} { - set w .$dataName + set w .$dataName } else { - set w $data(-parent).$dataName + set w $data(-parent).$dataName } # (re)create the dialog box if necessary # if {![winfo exists $w]} { - ::tk::dialog::file::Create $w TkFDialog + Create $w TkFDialog } elseif {[winfo class $w] ne "TkFDialog"} { destroy $w - ::tk::dialog::file::Create $w TkFDialog + Create $w TkFDialog } else { - set data(dirMenuBtn) $w.f1.menu - set data(dirMenu) $w.f1.menu.menu - set data(upBtn) $w.f1.up - set data(icons) $w.icons - set data(ent) $w.f2.ent - set data(typeMenuLab) $w.f2.lab2 - set data(typeMenuBtn) $w.f2.menu + set data(dirMenuBtn) $w.contents.f1.menu + set data(dirMenu) $w.contents.f1.menu.menu + set data(upBtn) $w.contents.f1.up + set data(icons) $w.contents.icons + set data(ent) $w.contents.f2.ent + set data(typeMenuLab) $w.contents.f2.lab2 + set data(typeMenuBtn) $w.contents.f2.menu set data(typeMenu) $data(typeMenuBtn).m - set data(okBtn) $w.f2.ok - set data(cancelBtn) $w.f2.cancel - set data(hiddenBtn) $w.f2.hidden - ::tk::dialog::file::SetSelectMode $w $data(-multiple) + set data(okBtn) $w.contents.f2.ok + set data(cancelBtn) $w.contents.f2.cancel + set data(hiddenBtn) $w.contents.f2.hidden + SetSelectMode $w $data(-multiple) } if {$::tk::dialog::file::showHiddenBtn} { $data(hiddenBtn) configure -state normal @@ -843,21 +870,39 @@ proc ::tk::dialog::file:: {type args} { # Add traces on the selectPath variable # - trace add variable data(selectPath) write [list ::tk::dialog::file::SetPath $w] + trace add variable data(selectPath) write \ + [list ::tk::dialog::file::SetPath $w] $data(dirMenuBtn) configure \ -textvariable ::tk::dialog::file::${dataName}(selectPath) + # Cleanup previous menu + # + $data(typeMenu) delete 0 end + $data(typeMenuBtn) configure -state normal -text "" + # Initialize the file types menu # if {[llength $data(-filetypes)]} { - $data(typeMenu) delete 0 end + # Default type and name to first entry + set initialtype [lindex $data(-filetypes) 0] + set initialTypeName [lindex $initialtype 0] + if {$data(-typevariable) ne ""} { + upvar #0 $data(-typevariable) typeVariable + if {[info exists typeVariable]} { + set initialTypeName $typeVariable + } + } foreach type $data(-filetypes) { set title [lindex $type 0] set filter [lindex $type 1] $data(typeMenu) add command -label $title \ -command [list ::tk::dialog::file::SetFilter $w $type] + # string first avoids glob-pattern char issues + if {[string first ${initialTypeName} $title] == 0} { + set initialtype $type + } } - ::tk::dialog::file::SetFilter $w [lindex $data(-filetypes) 0] + SetFilter $w $initialtype $data(typeMenuBtn) configure -state normal $data(typeMenuLab) configure -state normal } else { @@ -865,7 +910,7 @@ proc ::tk::dialog::file:: {type args} { $data(typeMenuBtn) configure -state disabled -takefocus 0 $data(typeMenuLab) configure -state disabled } - ::tk::dialog::file::UpdateWhenIdle $w + UpdateWhenIdle $w # Withdraw the window, then update all the geometry information # so we know how big it wants to be, then center the window in the @@ -929,14 +974,21 @@ proc ::tk::dialog::file::Config {dataName type argList} { {-initialfile "" "" ""} {-parent "" "" "."} {-title "" "" ""} + {-typevariable "" "" ""} } # The "-multiple" option is only available for the "open" file dialog. # - if { $type eq "open" } { + if {$type eq "open"} { lappend specs {-multiple "" "" "0"} } + # The "-confirmoverwrite" option is only for the "save" file dialog. + # + if {$type eq "save"} { + lappend specs {-confirmoverwrite "" "" "1"} + } + # 2: default values depending on the type of the dialog # if {![info exists data(selectPath)]} { @@ -951,9 +1003,9 @@ proc ::tk::dialog::file::Config {dataName type argList} { if {$data(-title) eq ""} { if {$type eq "open"} { - set data(-title) "[mc "Open"]" + set data(-title) [mc "Open"] } else { - set data(-title) "[mc "Save As"]" + set data(-title) [mc "Save As"] } } @@ -985,8 +1037,8 @@ proc ::tk::dialog::file::Config {dataName type argList} { # like "yes") so we can use it in tests more easily. if {$type eq "save"} { set data(-multiple) 0 - } elseif {$data(-multiple)} { - set data(-multiple) 1 + } elseif {$data(-multiple)} { + set data(-multiple) 1 } else { set data(-multiple) 0 } @@ -1000,16 +1052,25 @@ proc ::tk::dialog::file::Create {w class} { toplevel $w -class $class if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog} + pack [ttk::frame $w.contents] -expand 1 -fill both + #set w $w.contents # f1: the frame with the directory option menu # - set f1 [frame $w.f1] - bind [::tk::AmpWidget label $f1.lab -text "[mc "&Directory:"]" ] \ - <<AltUnderlined>> [list focus $f1.menu] - + set f1 [ttk::frame $w.contents.f1] + bind [::tk::AmpWidget ttk::label $f1.lab -text [mc "&Directory:"]] \ + <<AltUnderlined>> [list focus $f1.menu] + set data(dirMenuBtn) $f1.menu - set data(dirMenu) [tk_optionMenu $f1.menu [format %s(selectPath) ::tk::dialog::file::$dataName] ""] - set data(upBtn) [button $f1.up] + if {![info exists data(selectPath)]} { + set data(selectPath) "" + } + set data(dirMenu) $f1.menu.menu + ttk::menubutton $f1.menu -menu $data(dirMenu) -direction flush \ + -textvariable [format %s(selectPath) ::tk::dialog::file::$dataName] + [menu $data(dirMenu) -tearoff 0] add radiobutton -label "" -variable \ + [format %s(selectPath) ::tk::dialog::file::$dataName] + set data(upBtn) [ttk::button $f1.up] if {![info exists Priv(updirImage)]} { set Priv(updirImage) [image create bitmap -data { #define updir_width 28 @@ -1024,7 +1085,7 @@ static char updir_bits[] = { } $data(upBtn) configure -image $Priv(updirImage) - $f1.menu configure -takefocus 1 -highlightthickness 2 + $f1.menu configure -takefocus 1;# -highlightthickness 2 pack $data(upBtn) -side right -padx 4 -fill both pack $f1.lab -side left -padx 4 -fill both @@ -1032,7 +1093,7 @@ static char updir_bits[] = { # data(icons): the IconList that list the files and directories. # - if { $class eq "TkFDialog" } { + if {$class eq "TkFDialog"} { if { $data(-multiple) } { set fNameCaption [mc "File &names:"] } else { @@ -1044,34 +1105,35 @@ static char updir_bits[] = { set fNameCaption [mc "&Selection:"] set iconListCommand [list ::tk::dialog::file::chooseDir::DblClick $w] } - set data(icons) [::tk::IconList $w.icons \ - -command $iconListCommand \ - -multiple $data(-multiple)] + set data(icons) [::tk::IconList $w.contents.icons \ + -command $iconListCommand -multiple $data(-multiple)] bind $data(icons) <<ListboxSelect>> \ [list ::tk::dialog::file::ListBrowse $w] # f2: the frame with the OK button, cancel button, "file name" field # and file types field. # - set f2 [frame $w.f2 -bd 0] - bind [::tk::AmpWidget label $f2.lab -text $fNameCaption -anchor e -pady 0]\ + set f2 [ttk::frame $w.contents.f2] + bind [::tk::AmpWidget ttk::label $f2.lab -text $fNameCaption -anchor e]\ <<AltUnderlined>> [list focus $f2.ent] - set data(ent) [entry $f2.ent] + # -pady 0 + set data(ent) [ttk::entry $f2.ent] # The font to use for the icons. The default Canvas font on Unix # is just deviant. - set ::tk::$w.icons(font) [$data(ent) cget -font] + set ::tk::$w.contents.icons(font) [$data(ent) cget -font] # Make the file types bits only if this is a File Dialog - if { $class eq "TkFDialog" } { - set data(typeMenuLab) [::tk::AmpWidget label $f2.lab2 \ - -text $fTypeCaption -anchor e -pady [$f2.lab cget -pady]] - set data(typeMenuBtn) [menubutton $f2.menu -indicatoron 1 \ + if {$class eq "TkFDialog"} { + set data(typeMenuLab) [::tk::AmpWidget ttk::label $f2.lab2 \ + -text $fTypeCaption -anchor e] + # -pady [$f2.lab cget -pady] + set data(typeMenuBtn) [ttk::menubutton $f2.menu \ -menu $f2.menu.m] + # -indicatoron 1 set data(typeMenu) [menu $data(typeMenuBtn).m -tearoff 0] - $data(typeMenuBtn) configure -takefocus 1 -highlightthickness 2 \ - -relief raised -bd 2 -anchor w - bind $data(typeMenuLab) <<AltUnderlined>> [list \ + # $data(typeMenuBtn) configure -takefocus 1 -relief raised -anchor w + bind $data(typeMenuLab) <<AltUnderlined>> [list \ focus $data(typeMenuBtn)] } @@ -1083,10 +1145,11 @@ static char updir_bits[] = { } else { set text [mc "Show &Hidden Directories"] } - set data(hiddenBtn) [::tk::AmpWidget checkbutton $f2.hidden \ - -text $text -anchor w -padx 3 -state disabled \ + set data(hiddenBtn) [::tk::AmpWidget ttk::checkbutton $f2.hidden \ + -text $text -state disabled \ -variable ::tk::dialog::file::showHiddenVar \ -command [list ::tk::dialog::file::UpdateWhenIdle $w]] +# -anchor w -padx 3 # the okBtn is created after the typeMenu so that the keyboard traversal # is in the right order, and add binding so that we find out when the @@ -1094,17 +1157,17 @@ static char updir_bits[] = { # window so no confusion about how much <Destroy> gets called; exactly # once will do). [Bug 987169] - set data(okBtn) [::tk::AmpWidget button $f2.ok \ - -text [mc "&OK"] -default active -pady 3] + set data(okBtn) [::tk::AmpWidget ttk::button $f2.ok \ + -text [mc "&OK"] -default active];# -pady 3] bind $data(okBtn) <Destroy> [list ::tk::dialog::file::Destroyed $w] - set data(cancelBtn) [::tk::AmpWidget button $f2.cancel \ - -text [mc "&Cancel"] -default normal -pady 3] + set data(cancelBtn) [::tk::AmpWidget ttk::button $f2.cancel \ + -text [mc "&Cancel"] -default normal];# -pady 3] # grid the widgets in f2 # - grid $f2.lab $f2.ent $data(okBtn) -padx 4 -sticky ew + grid $f2.lab $f2.ent $data(okBtn) -padx 4 -pady 3 -sticky ew grid configure $f2.ent -padx 2 - if { $class eq "TkFDialog" } { + if {$class eq "TkFDialog"} { grid $data(typeMenuLab) $data(typeMenuBtn) $data(cancelBtn) \ -padx 4 -sticky ew grid configure $data(typeMenuBtn) -padx 0 @@ -1117,7 +1180,7 @@ static char updir_bits[] = { # Pack all the frames together. We are done with widget construction. # pack $f1 -side top -fill x -pady 4 - pack $f2 -side bottom -fill x + pack $f2 -side bottom -pady 4 -fill x pack $data(icons) -expand yes -fill both -padx 4 -pady 1 # Set up the event handlers that are common to Directory and File Dialogs @@ -1126,12 +1189,12 @@ static char updir_bits[] = { wm protocol $w WM_DELETE_WINDOW [list ::tk::dialog::file::CancelCmd $w] $data(upBtn) configure -command [list ::tk::dialog::file::UpDirCmd $w] $data(cancelBtn) configure -command [list ::tk::dialog::file::CancelCmd $w] - bind $w <KeyPress-Escape> [list tk::ButtonInvoke $data(cancelBtn)] + bind $w <KeyPress-Escape> [list $data(cancelBtn) invoke] bind $w <Alt-Key> [list tk::AltKeyInDialog $w %A] # Set up event handlers specific to File or Directory Dialogs # - if { $class eq "TkFDialog" } { + if {$class eq "TkFDialog"} { bind $data(ent) <Return> [list ::tk::dialog::file::ActivateEnt $w] $data(okBtn) configure -command [list ::tk::dialog::file::OkCmd $w] bind $w <Alt-t> [format { @@ -1144,15 +1207,18 @@ static char updir_bits[] = { bind $data(ent) <Return> $okCmd $data(okBtn) configure -command $okCmd bind $w <Alt-s> [list focus $data(ent)] - bind $w <Alt-o> [list tk::ButtonInvoke $data(okBtn)] + bind $w <Alt-o> [list $data(okBtn) invoke] } bind $w <Alt-h> [list $data(hiddenBtn) invoke] + bind $data(ent) <Tab> [list ::tk::dialog::file::CompleteEnt $w] # Build the focus group for all the entries # ::tk::FocusGroup_Create $w - ::tk::FocusGroup_BindIn $w $data(ent) [list ::tk::dialog::file::EntFocusIn $w] - ::tk::FocusGroup_BindOut $w $data(ent) [list ::tk::dialog::file::EntFocusOut $w] + ::tk::FocusGroup_BindIn $w $data(ent) [list \ + ::tk::dialog::file::EntFocusIn $w] + ::tk::FocusGroup_BindOut $w $data(ent) [list \ + ::tk::dialog::file::EntFocusOut $w] } # ::tk::dialog::file::SetSelectMode -- @@ -1170,12 +1236,12 @@ proc ::tk::dialog::file::SetSelectMode {w multi} { set dataName __tk_filedialog upvar ::tk::dialog::file::$dataName data if { $multi } { - set fNameCaption "[mc {File &names:}]" + set fNameCaption [mc "File &names:"] } else { - set fNameCaption "[mc {File &name:}]" + set fNameCaption [mc "File &name:"] } set iconListCommand [list ::tk::dialog::file::OkCmd $w] - ::tk::SetAmpText $w.f2.lab $fNameCaption + ::tk::SetAmpText $w.contents.f2.lab $fNameCaption ::tk::IconList_Config $data(icons) \ [list -multiple $multi -command $iconListCommand] return @@ -1242,7 +1308,7 @@ rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] # we normally won't come to here. Anyways, give an error and abort # action. tk_messageBox -type ok -parent $w -icon warning -message \ - [mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $data(selectPath)] + [mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $data(selectPath)] cd $appPWD return } @@ -1279,10 +1345,12 @@ rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] # but 'd'irectory type files. # set cmd [list glob -tails -directory [pwd] \ - -type {f b c l p s} -nocomplain] + -type {f b c l p s} -nocomplain] if {$data(filter) eq "*"} { lappend cmd * - if {$showHidden} { lappend cmd .* } + if {$showHidden} { + lappend cmd .* + } } else { eval [list lappend cmd] $data(filter) } @@ -1311,7 +1379,7 @@ rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] # cd $appPWD - if { $class eq "TkFDialog" } { + if {$class eq "TkFDialog"} { # Restore the Open/Save Button if this is a File Dialog # if {$data(type) eq "open"} { @@ -1333,7 +1401,7 @@ rSASvJTGhnhcV3EJlo3kh53ltF5nAhQAOw==}] # proc ::tk::dialog::file::SetPathSilently {w path} { upvar ::tk::dialog::file::[winfo name $w] data - + trace remove variable data(selectPath) write [list ::tk::dialog::file::SetPath $w] set data(selectPath) $path trace add variable data(selectPath) write [list ::tk::dialog::file::SetPath $w] @@ -1345,9 +1413,9 @@ proc ::tk::dialog::file::SetPathSilently {w path} { proc ::tk::dialog::file::SetPath {w name1 name2 op} { if {[winfo exists $w]} { upvar ::tk::dialog::file::[winfo name $w] data - ::tk::dialog::file::UpdateWhenIdle $w + UpdateWhenIdle $w # On directory dialogs, we keep the entry in sync with the currentdir. - if { [winfo class $w] eq "TkChooseDir" } { + if {[winfo class $w] eq "TkChooseDir"} { $data(ent) delete 0 end $data(ent) insert end $data(selectPath) } @@ -1360,8 +1428,9 @@ proc ::tk::dialog::file::SetFilter {w type} { upvar ::tk::dialog::file::[winfo name $w] data upvar ::tk::$data(icons) icons + set data(filterType) $type set data(filter) [lindex $type 1] - $data(typeMenuBtn) configure -text [lindex $type 0] -indicatoron 1 + $data(typeMenuBtn) configure -text [lindex $type 0] ;#-indicatoron 1 # If we aren't using a default extension, use the one suppled # by the filter. @@ -1387,8 +1456,8 @@ proc ::tk::dialog::file::SetFilter {w type} { } $icons(sbar) set 0.0 0.0 - - ::tk::dialog::file::UpdateWhenIdle $w + + UpdateWhenIdle $w } # tk::dialog::file::ResolveFile -- @@ -1400,11 +1469,14 @@ proc ::tk::dialog::file::SetFilter {w type} { # (2) resolve all instances of . and .. # (3) check for non-existent files/directories # (4) check for chdir permissions +# (5) conversion of environment variable references to their +# contents (once only) # # Arguments: # context: the current directory you are in # text: the text entered by the user # defaultext: the default extension to add to files with no extension +# expandEnv: whether to expand environment variables (yes by default) # # Return vaue: # [list $flag $directory $file] @@ -1423,20 +1495,21 @@ proc ::tk::dialog::file::SetFilter {w type} { # directory may not be the same as context, because text may contain # a subdirectory name # -proc ::tk::dialog::file::ResolveFile {context text defaultext} { - +proc ::tk::dialog::file::ResolveFile {context text defaultext {expandEnv 1}} { set appPWD [pwd] - set path [::tk::dialog::file::JoinFile $context $text] + set path [JoinFile $context $text] # If the file has no extension, append the default. Be careful not # to do this for directories, otherwise typing a dirname in the box # will give back "dirname.extension" instead of trying to change dir. - if {![file isdirectory $path] && [file ext $path] eq ""} { + if { + ![file isdirectory $path] && ([file ext $path] eq "") && + ![string match {$*} [file tail $path]] + } then { set path "$path$defaultext" } - if {[catch {file exists $path}]} { # This "if" block can be safely removed if the following code # stop generating errors. @@ -1471,17 +1544,31 @@ proc ::tk::dialog::file::ResolveFile {context text defaultext} { return [list CHDIR $dirname ""] } set directory [pwd] + cd $appPWD set file [file tail $path] - if {[regexp {[*]|[?]} $file]} { + # It's nothing else, so check to see if it is an env-reference + if {$expandEnv && [string match {$*} $file]} { + set var [string range $file 1 end] + if {[info exist ::env($var)]} { + return [ResolveFile $context $::env($var) $defaultext 0] + } + } + if {[regexp {[*?]} $file]} { set flag PATTERN } else { set flag FILE } - cd $appPWD } else { set directory $dirname set file [file tail $path] set flag PATH + # It's nothing else, so check to see if it is an env-reference + if {$expandEnv && [string match {$*} $file]} { + set var [string range $file 1 end] + if {[info exist ::env($var)]} { + return [ResolveFile $context $::env($var) $defaultext 0] + } + } } } @@ -1490,7 +1577,7 @@ proc ::tk::dialog::file::ResolveFile {context text defaultext} { # Gets called when the entry box gets keyboard focus. We clear the selection -# from the icon list . This way the user can be certain that the input in the +# from the icon list . This way the user can be certain that the input in the # entry box is the selection. # proc ::tk::dialog::file::EntFocusIn {w} { @@ -1503,7 +1590,7 @@ proc ::tk::dialog::file::EntFocusIn {w} { $data(ent) selection clear } - if { [winfo class $w] eq "TkFDialog" } { + if {[winfo class $w] eq "TkFDialog"} { # If this is a File Dialog, make sure the buttons are labeled right. if {$data(type) eq "open"} { ::tk::SetAmpText $data(okBtn) [mc "&Open"] @@ -1527,24 +1614,11 @@ proc ::tk::dialog::file::ActivateEnt {w} { set text [$data(ent) get] if {$data(-multiple)} { - # For the multiple case we have to be careful to get the file - # names as a true list, watching out for a single file with a - # space in the name. Thus we query the IconList directly. - - set selIcos [::tk::IconList_Curselection $data(icons)] - set data(selectFile) "" - if {[llength $selIcos] == 0 && $text ne ""} { - # This assumes the user typed something in without selecting - # files - so assume they only type in a single filename. - ::tk::dialog::file::VerifyFileName $w $text - } else { - foreach item $selIcos { - ::tk::dialog::file::VerifyFileName $w \ - [::tk::IconList_Get $data(icons) $item] - } + foreach t $text { + VerifyFileName $w $t } } else { - ::tk::dialog::file::VerifyFileName $w $text + VerifyFileName $w $text } } @@ -1553,8 +1627,7 @@ proc ::tk::dialog::file::ActivateEnt {w} { proc ::tk::dialog::file::VerifyFileName {w filename} { upvar ::tk::dialog::file::[winfo name $w] data - set list [::tk::dialog::file::ResolveFile $data(selectPath) $filename \ - $data(-defaultextension)] + set list [ResolveFile $data(selectPath) $filename $data(-defaultextension)] foreach {flag path file} $list { break } @@ -1566,13 +1639,13 @@ proc ::tk::dialog::file::VerifyFileName {w filename} { set data(selectPath) $path $data(ent) delete 0 end } else { - ::tk::dialog::file::SetPathSilently $w $path + SetPathSilently $w $path if {$data(-multiple)} { lappend data(selectFile) $file } else { set data(selectFile) $file } - ::tk::dialog::file::Done $w + Done $w } } PATTERN { @@ -1582,36 +1655,36 @@ proc ::tk::dialog::file::VerifyFileName {w filename} { FILE { if {$data(type) eq "open"} { tk_messageBox -icon warning -type ok -parent $w \ - -message "[mc "File \"%1\$s\" does not exist." [file join $path $file]]" + -message [mc "File \"%1\$s\" does not exist." \ + [file join $path $file]] $data(ent) selection range 0 end $data(ent) icursor end } else { - ::tk::dialog::file::SetPathSilently $w $path + SetPathSilently $w $path if {$data(-multiple)} { lappend data(selectFile) $file } else { set data(selectFile) $file } - ::tk::dialog::file::Done $w + Done $w } } PATH { tk_messageBox -icon warning -type ok -parent $w \ - -message "[mc "Directory \"%1\$s\" does not exist." $path]" + -message [mc "Directory \"%1\$s\" does not exist." $path] $data(ent) selection range 0 end $data(ent) icursor end } CHDIR { - tk_messageBox -type ok -parent $w -message \ - "[mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $path]"\ - -icon warning + tk_messageBox -type ok -parent $w -icon warning -message \ + [mc "Cannot change to the directory\ + \"%1\$s\".\nPermission denied." $path] $data(ent) selection range 0 end $data(ent) icursor end } ERROR { - tk_messageBox -type ok -parent $w -message \ - "[mc "Invalid file name \"%1\$s\"." $path]"\ - -icon warning + tk_messageBox -type ok -parent $w -icon warning -message \ + [mc "Invalid file name \"%1\$s\"." $path] $data(ent) selection range 0 end $data(ent) icursor end } @@ -1624,7 +1697,7 @@ proc ::tk::dialog::file::InvokeBtn {w key} { upvar ::tk::dialog::file::[winfo name $w] data if {[$data(okBtn) cget -text] eq $key} { - ::tk::ButtonInvoke $data(okBtn) + $data(okBtn) invoke } } @@ -1655,21 +1728,21 @@ proc ::tk::dialog::file::OkCmd {w} { upvar ::tk::dialog::file::[winfo name $w] data set filenames {} - foreach item [::tk::IconList_Curselection $data(icons)] { + foreach item [::tk::IconList_CurSelection $data(icons)] { lappend filenames [::tk::IconList_Get $data(icons) $item] } if {([llength $filenames] && !$data(-multiple)) || \ ($data(-multiple) && ([llength $filenames] == 1))} { set filename [lindex $filenames 0] - set file [::tk::dialog::file::JoinFile $data(selectPath) $filename] + set file [JoinFile $data(selectPath) $filename] if {[file isdirectory $file]} { - ::tk::dialog::file::ListInvoke $w [list $filename] + ListInvoke $w [list $filename] return } } - ::tk::dialog::file::ActivateEnt $w + ActivateEnt $w } # Gets called when user presses the "Cancel" button @@ -1698,16 +1771,16 @@ proc ::tk::dialog::file::ListBrowse {w} { upvar ::tk::dialog::file::[winfo name $w] data set text {} - foreach item [::tk::IconList_Curselection $data(icons)] { + foreach item [::tk::IconList_CurSelection $data(icons)] { lappend text [::tk::IconList_Get $data(icons) $item] } if {[llength $text] == 0} { return } - if { [llength $text] > 1 } { + if {$data(-multiple)} { set newtext {} foreach file $text { - set fullfile [::tk::dialog::file::JoinFile $data(selectPath) $file] + set fullfile [JoinFile $data(selectPath) $file] if { ![file isdirectory $fullfile] } { lappend newtext $file } @@ -1716,28 +1789,26 @@ proc ::tk::dialog::file::ListBrowse {w} { set isDir 0 } else { set text [lindex $text 0] - set file [::tk::dialog::file::JoinFile $data(selectPath) $text] + set file [JoinFile $data(selectPath) $text] set isDir [file isdirectory $file] } if {!$isDir} { $data(ent) delete 0 end $data(ent) insert 0 $text - if { [winfo class $w] eq "TkFDialog" } { + if {[winfo class $w] eq "TkFDialog"} { if {$data(type) eq "open"} { ::tk::SetAmpText $data(okBtn) [mc "&Open"] } else { ::tk::SetAmpText $data(okBtn) [mc "&Save"] } } - } else { - if { [winfo class $w] eq "TkFDialog" } { - ::tk::SetAmpText $data(okBtn) [mc "&Open"] - } + } elseif {[winfo class $w] eq "TkFDialog"} { + ::tk::SetAmpText $data(okBtn) [mc "&Open"] } } -# Gets called when user invokes the IconList widget (double-click, +# Gets called when user invokes the IconList widget (double-click, # Return key, etc) # proc ::tk::dialog::file::ListInvoke {w filenames} { @@ -1747,16 +1818,14 @@ proc ::tk::dialog::file::ListInvoke {w filenames} { return } - set file [::tk::dialog::file::JoinFile $data(selectPath) \ - [lindex $filenames 0]] - + set file [JoinFile $data(selectPath) [lindex $filenames 0]] + set class [winfo class $w] if {$class eq "TkChooseDir" || [file isdirectory $file]} { set appPWD [pwd] if {[catch {cd $file}]} { - tk_messageBox -type ok -parent $w -message \ - "[mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $file]"\ - -icon warning + tk_messageBox -type ok -parent $w -icon warning -message \ + [mc "Cannot change to the directory \"%1\$s\".\nPermission denied." $file] } else { cd $appPWD set data(selectPath) $file @@ -1767,7 +1836,7 @@ proc ::tk::dialog::file::ListInvoke {w filenames} { } else { set data(selectFile) $file } - ::tk::dialog::file::Done $w + Done $w } } @@ -1787,28 +1856,114 @@ proc ::tk::dialog::file::Done {w {selectFilePath ""}} { if {$data(-multiple)} { set selectFilePath {} foreach f $data(selectFile) { - lappend selectFilePath [::tk::dialog::file::JoinFile \ - $data(selectPath) $f] + lappend selectFilePath [JoinFile $data(selectPath) $f] } } else { - set selectFilePath [::tk::dialog::file::JoinFile \ - $data(selectPath) $data(selectFile)] - } - - set Priv(selectFile) $data(selectFile) - set Priv(selectPath) $data(selectPath) - - if {$data(type) eq "save"} { - if {[file exists $selectFilePath]} { - set reply [tk_messageBox -icon warning -type yesno\ - -parent $w -message \ - "[mc "File \"%1\$s\" already exists.\nDo you want to overwrite it?" $selectFilePath]"] + set selectFilePath [JoinFile $data(selectPath) $data(selectFile)] + } + + set Priv(selectFile) $data(selectFile) + set Priv(selectPath) $data(selectPath) + + if {($data(type) eq "save") && $data(-confirmoverwrite) && [file exists $selectFilePath]} { + set reply [tk_messageBox -icon warning -type yesno -parent $w \ + -message [mc "File \"%1\$s\" already exists.\nDo you want\ + to overwrite it?" $selectFilePath]] if {$reply eq "no"} { return - } } } + if {[info exists data(-typevariable)] && $data(-typevariable) ne "" + && [info exists data(-filetypes)] && [llength $data(-filetypes)] + && [info exists data(filterType)] && $data(filterType) ne ""} { + upvar #0 $data(-typevariable) typeVariable + set typeVariable [lindex $data(filterType) 0] + } } bind $data(okBtn) <Destroy> {} set Priv(selectFilePath) $selectFilePath } + +proc ::tk::dialog::file::CompleteEnt {w} { + upvar ::tk::dialog::file::[winfo name $w] data + set f [$data(ent) get] + if {$data(-multiple)} { + if {[catch {llength $f} len] || $len != 1} { + return -code break + } + set f [lindex $f 0] + } + + # Get list of matching filenames and dirnames + set globF [list glob -tails -directory $data(selectPath) \ + -type {f b c l p s} -nocomplain] + set globD [list glob -tails -directory $data(selectPath) -type d \ + -nocomplain *] + if {$data(filter) eq "*"} { + lappend globF * + if {$::tk::dialog::file::showHiddenVar} { + lappend globF .* + lappend globD .* + } + if {[winfo class $w] eq "TkFDialog"} { + set files [lsort -dictionary -unique [{*}$globF]] + } else { + set files {} + } + set dirs [lsort -dictionary -unique [{*}$globD]] + } else { + if {$::tk::dialog::file::showHiddenVar} { + lappend globD .* + } + if {[winfo class $w] eq "TkFDialog"} { + set files [lsort -dictionary -unique [{*}$globF {*}$data(filter)]] + } else { + set files {} + } + set dirs [lsort -dictionary -unique [{*}$globD]] + } + # Filter specials + set dirs [lsearch -all -not -exact -inline $dirs .] + set dirs [lsearch -all -not -exact -inline $dirs ..] + set dirs2 {} + foreach d $dirs {lappend dirs2 $d/} + + set targets [concat \ + [lsearch -glob -all -inline $files $f*] \ + [lsearch -glob -all -inline $dirs2 $f*]] + + if {[llength $targets] == 1} { + # We have a winner! + set f [lindex $targets 0] + } elseif {$f in $targets || [llength $targets] == 0} { + if {[string length $f] > 0} { + bell + } + return + } elseif {[llength $targets] > 1} { + # Multiple possibles + if {[string length $f] == 0} { + return + } + set t0 [lindex $targets 0] + for {set len [string length $t0]} {$len>0} {} { + set allmatch 1 + foreach s $targets { + if {![string equal -length $len $s $t0]} { + set allmatch 0 + break + } + } + incr len -1 + if {$allmatch} break + } + set f [string range $t0 0 $len] + } + + if {$data(-multiple)} { + set f [list $f] + } + $data(ent) delete 0 end + $data(ent) insert 0 $f + return -code break +} diff --git a/library/ttk/altTheme.tcl b/library/ttk/altTheme.tcl new file mode 100644 index 0000000..d57227c --- /dev/null +++ b/library/ttk/altTheme.tcl @@ -0,0 +1,101 @@ +# +# Ttk widget set: Alternate theme +# + +namespace eval ttk::theme::alt { + + variable colors + array set colors { + -frame "#d9d9d9" + -window "#ffffff" + -darker "#c3c3c3" + -border "#414141" + -activebg "#ececec" + -disabledfg "#a3a3a3" + -selectbg "#4a6984" + -selectfg "#ffffff" + } + + ttk::style theme settings alt { + + ttk::style configure "." \ + -background $colors(-frame) \ + -foreground black \ + -troughcolor $colors(-darker) \ + -bordercolor $colors(-border) \ + -selectbackground $colors(-selectbg) \ + -selectforeground $colors(-selectfg) \ + -font TkDefaultFont \ + ; + + ttk::style map "." -background \ + [list disabled $colors(-frame) active $colors(-activebg)] ; + ttk::style map "." -foreground [list disabled $colors(-disabledfg)] ; + ttk::style map "." -embossed [list disabled 1] ; + + ttk::style configure TButton \ + -anchor center -width -11 -padding "1 1" \ + -relief raised -shiftrelief 1 \ + -highlightthickness 1 -highlightcolor $colors(-frame) + + ttk::style map TButton -relief { + {pressed !disabled} sunken + {active !disabled} raised + } -highlightcolor {alternate black} + + ttk::style configure TCheckbutton -indicatorcolor "#ffffff" -padding 2 + ttk::style configure TRadiobutton -indicatorcolor "#ffffff" -padding 2 + ttk::style map TCheckbutton -indicatorcolor \ + [list disabled $colors(-frame) pressed $colors(-frame)] + ttk::style map TRadiobutton -indicatorcolor \ + [list disabled $colors(-frame) pressed $colors(-frame)] + + ttk::style configure TMenubutton \ + -width -11 -padding "3 3" -relief raised + + ttk::style configure TEntry -padding 1 + ttk::style map TEntry -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + ttk::style configure TCombobox -padding 1 + ttk::style map TCombobox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + ttk::style configure ComboboxPopdownFrame \ + -relief solid -borderwidth 1 + + ttk::style configure TSpinbox -arrowsize 10 -padding {2 0 10 0} + ttk::style map TSpinbox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] \ + -arrowcolor [list disabled $colors(-disabledfg)] + + ttk::style configure Toolbutton -relief flat -padding 2 + ttk::style map Toolbutton -relief \ + {disabled flat selected sunken pressed sunken active raised} + ttk::style map Toolbutton -background \ + [list pressed $colors(-darker) active $colors(-activebg)] + + ttk::style configure TScrollbar -relief raised + + ttk::style configure TLabelframe -relief groove -borderwidth 2 + + ttk::style configure TNotebook -tabmargins {2 2 1 0} + ttk::style configure TNotebook.Tab \ + -padding {4 2} -background $colors(-darker) + ttk::style map TNotebook.Tab \ + -background [list selected $colors(-frame)] \ + -expand [list selected {2 2 1 0}] \ + ; + + # Treeview: + ttk::style configure Heading -font TkHeadingFont -relief raised + ttk::style configure Treeview -background $colors(-window) + ttk::style map Treeview \ + -background [list selected $colors(-selectbg)] \ + -foreground [list selected $colors(-selectfg)] ; + + ttk::style configure TScale \ + -groovewidth 4 -troughrelief sunken \ + -sliderwidth raised -borderwidth 2 + ttk::style configure TProgressbar \ + -background $colors(-selectbg) -borderwidth 0 + } +} diff --git a/library/ttk/aquaTheme.tcl b/library/ttk/aquaTheme.tcl new file mode 100644 index 0000000..fa0fa12 --- /dev/null +++ b/library/ttk/aquaTheme.tcl @@ -0,0 +1,59 @@ +# +# Aqua theme (OSX native look and feel) +# + +namespace eval ttk::theme::aqua { + ttk::style theme settings aqua { + + ttk::style configure . \ + -font TkDefaultFont \ + -background systemWindowBody \ + -foreground systemModelessDialogActiveText \ + -selectbackground systemHighlight \ + -selectforeground systemModelessDialogActiveText \ + -selectborderwidth 0 \ + -insertwidth 1 + + ttk::style map . \ + -foreground {disabled systemModelessDialogInactiveText + background systemModelessDialogInactiveText} \ + -selectbackground {background systemHighlightSecondary + !focus systemHighlightSecondary} \ + -selectforeground {background systemModelessDialogInactiveText + !focus systemDialogActiveText} + + # Workaround for #1100117: + # Actually, on Aqua we probably shouldn't stipple images in + # disabled buttons even if it did work... + ttk::style configure . -stipple {} + + ttk::style configure TButton -anchor center -width -6 + ttk::style configure Toolbutton -padding 4 + + ttk::style configure TNotebook -tabmargins {10 0} -tabposition n + ttk::style configure TNotebook -padding {18 8 18 17} + ttk::style configure TNotebook.Tab -padding {12 3 12 2} + + # Combobox: + ttk::style configure TCombobox -postoffset {5 -2 -10 0} + + # Treeview: + ttk::style configure Heading -font TkHeadingFont + ttk::style configure Treeview -rowheight 18 -background White + ttk::style map Treeview \ + -background {{selected background} systemHighlightSecondary + selected systemHighlight} + + # Enable animation for ttk::progressbar widget: + ttk::style configure TProgressbar -period 100 -maxphase 255 + + # For Aqua, labelframe labels should appear outside the border, + # with a 14 pixel inset and 4 pixels spacing between border and label + # (ref: Apple Human Interface Guidelines / Controls / Grouping Controls) + # + ttk::style configure TLabelframe \ + -labeloutside true -labelmargins {14 0 14 4} + + # TODO: panedwindow sashes should be 9 pixels (HIG:Controls:Split Views) + } +} diff --git a/library/ttk/button.tcl b/library/ttk/button.tcl new file mode 100644 index 0000000..9f2cec7 --- /dev/null +++ b/library/ttk/button.tcl @@ -0,0 +1,83 @@ +# +# Bindings for Buttons, Checkbuttons, and Radiobuttons. +# +# Notes: <Button1-Leave>, <Button1-Enter> only control the "pressed" +# state; widgets remain "active" if the pointer is dragged out. +# This doesn't seem to be conventional, but it's a nice way +# to provide extra feedback while the grab is active. +# (If the button is released off the widget, the grab deactivates and +# we get a <Leave> event then, which turns off the "active" state) +# +# Normally, <ButtonRelease> and <ButtonN-Enter/Leave> events are +# delivered to the widget which received the initial <ButtonPress> +# event. However, Tk [grab]s (#1223103) and menu interactions +# (#1222605) can interfere with this. To guard against spurious +# <Button1-Enter> events, the <Button1-Enter> binding only sets +# the pressed state if the button is currently active. +# + +namespace eval ttk::button {} + +bind TButton <Enter> { %W instate !disabled {%W state active} } +bind TButton <Leave> { %W state !active } +bind TButton <Key-space> { ttk::button::activate %W } +bind TButton <<Invoke>> { ttk::button::activate %W } + +bind TButton <ButtonPress-1> \ + { %W instate !disabled { ttk::clickToFocus %W; %W state pressed } } +bind TButton <ButtonRelease-1> \ + { %W instate pressed { %W state !pressed; %W instate !disabled { %W invoke } } } +bind TButton <Button1-Leave> \ + { %W state !pressed } +bind TButton <Button1-Enter> \ + { %W instate {active !disabled} { %W state pressed } } + +# Checkbuttons and Radiobuttons have the same bindings as Buttons: +# +ttk::copyBindings TButton TCheckbutton +ttk::copyBindings TButton TRadiobutton + +# ...plus a few more: + +bind TRadiobutton <KeyPress-Up> { ttk::button::RadioTraverse %W -1 } +bind TRadiobutton <KeyPress-Down> { ttk::button::RadioTraverse %W +1 } + +# bind TCheckbutton <KeyPress-plus> { %W select } +# bind TCheckbutton <KeyPress-minus> { %W deselect } + +# activate -- +# Simulate a button press: temporarily set the state to 'pressed', +# then invoke the button. +# +proc ttk::button::activate {w} { + $w instate disabled { return } + set oldState [$w state pressed] + update idletasks; after 100 ;# block event loop to avoid reentrancy + $w state $oldState + $w invoke +} + +# RadioTraverse -- up/down keyboard traversal for radiobutton groups. +# Set focus to previous/next radiobutton in a group. +# A radiobutton group consists of all the radiobuttons with +# the same parent and -variable; this is a pretty good heuristic +# that works most of the time. +# +proc ttk::button::RadioTraverse {w dir} { + set group [list] + foreach sibling [winfo children [winfo parent $w]] { + if { [winfo class $sibling] eq "TRadiobutton" + && [$sibling cget -variable] eq [$w cget -variable] + && ![$sibling instate disabled] + } { + lappend group $sibling + } + } + + if {![llength $group]} { # Shouldn't happen, but can. + return + } + + set pos [expr {([lsearch -exact $group $w] + $dir) % [llength $group]}] + tk::TabToWindow [lindex $group $pos] +} diff --git a/library/ttk/clamTheme.tcl b/library/ttk/clamTheme.tcl new file mode 100644 index 0000000..f184ea0 --- /dev/null +++ b/library/ttk/clamTheme.tcl @@ -0,0 +1,137 @@ +# +# "Clam" theme. +# +# Inspired by the XFCE family of Gnome themes. +# + +namespace eval ttk::theme::clam { + variable colors + array set colors { + -disabledfg "#999999" + -frame "#dcdad5" + -window "#ffffff" + -dark "#cfcdc8" + -darker "#bab5ab" + -darkest "#9e9a91" + -lighter "#eeebe7" + -lightest "#ffffff" + -selectbg "#4a6984" + -selectfg "#ffffff" + } + + ttk::style theme settings clam { + + ttk::style configure "." \ + -background $colors(-frame) \ + -foreground black \ + -bordercolor $colors(-darkest) \ + -darkcolor $colors(-dark) \ + -lightcolor $colors(-lighter) \ + -troughcolor $colors(-darker) \ + -selectbackground $colors(-selectbg) \ + -selectforeground $colors(-selectfg) \ + -selectborderwidth 0 \ + -font TkDefaultFont \ + ; + + ttk::style map "." \ + -background [list disabled $colors(-frame) \ + active $colors(-lighter)] \ + -foreground [list disabled $colors(-disabledfg)] \ + -selectbackground [list !focus $colors(-darkest)] \ + -selectforeground [list !focus white] \ + ; + # -selectbackground [list !focus "#847d73"] + + ttk::style configure TButton \ + -anchor center -width -11 -padding 5 -relief raised + ttk::style map TButton \ + -background [list \ + disabled $colors(-frame) \ + pressed $colors(-darker) \ + active $colors(-lighter)] \ + -lightcolor [list pressed $colors(-darker)] \ + -darkcolor [list pressed $colors(-darker)] \ + -bordercolor [list alternate "#000000"] \ + ; + + ttk::style configure Toolbutton \ + -anchor center -padding 2 -relief flat + ttk::style map Toolbutton \ + -relief [list \ + disabled flat \ + selected sunken \ + pressed sunken \ + active raised] \ + -background [list \ + disabled $colors(-frame) \ + pressed $colors(-darker) \ + active $colors(-lighter)] \ + -lightcolor [list pressed $colors(-darker)] \ + -darkcolor [list pressed $colors(-darker)] \ + ; + + ttk::style configure TCheckbutton \ + -indicatorbackground "#ffffff" \ + -indicatormargin {1 1 4 1} \ + -padding 2 ; + ttk::style configure TRadiobutton \ + -indicatorbackground "#ffffff" \ + -indicatormargin {1 1 4 1} \ + -padding 2 ; + ttk::style map TCheckbutton -indicatorbackground \ + [list disabled $colors(-frame) pressed $colors(-frame)] + ttk::style map TRadiobutton -indicatorbackground \ + [list disabled $colors(-frame) pressed $colors(-frame)] + + ttk::style configure TMenubutton \ + -width -11 -padding 5 -relief raised + + ttk::style configure TEntry -padding 1 -insertwidth 1 + ttk::style map TEntry \ + -background [list readonly $colors(-frame)] \ + -bordercolor [list focus $colors(-selectbg)] \ + -lightcolor [list focus "#6f9dc6"] \ + -darkcolor [list focus "#6f9dc6"] \ + ; + + ttk::style configure TCombobox -padding 1 -insertwidth 1 + ttk::style map TCombobox \ + -background [list active $colors(-lighter) \ + pressed $colors(-lighter)] \ + -fieldbackground [list {readonly focus} $colors(-selectbg) \ + readonly $colors(-frame)] \ + -foreground [list {readonly focus} $colors(-selectfg)] \ + ; + ttk::style configure ComboboxPopdownFrame \ + -relief solid -borderwidth 1 + + ttk::style configure TSpinbox -arrowsize 10 -padding {2 0 10 0} + ttk::style map TSpinbox \ + -background [list readonly $colors(-frame)] \ + -arrowcolor [list disabled $colors(-disabledfg)] + + ttk::style configure TNotebook.Tab -padding {6 2 6 2} + ttk::style map TNotebook.Tab \ + -padding [list selected {6 4 6 2}] \ + -background [list selected $colors(-frame) {} $colors(-darker)] \ + -lightcolor [list selected $colors(-lighter) {} $colors(-dark)] \ + ; + + # Treeview: + ttk::style configure Heading \ + -font TkHeadingFont -relief raised -padding {3} + ttk::style configure Treeview -background $colors(-window) + ttk::style map Treeview \ + -background [list selected $colors(-selectbg)] \ + -foreground [list selected $colors(-selectfg)] ; + + ttk::style configure TLabelframe \ + -labeloutside true -labelmargins {0 0 0 4} \ + -borderwidth 2 -relief raised + + ttk::style configure TProgressbar -background $colors(-frame) + + ttk::style configure Sash -sashthickness 6 -gripcount 10 + } +} diff --git a/library/ttk/classicTheme.tcl b/library/ttk/classicTheme.tcl new file mode 100644 index 0000000..7e3eff5 --- /dev/null +++ b/library/ttk/classicTheme.tcl @@ -0,0 +1,108 @@ +# +# "classic" Tk theme. +# +# Implements Tk's traditional Motif-like look and feel. +# + +namespace eval ttk::theme::classic { + + variable colors; array set colors { + -frame "#d9d9d9" + -window "#ffffff" + -activebg "#ececec" + -troughbg "#c3c3c3" + -selectbg "#c3c3c3" + -selectfg "#000000" + -disabledfg "#a3a3a3" + -indicator "#b03060" + } + + ttk::style theme settings classic { + ttk::style configure "." \ + -font TkDefaultFont \ + -background $colors(-frame) \ + -foreground black \ + -selectbackground $colors(-selectbg) \ + -selectforeground $colors(-selectfg) \ + -troughcolor $colors(-troughbg) \ + -indicatorcolor $colors(-frame) \ + -highlightcolor $colors(-frame) \ + -highlightthickness 1 \ + -selectborderwidth 1 \ + -insertwidth 2 \ + ; + + # To match pre-Xft X11 appearance, use: + # ttk::style configure . -font {Helvetica 12 bold} + + ttk::style map "." -background \ + [list disabled $colors(-frame) active $colors(-activebg)] + ttk::style map "." -foreground \ + [list disabled $colors(-disabledfg)] + + ttk::style map "." -highlightcolor [list focus black] + + ttk::style configure TButton \ + -anchor center -padding "3m 1m" -relief raised -shiftrelief 1 + ttk::style map TButton -relief [list {!disabled pressed} sunken] + + ttk::style configure TCheckbutton -indicatorrelief raised + ttk::style map TCheckbutton \ + -indicatorcolor [list \ + pressed $colors(-frame) selected $colors(-indicator)] \ + -indicatorrelief {selected sunken pressed sunken} \ + ; + + ttk::style configure TRadiobutton -indicatorrelief raised + ttk::style map TRadiobutton \ + -indicatorcolor [list \ + pressed $colors(-frame) selected $colors(-indicator)] \ + -indicatorrelief {selected sunken pressed sunken} \ + ; + + ttk::style configure TMenubutton -relief raised -padding "3m 1m" + + ttk::style configure TEntry -relief sunken -padding 1 -font TkTextFont + ttk::style map TEntry -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + ttk::style configure TCombobox -padding 1 + ttk::style map TCombobox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + ttk::style configure ComboboxPopdownFrame \ + -relief solid -borderwidth 1 + + ttk::style configure TSpinbox -arrowsize 10 -padding {2 0 10 0} + ttk::style map TSpinbox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + + ttk::style configure TLabelframe -borderwidth 2 -relief groove + + ttk::style configure TScrollbar -relief raised + ttk::style map TScrollbar -relief {{pressed !disabled} sunken} + + ttk::style configure TScale -sliderrelief raised + ttk::style map TScale -sliderrelief {{pressed !disabled} sunken} + + ttk::style configure TProgressbar -background SteelBlue + ttk::style configure TNotebook.Tab \ + -padding {3m 1m} \ + -background $colors(-troughbg) + ttk::style map TNotebook.Tab -background [list selected $colors(-frame)] + + # Treeview: + ttk::style configure Heading -font TkHeadingFont -relief raised + ttk::style configure Treeview -background $colors(-window) + ttk::style map Treeview \ + -background [list selected $colors(-selectbg)] \ + -foreground [list selected $colors(-selectfg)] ; + + # + # Toolbar buttons: + # + ttk::style configure Toolbutton -padding 2 -relief flat -shiftrelief 2 + ttk::style map Toolbutton -relief \ + {disabled flat selected sunken pressed sunken active raised} + ttk::style map Toolbutton -background \ + [list pressed $colors(-troughbg) active $colors(-activebg)] + } +} diff --git a/library/ttk/combobox.tcl b/library/ttk/combobox.tcl new file mode 100644 index 0000000..03821a2 --- /dev/null +++ b/library/ttk/combobox.tcl @@ -0,0 +1,456 @@ +# +# Combobox bindings. +# +# <<NOTE-WM-TRANSIENT>>: +# +# Need to set [wm transient] just before mapping the popdown +# instead of when it's created, in case a containing frame +# has been reparented [#1818441]. +# +# On Windows: setting [wm transient] prevents the parent +# toplevel from becoming inactive when the popdown is posted +# (Tk 8.4.8+) +# +# On X11: WM_TRANSIENT_FOR on override-redirect windows +# may be used by compositing managers and by EWMH-aware +# window managers (even though the older ICCCM spec says +# it's meaningless). +# +# On OSX: [wm transient] does utterly the wrong thing. +# Instead, we use [MacWindowStyle "help" "noActivates hideOnSuspend"]. +# The "noActivates" attribute prevents the parent toplevel +# from deactivating when the popdown is posted, and is also +# necessary for "help" windows to receive mouse events. +# "hideOnSuspend" makes the popdown disappear (resp. reappear) +# when the parent toplevel is deactivated (resp. reactivated). +# (see [#1814778]). Also set [wm resizable 0 0], to prevent +# TkAqua from shrinking the scrollbar to make room for a grow box +# that isn't there. +# +# In order to work around other platform quirks in TkAqua, +# [grab] and [focus] are set in <Map> bindings instead of +# immediately after deiconifying the window. +# + +namespace eval ttk::combobox { + variable Values ;# Values($cb) is -listvariable of listbox widget + variable State + set State(entryPress) 0 +} + +### Combobox bindings. +# +# Duplicate the Entry bindings, override if needed: +# + +ttk::copyBindings TEntry TCombobox + +bind TCombobox <KeyPress-Down> { ttk::combobox::Post %W } +bind TCombobox <KeyPress-Escape> { ttk::combobox::Unpost %W } + +bind TCombobox <ButtonPress-1> { ttk::combobox::Press "" %W %x %y } +bind TCombobox <Shift-ButtonPress-1> { ttk::combobox::Press "s" %W %x %y } +bind TCombobox <Double-ButtonPress-1> { ttk::combobox::Press "2" %W %x %y } +bind TCombobox <Triple-ButtonPress-1> { ttk::combobox::Press "3" %W %x %y } +bind TCombobox <B1-Motion> { ttk::combobox::Drag %W %x } +bind TCombobox <Motion> { ttk::combobox::Motion %W %x %y } + +ttk::bindMouseWheel TCombobox [list ttk::combobox::Scroll %W] + +bind TCombobox <<TraverseIn>> { ttk::combobox::TraverseIn %W } + +### Combobox listbox bindings. +# +bind ComboboxListbox <ButtonRelease-1> { ttk::combobox::LBSelected %W } +bind ComboboxListbox <KeyPress-Return> { ttk::combobox::LBSelected %W } +bind ComboboxListbox <KeyPress-Escape> { ttk::combobox::LBCancel %W } +bind ComboboxListbox <KeyPress-Tab> { ttk::combobox::LBTab %W next } +bind ComboboxListbox <<PrevWindow>> { ttk::combobox::LBTab %W prev } +bind ComboboxListbox <Destroy> { ttk::combobox::LBCleanup %W } +bind ComboboxListbox <Motion> { ttk::combobox::LBHover %W %x %y } +bind ComboboxListbox <Map> { focus -force %W } + +switch -- [tk windowingsystem] { + win32 { + # Dismiss listbox when user switches to a different application. + # NB: *only* do this on Windows (see #1814778) + bind ComboboxListbox <FocusOut> { ttk::combobox::LBCancel %W } + } +} + +### Combobox popdown window bindings. +# +bind ComboboxPopdown <Map> { ttk::combobox::MapPopdown %W } +bind ComboboxPopdown <Unmap> { ttk::combobox::UnmapPopdown %W } +bind ComboboxPopdown <ButtonPress> \ + { ttk::combobox::Unpost [winfo parent %W] } + +### Option database settings. +# + +option add *TCombobox*Listbox.font TkTextFont +option add *TCombobox*Listbox.relief flat +option add *TCombobox*Listbox.highlightThickness 0 + +## Platform-specific settings. +# +switch -- [tk windowingsystem] { + x11 { + option add *TCombobox*Listbox.background white + } + aqua { + option add *TCombobox*Listbox.borderWidth 0 + } +} + +### Binding procedures. +# + +## Press $mode $x $y -- ButtonPress binding for comboboxes. +# Either post/unpost the listbox, or perform Entry widget binding, +# depending on widget state and location of button press. +# +proc ttk::combobox::Press {mode w x y} { + variable State + + $w instate disabled { return } + + set State(entryPress) [expr { + [$w instate !readonly] + && [string match *textarea [$w identify element $x $y]] + }] + + focus $w + if {$State(entryPress)} { + switch -- $mode { + s { ttk::entry::Shift-Press $w $x ; # Shift } + 2 { ttk::entry::Select $w $x word ; # Double click} + 3 { ttk::entry::Select $w $x line ; # Triple click } + "" - + default { ttk::entry::Press $w $x } + } + } else { + Post $w + } +} + +## Drag -- B1-Motion binding for comboboxes. +# If the initial ButtonPress event was handled by Entry binding, +# perform Entry widget drag binding; otherwise nothing. +# +proc ttk::combobox::Drag {w x} { + variable State + if {$State(entryPress)} { + ttk::entry::Drag $w $x + } +} + +## Motion -- +# Set cursor. +# +proc ttk::combobox::Motion {w x y} { + if { [$w identify $x $y] eq "textarea" + && [$w instate {!readonly !disabled}] + } { + ttk::setCursor $w text + } else { + ttk::setCursor $w "" + } +} + +## TraverseIn -- receive focus due to keyboard navigation +# For editable comboboxes, set the selection and insert cursor. +# +proc ttk::combobox::TraverseIn {w} { + $w instate {!readonly !disabled} { + $w selection range 0 end + $w icursor end + } +} + +## SelectEntry $cb $index -- +# Set the combobox selection in response to a user action. +# +proc ttk::combobox::SelectEntry {cb index} { + $cb current $index + $cb selection range 0 end + $cb icursor end + event generate $cb <<ComboboxSelected>> -when mark +} + +## Scroll -- Mousewheel binding +# +proc ttk::combobox::Scroll {cb dir} { + $cb instate disabled { return } + set max [llength [$cb cget -values]] + set current [$cb current] + incr current $dir + if {$max != 0 && $current == $current % $max} { + SelectEntry $cb $current + } +} + +## LBSelected $lb -- Activation binding for listbox +# Set the combobox value to the currently-selected listbox value +# and unpost the listbox. +# +proc ttk::combobox::LBSelected {lb} { + set cb [LBMaster $lb] + LBSelect $lb + Unpost $cb + focus $cb +} + +## LBCancel -- +# Unpost the listbox. +# +proc ttk::combobox::LBCancel {lb} { + Unpost [LBMaster $lb] +} + +## LBTab -- Tab key binding for combobox listbox. +# Set the selection, and navigate to next/prev widget. +# +proc ttk::combobox::LBTab {lb dir} { + set cb [LBMaster $lb] + switch -- $dir { + next { set newFocus [tk_focusNext $cb] } + prev { set newFocus [tk_focusPrev $cb] } + } + + if {$newFocus ne ""} { + LBSelect $lb + Unpost $cb + # The [grab release] call in [Unpost] queues events that later + # re-set the focus (@@@ NOTE: this might not be true anymore). + # Set new focus later: + after 0 [list ttk::traverseTo $newFocus] + } +} + +## LBHover -- <Motion> binding for combobox listbox. +# Follow selection on mouseover. +# +proc ttk::combobox::LBHover {w x y} { + $w selection clear 0 end + $w activate @$x,$y + $w selection set @$x,$y +} + +## MapPopdown -- <Map> binding for ComboboxPopdown +# +proc ttk::combobox::MapPopdown {w} { + [winfo parent $w] state pressed + ttk::globalGrab $w +} + +## UnmapPopdown -- <Unmap> binding for ComboboxPopdown +# +proc ttk::combobox::UnmapPopdown {w} { + [winfo parent $w] state !pressed + ttk::releaseGrab $w +} + +### +# + +namespace eval ::ttk::combobox { + # @@@ Until we have a proper native scrollbar on Aqua, use + # @@@ the regular Tk one. Use ttk::scrollbar on other platforms. + variable scrollbar ttk::scrollbar + if {[tk windowingsystem] eq "aqua"} { + set scrollbar ::scrollbar + } +} + +## PopdownWindow -- +# Returns the popdown widget associated with a combobox, +# creating it if necessary. +# +proc ttk::combobox::PopdownWindow {cb} { + variable scrollbar + + if {![winfo exists $cb.popdown]} { + set poplevel [PopdownToplevel $cb.popdown] + set popdown [ttk::frame $poplevel.f -style ComboboxPopdownFrame] + + $scrollbar $popdown.sb \ + -orient vertical -command [list $popdown.l yview] + listbox $popdown.l \ + -listvariable ttk::combobox::Values($cb) \ + -yscrollcommand [list $popdown.sb set] \ + -exportselection false \ + -selectmode browse \ + -activestyle none \ + ; + + bindtags $popdown.l \ + [list $popdown.l ComboboxListbox Listbox $popdown all] + + grid $popdown.l -row 0 -column 0 -padx {1 0} -pady 1 -sticky nsew + grid $popdown.sb -row 0 -column 1 -padx {0 1} -pady 1 -sticky ns + grid columnconfigure $popdown 0 -weight 1 + grid rowconfigure $popdown 0 -weight 1 + + grid $popdown -sticky news -padx 0 -pady 0 + grid rowconfigure $poplevel 0 -weight 1 + grid columnconfigure $poplevel 0 -weight 1 + } + return $cb.popdown +} + +## PopdownToplevel -- Create toplevel window for the combobox popdown +# +# See also <<NOTE-WM-TRANSIENT>> +# +proc ttk::combobox::PopdownToplevel {w} { + toplevel $w -class ComboboxPopdown + wm withdraw $w + switch -- [tk windowingsystem] { + default - + x11 { + $w configure -relief flat -borderwidth 0 + wm attributes $w -type combo + wm overrideredirect $w true + } + win32 { + $w configure -relief flat -borderwidth 0 + wm overrideredirect $w true + wm attributes $w -topmost 1 + } + aqua { + $w configure -relief solid -borderwidth 0 + tk::unsupported::MacWindowStyle style $w \ + help {noActivates hideOnSuspend} + wm resizable $w 0 0 + } + } + return $w +} + +## ConfigureListbox -- +# Set listbox values, selection, height, and scrollbar visibility +# from current combobox values. +# +proc ttk::combobox::ConfigureListbox {cb} { + variable Values + + set popdown [PopdownWindow $cb].f + set values [$cb cget -values] + set current [$cb current] + if {$current < 0} { + set current 0 ;# no current entry, highlight first one + } + set Values($cb) $values + $popdown.l selection clear 0 end + $popdown.l selection set $current + $popdown.l activate $current + $popdown.l see $current + set height [llength $values] + if {$height > [$cb cget -height]} { + set height [$cb cget -height] + grid $popdown.sb + grid configure $popdown.l -padx {1 0} + } else { + grid remove $popdown.sb + grid configure $popdown.l -padx 1 + } + $popdown.l configure -height $height +} + +## PlacePopdown -- +# Set popdown window geometry. +# +# @@@TODO: factor with menubutton::PostPosition +# +proc ttk::combobox::PlacePopdown {cb popdown} { + set x [winfo rootx $cb] + set y [winfo rooty $cb] + set w [winfo width $cb] + set h [winfo height $cb] + set postoffset [ttk::style lookup TCombobox -postoffset {} {0 0 0 0}] + foreach var {x y w h} delta $postoffset { + incr $var $delta + } + + set H [winfo reqheight $popdown] + if {$y + $h + $H > [winfo screenheight $popdown]} { + set Y [expr {$y - $H}] + } else { + set Y [expr {$y + $h}] + } + wm geometry $popdown ${w}x${H}+${x}+${Y} +} + +## Post $cb -- +# Pop down the associated listbox. +# +proc ttk::combobox::Post {cb} { + # Don't do anything if disabled: + # + $cb instate disabled { return } + + # ASSERT: ![$cb instate pressed] + + # Run -postcommand callback: + # + uplevel #0 [$cb cget -postcommand] + + set popdown [PopdownWindow $cb] + ConfigureListbox $cb + update idletasks ;# needed for geometry propagation. + PlacePopdown $cb $popdown + # See <<NOTE-WM-TRANSIENT>> + switch -- [tk windowingsystem] { + x11 - win32 { wm transient $popdown [winfo toplevel $cb] } + } + + # Post the listbox: + # + wm attribute $popdown -topmost 1 + wm deiconify $popdown + raise $popdown +} + +## Unpost $cb -- +# Unpost the listbox. +# +proc ttk::combobox::Unpost {cb} { + if {[winfo exists $cb.popdown]} { + wm withdraw $cb.popdown + } + grab release $cb.popdown ;# in case of stuck or unexpected grab [#1239190] +} + +## LBMaster $lb -- +# Return the combobox main widget that owns the listbox. +# +proc ttk::combobox::LBMaster {lb} { + winfo parent [winfo parent [winfo parent $lb]] +} + +## LBSelect $lb -- +# Transfer listbox selection to combobox value. +# +proc ttk::combobox::LBSelect {lb} { + set cb [LBMaster $lb] + set selection [$lb curselection] + if {[llength $selection] == 1} { + SelectEntry $cb [lindex $selection 0] + } +} + +## LBCleanup $lb -- +# <Destroy> binding for combobox listboxes. +# Cleans up by unsetting the linked textvariable. +# +# Note: we can't just use { unset [%W cget -listvariable] } +# because the widget command is already gone when this binding fires). +# [winfo parent] still works, fortunately. +# +proc ttk::combobox::LBCleanup {lb} { + variable Values + unset Values([LBMaster $lb]) +} + +#*EOF* diff --git a/library/ttk/cursors.tcl b/library/ttk/cursors.tcl new file mode 100644 index 0000000..75f7791 --- /dev/null +++ b/library/ttk/cursors.tcl @@ -0,0 +1,186 @@ +# +# Map symbolic cursor names to platform-appropriate cursors. +# +# The following cursors are defined: +# +# standard -- default cursor for most controls +# "" -- inherit cursor from parent window +# none -- no cursor +# +# text -- editable widgets (entry, text) +# link -- hyperlinks within text +# crosshair -- graphic selection, fine control +# busy -- operation in progress +# forbidden -- action not allowed +# +# hresize -- horizontal resizing +# vresize -- vertical resizing +# +# Also resize cursors for each of the compass points, +# {nw,n,ne,w,e,sw,s,se}resize. +# +# Platform notes: +# +# Windows doesn't distinguish resizing at the 8 compass points, +# only horizontal, vertical, and the two diagonals. +# +# OSX doesn't have resize cursors for nw, ne, sw, or se corners. +# We use the Tk-defined X11 fallbacks for these. +# +# X11 doesn't have a "forbidden" cursor (usually a slashed circle); +# "pirate" seems to be the conventional cursor for this purpose. +# +# Windows has an IDC_HELP cursor, but it's not available from Tk. +# +# Tk does not support "none" on Windows. +# + +namespace eval ttk { + + variable Cursors + + # Use X11 cursor names as defaults, since Tk supplies these + # on all platforms. + # + array set Cursors { + "" "" + none none + + standard left_ptr + text xterm + link hand2 + crosshair crosshair + busy watch + forbidden pirate + + hresize sb_h_double_arrow + vresize sb_v_double_arrow + + nresize top_side + sresize bottom_side + wresize left_side + eresize right_side + nwresize top_left_corner + neresize top_right_corner + swresize bottom_left_corner + seresize bottom_right_corner + move fleur + + } + + # Platform-specific overrides for Windows and OSX. + # + switch [tk windowingsystem] { + "win32" { + array set Cursors { + none {} + + standard arrow + text ibeam + link hand2 + crosshair crosshair + busy wait + forbidden no + + vresize size_ns + nresize size_ns + sresize size_ns + + wresize size_we + eresize size_we + hresize size_we + + nwresize size_nw_se + swresize size_ne_sw + + neresize size_ne_sw + seresize size_nw_se + } + } + + "aqua" { + if {[package vsatisfies [package provide Tk] 8.5]} { + # appeared 2007-04-23, Tk 8.5a6 + array set Cursors { + standard arrow + text ibeam + link pointinghand + crosshair crosshair + busy watch + forbidden notallowed + + hresize resizeleftright + vresize resizeupdown + nresize resizeup + sresize resizedown + wresize resizeleft + eresize resizeright + } + } + } + } +} + +## ttk::cursor $cursor -- +# Return platform-specific cursor for specified symbolic cursor. +# +proc ttk::cursor {name} { + variable Cursors + return $Cursors($name) +} + +## ttk::setCursor $w $cursor -- +# Set the cursor for specified window. +# +# [ttk::setCursor] should be used in <Motion> bindings +# instead of directly calling [$w configure -cursor ...], +# as the latter always incurs a server round-trip and +# can lead to high CPU load (see [#1184746]) +# + +proc ttk::setCursor {w name} { + variable Cursors + if {[$w cget -cursor] ne $Cursors($name)} { + $w configure -cursor $Cursors($name) + } +} + +## Interactive test harness: +# +proc ttk::CursorSampler {f} { + ttk::frame $f + + set r 0 + foreach row { + {nwresize nresize neresize} + { wresize move eresize} + {swresize sresize seresize} + {text link crosshair} + {hresize vresize ""} + {busy forbidden ""} + {none standard ""} + } { + set c 0 + foreach cursor $row { + set w $f.${r}${c} + ttk::label $w -text $cursor -cursor [ttk::cursor $cursor] \ + -relief solid -borderwidth 1 -padding 3 + grid $w -row $r -column $c -sticky nswe + grid columnconfigure $f $c -uniform cols -weight 1 + incr c + } + grid rowconfigure $f $r -uniform rows -weight 1 + incr r + } + + return $f +} + +if {[info exists argv0] && $argv0 eq [info script]} { + wm title . "[array size ::ttk::Cursors] cursors" + pack [ttk::CursorSampler .f] -expand true -fill both + bind . <KeyPress-Escape> [list destroy .] + focus .f +} + +#*EOF* diff --git a/library/ttk/defaults.tcl b/library/ttk/defaults.tcl new file mode 100644 index 0000000..05a46bd --- /dev/null +++ b/library/ttk/defaults.tcl @@ -0,0 +1,125 @@ +# +# Settings for default theme. +# + +namespace eval ttk::theme::default { + variable colors + array set colors { + -frame "#d9d9d9" + -foreground "#000000" + -window "#ffffff" + -text "#000000" + -activebg "#ececec" + -selectbg "#4a6984" + -selectfg "#ffffff" + -darker "#c3c3c3" + -disabledfg "#a3a3a3" + -indicator "#4a6984" + } + + ttk::style theme settings default { + + ttk::style configure "." \ + -borderwidth 1 \ + -background $colors(-frame) \ + -foreground $colors(-foreground) \ + -troughcolor $colors(-darker) \ + -font TkDefaultFont \ + -selectborderwidth 1 \ + -selectbackground $colors(-selectbg) \ + -selectforeground $colors(-selectfg) \ + -insertwidth 1 \ + -indicatordiameter 10 \ + ; + + ttk::style map "." -background \ + [list disabled $colors(-frame) active $colors(-activebg)] + ttk::style map "." -foreground \ + [list disabled $colors(-disabledfg)] + + ttk::style configure TButton \ + -anchor center -padding "3 3" -width -9 \ + -relief raised -shiftrelief 1 + ttk::style map TButton -relief [list {!disabled pressed} sunken] + + ttk::style configure TCheckbutton \ + -indicatorcolor "#ffffff" -indicatorrelief sunken -padding 1 + ttk::style map TCheckbutton -indicatorcolor \ + [list pressed $colors(-activebg) selected $colors(-indicator)] + + ttk::style configure TRadiobutton \ + -indicatorcolor "#ffffff" -indicatorrelief sunken -padding 1 + ttk::style map TRadiobutton -indicatorcolor \ + [list pressed $colors(-activebg) selected $colors(-indicator)] + + ttk::style configure TMenubutton \ + -relief raised -padding "10 3" + + ttk::style configure TEntry \ + -relief sunken -fieldbackground white -padding 1 + ttk::style map TEntry -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + + ttk::style configure TCombobox -arrowsize 12 -padding 1 + ttk::style map TCombobox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] + + ttk::style configure TSpinbox -arrowsize 10 -padding {2 0 10 0} + ttk::style map TSpinbox -fieldbackground \ + [list readonly $colors(-frame) disabled $colors(-frame)] \ + -arrowcolor [list disabled $colors(-disabledfg)] + + ttk::style configure TLabelframe \ + -relief groove -borderwidth 2 + + ttk::style configure TScrollbar \ + -width 12 -arrowsize 12 + ttk::style map TScrollbar \ + -arrowcolor [list disabled $colors(-disabledfg)] + + ttk::style configure TScale \ + -sliderrelief raised + ttk::style configure TProgressbar \ + -background $colors(-selectbg) + + ttk::style configure TNotebook.Tab \ + -padding {4 2} -background $colors(-darker) + ttk::style map TNotebook.Tab \ + -background [list selected $colors(-frame)] + + # Treeview. + # + ttk::style configure Heading -font TkHeadingFont -relief raised + ttk::style configure Treeview \ + -background $colors(-window) \ + -foreground $colors(-text) ; + ttk::style map Treeview \ + -background [list selected $colors(-selectbg)] \ + -foreground [list selected $colors(-selectfg)] ; + + # Combobox popdown frame + ttk::style layout ComboboxPopdownFrame { + ComboboxPopdownFrame.border -sticky nswe + } + ttk::style configure ComboboxPopdownFrame \ + -borderwidth 1 -relief solid + + # + # Toolbar buttons: + # + ttk::style layout Toolbutton { + Toolbutton.border -children { + Toolbutton.padding -children { + Toolbutton.label + } + } + } + + ttk::style configure Toolbutton \ + -padding 2 -relief flat + ttk::style map Toolbutton -relief \ + [list disabled flat selected sunken pressed sunken active raised] + ttk::style map Toolbutton -background \ + [list pressed $colors(-darker) active $colors(-activebg)] + } +} diff --git a/library/ttk/entry.tcl b/library/ttk/entry.tcl new file mode 100644 index 0000000..2c9fbc8 --- /dev/null +++ b/library/ttk/entry.tcl @@ -0,0 +1,585 @@ +# +# DERIVED FROM: tk/library/entry.tcl r1.22 +# +# Copyright (c) 1992-1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 2004, Joe English +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# + +namespace eval ttk { + namespace eval entry { + variable State + + set State(x) 0 + set State(selectMode) char + set State(anchor) 0 + set State(scanX) 0 + set State(scanIndex) 0 + set State(scanMoved) 0 + + # Button-2 scan speed is (scanNum/scanDen) characters + # per pixel of mouse movement. + # The standard Tk entry widget uses the equivalent of + # scanNum = 10, scanDen = average character width. + # I don't know why that was chosen. + # + set State(scanNum) 1 + set State(scanDen) 1 + set State(deadband) 3 ;# #pixels for mouse-moved deadband. + } +} + +### Option database settings. +# +option add *TEntry.cursor [ttk::cursor text] + +### Bindings. +# +# Removed the following standard Tk bindings: +# +# <Control-Key-space>, <Control-Shift-Key-space>, +# <Key-Select>, <Shift-Key-Select>: +# ttk::entry widget doesn't use selection anchor. +# <Key-Insert>: +# Inserts PRIMARY selection (on non-Windows platforms). +# This is inconsistent with typical platform bindings. +# <Double-Shift-ButtonPress-1>, <Triple-Shift-ButtonPress-1>: +# These don't do the right thing to start with. +# <Meta-Key-b>, <Meta-Key-d>, <Meta-Key-f>, +# <Meta-Key-BackSpace>, <Meta-Key-Delete>: +# Judgment call. If <Meta> happens to be assigned to the Alt key, +# these could conflict with application accelerators. +# (Plus, who has a Meta key these days?) +# <Control-Key-t>: +# Another judgment call. If anyone misses this, let me know +# and I'll put it back. +# + +## Clipboard events: +# +bind TEntry <<Cut>> { ttk::entry::Cut %W } +bind TEntry <<Copy>> { ttk::entry::Copy %W } +bind TEntry <<Paste>> { ttk::entry::Paste %W } +bind TEntry <<Clear>> { ttk::entry::Clear %W } + +## Button1 bindings: +# Used for selection and navigation. +# +bind TEntry <ButtonPress-1> { ttk::entry::Press %W %x } +bind TEntry <Shift-ButtonPress-1> { ttk::entry::Shift-Press %W %x } +bind TEntry <Double-ButtonPress-1> { ttk::entry::Select %W %x word } +bind TEntry <Triple-ButtonPress-1> { ttk::entry::Select %W %x line } +bind TEntry <B1-Motion> { ttk::entry::Drag %W %x } + +bind TEntry <B1-Leave> { ttk::Repeatedly ttk::entry::AutoScroll %W } +bind TEntry <B1-Enter> { ttk::CancelRepeat } +bind TEntry <ButtonRelease-1> { ttk::CancelRepeat } + +bind TEntry <Control-ButtonPress-1> { + %W instate {!readonly !disabled} { %W icursor @%x ; focus %W } +} + +## Button2 bindings: +# Used for scanning and primary transfer. +# Note: ButtonRelease-2 is mapped to <<PasteSelection>> in tk.tcl. +# +bind TEntry <ButtonPress-2> { ttk::entry::ScanMark %W %x } +bind TEntry <B2-Motion> { ttk::entry::ScanDrag %W %x } +bind TEntry <ButtonRelease-2> { ttk::entry::ScanRelease %W %x } +bind TEntry <<PasteSelection>> { ttk::entry::ScanRelease %W %x } + +## Keyboard navigation bindings: +# +bind TEntry <Key-Left> { ttk::entry::Move %W prevchar } +bind TEntry <Key-Right> { ttk::entry::Move %W nextchar } +bind TEntry <Control-Key-Left> { ttk::entry::Move %W prevword } +bind TEntry <Control-Key-Right> { ttk::entry::Move %W nextword } +bind TEntry <Key-Home> { ttk::entry::Move %W home } +bind TEntry <Key-End> { ttk::entry::Move %W end } + +bind TEntry <Shift-Key-Left> { ttk::entry::Extend %W prevchar } +bind TEntry <Shift-Key-Right> { ttk::entry::Extend %W nextchar } +bind TEntry <Shift-Control-Key-Left> { ttk::entry::Extend %W prevword } +bind TEntry <Shift-Control-Key-Right> { ttk::entry::Extend %W nextword } +bind TEntry <Shift-Key-Home> { ttk::entry::Extend %W home } +bind TEntry <Shift-Key-End> { ttk::entry::Extend %W end } + +bind TEntry <Control-Key-slash> { %W selection range 0 end } +bind TEntry <Control-Key-backslash> { %W selection clear } + +bind TEntry <<TraverseIn>> { %W selection range 0 end; %W icursor end } + +## Edit bindings: +# +bind TEntry <KeyPress> { ttk::entry::Insert %W %A } +bind TEntry <Key-Delete> { ttk::entry::Delete %W } +bind TEntry <Key-BackSpace> { ttk::entry::Backspace %W } + +# Ignore all Alt, Meta, and Control keypresses unless explicitly bound. +# Otherwise, the <KeyPress> class binding will fire and insert the character. +# Ditto for Escape, Return, and Tab. +# +bind TEntry <Alt-KeyPress> {# nothing} +bind TEntry <Meta-KeyPress> {# nothing} +bind TEntry <Control-KeyPress> {# nothing} +bind TEntry <Key-Escape> {# nothing} +bind TEntry <Key-Return> {# nothing} +bind TEntry <Key-KP_Enter> {# nothing} +bind TEntry <Key-Tab> {# nothing} + +# Argh. Apparently on Windows, the NumLock modifier is interpreted +# as a Command modifier. +if {[tk windowingsystem] eq "aqua"} { + bind TEntry <Command-KeyPress> {# nothing} +} +# Tk-on-Cocoa generates characters for these two keys. [Bug 2971663] +bind TEntry <Down> {# nothing} +bind TEntry <Up> {# nothing} + +## Additional emacs-like bindings: +# +bind TEntry <Control-Key-a> { ttk::entry::Move %W home } +bind TEntry <Control-Key-b> { ttk::entry::Move %W prevchar } +bind TEntry <Control-Key-d> { ttk::entry::Delete %W } +bind TEntry <Control-Key-e> { ttk::entry::Move %W end } +bind TEntry <Control-Key-f> { ttk::entry::Move %W nextchar } +bind TEntry <Control-Key-h> { ttk::entry::Backspace %W } +bind TEntry <Control-Key-k> { %W delete insert end } + +### Clipboard procedures. +# + +## EntrySelection -- Return the selected text of the entry. +# Raises an error if there is no selection. +# +proc ttk::entry::EntrySelection {w} { + set entryString [string range [$w get] [$w index sel.first] \ + [expr {[$w index sel.last] - 1}]] + if {[$w cget -show] ne ""} { + return [string repeat [string index [$w cget -show] 0] \ + [string length $entryString]] + } + return $entryString +} + +## Paste -- Insert clipboard contents at current insert point. +# +proc ttk::entry::Paste {w} { + catch { + set clipboard [::tk::GetSelection $w CLIPBOARD] + PendingDelete $w + $w insert insert $clipboard + See $w insert + } +} + +## Copy -- Copy selection to clipboard. +# +proc ttk::entry::Copy {w} { + if {![catch {EntrySelection $w} selection]} { + clipboard clear -displayof $w + clipboard append -displayof $w $selection + } +} + +## Clear -- Delete the selection. +# +proc ttk::entry::Clear {w} { + catch { $w delete sel.first sel.last } +} + +## Cut -- Copy selection to clipboard then delete it. +# +proc ttk::entry::Cut {w} { + Copy $w; Clear $w +} + +### Navigation procedures. +# + +## ClosestGap -- Find closest boundary between characters. +# Returns the index of the character just after the boundary. +# +proc ttk::entry::ClosestGap {w x} { + set pos [$w index @$x] + set bbox [$w bbox $pos] + if {$x - [lindex $bbox 0] > [lindex $bbox 2]/2} { + incr pos + } + return $pos +} + +## See $index -- Make sure that the character at $index is visible. +# +proc ttk::entry::See {w {index insert}} { + update idletasks ;# ensure scroll data up-to-date + set c [$w index $index] + # @@@ OR: check [$w index left] / [$w index right] + if {$c < [$w index @0] || $c >= [$w index @[winfo width $w]]} { + $w xview $c + } +} + +## NextWord -- Find the next word position. +# Note: The "next word position" follows platform conventions: +# either the next end-of-word position, or the start-of-word +# position following the next end-of-word position. +# +set ::ttk::entry::State(startNext) \ + [string equal [tk windowingsystem] "win32"] + +proc ttk::entry::NextWord {w start} { + variable State + set pos [tcl_endOfWord [$w get] [$w index $start]] + if {$pos >= 0 && $State(startNext)} { + set pos [tcl_startOfNextWord [$w get] $pos] + } + if {$pos < 0} { + return end + } + return $pos +} + +## PrevWord -- Find the previous word position. +# +proc ttk::entry::PrevWord {w start} { + set pos [tcl_startOfPreviousWord [$w get] [$w index $start]] + if {$pos < 0} { + return 0 + } + return $pos +} + +## RelIndex -- Compute character/word/line-relative index. +# +proc ttk::entry::RelIndex {w where {index insert}} { + switch -- $where { + prevchar { expr {[$w index $index] - 1} } + nextchar { expr {[$w index $index] + 1} } + prevword { PrevWord $w $index } + nextword { NextWord $w $index } + home { return 0 } + end { $w index end } + default { error "Bad relative index $index" } + } +} + +## Move -- Move insert cursor to relative location. +# Also clears the selection, if any, and makes sure +# that the insert cursor is visible. +# +proc ttk::entry::Move {w where} { + $w icursor [RelIndex $w $where] + $w selection clear + See $w insert +} + +### Selection procedures. +# + +## ExtendTo -- Extend the selection to the specified index. +# +# The other end of the selection (the anchor) is determined as follows: +# +# (1) if there is no selection, the anchor is the insert cursor; +# (2) if the index is outside the selection, grow the selection; +# (3) if the insert cursor is at one end of the selection, anchor the other end +# (4) otherwise anchor the start of the selection +# +# The insert cursor is placed at the new end of the selection. +# +# Returns: selection anchor. +# +proc ttk::entry::ExtendTo {w index} { + set index [$w index $index] + set insert [$w index insert] + + # Figure out selection anchor: + if {![$w selection present]} { + set anchor $insert + } else { + set selfirst [$w index sel.first] + set sellast [$w index sel.last] + + if { ($index < $selfirst) + || ($insert == $selfirst && $index <= $sellast) + } { + set anchor $sellast + } else { + set anchor $selfirst + } + } + + # Extend selection: + if {$anchor < $index} { + $w selection range $anchor $index + } else { + $w selection range $index $anchor + } + + $w icursor $index + return $anchor +} + +## Extend -- Extend the selection to a relative position, show insert cursor +# +proc ttk::entry::Extend {w where} { + ExtendTo $w [RelIndex $w $where] + See $w +} + +### Button 1 binding procedures. +# +# Double-clicking followed by a drag enters "word-select" mode. +# Triple-clicking enters "line-select" mode. +# + +## Press -- ButtonPress-1 binding. +# Set the insertion cursor, claim the input focus, set up for +# future drag operations. +# +proc ttk::entry::Press {w x} { + variable State + + $w icursor [ClosestGap $w $x] + $w selection clear + $w instate !disabled { focus $w } + + # Set up for future drag, double-click, or triple-click. + set State(x) $x + set State(selectMode) char + set State(anchor) [$w index insert] +} + +## Shift-Press -- Shift-ButtonPress-1 binding. +# Extends the selection, sets anchor for future drag operations. +# +proc ttk::entry::Shift-Press {w x} { + variable State + + focus $w + set anchor [ExtendTo $w @$x] + + set State(x) $x + set State(selectMode) char + set State(anchor) $anchor +} + +## Select $w $x $mode -- Binding for double- and triple- clicks. +# Selects a word or line (according to mode), +# and sets the selection mode for subsequent drag operations. +# +proc ttk::entry::Select {w x mode} { + variable State + set cur [ClosestGap $w $x] + + switch -- $mode { + word { WordSelect $w $cur $cur } + line { LineSelect $w $cur $cur } + char { # no-op } + } + + set State(anchor) $cur + set State(selectMode) $mode +} + +## Drag -- Button1 motion binding. +# +proc ttk::entry::Drag {w x} { + variable State + set State(x) $x + DragTo $w $x +} + +## DragTo $w $x -- Extend selection to $x based on current selection mode. +# +proc ttk::entry::DragTo {w x} { + variable State + + set cur [ClosestGap $w $x] + switch $State(selectMode) { + char { CharSelect $w $State(anchor) $cur } + word { WordSelect $w $State(anchor) $cur } + line { LineSelect $w $State(anchor) $cur } + } +} + +## AutoScroll +# Called repeatedly when the mouse is outside an entry window +# with Button 1 down. Scroll the window left or right, +# depending on where the mouse is, and extend the selection +# according to the current selection mode. +# +# TODO: AutoScroll should repeat faster (50ms) than normal autorepeat. +# TODO: Need a way for Repeat scripts to cancel themselves. +# +proc ttk::entry::AutoScroll {w} { + variable State + if {![winfo exists $w]} return + set x $State(x) + if {$x > [winfo width $w]} { + $w xview scroll 2 units + DragTo $w $x + } elseif {$x < 0} { + $w xview scroll -2 units + DragTo $w $x + } +} + +## CharSelect -- select characters between index $from and $to +# +proc ttk::entry::CharSelect {w from to} { + if {$to <= $from} { + $w selection range $to $from + } else { + $w selection range $from $to + } + $w icursor $to +} + +## WordSelect -- Select whole words between index $from and $to +# +proc ttk::entry::WordSelect {w from to} { + if {$to < $from} { + set first [WordBack [$w get] $to] + set last [WordForward [$w get] $from] + $w icursor $first + } else { + set first [WordBack [$w get] $from] + set last [WordForward [$w get] $to] + $w icursor $last + } + $w selection range $first $last +} + +## WordBack, WordForward -- helper routines for WordSelect. +# +proc ttk::entry::WordBack {text index} { + if {[set pos [tcl_wordBreakBefore $text $index]] < 0} { return 0 } + return $pos +} +proc ttk::entry::WordForward {text index} { + if {[set pos [tcl_wordBreakAfter $text $index]] < 0} { return end } + return $pos +} + +## LineSelect -- Select the entire line. +# +proc ttk::entry::LineSelect {w _ _} { + variable State + $w selection range 0 end + $w icursor end +} + +### Button 2 binding procedures. +# + +## ScanMark -- ButtonPress-2 binding. +# Marks the start of a scan or primary transfer operation. +# +proc ttk::entry::ScanMark {w x} { + variable State + set State(scanX) $x + set State(scanIndex) [$w index @0] + set State(scanMoved) 0 +} + +## ScanDrag -- Button2 motion binding. +# +proc ttk::entry::ScanDrag {w x} { + variable State + + set dx [expr {$State(scanX) - $x}] + if {abs($dx) > $State(deadband)} { + set State(scanMoved) 1 + } + set left [expr {$State(scanIndex) + ($dx*$State(scanNum))/$State(scanDen)}] + $w xview $left + + if {$left != [set newLeft [$w index @0]]} { + # We've scanned past one end of the entry; + # reset the mark so that the text will start dragging again + # as soon as the mouse reverses direction. + # + set State(scanX) $x + set State(scanIndex) $newLeft + } +} + +## ScanRelease -- Button2 release binding. +# Do a primary transfer if the mouse has not moved since the button press. +# +proc ttk::entry::ScanRelease {w x} { + variable State + if {!$State(scanMoved)} { + $w instate {!disabled !readonly} { + $w icursor [ClosestGap $w $x] + catch {$w insert insert [::tk::GetSelection $w PRIMARY]} + } + } +} + +### Insertion and deletion procedures. +# + +## PendingDelete -- Delete selection prior to insert. +# If the entry currently has a selection, delete it and +# set the insert position to where the selection was. +# Returns: 1 if pending delete occurred, 0 if nothing was selected. +# +proc ttk::entry::PendingDelete {w} { + if {[$w selection present]} { + $w icursor sel.first + $w delete sel.first sel.last + return 1 + } + return 0 +} + +## Insert -- Insert text into the entry widget. +# If a selection is present, the new text replaces it. +# Otherwise, the new text is inserted at the insert cursor. +# +proc ttk::entry::Insert {w s} { + if {$s eq ""} { return } + PendingDelete $w + $w insert insert $s + See $w insert +} + +## Backspace -- Backspace over the character just before the insert cursor. +# If there is a selection, delete that instead. +# If the new insert position is offscreen to the left, +# scroll to place the cursor at about the middle of the window. +# +proc ttk::entry::Backspace {w} { + if {[PendingDelete $w]} { + See $w + return + } + set x [expr {[$w index insert] - 1}] + if {$x < 0} { return } + + $w delete $x + + if {[$w index @0] >= [$w index insert]} { + set range [$w xview] + set left [lindex $range 0] + set right [lindex $range 1] + $w xview moveto [expr {$left - ($right - $left)/2.0}] + } +} + +## Delete -- Delete the character after the insert cursor. +# If there is a selection, delete that instead. +# +proc ttk::entry::Delete {w} { + if {![PendingDelete $w]} { + $w delete insert + } +} + +#*EOF* diff --git a/library/ttk/fonts.tcl b/library/ttk/fonts.tcl new file mode 100644 index 0000000..52298c5 --- /dev/null +++ b/library/ttk/fonts.tcl @@ -0,0 +1,157 @@ +# +# Font specifications. +# +# This file, [source]d at initialization time, sets up the following +# symbolic fonts based on the current platform: +# +# TkDefaultFont -- default for GUI items not otherwise specified +# TkTextFont -- font for user text (entry, listbox, others) +# TkFixedFont -- standard fixed width font +# TkHeadingFont -- headings (column headings, etc) +# TkCaptionFont -- dialog captions (primary text in alert dialogs, etc.) +# TkTooltipFont -- font to use for tooltip windows +# TkIconFont -- font to use for icon captions +# TkMenuFont -- used to use for menu items +# +# In Tk 8.5, some of these fonts may be provided by the TIP#145 implementation +# (On Windows and Mac OS X as of Oct 2007). +# +# +++ Platform notes: +# +# Windows: +# The default system font changed from "MS Sans Serif" to "Tahoma" +# in Windows XP/Windows 2000. +# +# MS documentation says to use "Tahoma 8" in Windows 2000/XP, +# although many MS programs still use "MS Sans Serif 8" +# +# Should use SystemParametersInfo() instead. +# +# Mac OSX / Aqua: +# Quoth the Apple HIG: +# The _system font_ (Lucida Grande Regular 13 pt) is used for text +# in menus, dialogs, and full-size controls. +# [...] Use the _view font_ (Lucida Grande Regular 12pt) as the default +# font of text in lists and tables. +# [...] Use the _emphasized system font_ (Lucida Grande Bold 13 pt) +# sparingly. It is used for the message text in alerts. +# [...] The _small system font_ (Lucida Grande Regular 11 pt) [...] +# is also the default font for column headings in lists, for help tags, +# and for small controls. +# +# Note that the font for column headings (TkHeadingFont) is +# _smaller_ than the default font. +# +# There does not appear to be any recommendations for fixed-width fonts. +# +# X11: +# Need a way to tell if Xft is enabled or not. +# For now, assume patch #971980 applied. +# +# "Classic" look used Helvetica bold for everything except +# for entry widgets, which use Helvetica medium. +# Most other toolkits use medium weight for all UI elements, +# which is what we do now. +# +# Font size specified in pixels on X11, not points. +# This is Theoretically Wrong, but in practice works better; using +# points leads to huge inconsistencies across different servers. +# + +namespace eval ttk { + +set tip145 [catch {font create TkDefaultFont}] +catch {font create TkTextFont} +catch {font create TkHeadingFont} +catch {font create TkCaptionFont} +catch {font create TkTooltipFont} +catch {font create TkFixedFont} +catch {font create TkIconFont} +catch {font create TkMenuFont} +catch {font create TkSmallCaptionFont} + +if {!$tip145} { +variable F ;# miscellaneous platform-specific font parameters +switch -- [tk windowingsystem] { + win32 { + # In safe interps there is no osVersion element. + if {[info exists tcl_platform(osVersion)]} { + if {$tcl_platform(osVersion) >= 5.0} { + set F(family) "Tahoma" + } else { + set F(family) "MS Sans Serif" + } + } else { + if {[lsearch -exact [font families] Tahoma] != -1} { + set F(family) "Tahoma" + } else { + set F(family) "MS Sans Serif" + } + } + set F(size) 8 + + font configure TkDefaultFont -family $F(family) -size $F(size) + font configure TkTextFont -family $F(family) -size $F(size) + font configure TkHeadingFont -family $F(family) -size $F(size) + font configure TkCaptionFont -family $F(family) -size $F(size) \ + -weight bold + font configure TkTooltipFont -family $F(family) -size $F(size) + font configure TkFixedFont -family Courier -size 10 + font configure TkIconFont -family $F(family) -size $F(size) + font configure TkMenuFont -family $F(family) -size $F(size) + font configure TkSmallCaptionFont -family $F(family) -size $F(size) + } + aqua { + set F(family) "Lucida Grande" + set F(fixed) "Monaco" + set F(menusize) 14 + set F(size) 13 + set F(viewsize) 12 + set F(smallsize) 11 + set F(labelsize) 10 + set F(fixedsize) 11 + + font configure TkDefaultFont -family $F(family) -size $F(size) + font configure TkTextFont -family $F(family) -size $F(size) + font configure TkHeadingFont -family $F(family) -size $F(smallsize) + font configure TkCaptionFont -family $F(family) -size $F(size) \ + -weight bold + font configure TkTooltipFont -family $F(family) -size $F(smallsize) + font configure TkFixedFont -family $F(fixed) -size $F(fixedsize) + font configure TkIconFont -family $F(family) -size $F(size) + font configure TkMenuFont -family $F(family) -size $F(menusize) + font configure TkSmallCaptionFont -family $F(family) -size $F(labelsize) + } + default - + x11 { + if {![catch {tk::pkgconfig get fontsystem} F(fs)] && $F(fs) eq "xft"} { + set F(family) "sans-serif" + set F(fixed) "monospace" + } else { + set F(family) "Helvetica" + set F(fixed) "courier" + } + set F(size) -12 + set F(ttsize) -10 + set F(capsize) -14 + set F(fixedsize) -12 + + font configure TkDefaultFont -family $F(family) -size $F(size) + font configure TkTextFont -family $F(family) -size $F(size) + font configure TkHeadingFont -family $F(family) -size $F(size) \ + -weight bold + font configure TkCaptionFont -family $F(family) -size $F(capsize) \ + -weight bold + font configure TkTooltipFont -family $F(family) -size $F(ttsize) + font configure TkFixedFont -family $F(fixed) -size $F(fixedsize) + font configure TkIconFont -family $F(family) -size $F(size) + font configure TkMenuFont -family $F(family) -size $F(size) + font configure TkSmallCaptionFont -family $F(family) -size $F(ttsize) + } +} +unset -nocomplain F +} + +} + +#*EOF* diff --git a/library/ttk/menubutton.tcl b/library/ttk/menubutton.tcl new file mode 100644 index 0000000..093bb02 --- /dev/null +++ b/library/ttk/menubutton.tcl @@ -0,0 +1,169 @@ +# +# Bindings for Menubuttons. +# +# Menubuttons have three interaction modes: +# +# Pulldown: Press menubutton, drag over menu, release to activate menu entry +# Popdown: Click menubutton to post menu +# Keyboard: <Key-space> or accelerator key to post menu +# +# (In addition, when menu system is active, "dropdown" -- menu posts +# on mouse-over. Ttk menubuttons don't implement this). +# +# For keyboard and popdown mode, we hand off to tk_popup and let +# the built-in Tk bindings handle the rest of the interaction. +# +# ON X11: +# +# Standard Tk menubuttons use a global grab on the menubutton. +# This won't work for Ttk menubuttons in pulldown mode, +# since we need to process the final <ButtonRelease> event, +# and this might be delivered to the menu. So instead we +# rely on the passive grab that occurs on <ButtonPress> events, +# and transition to popdown mode when the mouse is released +# or dragged outside the menubutton. +# +# ON WINDOWS: +# +# I'm not sure what the hell is going on here. [$menu post] apparently +# sets up some kind of internal grab for native menus. +# On this platform, just use [tk_popup] for all menu actions. +# +# ON MACOS: +# +# Same probably applies here. +# + +namespace eval ttk { + namespace eval menubutton { + variable State + array set State { + pulldown 0 + oldcursor {} + } + } +} + +bind TMenubutton <Enter> { %W instate !disabled {%W state active } } +bind TMenubutton <Leave> { %W state !active } +bind TMenubutton <Key-space> { ttk::menubutton::Popdown %W } +bind TMenubutton <<Invoke>> { ttk::menubutton::Popdown %W } + +if {[tk windowingsystem] eq "x11"} { + bind TMenubutton <ButtonPress-1> { ttk::menubutton::Pulldown %W } + bind TMenubutton <ButtonRelease-1> { ttk::menubutton::TransferGrab %W } + bind TMenubutton <B1-Leave> { ttk::menubutton::TransferGrab %W } +} else { + bind TMenubutton <ButtonPress-1> \ + { %W state pressed ; ttk::menubutton::Popdown %W } + bind TMenubutton <ButtonRelease-1> \ + { %W state !pressed } +} + +# PostPosition -- +# Returns the x and y coordinates where the menu +# should be posted, based on the menubutton and menu size +# and -direction option. +# +# TODO: adjust menu width to be at least as wide as the button +# for -direction above, below. +# +proc ttk::menubutton::PostPosition {mb menu} { + set x [winfo rootx $mb] + set y [winfo rooty $mb] + set dir [$mb cget -direction] + + set bw [winfo width $mb] + set bh [winfo height $mb] + set mw [winfo reqwidth $menu] + set mh [winfo reqheight $menu] + set sw [expr {[winfo screenwidth $menu] - $bw - $mw}] + set sh [expr {[winfo screenheight $menu] - $bh - $mh}] + + switch -- $dir { + above { if {$y >= $mh} { incr y -$mh } { incr y $bh } } + below { if {$y <= $sh} { incr y $bh } { incr y -$mh } } + left { if {$x >= $mw} { incr x -$mw } { incr x $bw } } + right { if {$x <= $sw} { incr x $bw } { incr x -$mw } } + flush { + # post menu atop menubutton. + # If there's a menu entry whose label matches the + # menubutton -text, assume this is an optionmenu + # and place that entry over the menubutton. + set index [FindMenuEntry $menu [$mb cget -text]] + if {$index ne ""} { + incr y -[$menu yposition $index] + } + } + } + + return [list $x $y] +} + +# Popdown -- +# Post the menu and set a grab on the menu. +# +proc ttk::menubutton::Popdown {mb} { + if {[$mb instate disabled] || [set menu [$mb cget -menu]] eq ""} { + return + } + foreach {x y} [PostPosition $mb $menu] { break } + tk_popup $menu $x $y +} + +# Pulldown (X11 only) -- +# Called when Button1 is pressed on a menubutton. +# Posts the menu; a subsequent ButtonRelease +# or Leave event will set a grab on the menu. +# +proc ttk::menubutton::Pulldown {mb} { + variable State + if {[$mb instate disabled] || [set menu [$mb cget -menu]] eq ""} { + return + } + foreach {x y} [PostPosition $mb $menu] { break } + set State(pulldown) 1 + set State(oldcursor) [$mb cget -cursor] + + $mb state pressed + $mb configure -cursor [$menu cget -cursor] + $menu post $x $y + tk_menuSetFocus $menu +} + +# TransferGrab (X11 only) -- +# Switch from pulldown mode (menubutton has an implicit grab) +# to popdown mode (menu has an explicit grab). +# +proc ttk::menubutton::TransferGrab {mb} { + variable State + if {$State(pulldown)} { + $mb configure -cursor $State(oldcursor) + $mb state {!pressed !active} + set State(pulldown) 0 + + set menu [$mb cget -menu] + tk_popup $menu [winfo rootx $menu] [winfo rooty $menu] + } +} + +# FindMenuEntry -- +# Hack to support tk_optionMenus. +# Returns the index of the menu entry with a matching -label, +# -1 if not found. +# +proc ttk::menubutton::FindMenuEntry {menu s} { + set last [$menu index last] + if {$last eq "none"} { + return "" + } + for {set i 0} {$i <= $last} {incr i} { + if {![catch {$menu entrycget $i -label} label] + && ($label eq $s)} { + return $i + } + } + return "" +} + +#*EOF* diff --git a/library/ttk/notebook.tcl b/library/ttk/notebook.tcl new file mode 100644 index 0000000..d424b6c --- /dev/null +++ b/library/ttk/notebook.tcl @@ -0,0 +1,197 @@ +# +# Bindings for TNotebook widget +# + +namespace eval ttk::notebook { + variable TLNotebooks ;# See enableTraversal +} + +bind TNotebook <ButtonPress-1> { ttk::notebook::Press %W %x %y } +bind TNotebook <Key-Right> { ttk::notebook::CycleTab %W 1; break } +bind TNotebook <Key-Left> { ttk::notebook::CycleTab %W -1; break } +bind TNotebook <Control-Key-Tab> { ttk::notebook::CycleTab %W 1; break } +bind TNotebook <Control-Shift-Key-Tab> { ttk::notebook::CycleTab %W -1; break } +catch { +bind TNotebook <Control-ISO_Left_Tab> { ttk::notebook::CycleTab %W -1; break } +} +bind TNotebook <Destroy> { ttk::notebook::Cleanup %W } + +# ActivateTab $nb $tab -- +# Select the specified tab and set focus. +# +# Desired behavior: +# + take focus when reselecting the currently-selected tab; +# + keep focus if the notebook already has it; +# + otherwise set focus to the first traversable widget +# in the newly-selected tab; +# + do not leave the focus in a deselected tab. +# +proc ttk::notebook::ActivateTab {w tab} { + set oldtab [$w select] + $w select $tab + set newtab [$w select] ;# NOTE: might not be $tab, if $tab is disabled + + if {[focus] eq $w} { return } + if {$newtab eq $oldtab} { focus $w ; return } + + update idletasks ;# needed so focus logic sees correct mapped states + if {[set f [ttk::focusFirst $newtab]] ne ""} { + ttk::traverseTo $f + } else { + focus $w + } +} + +# Press $nb $x $y -- +# ButtonPress-1 binding for notebook widgets. +# Activate the tab under the mouse cursor, if any. +# +proc ttk::notebook::Press {w x y} { + set index [$w index @$x,$y] + if {$index ne ""} { + ActivateTab $w $index + } +} + +# CycleTab -- +# Select the next/previous tab in the list. +# +proc ttk::notebook::CycleTab {w dir} { + if {[$w index end] != 0} { + set current [$w index current] + set select [expr {($current + $dir) % [$w index end]}] + while {[$w tab $select -state] != "normal" && ($select != $current)} { + set select [expr {($select + $dir) % [$w index end]}] + } + if {$select != $current} { + ActivateTab $w $select + } + } +} + +# MnemonicTab $nb $key -- +# Scan all tabs in the specified notebook for one with the +# specified mnemonic. If found, returns path name of tab; +# otherwise returns "" +# +proc ttk::notebook::MnemonicTab {nb key} { + set key [string toupper $key] + foreach tab [$nb tabs] { + set label [$nb tab $tab -text] + set underline [$nb tab $tab -underline] + set mnemonic [string toupper [string index $label $underline]] + if {$mnemonic ne "" && $mnemonic eq $key} { + return $tab + } + } + return "" +} + +# +++ Toplevel keyboard traversal. +# + +# enableTraversal -- +# Enable keyboard traversal for a notebook widget +# by adding bindings to the containing toplevel window. +# +# TLNotebooks($top) keeps track of the list of all traversal-enabled +# notebooks contained in the toplevel +# +proc ttk::notebook::enableTraversal {nb} { + variable TLNotebooks + + set top [winfo toplevel $nb] + + if {![info exists TLNotebooks($top)]} { + # Augment $top bindings: + # + bind $top <Control-Key-Next> {+ttk::notebook::TLCycleTab %W 1} + bind $top <Control-Key-Prior> {+ttk::notebook::TLCycleTab %W -1} + bind $top <Control-Key-Tab> {+ttk::notebook::TLCycleTab %W 1} + bind $top <Shift-Control-Key-Tab> {+ttk::notebook::TLCycleTab %W -1} + catch { + bind $top <Control-Key-ISO_Left_Tab> {+ttk::notebook::TLCycleTab %W -1} + } + if {[tk windowingsystem] eq "aqua"} { + bind $top <Option-KeyPress> \ + +[list ttk::notebook::MnemonicActivation $top %K] + } else { + bind $top <Alt-KeyPress> \ + +[list ttk::notebook::MnemonicActivation $top %K] + } + bind $top <Destroy> {+ttk::notebook::TLCleanup %W} + } + + lappend TLNotebooks($top) $nb +} + +# TLCleanup -- <Destroy> binding for traversal-enabled toplevels +# +proc ttk::notebook::TLCleanup {w} { + variable TLNotebooks + if {$w eq [winfo toplevel $w]} { + unset -nocomplain -please TLNotebooks($w) + } +} + +# Cleanup -- <Destroy> binding for notebooks +# +proc ttk::notebook::Cleanup {nb} { + variable TLNotebooks + set top [winfo toplevel $nb] + if {[info exists TLNotebooks($top)]} { + set index [lsearch -exact $TLNotebooks($top) $nb] + set TLNotebooks($top) [lreplace $TLNotebooks($top) $index $index] + } +} + +# EnclosingNotebook $w -- +# Return the nearest traversal-enabled notebook widget +# that contains $w. +# +# BUGS: this only works properly for tabs that are direct children +# of the notebook widget. This routine should follow the +# geometry manager hierarchy, not window ancestry, but that +# information is not available in Tk. +# +proc ttk::notebook::EnclosingNotebook {w} { + variable TLNotebooks + + set top [winfo toplevel $w] + if {![info exists TLNotebooks($top)]} { return } + + while {$w ne $top && $w ne ""} { + if {[lsearch -exact $TLNotebooks($top) $w] >= 0} { + return $w + } + set w [winfo parent $w] + } + return "" +} + +# TLCycleTab -- +# toplevel binding procedure for Control-Tab / Shift-Control-Tab +# Select the next/previous tab in the nearest ancestor notebook. +# +proc ttk::notebook::TLCycleTab {w dir} { + set nb [EnclosingNotebook $w] + if {$nb ne ""} { + CycleTab $nb $dir + return -code break + } +} + +# MnemonicActivation $nb $key -- +# Alt-KeyPress binding procedure for mnemonic activation. +# Scan all notebooks in specified toplevel for a tab with the +# the specified mnemonic. If found, activate it and return TCL_BREAK. +# +proc ttk::notebook::MnemonicActivation {top key} { + variable TLNotebooks + foreach nb $TLNotebooks($top) { + if {[set tab [MnemonicTab $nb $key]] ne ""} { + ActivateTab $nb [$nb index $tab] + return -code break + } + } +} diff --git a/library/ttk/panedwindow.tcl b/library/ttk/panedwindow.tcl new file mode 100644 index 0000000..a2e073b --- /dev/null +++ b/library/ttk/panedwindow.tcl @@ -0,0 +1,82 @@ +# +# Bindings for ttk::panedwindow widget. +# + +namespace eval ttk::panedwindow { + variable State + array set State { + pressed 0 + pressX - + pressY - + sash - + sashPos - + } +} + +## Bindings: +# +bind TPanedwindow <ButtonPress-1> { ttk::panedwindow::Press %W %x %y } +bind TPanedwindow <B1-Motion> { ttk::panedwindow::Drag %W %x %y } +bind TPanedwindow <ButtonRelease-1> { ttk::panedwindow::Release %W %x %y } + +bind TPanedwindow <Motion> { ttk::panedwindow::SetCursor %W %x %y } +bind TPanedwindow <Enter> { ttk::panedwindow::SetCursor %W %x %y } +bind TPanedwindow <Leave> { ttk::panedwindow::ResetCursor %W } +# See <<NOTE-PW-LEAVE-NOTIFYINFERIOR>> +bind TPanedwindow <<EnteredChild>> { ttk::panedwindow::ResetCursor %W } + +## Sash movement: +# +proc ttk::panedwindow::Press {w x y} { + variable State + + set sash [$w identify $x $y] + if {$sash eq ""} { + set State(pressed) 0 + return + } + set State(pressed) 1 + set State(pressX) $x + set State(pressY) $y + set State(sash) $sash + set State(sashPos) [$w sashpos $sash] +} + +proc ttk::panedwindow::Drag {w x y} { + variable State + if {!$State(pressed)} { return } + switch -- [$w cget -orient] { + horizontal { set delta [expr {$x - $State(pressX)}] } + vertical { set delta [expr {$y - $State(pressY)}] } + } + $w sashpos $State(sash) [expr {$State(sashPos) + $delta}] +} + +proc ttk::panedwindow::Release {w x y} { + variable State + set State(pressed) 0 + SetCursor $w $x $y +} + +## Cursor management: +# +proc ttk::panedwindow::ResetCursor {w} { + variable State + if {!$State(pressed)} { + ttk::setCursor $w {} + } +} + +proc ttk::panedwindow::SetCursor {w x y} { + set cursor "" + if {[llength [$w identify $x $y]]} { + # Assume we're over a sash. + switch -- [$w cget -orient] { + horizontal { set cursor hresize } + vertical { set cursor vresize } + } + } + ttk::setCursor $w $cursor +} + +#*EOF* diff --git a/library/ttk/progress.tcl b/library/ttk/progress.tcl new file mode 100644 index 0000000..b6e2ffb --- /dev/null +++ b/library/ttk/progress.tcl @@ -0,0 +1,49 @@ +# +# Ttk widget set: progress bar utilities. +# + +namespace eval ttk::progressbar { + variable Timers ;# Map: widget name -> after ID +} + +# Autoincrement -- +# Periodic callback procedure for autoincrement mode +# +proc ttk::progressbar::Autoincrement {pb steptime stepsize} { + variable Timers + + if {![winfo exists $pb]} { + # widget has been destroyed -- cancel timer + unset -nocomplain Timers($pb) + return + } + + $pb step $stepsize + + set Timers($pb) [after $steptime \ + [list ttk::progressbar::Autoincrement $pb $steptime $stepsize] ] +} + +# ttk::progressbar::start -- +# Start autoincrement mode. Invoked by [$pb start] widget code. +# +proc ttk::progressbar::start {pb {steptime 50} {stepsize 1}} { + variable Timers + if {![info exists Timers($pb)]} { + Autoincrement $pb $steptime $stepsize + } +} + +# ttk::progressbar::stop -- +# Cancel autoincrement mode. Invoked by [$pb stop] widget code. +# +proc ttk::progressbar::stop {pb} { + variable Timers + if {[info exists Timers($pb)]} { + after cancel $Timers($pb) + unset Timers($pb) + } + $pb configure -value 0 +} + + diff --git a/library/ttk/scale.tcl b/library/ttk/scale.tcl new file mode 100644 index 0000000..23d08ed --- /dev/null +++ b/library/ttk/scale.tcl @@ -0,0 +1,88 @@ +# scale.tcl - Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net> +# +# Bindings for the TScale widget + +namespace eval ttk::scale { + variable State + array set State { + dragging 0 + } +} + +bind TScale <ButtonPress-1> { ttk::scale::Press %W %x %y } +bind TScale <B1-Motion> { ttk::scale::Drag %W %x %y } +bind TScale <ButtonRelease-1> { ttk::scale::Release %W %x %y } + +bind TScale <ButtonPress-2> { ttk::scale::Jump %W %x %y } +bind TScale <B2-Motion> { ttk::scale::Drag %W %x %y } +bind TScale <ButtonRelease-2> { ttk::scale::Release %W %x %y } + +bind TScale <ButtonPress-3> { ttk::scale::Jump %W %x %y } +bind TScale <B3-Motion> { ttk::scale::Drag %W %x %y } +bind TScale <ButtonRelease-3> { ttk::scale::Release %W %x %y } + +bind TScale <Left> { ttk::scale::Increment %W -1 } +bind TScale <Up> { ttk::scale::Increment %W -1 } +bind TScale <Right> { ttk::scale::Increment %W 1 } +bind TScale <Down> { ttk::scale::Increment %W 1 } +bind TScale <Control-Left> { ttk::scale::Increment %W -10 } +bind TScale <Control-Up> { ttk::scale::Increment %W -10 } +bind TScale <Control-Right> { ttk::scale::Increment %W 10 } +bind TScale <Control-Down> { ttk::scale::Increment %W 10 } +bind TScale <Home> { %W set [%W cget -from] } +bind TScale <End> { %W set [%W cget -to] } + +proc ttk::scale::Press {w x y} { + variable State + set State(dragging) 0 + + switch -glob -- [$w identify $x $y] { + *track - + *trough { + set inc [expr {([$w get $x $y] <= [$w get]) ? -1 : 1}] + ttk::Repeatedly Increment $w $inc + } + *slider { + set State(dragging) 1 + set State(initial) [$w get] + } + } +} + +# scale::Jump -- ButtonPress-2/3 binding for scale acts like +# Press except that clicking in the trough jumps to the +# clicked position. +proc ttk::scale::Jump {w x y} { + variable State + set State(dragging) 0 + + switch -glob -- [$w identify $x $y] { + *track - + *trough { + $w set [$w get $x $y] + set State(dragging) 1 + set State(initial) [$w get] + } + *slider { + Press $w $x $y + } + } +} + +proc ttk::scale::Drag {w x y} { + variable State + if {$State(dragging)} { + $w set [$w get $x $y] + } +} + +proc ttk::scale::Release {w x y} { + variable State + set State(dragging) 0 + ttk::CancelRepeat +} + +proc ttk::scale::Increment {w delta} { + if {![winfo exists $w]} return + $w set [expr {[$w get] + $delta}] +} diff --git a/library/ttk/scrollbar.tcl b/library/ttk/scrollbar.tcl new file mode 100644 index 0000000..4bd5107 --- /dev/null +++ b/library/ttk/scrollbar.tcl @@ -0,0 +1,123 @@ +# +# Bindings for TScrollbar widget +# + +# Still don't have a working ttk::scrollbar under OSX - +# Swap in a [tk::scrollbar] on that platform, +# unless user specifies -class or -style. +# +if {[tk windowingsystem] eq "aqua"} { + rename ::ttk::scrollbar ::ttk::_scrollbar + proc ttk::scrollbar {w args} { + set constructor ::tk::scrollbar + foreach {option _} $args { + if {$option eq "-class" || $option eq "-style"} { + set constructor ::ttk::_scrollbar + break + } + } + return [$constructor $w {*}$args] + } +} + +namespace eval ttk::scrollbar { + variable State + # State(xPress) -- + # State(yPress) -- initial position of mouse at start of drag. + # State(first) -- value of -first at start of drag. +} + +bind TScrollbar <ButtonPress-1> { ttk::scrollbar::Press %W %x %y } +bind TScrollbar <B1-Motion> { ttk::scrollbar::Drag %W %x %y } +bind TScrollbar <ButtonRelease-1> { ttk::scrollbar::Release %W %x %y } + +bind TScrollbar <ButtonPress-2> { ttk::scrollbar::Jump %W %x %y } +bind TScrollbar <B2-Motion> { ttk::scrollbar::Drag %W %x %y } +bind TScrollbar <ButtonRelease-2> { ttk::scrollbar::Release %W %x %y } + +proc ttk::scrollbar::Scroll {w n units} { + set cmd [$w cget -command] + if {$cmd ne ""} { + uplevel #0 $cmd scroll $n $units + } +} + +proc ttk::scrollbar::Moveto {w fraction} { + set cmd [$w cget -command] + if {$cmd ne ""} { + uplevel #0 $cmd moveto $fraction + } +} + +proc ttk::scrollbar::Press {w x y} { + variable State + + set State(xPress) $x + set State(yPress) $y + + switch -glob -- [$w identify $x $y] { + *uparrow - + *leftarrow { + ttk::Repeatedly Scroll $w -1 units + } + *downarrow - + *rightarrow { + ttk::Repeatedly Scroll $w 1 units + } + *thumb { + set State(first) [lindex [$w get] 0] + } + *trough { + set f [$w fraction $x $y] + if {$f < [lindex [$w get] 0]} { + # Clicked in upper/left trough + ttk::Repeatedly Scroll $w -1 pages + } elseif {$f > [lindex [$w get] 1]} { + # Clicked in lower/right trough + ttk::Repeatedly Scroll $w 1 pages + } else { + # Clicked on thumb (???) + set State(first) [lindex [$w get] 0] + } + } + } +} + +proc ttk::scrollbar::Drag {w x y} { + variable State + if {![info exists State(first)]} { + # Initial buttonpress was not on the thumb, + # or something screwy has happened. In either case, ignore: + return; + } + set xDelta [expr {$x - $State(xPress)}] + set yDelta [expr {$y - $State(yPress)}] + Moveto $w [expr {$State(first) + [$w delta $xDelta $yDelta]}] +} + +proc ttk::scrollbar::Release {w x y} { + variable State + unset -nocomplain State(xPress) State(yPress) State(first) + ttk::CancelRepeat +} + +# scrollbar::Jump -- ButtonPress-2 binding for scrollbars. +# Behaves exactly like scrollbar::Press, except that +# clicking in the trough jumps to the the selected position. +# +proc ttk::scrollbar::Jump {w x y} { + variable State + + switch -glob -- [$w identify $x $y] { + *thumb - + *trough { + set State(first) [$w fraction $x $y] + Moveto $w $State(first) + set State(xPress) $x + set State(yPress) $y + } + default { + Press $w $x $y + } + } +} diff --git a/library/ttk/sizegrip.tcl b/library/ttk/sizegrip.tcl new file mode 100644 index 0000000..153e310 --- /dev/null +++ b/library/ttk/sizegrip.tcl @@ -0,0 +1,102 @@ +# +# Sizegrip widget bindings. +# +# Dragging a sizegrip widget resizes the containing toplevel. +# +# NOTE: the sizegrip widget must be in the lower right hand corner. +# + +switch -- [tk windowingsystem] { + x11 - + win32 { + option add *TSizegrip.cursor [ttk::cursor seresize] + } + aqua { + # Aqua sizegrips use default Arrow cursor. + } +} + +namespace eval ttk::sizegrip { + variable State + array set State { + pressed 0 + pressX 0 + pressY 0 + width 0 + height 0 + widthInc 1 + heightInc 1 + resizeX 1 + resizeY 1 + toplevel {} + } +} + +bind TSizegrip <ButtonPress-1> { ttk::sizegrip::Press %W %X %Y } +bind TSizegrip <B1-Motion> { ttk::sizegrip::Drag %W %X %Y } +bind TSizegrip <ButtonRelease-1> { ttk::sizegrip::Release %W %X %Y } + +proc ttk::sizegrip::Press {W X Y} { + variable State + + if {[$W instate disabled]} { return } + + set top [winfo toplevel $W] + + # If the toplevel is not resizable then bail + foreach {State(resizeX) State(resizeY)} [wm resizable $top] break + if {!$State(resizeX) && !$State(resizeY)} { + return + } + + # Sanity-checks: + # If a negative X or Y position was specified for [wm geometry], + # just bail out -- there's no way to handle this cleanly. + # + if {[scan [wm geometry $top] "%dx%d+%d+%d" width height x y] != 4} { + return; + } + + # Account for gridded geometry: + # + set grid [wm grid $top] + if {[llength $grid]} { + set State(widthInc) [lindex $grid 2] + set State(heightInc) [lindex $grid 3] + } else { + set State(widthInc) [set State(heightInc) 1] + } + + set State(toplevel) $top + set State(pressX) $X + set State(pressY) $Y + set State(width) $width + set State(height) $height + set State(x) $x + set State(y) $y + set State(pressed) 1 +} + +proc ttk::sizegrip::Drag {W X Y} { + variable State + if {!$State(pressed)} { return } + set w $State(width) + set h $State(height) + if {$State(resizeX)} { + set w [expr {$w + ($X - $State(pressX))/$State(widthInc)}] + } + if {$State(resizeY)} { + set h [expr {$h + ($Y - $State(pressY))/$State(heightInc)}] + } + if {$w <= 0} { set w 1 } + if {$h <= 0} { set h 1 } + set x $State(x) ; set y $State(y) + wm geometry $State(toplevel) ${w}x${h}+${x}+${y} +} + +proc ttk::sizegrip::Release {W X Y} { + variable State + set State(pressed) 0 +} + +#*EOF* diff --git a/library/ttk/spinbox.tcl b/library/ttk/spinbox.tcl new file mode 100644 index 0000000..1aa0ccb --- /dev/null +++ b/library/ttk/spinbox.tcl @@ -0,0 +1,173 @@ +# +# ttk::spinbox bindings +# + +namespace eval ttk::spinbox { } + +### Spinbox bindings. +# +# Duplicate the Entry bindings, override if needed: +# + +ttk::copyBindings TEntry TSpinbox + +bind TSpinbox <Motion> { ttk::spinbox::Motion %W %x %y } +bind TSpinbox <ButtonPress-1> { ttk::spinbox::Press %W %x %y } +bind TSpinbox <ButtonRelease-1> { ttk::spinbox::Release %W } +bind TSpinbox <Double-Button-1> { ttk::spinbox::DoubleClick %W %x %y } +bind TSpinbox <Triple-Button-1> {} ;# disable TEntry triple-click + +bind TSpinbox <KeyPress-Up> { event generate %W <<Increment>> } +bind TSpinbox <KeyPress-Down> { event generate %W <<Decrement>> } + +bind TSpinbox <<Increment>> { ttk::spinbox::Spin %W +1 } +bind TSpinbox <<Decrement>> { ttk::spinbox::Spin %W -1 } + +ttk::bindMouseWheel TSpinbox [list ttk::spinbox::MouseWheel %W] + +## Motion -- +# Sets cursor. +# +proc ttk::spinbox::Motion {w x y} { + if { [$w identify $x $y] eq "textarea" + && [$w instate {!readonly !disabled}] + } { + ttk::setCursor $w text + } else { + ttk::setCursor $w "" + } +} + +## Press -- +# +proc ttk::spinbox::Press {w x y} { + if {[$w instate disabled]} { return } + focus $w + switch -glob -- [$w identify $x $y] { + *textarea { ttk::entry::Press $w $x } + *rightarrow - + *uparrow { ttk::Repeatedly event generate $w <<Increment>> } + *leftarrow - + *downarrow { ttk::Repeatedly event generate $w <<Decrement>> } + *spinbutton { + if {$y * 2 >= [winfo height $w]} { + set event <<Decrement>> + } else { + set event <<Increment>> + } + ttk::Repeatedly event generate $w $event + } + } +} + +## DoubleClick -- +# Select all if over the text area; otherwise same as Press. +# +proc ttk::spinbox::DoubleClick {w x y} { + if {[$w instate disabled]} { return } + + switch -glob -- [$w identify $x $y] { + *textarea { SelectAll $w } + * { Press $w $x $y } + } +} + +proc ttk::spinbox::Release {w} { + ttk::CancelRepeat +} + +## MouseWheel -- +# Mousewheel callback. Turn these into <<Increment>> (-1, up) +# or <<Decrement> (+1, down) events. +# +proc ttk::spinbox::MouseWheel {w dir} { + if {$dir < 0} { + event generate $w <<Increment>> + } else { + event generate $w <<Decrement>> + } +} + +## SelectAll -- +# Select widget contents. +# +proc ttk::spinbox::SelectAll {w} { + $w selection range 0 end + $w icursor end +} + +## Limit -- +# Limit $v to lie between $min and $max +# +proc ttk::spinbox::Limit {v min max} { + if {$v < $min} { return $min } + if {$v > $max} { return $max } + return $v +} + +## Wrap -- +# Adjust $v to lie between $min and $max, wrapping if out of bounds. +# +proc ttk::spinbox::Wrap {v min max} { + if {$v < $min} { return $max } + if {$v > $max} { return $min } + return $v +} + +## Adjust -- +# Limit or wrap spinbox value depending on -wrap. +# +proc ttk::spinbox::Adjust {w v min max} { + if {[$w cget -wrap]} { + return [Wrap $v $min $max] + } else { + return [Limit $v $min $max] + } +} + +## Spin -- +# Handle <<Increment>> and <<Decrement>> events. +# If -values is specified, cycle through the list. +# Otherwise cycle through numeric range based on +# -from, -to, and -increment. +# +proc ttk::spinbox::Spin {w dir} { + set nvalues [llength [set values [$w cget -values]]] + set value [$w get] + if {$nvalues} { + set current [lsearch -exact $values $value] + set index [Adjust $w [expr {$current + $dir}] 0 [expr {$nvalues - 1}]] + $w set [lindex $values $index] + } else { + if {[catch { + set v [expr {[scan [$w get] %f] + $dir * [$w cget -increment]}] + }]} { + set v [$w cget -from] + } + $w set [FormatValue $w [Adjust $w $v [$w cget -from] [$w cget -to]]] + } + SelectAll $w + uplevel #0 [$w cget -command] +} + +## FormatValue -- +# Reformat numeric value based on -format. +# +proc ttk::spinbox::FormatValue {w val} { + set fmt [$w cget -format] + if {$fmt eq ""} { + # Try to guess a suitable -format based on -increment. + set delta [expr {abs([$w cget -increment])}] + if {0 < $delta && $delta < 1} { + # NB: This guesses wrong if -increment has more than 1 + # significant digit itself, e.g., -increment 0.25 + set nsd [expr {int(ceil(-log10($delta)))}] + set fmt "%.${nsd}f" + } else { + set fmt "%.0f" + } + } + return [format $fmt $val] +} + +#*EOF* diff --git a/library/ttk/treeview.tcl b/library/ttk/treeview.tcl new file mode 100644 index 0000000..1160e9b --- /dev/null +++ b/library/ttk/treeview.tcl @@ -0,0 +1,363 @@ +# +# ttk::treeview widget bindings and utilities. +# + +namespace eval ttk::treeview { + variable State + + # Enter/Leave/Motion + # + set State(activeWidget) {} + set State(activeHeading) {} + + # Press/drag/release: + # + set State(pressMode) none + set State(pressX) 0 + + # For pressMode == "resize" + set State(resizeColumn) #0 + + # For pressmode == "heading" + set State(heading) {} +} + +### Widget bindings. +# + +bind Treeview <Motion> { ttk::treeview::Motion %W %x %y } +bind Treeview <B1-Leave> { #nothing } +bind Treeview <Leave> { ttk::treeview::ActivateHeading {} {}} +bind Treeview <ButtonPress-1> { ttk::treeview::Press %W %x %y } +bind Treeview <Double-ButtonPress-1> { ttk::treeview::DoubleClick %W %x %y } +bind Treeview <ButtonRelease-1> { ttk::treeview::Release %W %x %y } +bind Treeview <B1-Motion> { ttk::treeview::Drag %W %x %y } +bind Treeview <KeyPress-Up> { ttk::treeview::Keynav %W up } +bind Treeview <KeyPress-Down> { ttk::treeview::Keynav %W down } +bind Treeview <KeyPress-Right> { ttk::treeview::Keynav %W right } +bind Treeview <KeyPress-Left> { ttk::treeview::Keynav %W left } +bind Treeview <KeyPress-Prior> { %W yview scroll -1 pages } +bind Treeview <KeyPress-Next> { %W yview scroll 1 pages } +bind Treeview <KeyPress-Return> { ttk::treeview::ToggleFocus %W } +bind Treeview <KeyPress-space> { ttk::treeview::ToggleFocus %W } + +bind Treeview <Shift-ButtonPress-1> \ + { ttk::treeview::Select %W %x %y extend } +bind Treeview <Control-ButtonPress-1> \ + { ttk::treeview::Select %W %x %y toggle } + +ttk::copyBindings TtkScrollable Treeview + +### Binding procedures. +# + +## Keynav -- Keyboard navigation +# +# @@@ TODO: verify/rewrite up and down code. +# +proc ttk::treeview::Keynav {w dir} { + set focus [$w focus] + if {$focus eq ""} { return } + + switch -- $dir { + up { + if {[set up [$w prev $focus]] eq ""} { + set focus [$w parent $focus] + } else { + while {[$w item $up -open] && [llength [$w children $up]]} { + set up [lindex [$w children $up] end] + } + set focus $up + } + } + down { + if {[$w item $focus -open] && [llength [$w children $focus]]} { + set focus [lindex [$w children $focus] 0] + } else { + set up $focus + while {$up ne "" && [set down [$w next $up]] eq ""} { + set up [$w parent $up] + } + set focus $down + } + } + left { + if {[$w item $focus -open] && [llength [$w children $focus]]} { + CloseItem $w $focus + } else { + set focus [$w parent $focus] + } + } + right { + OpenItem $w $focus + } + } + + if {$focus != {}} { + SelectOp $w $focus choose + } +} + +## Motion -- pointer motion binding. +# Sets cursor, active element ... +# +proc ttk::treeview::Motion {w x y} { + set cursor {} + set activeHeading {} + + switch -- [$w identify region $x $y] { + separator { set cursor hresize } + heading { set activeHeading [$w identify column $x $y] } + } + + ttk::setCursor $w $cursor + ActivateHeading $w $activeHeading +} + +## ActivateHeading -- track active heading element +# +proc ttk::treeview::ActivateHeading {w heading} { + variable State + + if {$w != $State(activeWidget) || $heading != $State(activeHeading)} { + if {$State(activeHeading) != {}} { + $State(activeWidget) heading $State(activeHeading) state !active + } + if {$heading != {}} { + $w heading $heading state active + } + set State(activeHeading) $heading + set State(activeWidget) $w + } +} + +## Select $w $x $y $selectop +# Binding procedure for selection operations. +# See "Selection modes", below. +# +proc ttk::treeview::Select {w x y op} { + if {[set item [$w identify row $x $y]] ne "" } { + SelectOp $w $item $op + } +} + +## DoubleClick -- Double-ButtonPress-1 binding. +# +proc ttk::treeview::DoubleClick {w x y} { + if {[set row [$w identify row $x $y]] ne ""} { + Toggle $w $row + } else { + Press $w $x $y ;# perform single-click action + } +} + +## Press -- ButtonPress binding. +# +proc ttk::treeview::Press {w x y} { + focus $w + switch -- [$w identify region $x $y] { + nothing { } + heading { heading.press $w $x $y } + separator { resize.press $w $x $y } + tree - + cell { + set item [$w identify item $x $y] + SelectOp $w $item choose + switch -glob -- [$w identify element $x $y] { + *indicator - + *disclosure { Toggle $w $item } + } + } + } +} + +## Drag -- B1-Motion binding +# +proc ttk::treeview::Drag {w x y} { + variable State + switch $State(pressMode) { + resize { resize.drag $w $x } + heading { heading.drag $w $x $y } + } +} + +proc ttk::treeview::Release {w x y} { + variable State + switch $State(pressMode) { + resize { resize.release $w $x } + heading { heading.release $w } + } + set State(pressMode) none + Motion $w $x $y +} + +### Interactive column resizing. +# +proc ttk::treeview::resize.press {w x y} { + variable State + set State(pressMode) "resize" + set State(resizeColumn) [$w identify column $x $y] +} + +proc ttk::treeview::resize.drag {w x} { + variable State + $w drag $State(resizeColumn) $x +} + +proc ttk::treeview::resize.release {w x} { + # no-op +} + +### Heading activation. +# + +proc ttk::treeview::heading.press {w x y} { + variable State + set column [$w identify column $x $y] + set State(pressMode) "heading" + set State(heading) $column + $w heading $column state pressed +} + +proc ttk::treeview::heading.drag {w x y} { + variable State + if { [$w identify region $x $y] eq "heading" + && [$w identify column $x $y] eq $State(heading) + } { + $w heading $State(heading) state pressed + } else { + $w heading $State(heading) state !pressed + } +} + +proc ttk::treeview::heading.release {w} { + variable State + if {[lsearch -exact [$w heading $State(heading) state] pressed] >= 0} { + after 0 [$w heading $State(heading) -command] + } + $w heading $State(heading) state !pressed +} + +### Selection modes. +# + +## SelectOp $w $item [ choose | extend | toggle ] -- +# Dispatch to appropriate selection operation +# depending on current value of -selectmode. +# +proc ttk::treeview::SelectOp {w item op} { + select.$op.[$w cget -selectmode] $w $item +} + +## -selectmode none: +# +proc ttk::treeview::select.choose.none {w item} { $w focus $item } +proc ttk::treeview::select.toggle.none {w item} { $w focus $item } +proc ttk::treeview::select.extend.none {w item} { $w focus $item } + +## -selectmode browse: +# +proc ttk::treeview::select.choose.browse {w item} { BrowseTo $w $item } +proc ttk::treeview::select.toggle.browse {w item} { BrowseTo $w $item } +proc ttk::treeview::select.extend.browse {w item} { BrowseTo $w $item } + +## -selectmode multiple: +# +proc ttk::treeview::select.choose.extended {w item} { + BrowseTo $w $item +} +proc ttk::treeview::select.toggle.extended {w item} { + $w selection toggle [list $item] +} +proc ttk::treeview::select.extend.extended {w item} { + if {[set anchor [$w focus]] ne ""} { + $w selection set [between $w $anchor $item] + } else { + BrowseTo $w $item + } +} + +### Tree structure utilities. +# + +## between $tv $item1 $item2 -- +# Returns a list of all items between $item1 and $item2, +# in preorder traversal order. $item1 and $item2 may be +# in either order. +# +# NOTES: +# This routine is O(N) in the size of the tree. +# There's probably a way to do this that's O(N) in the number +# of items returned, but I'm not clever enough to figure it out. +# +proc ttk::treeview::between {tv item1 item2} { + variable between [list] + variable selectingBetween 0 + ScanBetween $tv $item1 $item2 {} + return $between +} + +## ScanBetween -- +# Recursive worker routine for ttk::treeview::between +# +proc ttk::treeview::ScanBetween {tv item1 item2 item} { + variable between + variable selectingBetween + + if {$item eq $item1 || $item eq $item2} { + lappend between $item + set selectingBetween [expr {!$selectingBetween}] + } elseif {$selectingBetween} { + lappend between $item + } + foreach child [$tv children $item] { + ScanBetween $tv $item1 $item2 $child + } +} + +### User interaction utilities. +# + +## OpenItem, CloseItem -- Set the open state of an item, generate event +# + +proc ttk::treeview::OpenItem {w item} { + $w focus $item + event generate $w <<TreeviewOpen>> + $w item $item -open true +} + +proc ttk::treeview::CloseItem {w item} { + $w item $item -open false + $w focus $item + event generate $w <<TreeviewClose>> +} + +## Toggle -- toggle opened/closed state of item +# +proc ttk::treeview::Toggle {w item} { + if {[$w item $item -open]} { + CloseItem $w $item + } else { + OpenItem $w $item + } +} + +## ToggleFocus -- toggle opened/closed state of focus item +# +proc ttk::treeview::ToggleFocus {w} { + set item [$w focus] + if {$item ne ""} { + Toggle $w $item + } +} + +## BrowseTo -- navigate to specified item; set focus and selection +# +proc ttk::treeview::BrowseTo {w item} { + $w see $item + $w focus $item + $w selection set [list $item] +} + +#*EOF* diff --git a/library/ttk/ttk.tcl b/library/ttk/ttk.tcl new file mode 100644 index 0000000..7bae211 --- /dev/null +++ b/library/ttk/ttk.tcl @@ -0,0 +1,176 @@ +# +# Ttk widget set initialization script. +# + +### Source library scripts. +# + +namespace eval ::ttk { + variable library + if {![info exists library]} { + set library [file dirname [info script]] + } +} + +source [file join $::ttk::library fonts.tcl] +source [file join $::ttk::library cursors.tcl] +source [file join $::ttk::library utils.tcl] + +## ttk::deprecated $old $new -- +# Define $old command as a deprecated alias for $new command +# $old and $new must be fully namespace-qualified. +# +proc ttk::deprecated {old new} { + interp alias {} $old {} ttk::do'deprecate $old $new +} +## do'deprecate -- +# Implementation procedure for deprecated commands -- +# issue a warning (once), then re-alias old to new. +# +proc ttk::do'deprecate {old new args} { + deprecated'warning $old $new + interp alias {} $old {} $new + uplevel 1 [linsert $args 0 $new] +} + +## deprecated'warning -- +# Gripe about use of deprecated commands. +# +proc ttk::deprecated'warning {old new} { + puts stderr "$old deprecated -- use $new instead" +} + +### Backward-compatibility. +# +# +# Make [package require tile] an effective no-op; +# see SF#3016598 for discussion. +# +package ifneeded tile 0.8.6 { package provide tile 0.8.6 } + +# ttk::panedwindow used to be named ttk::paned. Keep the alias for now. +# +::ttk::deprecated ::ttk::paned ::ttk::panedwindow + +### ::ttk::ThemeChanged -- +# Called from [::ttk::style theme use]. +# Sends a <<ThemeChanged>> virtual event to all widgets. +# +proc ::ttk::ThemeChanged {} { + set Q . + while {[llength $Q]} { + set QN [list] + foreach w $Q { + event generate $w <<ThemeChanged>> + foreach child [winfo children $w] { + lappend QN $child + } + } + set Q $QN + } +} + +### Public API. +# + +proc ::ttk::themes {{ptn *}} { + set themes [list] + + foreach pkg [lsearch -inline -all -glob [package names] ttk::theme::$ptn] { + lappend themes [namespace tail $pkg] + } + + return $themes +} + +## ttk::setTheme $theme -- +# Set the current theme to $theme, loading it if necessary. +# +proc ::ttk::setTheme {theme} { + variable currentTheme ;# @@@ Temp -- [::ttk::style theme use] doesn't work + if {$theme ni [::ttk::style theme names]} { + package require ttk::theme::$theme + } + ::ttk::style theme use $theme + set currentTheme $theme +} + +### Load widget bindings. +# +source [file join $::ttk::library button.tcl] +source [file join $::ttk::library menubutton.tcl] +source [file join $::ttk::library scrollbar.tcl] +source [file join $::ttk::library scale.tcl] +source [file join $::ttk::library progress.tcl] +source [file join $::ttk::library notebook.tcl] +source [file join $::ttk::library panedwindow.tcl] +source [file join $::ttk::library entry.tcl] +source [file join $::ttk::library combobox.tcl] ;# dependency: entry.tcl +source [file join $::ttk::library spinbox.tcl] ;# dependency: entry.tcl +source [file join $::ttk::library treeview.tcl] +source [file join $::ttk::library sizegrip.tcl] + +## Label and Labelframe bindings: +# (not enough to justify their own file...) +# +bind TLabelframe <<Invoke>> { tk::TabToWindow [tk_focusNext %W] } +bind TLabel <<Invoke>> { tk::TabToWindow [tk_focusNext %W] } + +### Load settings for built-in themes: +# +proc ttk::LoadThemes {} { + variable library + + # "default" always present: + uplevel #0 [list source [file join $library defaults.tcl]] + + set builtinThemes [style theme names] + foreach {theme scripts} { + classic classicTheme.tcl + alt altTheme.tcl + clam clamTheme.tcl + winnative winTheme.tcl + xpnative {xpTheme.tcl vistaTheme.tcl} + aqua aquaTheme.tcl + } { + if {[lsearch -exact $builtinThemes $theme] >= 0} { + foreach script $scripts { + uplevel #0 [list source [file join $library $script]] + } + } + } +} + +ttk::LoadThemes; rename ::ttk::LoadThemes {} + +### Select platform-specific default theme: +# +# Notes: +# + On OSX, aqua theme is the default +# + On Windows, xpnative takes precedence over winnative if available. +# + On X11, users can use the X resource database to +# specify a preferred theme (*TkTheme: themeName); +# otherwise "default" is used. +# + +proc ttk::DefaultTheme {} { + set preferred [list aqua vista xpnative winnative] + + set userTheme [option get . tkTheme TkTheme] + if {$userTheme ne {} && ![catch { + uplevel #0 [list package require ttk::theme::$userTheme] + }]} { + return $userTheme + } + + foreach theme $preferred { + if {[package provide ttk::theme::$theme] ne ""} { + return $theme + } + } + return "default" +} + +ttk::setTheme [ttk::DefaultTheme] ; rename ttk::DefaultTheme {} + +#*EOF* diff --git a/library/ttk/utils.tcl b/library/ttk/utils.tcl new file mode 100644 index 0000000..7cc1bb7 --- /dev/null +++ b/library/ttk/utils.tcl @@ -0,0 +1,350 @@ +# +# Utilities for widget implementations. +# + +### Focus management. +# +# See also: #1516479 +# + +## ttk::takefocus -- +# This is the default value of the "-takefocus" option +# for ttk::* widgets that participate in keyboard navigation. +# +# NOTES: +# tk::FocusOK (called by tk_focusNext) tests [winfo viewable] +# if -takefocus is 1, empty, or missing; but not if it's a +# script prefix, so we have to check that here as well. +# +# +proc ttk::takefocus {w} { + expr {[$w instate !disabled] && [winfo viewable $w]} +} + +## ttk::GuessTakeFocus -- +# This routine is called as a fallback for widgets +# with a missing or empty -takefocus option. +# +# It implements the same heuristics as tk::FocusOK. +# +proc ttk::GuessTakeFocus {w} { + # Don't traverse to widgets with '-state disabled': + # + if {![catch {$w cget -state} state] && $state eq "disabled"} { + return 0 + } + + # Allow traversal to widgets with explicit key or focus bindings: + # + if {[regexp {Key|Focus} [concat [bind $w] [bind [winfo class $w]]]]} { + return 1; + } + + # Default is nontraversable: + # + return 0; +} + +## ttk::traverseTo $w -- +# Set the keyboard focus to the specified window. +# +proc ttk::traverseTo {w} { + set focus [focus] + if {$focus ne ""} { + event generate $focus <<TraverseOut>> + } + focus $w + event generate $w <<TraverseIn>> +} + +## ttk::clickToFocus $w -- +# Utility routine, used in <ButtonPress-1> bindings -- +# Assign keyboard focus to the specified widget if -takefocus is enabled. +# +proc ttk::clickToFocus {w} { + if {[ttk::takesFocus $w]} { focus $w } +} + +## ttk::takesFocus w -- +# Test if the widget can take keyboard focus. +# +# See the description of the -takefocus option in options(n) +# for details. +# +proc ttk::takesFocus {w} { + if {![winfo viewable $w]} { + return 0 + } elseif {[catch {$w cget -takefocus} takefocus]} { + return [GuessTakeFocus $w] + } else { + switch -- $takefocus { + "" { return [GuessTakeFocus $w] } + 0 { return 0 } + 1 { return 1 } + default { + return [expr {[uplevel #0 $takefocus [list $w]] == 1}] + } + } + } +} + +## ttk::focusFirst $w -- +# Return the first descendant of $w, in preorder traversal order, +# that can take keyboard focus, "" if none do. +# +# See also: tk_focusNext +# + +proc ttk::focusFirst {w} { + if {[ttk::takesFocus $w]} { + return $w + } + foreach child [winfo children $w] { + if {[set c [ttk::focusFirst $child]] ne ""} { + return $c + } + } + return "" +} + +### Grabs. +# +# Rules: +# Each call to [grabWindow $w] or [globalGrab $w] must be +# matched with a call to [releaseGrab $w] in LIFO order. +# +# Do not call [grabWindow $w] for a window that currently +# appears on the grab stack. +# +# See #1239190 and #1411983 for more discussion. +# +namespace eval ttk { + variable Grab ;# map: window name -> grab token + + # grab token details: + # Two-element list containing: + # 1) a script to evaluate to restore the previous grab (if any); + # 2) a script to evaluate to restore the focus (if any) +} + +## SaveGrab -- +# Record current grab and focus windows. +# +proc ttk::SaveGrab {w} { + variable Grab + + if {[info exists Grab($w)]} { + # $w is already on the grab stack. + # This should not happen, but bail out in case it does anyway: + # + return + } + + set restoreGrab [set restoreFocus ""] + + set grabbed [grab current $w] + if {[winfo exists $grabbed]} { + switch [grab status $grabbed] { + global { set restoreGrab [list grab -global $grabbed] } + local { set restoreGrab [list grab $grabbed] } + none { ;# grab window is really in a different interp } + } + } + + set focus [focus] + if {$focus ne ""} { + set restoreFocus [list focus -force $focus] + } + + set Grab($w) [list $restoreGrab $restoreFocus] +} + +## RestoreGrab -- +# Restore previous grab and focus windows. +# If called more than once without an intervening [SaveGrab $w], +# does nothing. +# +proc ttk::RestoreGrab {w} { + variable Grab + + if {![info exists Grab($w)]} { # Ignore + return; + } + + # The previous grab/focus window may have been destroyed, + # unmapped, or some other abnormal condition; ignore any errors. + # + foreach script $Grab($w) { + catch $script + } + + unset Grab($w) +} + +## ttk::grabWindow $w -- +# Records the current focus and grab windows, sets an application-modal +# grab on window $w. +# +proc ttk::grabWindow {w} { + SaveGrab $w + grab $w +} + +## ttk::globalGrab $w -- +# Same as grabWindow, but sets a global grab on $w. +# +proc ttk::globalGrab {w} { + SaveGrab $w + grab -global $w +} + +## ttk::releaseGrab -- +# Release the grab previously set by [ttk::grabWindow] +# or [ttk::globalGrab]. +# +proc ttk::releaseGrab {w} { + grab release $w + RestoreGrab $w +} + +### Auto-repeat. +# +# NOTE: repeating widgets do not have -repeatdelay +# or -repeatinterval resources as in standard Tk; +# instead a single set of settings is applied application-wide. +# (TODO: make this user-configurable) +# +# (@@@ Windows seems to use something like 500/50 milliseconds +# @@@ for -repeatdelay/-repeatinterval) +# + +namespace eval ttk { + variable Repeat + array set Repeat { + delay 300 + interval 100 + timer {} + script {} + } +} + +## ttk::Repeatedly -- +# Begin auto-repeat. +# +proc ttk::Repeatedly {args} { + variable Repeat + after cancel $Repeat(timer) + set script [uplevel 1 [list namespace code $args]] + set Repeat(script) $script + uplevel #0 $script + set Repeat(timer) [after $Repeat(delay) ttk::Repeat] +} + +## Repeat -- +# Continue auto-repeat +# +proc ttk::Repeat {} { + variable Repeat + uplevel #0 $Repeat(script) + set Repeat(timer) [after $Repeat(interval) ttk::Repeat] +} + +## ttk::CancelRepeat -- +# Halt auto-repeat. +# +proc ttk::CancelRepeat {} { + variable Repeat + after cancel $Repeat(timer) +} + +### Bindings. +# + +## ttk::copyBindings $from $to -- +# Utility routine; copies bindings from one bindtag onto another. +# +proc ttk::copyBindings {from to} { + foreach event [bind $from] { + bind $to $event [bind $from $event] + } +} + +### Mousewheel bindings. +# +# Platform inconsistencies: +# +# On X11, the server typically maps the mouse wheel to Button4 and Button5. +# +# On OSX, Tk generates sensible values for the %D field in <MouseWheel> events. +# +# On Windows, %D must be scaled by a factor of 120. +# In addition, Tk redirects mousewheel events to the window with +# keyboard focus instead of sending them to the window under the pointer. +# We do not attempt to fix that here, see also TIP#171. +# +# OSX conventionally uses Shift+MouseWheel for horizontal scrolling, +# and Option+MouseWheel for accelerated scrolling. +# +# The Shift+MouseWheel behavior is not conventional on Windows or most +# X11 toolkits, but it's useful. +# +# MouseWheel scrolling is accelerated on X11, which is conventional +# for Tk and appears to be conventional for other toolkits (although +# Gtk+ and Qt do not appear to use as large a factor). +# + +## ttk::bindMouseWheel $bindtag $command... +# Adds basic mousewheel support to $bindtag. +# $command will be passed one additional argument +# specifying the mousewheel direction (-1: up, +1: down). +# + +proc ttk::bindMouseWheel {bindtag callback} { + switch -- [tk windowingsystem] { + x11 { + bind $bindtag <ButtonPress-4> "$callback -1" + bind $bindtag <ButtonPress-5> "$callback +1" + } + win32 { + bind $bindtag <MouseWheel> [append callback { [expr {-(%D/120)}]}] + } + aqua { + bind $bindtag <MouseWheel> [append callback { [expr {-(%D)}]} ] + } + } +} + +## Mousewheel bindings for standard scrollable widgets. +# +# Usage: [ttk::copyBindings TtkScrollable $bindtag] +# +# $bindtag should be for a widget that supports the +# standard scrollbar protocol. +# + +switch -- [tk windowingsystem] { + x11 { + bind TtkScrollable <ButtonPress-4> { %W yview scroll -5 units } + bind TtkScrollable <ButtonPress-5> { %W yview scroll 5 units } + bind TtkScrollable <Shift-ButtonPress-4> { %W xview scroll -5 units } + bind TtkScrollable <Shift-ButtonPress-5> { %W xview scroll 5 units } + } + win32 { + bind TtkScrollable <MouseWheel> \ + { %W yview scroll [expr {-(%D/120)}] units } + bind TtkScrollable <Shift-MouseWheel> \ + { %W xview scroll [expr {-(%D/120)}] units } + } + aqua { + bind TtkScrollable <MouseWheel> \ + { %W yview scroll [expr {-(%D)}] units } + bind TtkScrollable <Shift-MouseWheel> \ + { %W xview scroll [expr {-(%D)}] units } + bind TtkScrollable <Option-MouseWheel> \ + { %W yview scroll [expr {-10*(%D)}] units } + bind TtkScrollable <Shift-Option-MouseWheel> \ + { %W xview scroll [expr {-10*(%D)}] units } + } +} + +#*EOF* diff --git a/library/ttk/vistaTheme.tcl b/library/ttk/vistaTheme.tcl new file mode 100644 index 0000000..99410cb --- /dev/null +++ b/library/ttk/vistaTheme.tcl @@ -0,0 +1,224 @@ +# +# Settings for Microsoft Windows Vista and Server 2008 +# + +# The Vista theme can only be defined on Windows Vista and above. The theme +# is created in C due to the need to assign a theme-enabled function for +# detecting when themeing is disabled. On systems that cannot support the +# Vista theme, there will be no such theme created and we must not +# evaluate this script. + +if {"vista" ni [ttk::style theme names]} { + return +} + +namespace eval ttk::theme::vista { + + ttk::style theme settings vista { + + ttk::style configure . \ + -background SystemButtonFace \ + -foreground SystemWindowText \ + -selectforeground SystemHighlightText \ + -selectbackground SystemHighlight \ + -font TkDefaultFont \ + ; + + ttk::style map "." \ + -foreground [list disabled SystemGrayText] \ + ; + + ttk::style configure TButton -anchor center -padding {1 1} -width -11 + ttk::style configure TRadiobutton -padding 2 + ttk::style configure TCheckbutton -padding 2 + ttk::style configure TMenubutton -padding {8 4} + + ttk::style element create Menubutton.dropdown vsapi \ + TOOLBAR 4 {{selected active} 6 {selected !active} 5 + disabled 4 pressed 3 active 2 {} 1} \ + -syssize {SM_CXVSCROLL SM_CYVSCROLL} + + ttk::style configure TNotebook -tabmargins {2 2 2 0} + ttk::style map TNotebook.Tab \ + -expand [list selected {2 2 2 2}] + + # Treeview: + ttk::style configure Heading -font TkHeadingFont + ttk::style configure Treeview -background SystemWindow + ttk::style map Treeview \ + -background [list selected SystemHighlight] \ + -foreground [list selected SystemHighlightText] ; + + # Label and Toolbutton + ttk::style configure TLabelframe.Label -foreground "#0046d5" + + ttk::style configure Toolbutton -padding {4 4} + + # Combobox + ttk::style configure TCombobox -padding 2 + ttk::style element create Combobox.field vsapi \ + COMBOBOX 2 {{} 1} + ttk::style element create Combobox.border vsapi \ + COMBOBOX 4 {disabled 4 focus 3 active 2 hover 2 {} 1} + ttk::style element create Combobox.rightdownarrow vsapi \ + COMBOBOX 6 {disabled 4 pressed 3 active 2 {} 1} \ + -syssize {SM_CXVSCROLL SM_CYVSCROLL} + ttk::style layout TCombobox { + Combobox.border -sticky nswe -border 0 -children { + Combobox.rightdownarrow -side right -sticky ns + Combobox.padding -expand 1 -sticky nswe -children { + Combobox.focus -expand 1 -sticky nswe -children { + Combobox.textarea -sticky nswe + } + } + } + } + # Vista.Combobox droplist frame + ttk::style element create ComboboxPopdownFrame.background vsapi\ + LISTBOX 3 {disabled 4 active 3 focus 2 {} 1} + ttk::style layout ComboboxPopdownFrame { + ComboboxPopdownFrame.background -sticky news -border 1 -children { + ComboboxPopdownFrame.padding -sticky news + } + } + ttk::style map TCombobox \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + -foreground [list \ + disabled SystemGrayText \ + {readonly focus} SystemHighlightText \ + ] \ + -focusfill [list {readonly focus} SystemHighlight] \ + ; + + # Entry + ttk::style configure TEntry -padding {1 1 1 1} ;# Needs lookup + ttk::style element create Entry.field vsapi \ + EDIT 6 {disabled 4 focus 3 hover 2 {} 1} -padding {2 2 2 2} + ttk::style element create Entry.background vsapi \ + EDIT 3 {disabled 3 readonly 3 focus 4 hover 2 {} 1} + ttk::style layout TEntry { + Entry.field -sticky news -border 0 -children { + Entry.background -sticky news -children { + Entry.padding -sticky news -children { + Entry.textarea -sticky news + } + } + } + } + ttk::style map TEntry \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + ; + + # Spinbox + ttk::style configure TSpinbox -padding 0 + ttk::style element create Spinbox.field vsapi \ + EDIT 9 {disabled 4 focus 3 hover 2 {} 1} -padding {1 1 1 2} + ttk::style element create Spinbox.background vsapi \ + EDIT 3 {disabled 3 readonly 3 focus 4 hover 2 {} 1} + ttk::style element create Spinbox.innerbg vsapi \ + EDIT 3 {disabled 3 readonly 3 focus 4 hover 2 {} 1}\ + -padding {2 0 15 2} + ttk::style element create Spinbox.uparrow vsapi \ + SPIN 1 {disabled 4 pressed 3 active 2 {} 1} \ + -padding 1 -halfheight 1 \ + -syssize { SM_CXVSCROLL SM_CYVSCROLL } + ttk::style element create Spinbox.downarrow vsapi \ + SPIN 2 {disabled 4 pressed 3 active 2 {} 1} \ + -padding 1 -halfheight 1 \ + -syssize { SM_CXVSCROLL SM_CYVSCROLL } + ttk::style layout TSpinbox { + Spinbox.field -sticky nswe -children { + Spinbox.background -sticky news -children { + Spinbox.padding -sticky news -children { + Spinbox.innerbg -sticky news -children { + Spinbox.textarea -expand 1 -sticky {} + } + } + Spinbox.uparrow -side top -sticky ens + Spinbox.downarrow -side bottom -sticky ens + } + } + } + ttk::style map TSpinbox \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + ; + + + # SCROLLBAR elements (Vista includes a state for 'hover') + ttk::style element create Vertical.Scrollbar.uparrow vsapi \ + SCROLLBAR 1 {disabled 4 pressed 3 active 2 hover 17 {} 1} \ + -syssize {SM_CXVSCROLL SM_CYVSCROLL} + ttk::style element create Vertical.Scrollbar.downarrow vsapi \ + SCROLLBAR 1 {disabled 8 pressed 7 active 6 hover 18 {} 5} \ + -syssize {SM_CXVSCROLL SM_CYVSCROLL} + ttk::style element create Vertical.Scrollbar.trough vsapi \ + SCROLLBAR 7 {disabled 4 pressed 3 active 2 hover 5 {} 1} + ttk::style element create Vertical.Scrollbar.thumb vsapi \ + SCROLLBAR 3 {disabled 4 pressed 3 active 2 hover 5 {} 1} \ + -syssize {SM_CXVSCROLL SM_CYVSCROLL} + ttk::style element create Vertical.Scrollbar.grip vsapi \ + SCROLLBAR 9 {disabled 4 pressed 3 active 2 hover 5 {} 1} \ + -syssize {SM_CXVSCROLL SM_CYVSCROLL} + ttk::style element create Horizontal.Scrollbar.leftarrow vsapi \ + SCROLLBAR 1 {disabled 12 pressed 11 active 10 hover 19 {} 9} \ + -syssize {SM_CXHSCROLL SM_CYHSCROLL} + ttk::style element create Horizontal.Scrollbar.rightarrow vsapi \ + SCROLLBAR 1 {disabled 16 pressed 15 active 14 hover 20 {} 13} \ + -syssize {SM_CXHSCROLL SM_CYHSCROLL} + ttk::style element create Horizontal.Scrollbar.trough vsapi \ + SCROLLBAR 5 {disabled 4 pressed 3 active 2 hover 5 {} 1} + ttk::style element create Horizontal.Scrollbar.thumb vsapi \ + SCROLLBAR 2 {disabled 4 pressed 3 active 2 hover 5 {} 1} \ + -syssize {SM_CXHSCROLL SM_CYHSCROLL} + ttk::style element create Horizontal.Scrollbar.grip vsapi \ + SCROLLBAR 8 {disabled 4 pressed 3 active 2 hover 5 {} 1} + + # Progressbar + ttk::style element create Horizontal.Progressbar.pbar vsapi \ + PROGRESS 3 {{} 1} -padding 8 + ttk::style layout Horizontal.TProgressbar { + Horizontal.Progressbar.trough -sticky nswe -children { + Horizontal.Progressbar.pbar -side left -sticky ns + } + } + ttk::style element create Vertical.Progressbar.pbar vsapi \ + PROGRESS 3 {{} 1} -padding 8 + ttk::style layout Vertical.TProgressbar { + Vertical.Progressbar.trough -sticky nswe -children { + Vertical.Progressbar.pbar -side bottom -sticky we + } + } + + # Scale + ttk::style element create Horizontal.Scale.slider vsapi \ + TRACKBAR 3 {disabled 5 focus 4 pressed 3 active 2 {} 1} \ + -width 6 -height 12 + ttk::style layout Horizontal.TScale { + Scale.focus -expand 1 -sticky nswe -children { + Horizontal.Scale.trough -expand 1 -sticky nswe -children { + Horizontal.Scale.track -sticky we + Horizontal.Scale.slider -side left -sticky {} + } + } + } + ttk::style element create Vertical.Scale.slider vsapi \ + TRACKBAR 6 {disabled 5 focus 4 pressed 3 active 2 {} 1} \ + -width 12 -height 6 + ttk::style layout Vertical.TScale { + Scale.focus -expand 1 -sticky nswe -children { + Vertical.Scale.trough -expand 1 -sticky nswe -children { + Vertical.Scale.track -sticky ns + Vertical.Scale.slider -side top -sticky {} + } + } + } + + # Treeview + ttk::style configure Item -padding {4 0 0 0} + + package provide ttk::theme::vista 1.0 + } +} diff --git a/library/ttk/winTheme.tcl b/library/ttk/winTheme.tcl new file mode 100644 index 0000000..55367bc --- /dev/null +++ b/library/ttk/winTheme.tcl @@ -0,0 +1,80 @@ +# +# Settings for 'winnative' theme. +# + +namespace eval ttk::theme::winnative { + ttk::style theme settings winnative { + + ttk::style configure "." \ + -background SystemButtonFace \ + -foreground SystemWindowText \ + -selectforeground SystemHighlightText \ + -selectbackground SystemHighlight \ + -troughcolor SystemScrollbar \ + -font TkDefaultFont \ + ; + + ttk::style map "." -foreground [list disabled SystemGrayText] ; + ttk::style map "." -embossed [list disabled 1] ; + + ttk::style configure TButton \ + -anchor center -width -11 -relief raised -shiftrelief 1 + ttk::style configure TCheckbutton -padding "2 4" + ttk::style configure TRadiobutton -padding "2 4" + ttk::style configure TMenubutton \ + -padding "8 4" -arrowsize 3 -relief raised + + ttk::style map TButton -relief {{!disabled pressed} sunken} + + ttk::style configure TEntry \ + -padding 2 -selectborderwidth 0 -insertwidth 1 + ttk::style map TEntry \ + -fieldbackground \ + [list readonly SystemButtonFace disabled SystemButtonFace] \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + ; + + ttk::style configure TCombobox -padding 2 + ttk::style map TCombobox \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + -fieldbackground [list \ + readonly SystemButtonFace \ + disabled SystemButtonFace] \ + -foreground [list \ + disabled SystemGrayText \ + {readonly focus} SystemHighlightText \ + ] \ + -focusfill [list {readonly focus} SystemHighlight] \ + ; + + ttk::style element create ComboboxPopdownFrame.border from default + ttk::style configure ComboboxPopdownFrame \ + -borderwidth 1 -relief solid + + ttk::style configure TSpinbox -padding {2 0 16 0} + + ttk::style configure TLabelframe -borderwidth 2 -relief groove + + ttk::style configure Toolbutton -relief flat -padding {8 4} + ttk::style map Toolbutton -relief \ + {disabled flat selected sunken pressed sunken active raised} + + ttk::style configure TScale -groovewidth 4 + + ttk::style configure TNotebook -tabmargins {2 2 2 0} + ttk::style configure TNotebook.Tab -padding {3 1} -borderwidth 1 + ttk::style map TNotebook.Tab -expand [list selected {2 2 2 0}] + + # Treeview: + ttk::style configure Heading -font TkHeadingFont -relief raised + ttk::style configure Treeview -background SystemWindow + ttk::style map Treeview \ + -background [list selected SystemHighlight] \ + -foreground [list selected SystemHighlightText] ; + + ttk::style configure TProgressbar \ + -background SystemHighlight -borderwidth 0 ; + } +} diff --git a/library/ttk/xpTheme.tcl b/library/ttk/xpTheme.tcl new file mode 100644 index 0000000..187ce0b --- /dev/null +++ b/library/ttk/xpTheme.tcl @@ -0,0 +1,65 @@ +# +# Settings for 'xpnative' theme +# + +namespace eval ttk::theme::xpnative { + + ttk::style theme settings xpnative { + + ttk::style configure . \ + -background SystemButtonFace \ + -foreground SystemWindowText \ + -selectforeground SystemHighlightText \ + -selectbackground SystemHighlight \ + -font TkDefaultFont \ + ; + + ttk::style map "." \ + -foreground [list disabled SystemGrayText] \ + ; + + ttk::style configure TButton -anchor center -padding {1 1} -width -11 + ttk::style configure TRadiobutton -padding 2 + ttk::style configure TCheckbutton -padding 2 + ttk::style configure TMenubutton -padding {8 4} + + ttk::style configure TNotebook -tabmargins {2 2 2 0} + ttk::style map TNotebook.Tab \ + -expand [list selected {2 2 2 2}] + + # Treeview: + ttk::style configure Heading -font TkHeadingFont + ttk::style configure Treeview -background SystemWindow + ttk::style map Treeview \ + -background [list selected SystemHighlight] \ + -foreground [list selected SystemHighlightText] ; + + ttk::style configure TLabelframe.Label -foreground "#0046d5" + + # OR: -padding {3 3 3 6}, which some apps seem to use. + ttk::style configure TEntry -padding {2 2 2 4} + ttk::style map TEntry \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + ; + ttk::style configure TCombobox -padding 2 + ttk::style map TCombobox \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + -foreground [list \ + disabled SystemGrayText \ + {readonly focus} SystemHighlightText \ + ] \ + -focusfill [list {readonly focus} SystemHighlight] \ + ; + + ttk::style configure TSpinbox -padding {2 0 14 0} + ttk::style map TSpinbox \ + -selectbackground [list !focus SystemWindow] \ + -selectforeground [list !focus SystemWindowText] \ + ; + + ttk::style configure Toolbutton -padding {4 4} + + } +} diff --git a/library/unsupported.tcl b/library/unsupported.tcl index f9a2ab9..aeece38 100644 --- a/library/unsupported.tcl +++ b/library/unsupported.tcl @@ -93,7 +93,7 @@ namespace eval ::tk::unsupported { tkIconList_Config ::tk::IconList_Config tkIconList_Create ::tk::IconList_Create tkIconList_CtrlBtn1 ::tk::IconList_CtrlBtn1 - tkIconList_Curselection ::tk::IconList_Curselection + tkIconList_Curselection ::tk::IconList_CurSelection tkIconList_DeleteAll ::tk::IconList_DeleteAll tkIconList_Double1 ::tk::IconList_Double1 tkIconList_DrawSelection ::tk::IconList_DrawSelection diff --git a/library/xmfbox.tcl b/library/xmfbox.tcl index df5a363..0cbf251 100644 --- a/library/xmfbox.tcl +++ b/library/xmfbox.tcl @@ -155,7 +155,24 @@ proc ::tk::MotifFDialog_FileTypes {w} { # The filetypes radiobuttons # set data(fileType) $data(-defaulttype) + # Default type to first entry + set initialTypeName [lindex $data(-filetypes) 0 0] + if {$data(-typevariable) ne ""} { + upvar #0 $data(-typevariable) typeVariable + if {[info exist typeVariable]} { + set initialTypeName $typeVariable + } + } + set ix 0 set data(fileType) 0 + foreach fltr $data(-filetypes) { + set fname [lindex $fltr 0] + if {[string first $initialTypeName $fname] == 0} { + set data(fileType) $ix + break + } + incr ix + } MotifFDialog_SetFilter $w [lindex $data(-filetypes) $data(fileType)] @@ -166,7 +183,7 @@ proc ::tk::MotifFDialog_FileTypes {w} { frame $f set cnt 0 - if {$data(-filetypes) ne ""} { + if {$data(-filetypes) ne {}} { foreach type $data(-filetypes) { set title [lindex [lindex $type 0] 0] set filter [lindex $type 1] @@ -174,7 +191,7 @@ proc ::tk::MotifFDialog_FileTypes {w} { -text $title \ -variable ::tk::dialog::file::[winfo name $w](fileType) \ -value $cnt \ - -command "[list tk::MotifFDialog_SetFilter $w $type]" + -command [list tk::MotifFDialog_SetFilter $w $type] pack $f.b$cnt -side left incr cnt } @@ -224,12 +241,17 @@ proc ::tk::MotifFDialog_Config {dataName type argList} { {-initialfile "" "" ""} {-parent "" "" "."} {-title "" "" ""} + {-typevariable "" "" ""} } - if { $type eq "open" } { + if {$type eq "open"} { lappend specs {-multiple "" "" "0"} } + if {$type eq "save"} { + lappend specs {-confirmoverwrite "" "" "1"} + } set data(-multiple) 0 + set data(-confirmoverwrite) 1 # 2: default values depending on the type of the dialog # if {![info exists data(selectPath)]} { @@ -247,7 +269,7 @@ proc ::tk::MotifFDialog_Config {dataName type argList} { if {$data(-multiple) != 0} { set data(-title) "[mc {Open Multiple Files}]" } else { - set data(-title) [mc "Open"] + set data(-title) [mc "Open"] } } else { set data(-title) [mc "Save As"] @@ -487,7 +509,7 @@ proc ::tk::MotifFDialog_InterpFilter {w} { if {$relative} { tk_messageBox -icon warning -type ok \ - -message "\"$text\" must be an absolute pathname" + -message "\"$text\" must be an absolute pathname" $data(fEnt) delete 0 end $data(fEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ @@ -575,12 +597,12 @@ proc ::tk::MotifFDialog_LoadFiles {w} { } else { foreach pat $data(filter) { if {[string match $pat $f]} { - if {[string match .* $f]} { - incr top - } - lappend flist $f + if {[string match .* $f]} { + incr top + } + lappend flist $f break - } + } } } } @@ -725,7 +747,7 @@ proc ::tk::MotifFDialog_BrowseFList {w} { $data(sEnt) insert 0 $data(selectFile) } else { $data(sEnt) insert 0 [::tk::dialog::file::JoinFile $data(selectPath) \ - [lindex $data(selectFile) 0]] + [lindex $data(selectFile) 0]] } $data(sEnt) xview end } @@ -829,23 +851,27 @@ proc ::tk::MotifFDialog_ActivateSEnt {w} { -message [mc {File "%1$s" does not exist.} $item] return } - } else { - if {$data(type) eq "save"} { - set message [format %s%s \ - [mc "File \"%1\$s\" already exists.\n\n" \ - $selectFilePath] \ - [mc {Replace existing file?}]] - set answer [tk_messageBox -icon warning -type yesno \ - -message $message] - if {$answer eq "no"} { - return - } + } elseif {$data(type) eq "save" && $data(-confirmoverwrite)} { + set message [format %s%s \ + [mc "File \"%1\$s\" already exists.\n\n" $selectFilePath] \ + [mc {Replace existing file?}]] + set answer [tk_messageBox -icon warning -type yesno \ + -message $message] + if {$answer eq "no"} { + return } } - + lappend newFileList $item } + # Return selected filter + if {[info exists data(-typevariable)] && $data(-typevariable) ne "" + && [info exists data(-filetypes)] && $data(-filetypes) ne ""} { + upvar #0 $data(-typevariable) typeVariable + set typeVariable [lindex $data(-filetypes) $data(fileType) 0] + } + if {$data(-multiple) != 0} { set Priv(selectFilePath) $newFileList } else { |
