Update Pier_v1 project
Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com>
This commit is contained in:
1 parent
f25e36c050
commit
ad73ddec2b
2476 files changed
+3423
-4902
No files matched your search
@@ -0,0 +1,272 @@
|
||||
# bgerror.tcl --
|
||||
#
|
||||
# Implementation of the bgerror procedure. It posts a dialog box with
|
||||
# the error message and gives the user a chance to see a more detailed
|
||||
# stack trace, and possible do something more interesting with that
|
||||
# trace (like save it to a log). This is adapted from work done by
|
||||
# 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>
|
||||
# Copyright (c) 2009 Pat Thoyts <patthoyts@users.sourceforge.net>
|
||||
|
||||
namespace eval ::tk::dialog::error {
|
||||
namespace import -force ::tk::msgcat::*
|
||||
namespace export bgerror
|
||||
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
|
||||
option add *ErrorDialog*info.text.background \
|
||||
systemTextBackgroundColor widgetDefault
|
||||
option add *ErrorDialog*Button.highlightBackground \
|
||||
systemAlertBackgroundActive widgetDefault
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::Return {which code} {
|
||||
variable button
|
||||
|
||||
.bgerrorDialog.$which state {active selected focus}
|
||||
update idletasks
|
||||
after 100
|
||||
set button $code
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::Details {} {
|
||||
set w .bgerrorDialog
|
||||
set caption [option get $w.function text {}]
|
||||
set command [option get $w.function command {}]
|
||||
if {($caption eq "") || ($command eq "")} {
|
||||
grid forget $w.function
|
||||
}
|
||||
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
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::SaveToLog {text} {
|
||||
if {$::tcl_platform(platform) eq "windows"} {
|
||||
set allFiles *.*
|
||||
} else {
|
||||
set allFiles *
|
||||
}
|
||||
set types [list \
|
||||
[list [mc "Log Files"] .log] \
|
||||
[list [mc "Text Files"] .txt] \
|
||||
[list [mc "All Files"] $allFiles] \
|
||||
]
|
||||
set filename [tk_getSaveFile -title [mc "Select Log File"] \
|
||||
-filetypes $types -defaultextension .log -parent .bgerrorDialog]
|
||||
if {$filename ne {}} {
|
||||
set f [open $filename w]
|
||||
puts -nonewline $f $text
|
||||
close $f
|
||||
}
|
||||
return
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::Destroy {w} {
|
||||
if {$w eq ".bgerrorDialog"} {
|
||||
variable button
|
||||
set button -1
|
||||
}
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::DeleteByProtocol {} {
|
||||
variable button
|
||||
set button 1
|
||||
}
|
||||
|
||||
proc ::tk::dialog::error::ReturnInDetails w {
|
||||
bind $w <Return> {}; # Remove this binding
|
||||
$w invoke
|
||||
return -code break
|
||||
}
|
||||
|
||||
# ::tk::dialog::error::bgerror --
|
||||
#
|
||||
# This is the default version of bgerror.
|
||||
# It tries to execute tkerror, if that fails it posts a dialog box
|
||||
# containing the error message and gives the user a chance to ask
|
||||
# to see a stack trace.
|
||||
#
|
||||
# Arguments:
|
||||
# err - The error message.
|
||||
#
|
||||
proc ::tk::dialog::error::bgerror {err {flag 1}} {
|
||||
global errorInfo
|
||||
variable button
|
||||
|
||||
set info $errorInfo
|
||||
|
||||
set ret [catch {::tkerror $err} msg];
|
||||
if {$ret != 1} {return -code $ret $msg}
|
||||
|
||||
# The application's tkerror either failed or was not found
|
||||
# so we use the default dialog. But on Aqua we cannot display
|
||||
# the dialog if the background error occurs in an idle task
|
||||
# being processed inside of [NSView drawRect]. In that case
|
||||
# we post the dialog as an after task instead.
|
||||
set windowingsystem [tk windowingsystem]
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
if $flag {
|
||||
set errorInfo $info
|
||||
after 500 [list bgerror "$err" 0]
|
||||
return
|
||||
}
|
||||
}
|
||||
|
||||
set ok [mc OK]
|
||||
# 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] > $maxLine} {
|
||||
append displayedErr "[string range $line 0 $maxLine-3]..."
|
||||
break
|
||||
}
|
||||
if {$lines > 4} {
|
||||
append displayedErr "..."
|
||||
break
|
||||
} else {
|
||||
append displayedErr "${line}\n"
|
||||
}
|
||||
incr lines
|
||||
}
|
||||
|
||||
set title [mc "Application Error"]
|
||||
set text [mc "Error: %1\$s" $displayedErr]
|
||||
set buttons [list ok $ok dismiss [mc "Skip Messages"] \
|
||||
function [mc "Details >>"]]
|
||||
|
||||
# 1. Create the top-level window and divide it into top
|
||||
# and bottom parts.
|
||||
|
||||
set dlg .bgerrorDialog
|
||||
set bg [ttk::style lookup . -background]
|
||||
destroy $dlg
|
||||
toplevel $dlg -class ErrorDialog -background $bg
|
||||
wm withdraw $dlg
|
||||
wm title $dlg $title
|
||||
wm iconname $dlg ErrorDialog
|
||||
wm protocol $dlg WM_DELETE_WINDOW [namespace code DeleteByProtocol]
|
||||
|
||||
if {$windowingsystem eq "aqua"} {
|
||||
::tk::unsupported::MacWindowStyle style $dlg moveableAlert {}
|
||||
} elseif {$windowingsystem eq "x11"} {
|
||||
wm attributes $dlg -type dialog
|
||||
}
|
||||
|
||||
ttk::frame $dlg.bot
|
||||
ttk::frame $dlg.top
|
||||
pack $dlg.bot -side bottom -fill both
|
||||
pack $dlg.top -side top -fill both -expand 1
|
||||
|
||||
set W [ttk::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
|
||||
}
|
||||
|
||||
ttk::scrollbar $W.scroll -command [list $W.text yview]
|
||||
pack $W.scroll -side right -fill y
|
||||
pack $W.text -side left -expand yes -fill both
|
||||
$W.text insert 0.0 "$err\n$info"
|
||||
$W.text mark set insert 0.0
|
||||
bind $W.text <Button-1> {focus %W}
|
||||
$W.text configure -state disabled
|
||||
|
||||
# 2. Fill the top part with bitmap and message
|
||||
|
||||
# Max-width of message is the width of the screen...
|
||||
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 $dlg 9m]}]
|
||||
ttk::label $dlg.msg -justify left -text $text -wraplength $wrapwidth
|
||||
ttk::label $dlg.bitmap -image ::tk::icons::error
|
||||
|
||||
grid $dlg.bitmap $dlg.msg -in $dlg.top -row 0 -padx 3m -pady 3m
|
||||
grid configure $dlg.bitmap -sticky ne
|
||||
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 {
|
||||
ttk::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 "aqua"} {
|
||||
if {($name eq "ok") || ($name eq "dismiss")} {
|
||||
grid columnconfigure $dlg.bot $i -minsize 90
|
||||
}
|
||||
grid configure $dlg.$name -pady 7
|
||||
}
|
||||
incr i
|
||||
}
|
||||
# The "OK" button is the default for this dialog.
|
||||
$dlg.ok configure -default active
|
||||
|
||||
bind $dlg <Return> [namespace code {Return ok 0}]
|
||||
bind $dlg <Escape> [namespace code {Return dismiss 1}]
|
||||
bind $dlg <Destroy> [namespace code {Destroy %W}]
|
||||
bind $dlg.function <Return> [namespace code {ReturnInDetails %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 $dlg
|
||||
|
||||
# 7. Set a grab and claim the focus too.
|
||||
|
||||
::tk::SetFocusGrab $dlg $dlg.ok
|
||||
|
||||
# 8. Ensure that we are topmost.
|
||||
|
||||
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 "$dlg"} {
|
||||
wm attributes $dlg -topmost 1
|
||||
}
|
||||
}
|
||||
|
||||
# 9. Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait [namespace which -variable button]
|
||||
set copy $button; # Save a copy...
|
||||
|
||||
::tk::RestoreFocusGrab $dlg $dlg.ok destroy
|
||||
|
||||
if {$copy == 1} {
|
||||
return -code break
|
||||
}
|
||||
}
|
||||
|
||||
namespace eval :: {
|
||||
# Fool the indexer
|
||||
proc bgerror err {}
|
||||
rename bgerror {}
|
||||
namespace import ::tk::dialog::error::bgerror
|
||||
}
|
||||
@@ -0,0 +1,782 @@
|
||||
# button.tcl --
|
||||
#
|
||||
# This file defines the default bindings for Tk label, button,
|
||||
# checkbutton, and radiobutton widgets and provides procedures
|
||||
# that help in implementing those bindings.
|
||||
#
|
||||
# Copyright (c) 1992-1994 The Regents of the University of California.
|
||||
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
|
||||
# Copyright (c) 2002 ActiveState Corporation.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
#-------------------------------------------------------------------------
|
||||
# The code below creates the default class bindings for buttons.
|
||||
#-------------------------------------------------------------------------
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
|
||||
bind Radiobutton <Enter> {
|
||||
tk::ButtonEnter %W
|
||||
}
|
||||
bind Radiobutton <1> {
|
||||
tk::ButtonDown %W
|
||||
}
|
||||
bind Radiobutton <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
bind Checkbutton <Enter> {
|
||||
tk::ButtonEnter %W
|
||||
}
|
||||
bind Checkbutton <1> {
|
||||
tk::ButtonDown %W
|
||||
}
|
||||
bind Checkbutton <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
bind Checkbutton <Leave> {
|
||||
tk::ButtonLeave %W
|
||||
}
|
||||
}
|
||||
if {"win32" eq [tk windowingsystem]} {
|
||||
bind Checkbutton <equal> {
|
||||
tk::CheckRadioInvoke %W select
|
||||
}
|
||||
bind Checkbutton <plus> {
|
||||
tk::CheckRadioInvoke %W select
|
||||
}
|
||||
bind Checkbutton <minus> {
|
||||
tk::CheckRadioInvoke %W deselect
|
||||
}
|
||||
bind Checkbutton <1> {
|
||||
tk::CheckRadioDown %W
|
||||
}
|
||||
bind Checkbutton <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
bind Checkbutton <Enter> {
|
||||
tk::CheckRadioEnter %W
|
||||
}
|
||||
bind Checkbutton <Leave> {
|
||||
tk::ButtonLeave %W
|
||||
}
|
||||
|
||||
bind Radiobutton <1> {
|
||||
tk::CheckRadioDown %W
|
||||
}
|
||||
bind Radiobutton <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
bind Radiobutton <Enter> {
|
||||
tk::CheckRadioEnter %W
|
||||
}
|
||||
}
|
||||
if {"x11" eq [tk windowingsystem]} {
|
||||
bind Checkbutton <Return> {
|
||||
if {!$tk_strictMotif} {
|
||||
tk::CheckInvoke %W
|
||||
}
|
||||
}
|
||||
bind Radiobutton <Return> {
|
||||
if {!$tk_strictMotif} {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
}
|
||||
bind Checkbutton <1> {
|
||||
tk::CheckInvoke %W
|
||||
}
|
||||
bind Radiobutton <1> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
bind Checkbutton <Enter> {
|
||||
tk::CheckEnter %W
|
||||
}
|
||||
bind Radiobutton <Enter> {
|
||||
tk::ButtonEnter %W
|
||||
}
|
||||
bind Checkbutton <Leave> {
|
||||
tk::CheckLeave %W
|
||||
}
|
||||
}
|
||||
|
||||
bind Button <space> {
|
||||
tk::ButtonInvoke %W
|
||||
}
|
||||
bind Checkbutton <space> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
bind Radiobutton <space> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
bind Button <<Invoke>> {
|
||||
tk::ButtonInvoke %W
|
||||
}
|
||||
bind Checkbutton <<Invoke>> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
bind Radiobutton <<Invoke>> {
|
||||
tk::CheckRadioInvoke %W
|
||||
}
|
||||
|
||||
bind Button <FocusIn> {}
|
||||
bind Button <Enter> {
|
||||
tk::ButtonEnter %W
|
||||
}
|
||||
bind Button <Leave> {
|
||||
tk::ButtonLeave %W
|
||||
}
|
||||
bind Button <1> {
|
||||
tk::ButtonDown %W
|
||||
}
|
||||
bind Button <ButtonRelease-1> {
|
||||
tk::ButtonUp %W
|
||||
}
|
||||
|
||||
bind Checkbutton <FocusIn> {}
|
||||
|
||||
bind Radiobutton <FocusIn> {}
|
||||
bind Radiobutton <Leave> {
|
||||
tk::ButtonLeave %W
|
||||
}
|
||||
|
||||
if {"win32" eq [tk windowingsystem]} {
|
||||
|
||||
#########################
|
||||
# Windows implementation
|
||||
#########################
|
||||
|
||||
# ::tk::ButtonEnter --
|
||||
# The procedure below is invoked when the mouse pointer enters a
|
||||
# button widget. It records the button we're in and changes the
|
||||
# state of the button to active unless the button is disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonEnter w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
|
||||
# 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 -state active
|
||||
set Priv($w,prelief) sunken
|
||||
} elseif {[set over [$w cget -overrelief]] ne ""} {
|
||||
$w configure -relief $over
|
||||
set Priv($w,prelief) $over
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::ButtonLeave --
|
||||
# The procedure below is invoked when the mouse pointer leaves a
|
||||
# button widget. It changes the state of the button back to inactive.
|
||||
# Restore any modified relief too.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonLeave w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
$w configure -state normal
|
||||
}
|
||||
|
||||
# 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) ""
|
||||
}
|
||||
|
||||
# ::tk::ButtonDown --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a button widget. It records the fact that the mouse is in the button,
|
||||
# saves the button's relief so it can be restored later, and changes
|
||||
# the relief to sunken.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonDown w {
|
||||
variable ::tk::Priv
|
||||
|
||||
# Only save the button's relief if it does not yet exist. If there
|
||||
# is an overrelief setting, Priv($w,relief) will already have been set,
|
||||
# and the current value of the -relief option will be incorrect.
|
||||
|
||||
if {![info exists Priv($w,relief)]} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
}
|
||||
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
set Priv(buttonWindow) $w
|
||||
$w configure -relief sunken -state active
|
||||
set Priv($w,prelief) sunken
|
||||
|
||||
# If this button has a repeatdelay set up, get it going with an after
|
||||
after cancel $Priv(afterId)
|
||||
set delay [$w cget -repeatdelay]
|
||||
set Priv(repeated) 0
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonUp --
|
||||
# The procedure below is invoked when the mouse button is released
|
||||
# in a button widget. It restores the button's relief and invokes
|
||||
# the command as long as the mouse hasn't left the button.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonUp w {
|
||||
variable ::tk::Priv
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
set Priv(buttonWindow) ""
|
||||
|
||||
# Restore the button's relief if it was cached.
|
||||
|
||||
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)
|
||||
}
|
||||
|
||||
# Clean up the after event from the auto-repeater
|
||||
after cancel $Priv(afterId)
|
||||
|
||||
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
|
||||
$w configure -state normal
|
||||
|
||||
# Only invoke the command if it wasn't already invoked by the
|
||||
# auto-repeater functionality
|
||||
if { $Priv(repeated) == 0 } {
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::CheckRadioEnter --
|
||||
# The procedure below is invoked when the mouse pointer enters a
|
||||
# checkbutton or radiobutton widget. It records the button we're in
|
||||
# and changes the state of the button to active unless the button is
|
||||
# disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::CheckRadioEnter w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
$w configure -state active
|
||||
}
|
||||
if {[set over [$w cget -overrelief]] ne ""} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
set Priv($w,prelief) $over
|
||||
$w configure -relief $over
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::CheckRadioDown --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a button widget. It records the fact that the mouse is in the button,
|
||||
# saves the button's relief so it can be restored later, and changes
|
||||
# the relief to sunken.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::CheckRadioDown w {
|
||||
variable ::tk::Priv
|
||||
if {![info exists Priv($w,relief)]} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
}
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
set Priv(buttonWindow) $w
|
||||
set Priv(repeated) 0
|
||||
$w configure -state active
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if {"x11" eq [tk windowingsystem]} {
|
||||
|
||||
#####################
|
||||
# Unix implementation
|
||||
#####################
|
||||
|
||||
# ::tk::ButtonEnter --
|
||||
# The procedure below is invoked when the mouse pointer enters a
|
||||
# button widget. It records the button we're in and changes the
|
||||
# state of the button to active unless the button is disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonEnter {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
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::ButtonLeave --
|
||||
# The procedure below is invoked when the mouse pointer leaves a
|
||||
# button widget. It changes the state of the button back to inactive.
|
||||
# Restore any modified relief too.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonLeave w {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
$w configure -state normal
|
||||
}
|
||||
|
||||
# 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) ""
|
||||
}
|
||||
|
||||
# ::tk::ButtonDown --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a button widget. It records the fact that the mouse is in the button,
|
||||
# saves the button's relief so it can be restored later, and changes
|
||||
# the relief to sunken.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonDown w {
|
||||
variable ::tk::Priv
|
||||
|
||||
# Only save the button's relief if it does not yet exist. If there
|
||||
# is an overrelief setting, Priv($w,relief) will already have been set,
|
||||
# and the current value of the -relief option will be incorrect.
|
||||
|
||||
if {![info exists Priv($w,relief)]} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
}
|
||||
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
set Priv(buttonWindow) $w
|
||||
$w configure -relief sunken
|
||||
set Priv($w,prelief) sunken
|
||||
|
||||
# If this button has a repeatdelay set up, get it going with an after
|
||||
after cancel $Priv(afterId)
|
||||
set delay [$w cget -repeatdelay]
|
||||
set Priv(repeated) 0
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonUp --
|
||||
# The procedure below is invoked when the mouse button is released
|
||||
# in a button widget. It restores the button's relief and invokes
|
||||
# the command as long as the mouse hasn't left the button.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonUp w {
|
||||
variable ::tk::Priv
|
||||
if {$w eq $Priv(buttonWindow)} {
|
||||
set Priv(buttonWindow) ""
|
||||
|
||||
# Restore the button's relief if it was cached.
|
||||
|
||||
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)
|
||||
}
|
||||
|
||||
# Clean up the after event from the auto-repeater
|
||||
after cancel $Priv(afterId)
|
||||
|
||||
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
|
||||
# Only invoke the command if it wasn't already invoked by the
|
||||
# auto-repeater functionality
|
||||
if { $Priv(repeated) == 0 } {
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
|
||||
####################
|
||||
# Mac implementation
|
||||
####################
|
||||
|
||||
# ::tk::ButtonEnter --
|
||||
# The procedure below is invoked when the mouse pointer enters a
|
||||
# button widget. It records the button we're in and changes the
|
||||
# state of the button to active unless the button is disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonEnter {w} {
|
||||
variable ::tk::Priv
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
|
||||
# If there's an -overrelief value, set the relief to that.
|
||||
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
$w configure -state active
|
||||
} elseif {[set over [$w cget -overrelief]] ne ""} {
|
||||
set Priv($w,relief) [$w cget -relief]
|
||||
set Priv($w,prelief) $over
|
||||
$w configure -relief $over
|
||||
}
|
||||
}
|
||||
set Priv(window) $w
|
||||
}
|
||||
|
||||
# ::tk::ButtonLeave --
|
||||
# The procedure below is invoked when the mouse pointer leaves a
|
||||
# button widget. It changes the state of the button back to
|
||||
# inactive. If we're leaving the button window with a mouse button
|
||||
# pressed (Priv(buttonWindow) == $w), restore the relief of the
|
||||
# button too.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonLeave w {
|
||||
variable ::tk::Priv
|
||||
if {$w eq $Priv(buttonWindow)} {
|
||||
$w configure -state normal
|
||||
}
|
||||
|
||||
# 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) ""
|
||||
}
|
||||
|
||||
# ::tk::ButtonDown --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a button widget. It records the fact that the mouse is in the button,
|
||||
# saves the button's relief so it can be restored later, and changes
|
||||
# the relief to sunken.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonDown w {
|
||||
variable ::tk::Priv
|
||||
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
set Priv(buttonWindow) $w
|
||||
$w configure -state active
|
||||
|
||||
# If this button has a repeatdelay set up, get it going with an after
|
||||
after cancel $Priv(afterId)
|
||||
set Priv(repeated) 0
|
||||
if { ![catch {$w cget -repeatdelay} delay] } {
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonUp --
|
||||
# The procedure below is invoked when the mouse button is released
|
||||
# in a button widget. It restores the button's relief and invokes
|
||||
# the command as long as the mouse hasn't left the button.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonUp w {
|
||||
variable ::tk::Priv
|
||||
if {$Priv(buttonWindow) eq $w} {
|
||||
set Priv(buttonWindow) ""
|
||||
$w configure -state normal
|
||||
|
||||
# Restore the button's relief if it was cached.
|
||||
|
||||
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)
|
||||
}
|
||||
|
||||
# Clean up the after event from the auto-repeater
|
||||
after cancel $Priv(afterId)
|
||||
|
||||
if {$Priv(window) eq $w && [$w cget -state] ne "disabled"} {
|
||||
# Only invoke the command if it wasn't already invoked by the
|
||||
# auto-repeater functionality
|
||||
if { $Priv(repeated) == 0 } {
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
##################
|
||||
# Shared routines
|
||||
##################
|
||||
|
||||
# ::tk::ButtonInvoke --
|
||||
# The procedure below is called when a button is invoked through
|
||||
# the keyboard. It simulate a press of the button via the mouse.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
|
||||
proc ::tk::ButtonInvoke w {
|
||||
if {[winfo exists $w] && [$w cget -state] ne "disabled"} {
|
||||
set oldRelief [$w cget -relief]
|
||||
set oldState [$w cget -state]
|
||||
$w configure -state active -relief sunken
|
||||
after 100 [list ::tk::ButtonInvokeEnd $w $oldState $oldRelief]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonInvokeEnd --
|
||||
# The procedure below is called after a button is invoked through
|
||||
# the keyboard. It simulate a release of the button via the mouse.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
# oldState - Old state to be set back.
|
||||
# oldRelief - Old relief to be set back.
|
||||
|
||||
proc ::tk::ButtonInvokeEnd {w oldState oldRelief} {
|
||||
if {[winfo exists $w]} {
|
||||
$w configure -state $oldState -relief $oldRelief
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::ButtonAutoInvoke --
|
||||
#
|
||||
# Invoke an auto-repeating button, and set it up to continue to repeat.
|
||||
#
|
||||
# Arguments:
|
||||
# w button to invoke.
|
||||
#
|
||||
# Results:
|
||||
# None.
|
||||
#
|
||||
# Side effects:
|
||||
# May create an after event to call ::tk::ButtonAutoInvoke.
|
||||
|
||||
proc ::tk::ButtonAutoInvoke {w} {
|
||||
variable ::tk::Priv
|
||||
after cancel $Priv(afterId)
|
||||
set delay [$w cget -repeatinterval]
|
||||
if {$Priv(window) eq $w} {
|
||||
incr Priv(repeated)
|
||||
uplevel #0 [list $w invoke]
|
||||
}
|
||||
if {$delay > 0} {
|
||||
set Priv(afterId) [after $delay [list tk::ButtonAutoInvoke $w]]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::CheckRadioInvoke --
|
||||
# The procedure below is invoked when the mouse button is pressed in
|
||||
# a checkbutton or radiobutton widget, or when the widget is invoked
|
||||
# through the keyboard. It invokes the widget if it
|
||||
# isn't disabled.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The name of the widget.
|
||||
# cmd - The subcommand to invoke (one of invoke, select, or deselect).
|
||||
|
||||
proc ::tk::CheckRadioInvoke {w {cmd invoke}} {
|
||||
if {[$w cget -state] ne "disabled"} {
|
||||
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; but only if the user
|
||||
# has not changed it in the meantime.
|
||||
|
||||
if {![$w cget -indicatoron] && [info exist Priv($w,selectcolor)]} {
|
||||
if {[$w cget -selectcolor] eq $Priv($w,selectcolor)
|
||||
|| ([info exist Priv($w,aselectcolor)] &&
|
||||
[$w cget -selectcolor] eq $Priv($w,aselectcolor))} {
|
||||
$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) ""
|
||||
}
|
||||
|
||||
return
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# fill-column: 78
|
||||
# End:
|
||||
@@ -0,0 +1,308 @@
|
||||
# choosedir.tcl --
|
||||
#
|
||||
# Choose directory dialog implementation for Unix/Mac.
|
||||
#
|
||||
# Copyright (c) 1998-2000 by Scriptics Corporation.
|
||||
# All rights reserved.
|
||||
|
||||
# Make sure the tk::dialog namespace, in which all dialogs should live, exists
|
||||
namespace eval ::tk::dialog {}
|
||||
namespace eval ::tk::dialog::file {}
|
||||
|
||||
# Make the chooseDir namespace inside the dialog namespace
|
||||
namespace eval ::tk::dialog::file::chooseDir {
|
||||
namespace import -force ::tk::msgcat::*
|
||||
}
|
||||
|
||||
# ::tk::dialog::file::chooseDir:: --
|
||||
#
|
||||
# Implements the TK directory selection dialog.
|
||||
#
|
||||
# Arguments:
|
||||
# args Options parsed by the procedure.
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir:: {args} {
|
||||
variable ::tk::Priv
|
||||
set dataName __tk_choosedir
|
||||
upvar ::tk::dialog::file::$dataName data
|
||||
Config $dataName $args
|
||||
|
||||
if {$data(-parent) eq "."} {
|
||||
set w .$dataName
|
||||
} else {
|
||||
set w $data(-parent).$dataName
|
||||
}
|
||||
|
||||
# (re)create the dialog box if necessary
|
||||
#
|
||||
if {![winfo exists $w]} {
|
||||
::tk::dialog::file::Create $w TkChooseDir
|
||||
} elseif {[winfo class $w] ne "TkChooseDir"} {
|
||||
destroy $w
|
||||
::tk::dialog::file::Create $w TkChooseDir
|
||||
} else {
|
||||
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
|
||||
grid $data(hiddenBtn)
|
||||
} else {
|
||||
$data(hiddenBtn) configure -state disabled
|
||||
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
|
||||
# window is withdrawn or iconified. Combined with the grab we put on the
|
||||
# window, this can hang the entire application. Therefore we only make
|
||||
# the dialog transient if the parent is viewable.
|
||||
|
||||
if {[winfo viewable [winfo toplevel $data(-parent)]] } {
|
||||
wm transient $w $data(-parent)
|
||||
}
|
||||
|
||||
trace add variable data(selectPath) write \
|
||||
[list ::tk::dialog::file::SetPath $w]
|
||||
$data(dirMenuBtn) configure \
|
||||
-textvariable ::tk::dialog::file::${dataName}(selectPath)
|
||||
|
||||
set data(filter) "*"
|
||||
set data(previousEntryText) ""
|
||||
::tk::dialog::file::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
|
||||
# display (Motif style) and de-iconify it.
|
||||
|
||||
::tk::PlaceWindow $w widget $data(-parent)
|
||||
wm title $w $data(-title)
|
||||
|
||||
# Set a grab and claim the focus too.
|
||||
|
||||
::tk::SetFocusGrab $w $data(ent)
|
||||
$data(ent) delete 0 end
|
||||
$data(ent) insert 0 $data(selectPath)
|
||||
$data(ent) selection range 0 end
|
||||
$data(ent) icursor end
|
||||
|
||||
# Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait ::tk::Priv(selectFilePath)
|
||||
|
||||
::tk::RestoreFocusGrab $w $data(ent) withdraw
|
||||
|
||||
# Cleanup traces on selectPath variable
|
||||
#
|
||||
|
||||
foreach trace [trace info variable data(selectPath)] {
|
||||
trace remove variable data(selectPath) [lindex $trace 0] [lindex $trace 1]
|
||||
}
|
||||
$data(dirMenuBtn) configure -textvariable {}
|
||||
|
||||
# Return value to user
|
||||
#
|
||||
|
||||
return $Priv(selectFilePath)
|
||||
}
|
||||
|
||||
# ::tk::dialog::file::chooseDir::Config --
|
||||
#
|
||||
# Configures the Tk choosedir dialog according to the argument list
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::Config {dataName argList} {
|
||||
upvar ::tk::dialog::file::$dataName data
|
||||
|
||||
# 0: Delete all variable that were set on data(selectPath) the
|
||||
# last time the file dialog is used. The traces may cause troubles
|
||||
# if the dialog is now used with a different -parent option.
|
||||
#
|
||||
foreach trace [trace info variable data(selectPath)] {
|
||||
trace remove variable data(selectPath) [lindex $trace 0] [lindex $trace 1]
|
||||
}
|
||||
|
||||
# 1: the configuration specs
|
||||
#
|
||||
set specs {
|
||||
{-mustexist "" "" 0}
|
||||
{-initialdir "" "" ""}
|
||||
{-parent "" "" "."}
|
||||
{-title "" "" ""}
|
||||
}
|
||||
|
||||
# 2: default values depending on the type of the dialog
|
||||
#
|
||||
if {![info exists data(selectPath)]} {
|
||||
# first time the dialog has been popped up
|
||||
set data(selectPath) [pwd]
|
||||
}
|
||||
|
||||
# 3: parse the arguments
|
||||
#
|
||||
tclParseConfigSpec ::tk::dialog::file::$dataName $specs "" $argList
|
||||
|
||||
if {$data(-title) eq ""} {
|
||||
set data(-title) "[mc "Choose Directory"]"
|
||||
}
|
||||
|
||||
# Stub out the -multiple value for the dialog; it doesn't make sense for
|
||||
# choose directory dialogs, but we have to have something there because we
|
||||
# share so much code with the file dialogs.
|
||||
set data(-multiple) 0
|
||||
|
||||
# 4: set the default directory and selection according to the -initial
|
||||
# settings
|
||||
#
|
||||
if {$data(-initialdir) ne ""} {
|
||||
# Ensure that initialdir is an absolute path name.
|
||||
if {[file isdirectory $data(-initialdir)]} {
|
||||
set old [pwd]
|
||||
cd $data(-initialdir)
|
||||
set data(selectPath) [pwd]
|
||||
cd $old
|
||||
} else {
|
||||
set data(selectPath) [pwd]
|
||||
}
|
||||
}
|
||||
|
||||
if {![winfo exists $data(-parent)]} {
|
||||
return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
|
||||
"bad window path name \"$data(-parent)\""
|
||||
}
|
||||
}
|
||||
|
||||
# Gets called when user presses Return in the "Selection" entry or presses OK.
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::OkCmd {w} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
# This is the brains behind selecting non-existant directories. Here's
|
||||
# the flowchart:
|
||||
# 1. If the icon list has a selection, join it with the current dir,
|
||||
# and return that value.
|
||||
# 1a. If the icon list does not have a selection ...
|
||||
# 2. If the entry is empty, do nothing.
|
||||
# 3. If the entry contains an invalid directory, then...
|
||||
# 3a. If the value is the same as last time through here, end dialog.
|
||||
# 3b. If the value is different than last time, save it and return.
|
||||
# 4. If entry contains a valid directory, then...
|
||||
# 4a. If the value is the same as the current directory, end dialog.
|
||||
# 4b. If the value is different from the current directory, change to
|
||||
# that directory.
|
||||
|
||||
set selection [$data(icons) selection get]
|
||||
if {[llength $selection] != 0} {
|
||||
set iconText [$data(icons) get [lindex $selection 0]]
|
||||
set iconText [file join $data(selectPath) $iconText]
|
||||
Done $w $iconText
|
||||
} else {
|
||||
set text [$data(ent) get]
|
||||
if {$text eq ""} {
|
||||
return
|
||||
}
|
||||
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)} {
|
||||
set data(previousEntryText) ""
|
||||
Done $w $text
|
||||
} else {
|
||||
set data(previousEntryText) $text
|
||||
}
|
||||
} else {
|
||||
# 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)} {
|
||||
Done $w $text
|
||||
} else {
|
||||
set data(selectPath) $text
|
||||
}
|
||||
}
|
||||
}
|
||||
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 [$data(icons) selection get]
|
||||
if {[llength $selection] != 0} {
|
||||
set filenameFragment [$data(icons) get [lindex $selection 0]]
|
||||
set file $data(selectPath)
|
||||
if {[file isdirectory $file]} {
|
||||
::tk::dialog::file::ListInvoke $w [list $filenameFragment]
|
||||
return
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Gets called when user browses the IconList widget (dragging mouse, arrow
|
||||
# keys, etc)
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::ListBrowse {w text} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
|
||||
if {$text eq ""} {
|
||||
return
|
||||
}
|
||||
|
||||
set file [::tk::dialog::file::JoinFile $data(selectPath) $text]
|
||||
$data(ent) delete 0 end
|
||||
$data(ent) insert 0 $file
|
||||
}
|
||||
|
||||
# ::tk::dialog::file::chooseDir::Done --
|
||||
#
|
||||
# Gets called when user has input a valid filename. Pops up a
|
||||
# dialog box to confirm selection when necessary. Sets the
|
||||
# Priv(selectFilePath) variable, which will break the "vwait"
|
||||
# loop in tk_chooseDirectory and return the selected filename to the
|
||||
# script that calls tk_getOpenFile or tk_getSaveFile
|
||||
#
|
||||
proc ::tk::dialog::file::chooseDir::Done {w {selectFilePath ""}} {
|
||||
upvar ::tk::dialog::file::[winfo name $w] data
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$selectFilePath eq ""} {
|
||||
set selectFilePath $data(selectPath)
|
||||
}
|
||||
if {$data(-mustexist) && ![file isdirectory $selectFilePath]} {
|
||||
return
|
||||
}
|
||||
set Priv(selectFilePath) $selectFilePath
|
||||
}
|
||||
@@ -0,0 +1,695 @@
|
||||
# clrpick.tcl --
|
||||
#
|
||||
# Color selection dialog for platforms that do not support a
|
||||
# standard color selection dialog.
|
||||
#
|
||||
# Copyright (c) 1996 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
# ToDo:
|
||||
#
|
||||
# (1): Find out how many free colors are left in the colormap and
|
||||
# don't allocate too many colors.
|
||||
# (2): Implement HSV color selection.
|
||||
#
|
||||
|
||||
# Make sure namespaces exist
|
||||
namespace eval ::tk {}
|
||||
namespace eval ::tk::dialog {}
|
||||
namespace eval ::tk::dialog::color {
|
||||
namespace import ::tk::msgcat::*
|
||||
}
|
||||
|
||||
# ::tk::dialog::color:: --
|
||||
#
|
||||
# Create a color dialog and let the user choose a color. This function
|
||||
# should not be called directly. It is called by the tk_chooseColor
|
||||
# function when a native color selector widget does not exist
|
||||
#
|
||||
proc ::tk::dialog::color:: {args} {
|
||||
variable ::tk::Priv
|
||||
set dataName __tk__color
|
||||
upvar ::tk::dialog::color::$dataName data
|
||||
set w .$dataName
|
||||
|
||||
# The lines variables track the start and end indices of the line
|
||||
# elements in the colorbar canvases.
|
||||
set data(lines,red,start) 0
|
||||
set data(lines,red,last) -1
|
||||
set data(lines,green,start) 0
|
||||
set data(lines,green,last) -1
|
||||
set data(lines,blue,start) 0
|
||||
set data(lines,blue,last) -1
|
||||
|
||||
# This is the actual number of lines that are drawn in each color strip.
|
||||
# Note that the bars may be of any width.
|
||||
# However, NUM_COLORBARS must be a number that evenly divides 256.
|
||||
# Such as 256, 128, 64, etc.
|
||||
set data(NUM_COLORBARS) 16
|
||||
|
||||
# BARS_WIDTH is the number of pixels wide the color bar portion of the
|
||||
# canvas is. This number must be a multiple of NUM_COLORBARS
|
||||
set data(BARS_WIDTH) 160
|
||||
|
||||
# PLGN_WIDTH is the number of pixels wide of the triangular selection
|
||||
# polygon. This also results in the definition of the padding on the
|
||||
# left and right sides which is half of PLGN_WIDTH. Make this number even.
|
||||
set data(PLGN_HEIGHT) 10
|
||||
|
||||
# PLGN_HEIGHT is the height of the selection polygon and the height of the
|
||||
# selection rectangle at the bottom of the color bar. No restrictions.
|
||||
set data(PLGN_WIDTH) 10
|
||||
|
||||
Config $dataName $args
|
||||
InitValues $dataName
|
||||
|
||||
set sc [winfo screen $data(-parent)]
|
||||
set winExists [winfo exists $w]
|
||||
if {!$winExists || $sc ne [winfo screen $w]} {
|
||||
if {$winExists} {
|
||||
destroy $w
|
||||
}
|
||||
toplevel $w -class TkColorDialog -screen $sc
|
||||
if {[tk windowingsystem] eq "x11"} {wm attributes $w -type dialog}
|
||||
BuildDialog $w
|
||||
}
|
||||
|
||||
# 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
|
||||
# window is withdrawn or iconified. Combined with the grab we put on the
|
||||
# window, this can hang the entire application. Therefore we only make
|
||||
# the dialog transient if the parent is viewable.
|
||||
|
||||
if {[winfo viewable [winfo toplevel $data(-parent)]] } {
|
||||
wm transient $w $data(-parent)
|
||||
}
|
||||
|
||||
# 5. 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 $w widget $data(-parent)
|
||||
wm title $w $data(-title)
|
||||
|
||||
# 6. Set a grab and claim the focus too.
|
||||
|
||||
::tk::SetFocusGrab $w $data(okBtn)
|
||||
|
||||
# 7. Wait for the user to respond, then restore the focus and
|
||||
# return the index of the selected button. Restore the focus
|
||||
# before deleting the window, since otherwise the window manager
|
||||
# may take the focus away so we can't redirect it. Finally,
|
||||
# restore any grab that was in effect.
|
||||
|
||||
vwait ::tk::Priv(selectColor)
|
||||
set result $Priv(selectColor)
|
||||
::tk::RestoreFocusGrab $w $data(okBtn)
|
||||
unset data
|
||||
|
||||
return $result
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::InitValues --
|
||||
#
|
||||
# Get called during initialization or when user resets NUM_COLORBARS
|
||||
#
|
||||
proc ::tk::dialog::color::InitValues {dataName} {
|
||||
upvar ::tk::dialog::color::$dataName data
|
||||
|
||||
# IntensityIncr is the difference in color intensity between a colorbar
|
||||
# and its neighbors.
|
||||
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)}]
|
||||
|
||||
# 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
|
||||
# polygon extends into the space.
|
||||
set data(indent) [expr {$data(PLGN_WIDTH) / 2}]
|
||||
|
||||
set data(colorPad) 2
|
||||
set data(selPad) [expr {$data(PLGN_WIDTH) / 2}]
|
||||
|
||||
#
|
||||
# minX is the x coordinate of the first colorbar
|
||||
#
|
||||
set data(minX) $data(indent)
|
||||
|
||||
#
|
||||
# maxX is the x coordinate of the last colorbar
|
||||
#
|
||||
set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}]
|
||||
|
||||
#
|
||||
# canvasWidth is the width of the entire canvas, including the indents
|
||||
#
|
||||
set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}]
|
||||
|
||||
# Set the initial color, specified by -initialcolor, or the
|
||||
# color chosen by the user the last time.
|
||||
set data(selection) $data(-initialcolor)
|
||||
set data(finalColor) $data(-initialcolor)
|
||||
set rgb [winfo rgb . $data(selection)]
|
||||
|
||||
set data(red,intensity) [expr {[lindex $rgb 0]/0x100}]
|
||||
set data(green,intensity) [expr {[lindex $rgb 1]/0x100}]
|
||||
set data(blue,intensity) [expr {[lindex $rgb 2]/0x100}]
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::Config --
|
||||
#
|
||||
# Parses the command line arguments to tk_chooseColor
|
||||
#
|
||||
proc ::tk::dialog::color::Config {dataName argList} {
|
||||
variable ::tk::Priv
|
||||
upvar ::tk::dialog::color::$dataName data
|
||||
|
||||
# 1: the configuration specs
|
||||
#
|
||||
if {[info exists Priv(selectColor)] && $Priv(selectColor) ne ""} {
|
||||
set defaultColor $Priv(selectColor)
|
||||
} else {
|
||||
set defaultColor [. cget -background]
|
||||
}
|
||||
|
||||
set specs [list \
|
||||
[list -initialcolor "" "" $defaultColor] \
|
||||
[list -parent "" "" "."] \
|
||||
[list -title "" "" [mc "Color"]] \
|
||||
]
|
||||
|
||||
# 2: parse the arguments
|
||||
#
|
||||
tclParseConfigSpec ::tk::dialog::color::$dataName $specs "" $argList
|
||||
|
||||
if {$data(-title) eq ""} {
|
||||
set data(-title) " "
|
||||
}
|
||||
if {[catch {winfo rgb . $data(-initialcolor)} err]} {
|
||||
return -code error -errorcode [list TK LOOKUP COLOR $data(-initialcolor)] \
|
||||
$err
|
||||
}
|
||||
|
||||
if {![winfo exists $data(-parent)]} {
|
||||
return -code error -errorcode [list TK LOOKUP WINDOW $data(-parent)] \
|
||||
"bad window path name \"$data(-parent)\""
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::BuildDialog --
|
||||
#
|
||||
# Build the dialog.
|
||||
#
|
||||
proc ::tk::dialog::color::BuildDialog {w} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
# TopFrame contains the color strips and the color selection
|
||||
#
|
||||
set topFrame [frame $w.top -relief raised -bd 1]
|
||||
|
||||
# StripsFrame contains the colorstrips and the individual RGB entries
|
||||
set stripsFrame [frame $topFrame.colorStrip]
|
||||
|
||||
set maxWidth [::tk::mcmaxamp &Red &Green &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]
|
||||
|
||||
# The box frame contains the label and entry widget for an [R|G|B]
|
||||
set box [frame $f.box]
|
||||
|
||||
::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
|
||||
pack $box.label -side left -fill y -padx 2 -pady 3
|
||||
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])
|
||||
}]
|
||||
|
||||
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
|
||||
pack $f.color -expand yes -fill both
|
||||
pack $f.sel -expand yes -fill both
|
||||
|
||||
pack $f -side top -fill x -padx 0 -pady 2
|
||||
|
||||
set data($color,entry) $box.entry
|
||||
set data($color,col) $f.color
|
||||
set data($color,sel) $f.sel
|
||||
|
||||
bind $data($color,col) <Configure> \
|
||||
[list tk::dialog::color::DrawColorScale $w $color 1]
|
||||
bind $data($color,col) <Enter> \
|
||||
[list tk::dialog::color::EnterColorBar $w $color]
|
||||
bind $data($color,col) <Leave> \
|
||||
[list tk::dialog::color::LeaveColorBar $w $color]
|
||||
|
||||
bind $data($color,sel) <Enter> \
|
||||
[list tk::dialog::color::EnterColorBar $w $color]
|
||||
bind $data($color,sel) <Leave> \
|
||||
[list tk::dialog::color::LeaveColorBar $w $color]
|
||||
|
||||
bind $box.entry <Return> [list tk::dialog::color::HandleRGBEntry $w]
|
||||
}
|
||||
|
||||
pack $stripsFrame -side left -fill both -padx 4 -pady 10
|
||||
|
||||
# The selFrame contains a frame that demonstrates the currently
|
||||
# selected color
|
||||
#
|
||||
set selFrame [frame $topFrame.sel]
|
||||
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]
|
||||
set f1 [frame $selFrame.f1 -relief sunken -bd 2]
|
||||
set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70]
|
||||
|
||||
pack $lab $ent -side top -fill x -padx 4 -pady 2
|
||||
pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10
|
||||
pack $data(finalCanvas) -expand yes -fill both
|
||||
|
||||
bind $ent <Return> [list tk::dialog::color::HandleSelEntry $w]
|
||||
|
||||
pack $selFrame -side left -fill none -anchor nw
|
||||
pack $topFrame -side top -expand yes -fill both -anchor nw
|
||||
|
||||
# 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"] \
|
||||
-command [list tk::dialog::color::CancelCmd $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
|
||||
grid columnconfigure $botFrame {1 3} -weight 1 -uniform button
|
||||
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 --
|
||||
#
|
||||
# Sets the current selection of the dialog box
|
||||
#
|
||||
proc ::tk::dialog::color::SetRGBValue {w color} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
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 {red green blue} {
|
||||
set x [RgbToX $w $data($color,intensity)]
|
||||
MoveSelector $w $data($color,sel) $color $x 0
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::XToRgb --
|
||||
#
|
||||
# Converts a screen coordinate to intensity
|
||||
#
|
||||
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
|
||||
}
|
||||
return $x
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::RgbToX
|
||||
#
|
||||
# Converts an intensity to screen coordinate.
|
||||
#
|
||||
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
|
||||
# scale canvases is changed.
|
||||
#
|
||||
proc ::tk::dialog::color::DrawColorScale {w c {create 0}} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
# col: color bar canvas
|
||||
# sel: selector canvas
|
||||
set col $data($c,col)
|
||||
set sel $data($c,sel)
|
||||
|
||||
# First handle the case that we are creating everything for the first time.
|
||||
if {$create} {
|
||||
# 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} {
|
||||
$sel delete $i
|
||||
}
|
||||
}
|
||||
# Delete the selector if it exists
|
||||
if {[info exists data($c,index)]} {
|
||||
$sel delete $data($c,index)
|
||||
}
|
||||
|
||||
# Draw the selection polygons
|
||||
CreateSelector $w $sel $c
|
||||
$sel bind $data($c,index) <Button-1> \
|
||||
[list tk::dialog::color::StartMove $w $sel $c %x $data(selPad) 1]
|
||||
$sel bind $data($c,index) <B1-Motion> \
|
||||
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
|
||||
$sel bind $data($c,index) <ButtonRelease-1> \
|
||||
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)]
|
||||
|
||||
set height [winfo height $col]
|
||||
# Create an invisible region under the colorstrip to catch mouse clicks
|
||||
# that aren't on the selector.
|
||||
set data($c,clickRegion) [$sel create rectangle 0 0 \
|
||||
$data(canvasWidth) $height -fill {} -outline {}]
|
||||
|
||||
bind $col <Button-1> \
|
||||
[list tk::dialog::color::StartMove $w $sel $c %x $data(colorPad)]
|
||||
bind $col <B1-Motion> \
|
||||
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(colorPad)]
|
||||
bind $col <ButtonRelease-1> \
|
||||
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(colorPad)]
|
||||
|
||||
$sel bind $data($c,clickRegion) <Button-1> \
|
||||
[list tk::dialog::color::StartMove $w $sel $c %x $data(selPad)]
|
||||
$sel bind $data($c,clickRegion) <B1-Motion> \
|
||||
[list tk::dialog::color::MoveSelector $w $sel $c %x $data(selPad)]
|
||||
$sel bind $data($c,clickRegion) <ButtonRelease-1> \
|
||||
[list tk::dialog::color::ReleaseMouse $w $sel $c %x $data(selPad)]
|
||||
} else {
|
||||
# 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} {
|
||||
set intensity [expr {$i * $data(intensityIncr)}]
|
||||
set startx [expr {$i * $data(colorbarWidth) + $highlightW}]
|
||||
if {$c eq "red"} {
|
||||
set color [format "#%02x%02x%02x" \
|
||||
$intensity $data(green,intensity) $data(blue,intensity)]
|
||||
} elseif {$c eq "green"} {
|
||||
set color [format "#%02x%02x%02x" \
|
||||
$data(red,intensity) $intensity $data(blue,intensity)]
|
||||
} else {
|
||||
set color [format "#%02x%02x%02x" \
|
||||
$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]
|
||||
} else {
|
||||
$col itemconfigure $l -fill $color -outline $color
|
||||
incr l
|
||||
}
|
||||
}
|
||||
$sel raise $data($c,index)
|
||||
|
||||
if {$create} {
|
||||
set data(lines,$c,last) $index
|
||||
set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}]
|
||||
}
|
||||
|
||||
RedrawFinalColor $w
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::CreateSelector --
|
||||
#
|
||||
# Creates and draws the selector polygon at the position
|
||||
# $data($c,intensity).
|
||||
#
|
||||
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]
|
||||
set data($c,x) [RgbToX $w $data($c,intensity)]
|
||||
$sel move $data($c,index) $data($c,x) 0
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::RedrawFinalColor
|
||||
#
|
||||
# Combines the intensities of the three colors into the final color
|
||||
#
|
||||
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(finalCanvas) configure -bg $color
|
||||
set data(finalColor) $color
|
||||
set data(selection) $color
|
||||
set data(finalRGB) [list \
|
||||
$data(red,intensity) \
|
||||
$data(green,intensity) \
|
||||
$data(blue,intensity)]
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::RedrawColorBars --
|
||||
#
|
||||
# Only redraws the colors on the color strips that were not manipulated.
|
||||
# Params: color of colorstrip that changed. If color is not [red|green|blue]
|
||||
# Then all colorstrips will be updated
|
||||
#
|
||||
proc ::tk::dialog::color::RedrawColorBars {w colorChanged} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
switch $colorChanged {
|
||||
red {
|
||||
DrawColorScale $w green
|
||||
DrawColorScale $w blue
|
||||
}
|
||||
green {
|
||||
DrawColorScale $w red
|
||||
DrawColorScale $w blue
|
||||
}
|
||||
blue {
|
||||
DrawColorScale $w red
|
||||
DrawColorScale $w green
|
||||
}
|
||||
default {
|
||||
DrawColorScale $w red
|
||||
DrawColorScale $w green
|
||||
DrawColorScale $w blue
|
||||
}
|
||||
}
|
||||
RedrawFinalColor $w
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
# Event handlers
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
# ::tk::dialog::color::StartMove --
|
||||
#
|
||||
# Handles a mousedown button event over the selector polygon.
|
||||
# Adds the bindings for moving the mouse while the button is
|
||||
# pressed. Sets the binding for the button-release event.
|
||||
#
|
||||
# Params: sel is the selector canvas window, color is the color of the strip.
|
||||
#
|
||||
proc ::tk::dialog::color::StartMove {w sel color x delta {dontMove 0}} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
if {!$dontMove} {
|
||||
MoveSelector $w $sel $color $x $delta
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::MoveSelector --
|
||||
#
|
||||
# Moves the polygon selector so that its middle point has the same
|
||||
# x value as the specified x. If x is outside the bounds [0,255],
|
||||
# the selector is set to the closest endpoint.
|
||||
#
|
||||
# Params: sel is the selector canvas, c is [red|green|blue]
|
||||
# x is a x-coordinate.
|
||||
#
|
||||
proc ::tk::dialog::color::MoveSelector {w sel color x delta} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
incr x -$delta
|
||||
|
||||
if { $x < 0 } {
|
||||
set x 0
|
||||
} elseif { $x > $data(BARS_WIDTH)} {
|
||||
set x $data(BARS_WIDTH)
|
||||
}
|
||||
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
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::ReleaseMouse
|
||||
#
|
||||
# Removes mouse tracking bindings, updates the colorbars.
|
||||
#
|
||||
# Params: sel is the selector canvas, color is the color of the strip,
|
||||
# x is the x-coord of the mouse.
|
||||
#
|
||||
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]
|
||||
|
||||
RedrawColorBars $w $color
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::ResizeColorbars --
|
||||
#
|
||||
# Completely redraws the colorbars, including resizing the
|
||||
# colorstrips
|
||||
#
|
||||
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)
|
||||
} then {
|
||||
set data(BARS_WIDTH) $data(NUM_COLORBARS)
|
||||
}
|
||||
InitValues [winfo name $w]
|
||||
foreach color {red green blue} {
|
||||
$data($color,col) configure -width $data(canvasWidth)
|
||||
DrawColorScale $w $color 1
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::HandleSelEntry --
|
||||
#
|
||||
# Handles the return keypress event in the "Selection:" entry
|
||||
#
|
||||
proc ::tk::dialog::color::HandleSelEntry {w} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
set text [string trim $data(selection)]
|
||||
# Check to make sure that the color is valid
|
||||
if {[catch {set color [winfo rgb . $text]} ]} {
|
||||
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}]
|
||||
|
||||
SetRGBValue $w "$R $G $B"
|
||||
set data(selection) $text
|
||||
}
|
||||
|
||||
# ::tk::dialog::color::HandleRGBEntry --
|
||||
#
|
||||
# Handles the return keypress event in the R, G or B entry
|
||||
#
|
||||
proc ::tk::dialog::color::HandleRGBEntry {w} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
foreach c {red green blue} {
|
||||
if {[catch {
|
||||
set data($c,intensity) [expr {int($data($c,intensity))}]
|
||||
}]} {
|
||||
set data($c,intensity) 0
|
||||
}
|
||||
|
||||
if {$data($c,intensity) < 0} {
|
||||
set data($c,intensity) 0
|
||||
}
|
||||
if {$data($c,intensity) > 255} {
|
||||
set data($c,intensity) 255
|
||||
}
|
||||
}
|
||||
|
||||
SetRGBValue $w "$data(red,intensity) \
|
||||
$data(green,intensity) $data(blue,intensity)"
|
||||
}
|
||||
|
||||
# mouse cursor enters a color bar
|
||||
#
|
||||
proc ::tk::dialog::color::EnterColorBar {w color} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
$data($color,sel) itemconfigure $data($color,index) -fill red
|
||||
}
|
||||
|
||||
# mouse leaves enters a color bar
|
||||
#
|
||||
proc ::tk::dialog::color::LeaveColorBar {w color} {
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
$data($color,sel) itemconfigure $data($color,index) -fill black
|
||||
}
|
||||
|
||||
# user hits OK button
|
||||
#
|
||||
proc ::tk::dialog::color::OkCmd {w} {
|
||||
variable ::tk::Priv
|
||||
upvar ::tk::dialog::color::[winfo name $w] data
|
||||
|
||||
set Priv(selectColor) $data(finalColor)
|
||||
}
|
||||
|
||||
# user hits Cancel button or destroys window
|
||||
#
|
||||
proc ::tk::dialog::color::CancelCmd {w} {
|
||||
variable ::tk::Priv
|
||||
set Priv(selectColor) ""
|
||||
}
|
||||
@@ -0,0 +1,322 @@
|
||||
# comdlg.tcl --
|
||||
#
|
||||
# Some functions needed for the common dialog boxes. Probably need to go
|
||||
# in a different file.
|
||||
#
|
||||
# Copyright (c) 1996 Sun Microsystems, Inc.
|
||||
#
|
||||
# See the file "license.terms" for information on usage and redistribution
|
||||
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||||
#
|
||||
|
||||
# tclParseConfigSpec --
|
||||
#
|
||||
# Parses a list of "-option value" pairs. If all options and
|
||||
# values are legal, the values are stored in
|
||||
# $data($option). Otherwise an error message is returned. When
|
||||
# an error happens, the data() array may have been partially
|
||||
# modified, but all the modified members of the data(0 array are
|
||||
# guaranteed to have valid values. This is different than
|
||||
# Tk_ConfigureWidget() which does not modify the value of a
|
||||
# widget record if any error occurs.
|
||||
#
|
||||
# Arguments:
|
||||
#
|
||||
# w = widget record to modify. Must be the pathname of a widget.
|
||||
#
|
||||
# specs = {
|
||||
# {-commandlineswitch resourceName ResourceClass defaultValue verifier}
|
||||
# {....}
|
||||
# }
|
||||
#
|
||||
# flags = a list of flags. Currently supported flags are:
|
||||
# DONTSETDEFAULTS = skip default values setting
|
||||
#
|
||||
# argList = The list of "-option value" pairs.
|
||||
#
|
||||
proc tclParseConfigSpec {w specs flags argList} {
|
||||
upvar #0 $w data
|
||||
|
||||
# 1: Put the specs in associative arrays for faster access
|
||||
#
|
||||
foreach spec $specs {
|
||||
if {[llength $spec] < 4} {
|
||||
return -code error -errorcode {TK VALUE CONFIG_SPEC} \
|
||||
"\"spec\" should contain 5 or 4 elements"
|
||||
}
|
||||
set cmdsw [lindex $spec 0]
|
||||
set cmd($cmdsw) ""
|
||||
set rname($cmdsw) [lindex $spec 1]
|
||||
set rclass($cmdsw) [lindex $spec 2]
|
||||
set def($cmdsw) [lindex $spec 3]
|
||||
set verproc($cmdsw) [lindex $spec 4]
|
||||
}
|
||||
|
||||
if {[llength $argList] & 1} {
|
||||
set cmdsw [lindex $argList end]
|
||||
if {![info exists cmd($cmdsw)]} {
|
||||
return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
|
||||
"bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
|
||||
}
|
||||
return -code error -errorcode {TK VALUE_MISSING} \
|
||||
"value for \"$cmdsw\" missing"
|
||||
}
|
||||
|
||||
# 2: set the default values
|
||||
#
|
||||
if {"DONTSETDEFAULTS" ni $flags} {
|
||||
foreach cmdsw [array names cmd] {
|
||||
set data($cmdsw) $def($cmdsw)
|
||||
}
|
||||
}
|
||||
|
||||
# 3: parse the argument list
|
||||
#
|
||||
foreach {cmdsw value} $argList {
|
||||
if {![info exists cmd($cmdsw)]} {
|
||||
return -code error -errorcode [list TK LOOKUP OPTION $cmdsw] \
|
||||
"bad option \"$cmdsw\": must be [tclListValidFlags cmd]"
|
||||
}
|
||||
set data($cmdsw) $value
|
||||
}
|
||||
|
||||
# Done!
|
||||
}
|
||||
|
||||
proc tclListValidFlags {v} {
|
||||
upvar $v cmd
|
||||
|
||||
set len [llength [array names cmd]]
|
||||
set i 1
|
||||
set separator ""
|
||||
set errormsg ""
|
||||
foreach cmdsw [lsort [array names cmd]] {
|
||||
append errormsg "$separator$cmdsw"
|
||||
incr i
|
||||
if {$i == $len} {
|
||||
set separator ", or "
|
||||
} else {
|
||||
set separator ", "
|
||||
}
|
||||
}
|
||||
return $errormsg
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------
|
||||
#
|
||||
# Focus Group
|
||||
#
|
||||
# Focus groups are used to handle the user's focusing actions inside a
|
||||
# toplevel.
|
||||
#
|
||||
# One example of using focus groups is: when the user focuses on an
|
||||
# entry, the text in the entry is highlighted and the cursor is put to
|
||||
# the end of the text. When the user changes focus to another widget,
|
||||
# the text in the previously focused entry is validated.
|
||||
#
|
||||
#----------------------------------------------------------------------
|
||||
|
||||
|
||||
# ::tk::FocusGroup_Create --
|
||||
#
|
||||
# Create a focus group. All the widgets in a focus group must be
|
||||
# within the same focus toplevel. Each toplevel can have only
|
||||
# one focus group, which is identified by the name of the
|
||||
# toplevel widget.
|
||||
#
|
||||
proc ::tk::FocusGroup_Create {t} {
|
||||
variable ::tk::Priv
|
||||
if {[winfo toplevel $t] ne $t} {
|
||||
return -code error -errorcode [list TK LOOKUP TOPLEVEL $t] \
|
||||
"$t is not a toplevel window"
|
||||
}
|
||||
if {![info exists Priv(fg,$t)]} {
|
||||
set Priv(fg,$t) 1
|
||||
set Priv(focus,$t) ""
|
||||
bind $t <FocusIn> [list tk::FocusGroup_In $t %W %d]
|
||||
bind $t <FocusOut> [list tk::FocusGroup_Out $t %W %d]
|
||||
bind $t <Destroy> [list tk::FocusGroup_Destroy $t %W]
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FocusGroup_BindIn --
|
||||
#
|
||||
# Add a widget into the "FocusIn" list of the focus group. The $cmd will be
|
||||
# called when the widget is focused on by the user.
|
||||
#
|
||||
proc ::tk::FocusGroup_BindIn {t w cmd} {
|
||||
variable FocusIn
|
||||
variable ::tk::Priv
|
||||
if {![info exists Priv(fg,$t)]} {
|
||||
return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
|
||||
"focus group \"$t\" doesn't exist"
|
||||
}
|
||||
set FocusIn($t,$w) $cmd
|
||||
}
|
||||
|
||||
|
||||
# ::tk::FocusGroup_BindOut --
|
||||
#
|
||||
# Add a widget into the "FocusOut" list of the focus group. The
|
||||
# $cmd will be called when the widget loses the focus (User
|
||||
# types Tab or click on another widget).
|
||||
#
|
||||
proc ::tk::FocusGroup_BindOut {t w cmd} {
|
||||
variable FocusOut
|
||||
variable ::tk::Priv
|
||||
if {![info exists Priv(fg,$t)]} {
|
||||
return -code error -errorcode [list TK LOOKUP FOCUS_GROUP $t] \
|
||||
"focus group \"$t\" doesn't exist"
|
||||
}
|
||||
set FocusOut($t,$w) $cmd
|
||||
}
|
||||
|
||||
# ::tk::FocusGroup_Destroy --
|
||||
#
|
||||
# Cleans up when members of the focus group is deleted, or when the
|
||||
# toplevel itself gets deleted.
|
||||
#
|
||||
proc ::tk::FocusGroup_Destroy {t w} {
|
||||
variable FocusIn
|
||||
variable FocusOut
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$t eq $w} {
|
||||
unset Priv(fg,$t)
|
||||
unset Priv(focus,$t)
|
||||
|
||||
foreach name [array names FocusIn $t,*] {
|
||||
unset FocusIn($name)
|
||||
}
|
||||
foreach name [array names FocusOut $t,*] {
|
||||
unset FocusOut($name)
|
||||
}
|
||||
} else {
|
||||
if {[info exists Priv(focus,$t)] && ($Priv(focus,$t) eq $w)} {
|
||||
set Priv(focus,$t) ""
|
||||
}
|
||||
unset -nocomplain FocusIn($t,$w) FocusOut($t,$w)
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FocusGroup_In --
|
||||
#
|
||||
# Handles the <FocusIn> event. Calls the FocusIn command for the newly
|
||||
# focused widget in the focus group.
|
||||
#
|
||||
proc ::tk::FocusGroup_In {t w detail} {
|
||||
variable FocusIn
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
|
||||
# This is caused by mouse moving out&in of the window *or*
|
||||
# ordinary keypresses some window managers (ie: CDE [Bug: 2960]).
|
||||
return
|
||||
}
|
||||
if {![info exists FocusIn($t,$w)]} {
|
||||
set FocusIn($t,$w) ""
|
||||
return
|
||||
}
|
||||
if {![info exists Priv(focus,$t)]} {
|
||||
return
|
||||
}
|
||||
if {$Priv(focus,$t) eq $w} {
|
||||
# This is already in focus
|
||||
#
|
||||
return
|
||||
} else {
|
||||
set Priv(focus,$t) $w
|
||||
eval $FocusIn($t,$w)
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FocusGroup_Out --
|
||||
#
|
||||
# Handles the <FocusOut> event. Checks if this is really a lose
|
||||
# focus event, not one generated by the mouse moving out of the
|
||||
# toplevel window. Calls the FocusOut command for the widget
|
||||
# who loses its focus.
|
||||
#
|
||||
proc ::tk::FocusGroup_Out {t w detail} {
|
||||
variable FocusOut
|
||||
variable ::tk::Priv
|
||||
|
||||
if {$detail ne "NotifyNonlinear" && $detail ne "NotifyNonlinearVirtual"} {
|
||||
# This is caused by mouse moving out of the window
|
||||
return
|
||||
}
|
||||
if {![info exists Priv(focus,$t)]} {
|
||||
return
|
||||
}
|
||||
if {![info exists FocusOut($t,$w)]} {
|
||||
return
|
||||
} else {
|
||||
eval $FocusOut($t,$w)
|
||||
set Priv(focus,$t) ""
|
||||
}
|
||||
}
|
||||
|
||||
# ::tk::FDGetFileTypes --
|
||||
#
|
||||
# Process the string given by the -filetypes option of the file
|
||||
# dialogs. Similar to the C function TkGetFileFilters() on the Mac
|
||||
# and Windows platform.
|
||||
#
|
||||
proc ::tk::FDGetFileTypes {string} {
|
||||
foreach t $string {
|
||||
if {[llength $t] < 2 || [llength $t] > 3} {
|
||||
return -code error -errorcode {TK VALUE FILE_TYPE} \
|
||||
"bad file type \"$t\", should be \"typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?\""
|
||||
}
|
||||
lappend fileTypes([lindex $t 0]) {*}[lindex $t 1]
|
||||
}
|
||||
|
||||
set types {}
|
||||
foreach t $string {
|
||||
set label [lindex $t 0]
|
||||
set exts {}
|
||||
|
||||
if {[info exists hasDoneType($label)]} {
|
||||
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} {
|
||||
return -code error -errorcode {TK VALUE MAC_TYPE} \
|
||||
"bad Macintosh file type \"$macType\""
|
||||
}
|
||||
}
|
||||
|
||||
set name "$label \("
|
||||
set sep ""
|
||||
set doAppend 1
|
||||
foreach ext $fileTypes($label) {
|
||||
if {$ext eq ""} {
|
||||
continue
|
||||
}
|
||||
regsub {^[.]} $ext "*." ext
|
||||
if {![info exists hasGotExt($label,$ext)]} {
|
||||
if {$doAppend} {
|
||||
if {[string length $sep] && [string length $name]>40} {
|
||||
set doAppend 0
|
||||
append name $sep...
|
||||
} else {
|
||||
append name $sep$ext
|
||||
}
|
||||
}
|
||||
lappend exts $ext
|
||||
set hasGotExt($label,$ext) 1
|
||||
}
|
||||
set sep ","
|
||||
}
|
||||
append name "\)"
|
||||
lappend types [list $name $exts]
|
||||
|
||||
set hasDoneType($label) 1
|
||||
}
|
||||
|
||||
return $types
|
||||
}
|
||||
File diff suppressed because it is too large.
Load diff
@@ -0,0 +1,44 @@
|
||||
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 on your path
|
||||
then you can invoke any of the programs in this directory just
|
||||
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
|
||||
themselves so they aren't described below.
|
||||
|
||||
hello - Creates a single button; if you click on it, a message
|
||||
is typed and the application terminates.
|
||||
|
||||
widget - Contains a collection of demonstrations of the widgets
|
||||
currently available in the Tk library. Most of the .tcl
|
||||
files are scripts for individual demos available through
|
||||
the "widget" program.
|
||||
|
||||
ixset - A simple Tk-based wrapper for the "xset" program, which
|
||||
allows you to interactively query and set various X options
|
||||
such as mouse acceleration and bell volume. Thanks to
|
||||
Pierre David for contributing this example.
|
||||
|
||||
rolodex - A mock-up of a simple rolodex application. It has much of
|
||||
the user interface for such an application but no back-end
|
||||
database. This program was written in response to Tom
|
||||
LaStrange's toolkit benchmark challenge.
|
||||
|
||||
tcolor - A color editor. Allows you to edit colors in several
|
||||
different ways, and will also perform automatic updates
|
||||
using "send".
|
||||
|
||||
rmt - Allows you to "hook-up" remotely to any Tk application
|
||||
on the display. Select an application with the menu,
|
||||
then just type commands: they'll go to that application.
|
||||
|
||||
timer - Displays a seconds timer with start and stop buttons.
|
||||
Control-c and control-q cause it to exit.
|
||||
|
||||
browse - A simple directory browser. Invoke it with and argument
|
||||
giving the name of the directory you'd like to browse.
|
||||
Double-click on files or subdirectories to browse them.
|
||||
Control-c and control-q cause the program to exit.
|
||||
@@ -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
|
||||
@@ -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
|
||||
@@ -0,0 +1,241 @@
|
||||
# arrow.tcl --
|
||||
#
|
||||
# This demonstration script creates a canvas widget that displays a
|
||||
# large line with an arrowhead whose shape can be edited interactively.
|
||||
|
||||
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
|
||||
# whenever any of the parameters of the arrow head are changed
|
||||
# interactively.
|
||||
#
|
||||
# Arguments:
|
||||
# c - Name of the canvas widget.
|
||||
|
||||
proc arrowSetup c {
|
||||
upvar #0 demo_arrowInfo v
|
||||
|
||||
# Remember the current box, if there is one.
|
||||
|
||||
set tags [$c gettags current]
|
||||
if {$tags != ""} {
|
||||
set cur [lindex $tags [lsearch -glob $tags box?]]
|
||||
} else {
|
||||
set cur ""
|
||||
}
|
||||
|
||||
# Create the arrow and outline.
|
||||
|
||||
$c delete all
|
||||
eval {$c create line $v(x1) $v(y) $v(x2) $v(y) -arrow last \
|
||||
-width [expr {10*$v(width)}] -arrowshape [list \
|
||||
[expr {10*$v(a)}] [expr {10*$v(b)}] [expr {10*$v(c)}]]} \
|
||||
$v(bigLineStyle)
|
||||
set xtip [expr {$v(x2)-10*$v(b)}]
|
||||
set deltaY [expr {10*$v(c)+5*$v(width)}]
|
||||
$c create line $v(x2) $v(y) $xtip [expr {$v(y)+$deltaY}] \
|
||||
[expr {$v(x2)-10*$v(a)}] $v(y) $xtip [expr {$v(y)-$deltaY}] \
|
||||
$v(x2) $v(y) -width 2 -capstyle round -joinstyle round
|
||||
|
||||
# Create the boxes for reshaping the line and arrowhead.
|
||||
|
||||
eval {$c create rect [expr {$v(x2)-10*$v(a)-5}] [expr {$v(y)-5}] \
|
||||
[expr {$v(x2)-10*$v(a)+5}] [expr {$v(y)+5}] \
|
||||
-tags {box1 box}} $v(boxStyle)
|
||||
eval {$c create rect [expr {$xtip-5}] [expr {$v(y)-$deltaY-5}] \
|
||||
[expr {$xtip+5}] [expr {$v(y)-$deltaY+5}] \
|
||||
-tags {box2 box}} $v(boxStyle)
|
||||
eval {$c create rect [expr {$v(x1)-5}] [expr {$v(y)-5*$v(width)-5}] \
|
||||
[expr {$v(x1)+5}] [expr {$v(y)-5*$v(width)+5}] \
|
||||
-tags {box3 box}} $v(boxStyle)
|
||||
if {$cur != ""} {
|
||||
eval $c itemconfigure $cur $v(activeStyle)
|
||||
}
|
||||
|
||||
# Create three arrows in actual size with the same parameters
|
||||
|
||||
$c create line [expr {$v(x2)+50}] 0 [expr {$v(x2)+50}] 1000 \
|
||||
-width 2
|
||||
set tmp [expr {$v(x2)+100}]
|
||||
$c create line $tmp [expr {$v(y)-125}] $tmp [expr {$v(y)-75}] \
|
||||
-width $v(width) \
|
||||
-arrow both -arrowshape "$v(a) $v(b) $v(c)"
|
||||
$c create line [expr {$tmp-25}] $v(y) [expr {$tmp+25}] $v(y) \
|
||||
-width $v(width) \
|
||||
-arrow both -arrowshape "$v(a) $v(b) $v(c)"
|
||||
$c create line [expr {$tmp-25}] [expr {$v(y)+75}] [expr {$tmp+25}] \
|
||||
[expr {$v(y)+125}] -width $v(width) \
|
||||
-arrow both -arrowshape "$v(a) $v(b) $v(c)"
|
||||
|
||||
# Create a bunch of other arrows and text items showing the
|
||||
# current dimensions.
|
||||
|
||||
set tmp [expr {$v(x2)+10}]
|
||||
$c create line $tmp [expr {$v(y)-5*$v(width)}] \
|
||||
$tmp [expr {$v(y)-$deltaY}] \
|
||||
-arrow both -arrowshape $v(smallTips)
|
||||
$c create text [expr {$v(x2)+15}] [expr {$v(y)-$deltaY+5*$v(c)}] \
|
||||
-text $v(c) -anchor w
|
||||
set tmp [expr {$v(x1)-10}]
|
||||
$c create line $tmp [expr {$v(y)-5*$v(width)}] \
|
||||
$tmp [expr {$v(y)+5*$v(width)}] \
|
||||
-arrow both -arrowshape $v(smallTips)
|
||||
$c create text [expr {$v(x1)-15}] $v(y) -text $v(width) -anchor e
|
||||
set tmp [expr {$v(y)+5*$v(width)+10*$v(c)+10}]
|
||||
$c create line [expr {$v(x2)-10*$v(a)}] $tmp $v(x2) $tmp \
|
||||
-arrow both -arrowshape $v(smallTips)
|
||||
$c create text [expr {$v(x2)-5*$v(a)}] [expr {$tmp+5}] \
|
||||
-text $v(a) -anchor n
|
||||
set tmp [expr {$tmp+25}]
|
||||
$c create line [expr {$v(x2)-10*$v(b)}] $tmp $v(x2) $tmp \
|
||||
-arrow both -arrowshape $v(smallTips)
|
||||
$c create text [expr {$v(x2)-5*$v(b)}] [expr {$tmp+5}] \
|
||||
-text $v(b) -anchor n
|
||||
|
||||
$c create text $v(x1) 310 -text "-width $v(width)" \
|
||||
-anchor w -font {Helvetica 18}
|
||||
$c create text $v(x1) 330 -text "-arrowshape {$v(a) $v(b) $v(c)}" \
|
||||
-anchor w -font {Helvetica 18}
|
||||
|
||||
incr v(count)
|
||||
}
|
||||
|
||||
set w .arrow
|
||||
catch {destroy $w}
|
||||
toplevel $w
|
||||
wm title $w "Arrowhead Editor Demonstration"
|
||||
wm iconname $w "arrow"
|
||||
positionWindow $w
|
||||
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
|
||||
|
||||
## 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
|
||||
|
||||
set demo_arrowInfo(a) 8
|
||||
set demo_arrowInfo(b) 10
|
||||
set demo_arrowInfo(c) 3
|
||||
set demo_arrowInfo(width) 2
|
||||
set demo_arrowInfo(motionProc) arrowMoveNull
|
||||
set demo_arrowInfo(x1) 40
|
||||
set demo_arrowInfo(x2) 350
|
||||
set demo_arrowInfo(y) 150
|
||||
set demo_arrowInfo(smallTips) {5 5 2}
|
||||
set demo_arrowInfo(count) 0
|
||||
if {[winfo depth $c] > 1} {
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
set demo_arrowInfo(bigLineStyle) "-fill systemSelectedTextBackgroundColor"
|
||||
} else {
|
||||
set demo_arrowInfo(bigLineStyle) "-fill LightSeaGreen"
|
||||
}
|
||||
set demo_arrowInfo(boxStyle) "-fill {} -width 1"
|
||||
set demo_arrowInfo(activeStyle) "-fill red -width 1"
|
||||
} else {
|
||||
# Main widget program sets variable tk_demoDirectory
|
||||
set demo_arrowInfo(bigLineStyle) "-fill black \
|
||||
-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"
|
||||
}
|
||||
arrowSetup $c
|
||||
$c bind box <Enter> "$c itemconfigure current $demo_arrowInfo(activeStyle)"
|
||||
$c bind box <Leave> "$c itemconfigure current $demo_arrowInfo(boxStyle)"
|
||||
$c bind box <B1-Enter> " "
|
||||
$c bind box <B1-Leave> " "
|
||||
$c bind box1 <Button-1> {set demo_arrowInfo(motionProc) arrowMove1}
|
||||
$c bind box2 <Button-1> {set demo_arrowInfo(motionProc) arrowMove2}
|
||||
$c bind box3 <Button-1> {set demo_arrowInfo(motionProc) arrowMove3}
|
||||
$c bind box <B1-Motion> "\$demo_arrowInfo(motionProc) $c %x %y"
|
||||
bind $c <ButtonRelease-1> "arrowSetup $c"
|
||||
|
||||
# arrowMove1 --
|
||||
# This procedure is called for each mouse motion event on box1 (the
|
||||
# one at the vertex of the arrow). It updates the controlling parameters
|
||||
# for the line and arrowhead.
|
||||
#
|
||||
# Arguments:
|
||||
# c - The name of the canvas window.
|
||||
# x, y - The coordinates of the mouse.
|
||||
|
||||
proc arrowMove1 {c x y} {
|
||||
upvar #0 demo_arrowInfo v
|
||||
set newA [expr {($v(x2)+5-round([$c canvasx $x]))/10}]
|
||||
if {$newA < 0} {
|
||||
set newA 0
|
||||
}
|
||||
if {$newA > 25} {
|
||||
set newA 25
|
||||
}
|
||||
if {$newA != $v(a)} {
|
||||
$c move box1 [expr {10*($v(a)-$newA)}] 0
|
||||
set v(a) $newA
|
||||
}
|
||||
}
|
||||
|
||||
# arrowMove2 --
|
||||
# This procedure is called for each mouse motion event on box2 (the
|
||||
# one at the trailing tip of the arrowhead). It updates the controlling
|
||||
# parameters for the line and arrowhead.
|
||||
#
|
||||
# Arguments:
|
||||
# c - The name of the canvas window.
|
||||
# x, y - The coordinates of the mouse.
|
||||
|
||||
proc arrowMove2 {c x y} {
|
||||
upvar #0 demo_arrowInfo v
|
||||
set newB [expr {($v(x2)+5-round([$c canvasx $x]))/10}]
|
||||
if {$newB < 0} {
|
||||
set newB 0
|
||||
}
|
||||
if {$newB > 25} {
|
||||
set newB 25
|
||||
}
|
||||
set newC [expr {($v(y)+5-round([$c canvasy $y])-5*$v(width))/10}]
|
||||
if {$newC < 0} {
|
||||
set newC 0
|
||||
}
|
||||
if {$newC > 20} {
|
||||
set newC 20
|
||||
}
|
||||
if {($newB != $v(b)) || ($newC != $v(c))} {
|
||||
$c move box2 [expr {10*($v(b)-$newB)}] [expr {10*($v(c)-$newC)}]
|
||||
set v(b) $newB
|
||||
set v(c) $newC
|
||||
}
|
||||
}
|
||||
|
||||
# arrowMove3 --
|
||||
# This procedure is called for each mouse motion event on box3 (the
|
||||
# one that controls the thickness of the line). It updates the
|
||||
# controlling parameters for the line and arrowhead.
|
||||
#
|
||||
# Arguments:
|
||||
# c - The name of the canvas window.
|
||||
# x, y - The coordinates of the mouse.
|
||||
|
||||
proc arrowMove3 {c x y} {
|
||||
upvar #0 demo_arrowInfo v
|
||||
set newWidth [expr {($v(y)+2-round([$c canvasy $y]))/5}]
|
||||
if {$newWidth < 0} {
|
||||
set newWidth 0
|
||||
}
|
||||
if {$newWidth > 20} {
|
||||
set newWidth 20
|
||||
}
|
||||
if {$newWidth != $v(width)} {
|
||||
$c move box3 0 [expr {5*($v(width)-$newWidth)}]
|
||||
set v(width) $newWidth
|
||||
}
|
||||
}
|
||||
@@ -0,0 +1,78 @@
|
||||
# bind.tcl --
|
||||
#
|
||||
# This demonstration script creates a text widget with bindings set
|
||||
# up for hypertext-like effects.
|
||||
|
||||
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
|
||||
wm title $w "Text Demonstration - Tag Bindings"
|
||||
wm iconname $w "bind"
|
||||
positionWindow $w
|
||||
|
||||
## 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
|
||||
ttk::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.
|
||||
|
||||
if {[winfo depth $w] > 1} {
|
||||
set bold "-background #43ce80 -relief raised -borderwidth 1"
|
||||
set normal "-background {} -relief flat"
|
||||
} else {
|
||||
set bold "-foreground white -background black"
|
||||
set normal "-foreground {} -background {}"
|
||||
}
|
||||
|
||||
# Add text to widget.
|
||||
|
||||
$w.text insert 0.0 {\
|
||||
The same tag mechanism that controls display styles in text widgets can also be used to associate Tcl commands with regions of text, so that mouse or keyboard actions on the text cause particular Tcl commands to be invoked. For example, in the text below the descriptions of the canvas demonstrations have been tagged. When you move the mouse over a demo description the description lights up, and when you press button 1 over a description then that particular demonstration is invoked.
|
||||
|
||||
}
|
||||
$w.text insert end \
|
||||
{1. Samples of all the different types of items that can be created in canvas widgets.} d1
|
||||
$w.text insert end \n\n
|
||||
$w.text insert end \
|
||||
{2. A simple two-dimensional plot that allows you to adjust the positions of the data points.} d2
|
||||
$w.text insert end \n\n
|
||||
$w.text insert end \
|
||||
{3. Anchoring and justification modes for text items.} d3
|
||||
$w.text insert end \n\n
|
||||
$w.text insert end \
|
||||
{4. An editor for arrow-head shapes for line items.} d4
|
||||
$w.text insert end \n\n
|
||||
$w.text insert end \
|
||||
{5. A ruler with facilities for editing tab stops.} d5
|
||||
$w.text insert end \n\n
|
||||
$w.text insert end \
|
||||
{6. A grid that demonstrates how canvases can be scrolled.} d6
|
||||
|
||||
# Create bindings for tags.
|
||||
|
||||
foreach tag {d1 d2 d3 d4 d5 d6} {
|
||||
$w.text tag bind $tag <Enter> "$w.text tag configure $tag $bold"
|
||||
$w.text tag bind $tag <Leave> "$w.text tag configure $tag $normal"
|
||||
}
|
||||
# Main widget program sets variable tk_demoDirectory
|
||||
$w.text tag bind d1 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory items.tcl]}
|
||||
$w.text tag bind d2 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory plot.tcl]}
|
||||
$w.text tag bind d3 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory ctext.tcl]}
|
||||
$w.text tag bind d4 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory arrow.tcl]}
|
||||
$w.text tag bind d5 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory ruler.tcl]}
|
||||
$w.text tag bind d6 <Button-1> {source -encoding utf-8 [file join $tk_demoDirectory cscroll.tcl]}
|
||||
|
||||
$w.text mark set insert 0.0
|
||||
$w.text configure -state disabled
|
||||
@@ -0,0 +1,52 @@
|
||||
# bitmap.tcl --
|
||||
#
|
||||
# This demonstration script creates a toplevel window that displays
|
||||
# all of Tk's built-in bitmaps.
|
||||
|
||||
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.
|
||||
#
|
||||
# Arguments:
|
||||
# w - The window that is to contain the row.
|
||||
# args - The names of one or more bitmaps, which will be displayed
|
||||
# in a new row across the bottom of w along with their
|
||||
# names.
|
||||
|
||||
proc bitmapRow {w args} {
|
||||
frame $w
|
||||
pack $w -side top -fill both
|
||||
set i 0
|
||||
foreach bitmap $args {
|
||||
frame $w.$i
|
||||
pack $w.$i -side left -fill both -pady .25c -padx .25c
|
||||
label $w.$i.bitmap -bitmap $bitmap
|
||||
label $w.$i.label -text $bitmap -width 9
|
||||
pack $w.$i.label $w.$i.bitmap -side bottom
|
||||
incr i
|
||||
}
|
||||
}
|
||||
|
||||
set w .bitmap
|
||||
catch {destroy $w}
|
||||
toplevel $w
|
||||
wm title $w "Bitmap Demonstration"
|
||||
wm iconname $w "bitmap"
|
||||
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
|
||||
|
||||
## 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
|
||||
bitmapRow $w.frame.1 hourglass info question questhead warning
|
||||
pack $w.frame -side top -expand yes -fill both
|
||||
@@ -0,0 +1,66 @@
|
||||
#!/bin/sh
|
||||
# the next line restarts using wish \
|
||||
exec wish "$0" ${1+"$@"}
|
||||
|
||||
# browse --
|
||||
# This script generates a directory browser, which lists the working
|
||||
# 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.
|
||||
|
||||
scrollbar .scroll -command ".list yview"
|
||||
pack .scroll -side right -fill y
|
||||
listbox .list -yscroll ".scroll set" -relief sunken -width 20 -height 20 \
|
||||
-setgrid yes
|
||||
pack .list -side left -fill both -expand yes
|
||||
wm minsize . 1 1
|
||||
|
||||
# The procedure below is invoked to open a browser on a given file; if the
|
||||
# file is a directory then another instance of this program is invoked; if
|
||||
# the file is a regular file then the Mx editor is invoked to display
|
||||
# the file.
|
||||
|
||||
set browseScript [file join [pwd] $argv0]
|
||||
proc browse {dir file} {
|
||||
global env browseScript
|
||||
if {[string compare $dir "."] != 0} {set file $dir/$file}
|
||||
switch [file type $file] {
|
||||
directory {
|
||||
exec [info nameofexecutable] $browseScript $file &
|
||||
}
|
||||
file {
|
||||
if {[info exists env(EDITOR)]} {
|
||||
eval exec $env(EDITOR) $file &
|
||||
} else {
|
||||
exec xedit $file &
|
||||
}
|
||||
}
|
||||
default {
|
||||
puts stdout "\"$file\" isn't a directory or regular file"
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Fill the listbox with a list of all the files in the directory.
|
||||
|
||||
if {$argc>0} {set dir [lindex $argv 0]} else {set dir "."}
|
||||
foreach i [lsort [glob * .* *.*]] {
|
||||
if {[file type $i] eq "directory"} {
|
||||
# Safe to do since it is still a directory.
|
||||
append i /
|
||||
}
|
||||
.list insert end $i
|
||||
}
|
||||
|
||||
# Set up bindings for the browser.
|
||||
|
||||
bind all <Control-c> {destroy .}
|
||||
bind .list <Double-Button-1> {foreach i [selection get] {browse $dir $i}}
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
@@ -0,0 +1,47 @@
|
||||
# button.tcl --
|
||||
#
|
||||
# This demonstration script creates a toplevel window containing
|
||||
# several button widgets.
|
||||
|
||||
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
|
||||
wm title $w "Button Demonstration"
|
||||
wm iconname $w "button"
|
||||
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
|
||||
|
||||
## See Code / Dismiss buttons
|
||||
pack [addSeeDismiss $w.buttons $w] -side bottom -fill x
|
||||
|
||||
proc colorrefresh {w col} {
|
||||
$w 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 [lassign $l b] [winfo children $b]]
|
||||
if {[winfo class $b] eq "Button"} {
|
||||
$b configure -highlightbackground $col
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
button $w.b1 -text "Peach Puff" -width 10 \
|
||||
-command [list colorrefresh $w PeachPuff1]
|
||||
button $w.b2 -text "Light Blue" -width 10 \
|
||||
-command [list colorrefresh $w LightBlue1]
|
||||
button $w.b3 -text "Sea Green" -width 10 \
|
||||
-command [list colorrefresh $w SeaGreen2]
|
||||
button $w.b4 -text "Yellow" -width 10 \
|
||||
-command [list colorrefresh $w Yellow1]
|
||||
pack $w.b1 $w.b2 $w.b3 $w.b4 -side top -expand yes -pady 2
|
||||
@@ -0,0 +1,71 @@
|
||||
# check.tcl --
|
||||
#
|
||||
# This demonstration script creates a toplevel window containing
|
||||
# several checkbuttons.
|
||||
|
||||
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
|
||||
wm title $w "Checkbutton Demonstration"
|
||||
wm iconname $w "check"
|
||||
positionWindow $w
|
||||
|
||||
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
|
||||
|
||||
## 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.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
|
||||
@@ -0,0 +1,54 @@
|
||||
# clrpick.tcl --
|
||||
#
|
||||
# This demonstration script prompts the user to select a color.
|
||||
|
||||
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
|
||||
wm title $w "Color Selection Dialog"
|
||||
wm iconname $w "colors"
|
||||
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
|
||||
|
||||
## See Code / Dismiss buttons
|
||||
set btns [addSeeDismiss $w.buttons $w]
|
||||
pack $btns -side bottom -fill x
|
||||
|
||||
button $w.back -text "Set background color ..." \
|
||||
-command \
|
||||
"setColor $w $w.back background {-background -highlightbackground}"
|
||||
button $w.fore -text "Set foreground color ..." \
|
||||
-command \
|
||||
"setColor $w $w.back foreground -foreground"
|
||||
|
||||
pack $w.back $w.fore -side top -anchor c -pady 2m
|
||||
|
||||
proc setColor {w button name options} {
|
||||
grab $w
|
||||
set initialColor [$button cget -$name]
|
||||
set color [tk_chooseColor -title "Choose a $name color" -parent $w \
|
||||
-initialcolor $initialColor]
|
||||
if {[string compare $color ""]} {
|
||||
setColor_helper $w $options $color
|
||||
}
|
||||
grab release $w
|
||||
}
|
||||
|
||||
proc setColor_helper {w options color} {
|
||||
foreach option $options {
|
||||
catch {
|
||||
$w config $option $color
|
||||
}
|
||||
}
|
||||
foreach child [winfo children $w] {
|
||||
setColor_helper $child $options $color
|
||||
}
|
||||
}
|
||||
@@ -0,0 +1,99 @@
|
||||
# colors.tcl --
|
||||
#
|
||||
# This demonstration script creates a listbox widget that displays
|
||||
# many of the colors from the X color database. You can click on
|
||||
# a color to change the application's palette.
|
||||
|
||||
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
|
||||
wm title $w "Listbox Demonstration (colors)"
|
||||
wm iconname $w "Listbox"
|
||||
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
|
||||
|
||||
## 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
|
||||
|
||||
scrollbar $w.frame.scroll -command "$w.frame.list yview"
|
||||
listbox $w.frame.list -yscroll "$w.frame.scroll set" \
|
||||
-width 20 -height 16 -setgrid 1
|
||||
pack $w.frame.list $w.frame.scroll -side left -fill y -expand 1
|
||||
|
||||
bind $w.frame.list <Double-Button-1> {
|
||||
tk_setPalette [selection get]
|
||||
}
|
||||
$w.frame.list insert 0 gray60 gray70 gray80 gray85 gray90 gray95 \
|
||||
snow1 snow2 snow3 snow4 seashell1 seashell2 \
|
||||
seashell3 seashell4 AntiqueWhite1 AntiqueWhite2 AntiqueWhite3 \
|
||||
AntiqueWhite4 bisque1 bisque2 bisque3 bisque4 PeachPuff1 \
|
||||
PeachPuff2 PeachPuff3 PeachPuff4 NavajoWhite1 NavajoWhite2 \
|
||||
NavajoWhite3 NavajoWhite4 LemonChiffon1 LemonChiffon2 \
|
||||
LemonChiffon3 LemonChiffon4 cornsilk1 cornsilk2 cornsilk3 \
|
||||
cornsilk4 ivory1 ivory2 ivory3 ivory4 honeydew1 honeydew2 \
|
||||
honeydew3 honeydew4 LavenderBlush1 LavenderBlush2 \
|
||||
LavenderBlush3 LavenderBlush4 MistyRose1 MistyRose2 \
|
||||
MistyRose3 MistyRose4 azure1 azure2 azure3 azure4 \
|
||||
SlateBlue1 SlateBlue2 SlateBlue3 SlateBlue4 RoyalBlue1 \
|
||||
RoyalBlue2 RoyalBlue3 RoyalBlue4 blue1 blue2 blue3 blue4 \
|
||||
DodgerBlue1 DodgerBlue2 DodgerBlue3 DodgerBlue4 SteelBlue1 \
|
||||
SteelBlue2 SteelBlue3 SteelBlue4 DeepSkyBlue1 DeepSkyBlue2 \
|
||||
DeepSkyBlue3 DeepSkyBlue4 SkyBlue1 SkyBlue2 SkyBlue3 \
|
||||
SkyBlue4 LightSkyBlue1 LightSkyBlue2 LightSkyBlue3 \
|
||||
LightSkyBlue4 SlateGray1 SlateGray2 SlateGray3 SlateGray4 \
|
||||
LightSteelBlue1 LightSteelBlue2 LightSteelBlue3 \
|
||||
LightSteelBlue4 LightBlue1 LightBlue2 LightBlue3 \
|
||||
LightBlue4 LightCyan1 LightCyan2 LightCyan3 LightCyan4 \
|
||||
PaleTurquoise1 PaleTurquoise2 PaleTurquoise3 PaleTurquoise4 \
|
||||
CadetBlue1 CadetBlue2 CadetBlue3 CadetBlue4 turquoise1 \
|
||||
turquoise2 turquoise3 turquoise4 cyan1 cyan2 cyan3 cyan4 \
|
||||
DarkSlateGray1 DarkSlateGray2 DarkSlateGray3 \
|
||||
DarkSlateGray4 aquamarine1 aquamarine2 aquamarine3 \
|
||||
aquamarine4 DarkSeaGreen1 DarkSeaGreen2 DarkSeaGreen3 \
|
||||
DarkSeaGreen4 SeaGreen1 SeaGreen2 SeaGreen3 SeaGreen4 \
|
||||
PaleGreen1 PaleGreen2 PaleGreen3 PaleGreen4 SpringGreen1 \
|
||||
SpringGreen2 SpringGreen3 SpringGreen4 green1 green2 \
|
||||
green3 green4 chartreuse1 chartreuse2 chartreuse3 \
|
||||
chartreuse4 OliveDrab1 OliveDrab2 OliveDrab3 OliveDrab4 \
|
||||
DarkOliveGreen1 DarkOliveGreen2 DarkOliveGreen3 \
|
||||
DarkOliveGreen4 khaki1 khaki2 khaki3 khaki4 \
|
||||
LightGoldenrod1 LightGoldenrod2 LightGoldenrod3 \
|
||||
LightGoldenrod4 LightYellow1 LightYellow2 LightYellow3 \
|
||||
LightYellow4 yellow1 yellow2 yellow3 yellow4 gold1 gold2 \
|
||||
gold3 gold4 goldenrod1 goldenrod2 goldenrod3 goldenrod4 \
|
||||
DarkGoldenrod1 DarkGoldenrod2 DarkGoldenrod3 DarkGoldenrod4 \
|
||||
RosyBrown1 RosyBrown2 RosyBrown3 RosyBrown4 IndianRed1 \
|
||||
IndianRed2 IndianRed3 IndianRed4 sienna1 sienna2 sienna3 \
|
||||
sienna4 burlywood1 burlywood2 burlywood3 burlywood4 wheat1 \
|
||||
wheat2 wheat3 wheat4 tan1 tan2 tan3 tan4 chocolate1 \
|
||||
chocolate2 chocolate3 chocolate4 firebrick1 firebrick2 \
|
||||
firebrick3 firebrick4 brown1 brown2 brown3 brown4 salmon1 \
|
||||
salmon2 salmon3 salmon4 LightSalmon1 LightSalmon2 \
|
||||
LightSalmon3 LightSalmon4 orange1 orange2 orange3 orange4 \
|
||||
DarkOrange1 DarkOrange2 DarkOrange3 DarkOrange4 coral1 \
|
||||
coral2 coral3 coral4 tomato1 tomato2 tomato3 tomato4 \
|
||||
OrangeRed1 OrangeRed2 OrangeRed3 OrangeRed4 red1 red2 red3 \
|
||||
red4 DeepPink1 DeepPink2 DeepPink3 DeepPink4 HotPink1 \
|
||||
HotPink2 HotPink3 HotPink4 pink1 pink2 pink3 pink4 \
|
||||
LightPink1 LightPink2 LightPink3 LightPink4 PaleVioletRed1 \
|
||||
PaleVioletRed2 PaleVioletRed3 PaleVioletRed4 maroon1 \
|
||||
maroon2 maroon3 maroon4 VioletRed1 VioletRed2 VioletRed3 \
|
||||
VioletRed4 magenta1 magenta2 magenta3 magenta4 orchid1 \
|
||||
orchid2 orchid3 orchid4 plum1 plum2 plum3 plum4 \
|
||||
MediumOrchid1 MediumOrchid2 MediumOrchid3 MediumOrchid4 \
|
||||
DarkOrchid1 DarkOrchid2 DarkOrchid3 DarkOrchid4 purple1 \
|
||||
purple2 purple3 purple4 MediumPurple1 MediumPurple2 \
|
||||
MediumPurple3 MediumPurple4 thistle1 thistle2 thistle3 \
|
||||
thistle4
|
||||
@@ -0,0 +1,61 @@
|
||||
# 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
|
||||
|
||||
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
|
||||
@@ -0,0 +1,172 @@
|
||||
# cscroll.tcl --
|
||||
#
|
||||
# This demonstration script creates a simple canvas that can be
|
||||
# scrolled in two dimensions.
|
||||
|
||||
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
|
||||
wm title $w "Scrollable Canvas Demonstration"
|
||||
wm iconname $w "cscroll"
|
||||
positionWindow $w
|
||||
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
|
||||
|
||||
## 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"
|
||||
scrollbar $w.vscroll -command "$c yview"
|
||||
canvas $c -relief sunken -borderwidth 2 -scrollregion {-11c -11c 50c 20c} \
|
||||
-xscrollcommand "$w.hscroll set" \
|
||||
-yscrollcommand "$w.vscroll set"
|
||||
pack $w.grid -expand yes -fill both -padx 1 -pady 1
|
||||
grid rowconfig $w.grid 0 -weight 1 -minsize 0
|
||||
grid columnconfig $w.grid 0 -weight 1 -minsize 0
|
||||
|
||||
grid $c -padx 1 -in $w.grid -pady 1 \
|
||||
-row 0 -column 0 -rowspan 1 -columnspan 1 -sticky news
|
||||
grid $w.vscroll -in $w.grid -padx 1 -pady 1 \
|
||||
-row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
|
||||
grid $w.hscroll -in $w.grid -padx 1 -pady 1 \
|
||||
-row 1 -column 0 -rowspan 1 -columnspan 1 -sticky news
|
||||
|
||||
|
||||
set bg [lindex [$c config -bg] 4]
|
||||
for {set i 0} {$i < 20} {incr i} {
|
||||
set x [expr {-10 + 3*$i}]
|
||||
for {set j 0; set y -10} {$j < 10} {incr j; incr y 3} {
|
||||
$c create rect ${x}c ${y}c [expr {$x+2}]c [expr {$y+2}]c \
|
||||
-fill $bg -tags rect
|
||||
$c create text [expr {$x+1}]c [expr {$y+1}]c -text "$i,$j" \
|
||||
-anchor center -tags text
|
||||
}
|
||||
}
|
||||
|
||||
$c bind all <Enter> "scrollEnter $c"
|
||||
$c bind all <Leave> "scrollLeave $c"
|
||||
$c bind all <Button-1> "scrollButton $c"
|
||||
if {([tk windowingsystem] eq "aqua") && ![package vsatisfies [package provide Tk] 8.7-]} {
|
||||
bind $c <Button-3> "$c scan mark %x %y"
|
||||
bind $c <B3-Motion> "$c scan dragto %x %y"
|
||||
bind $c <MouseWheel> {
|
||||
%W yview scroll [expr {-%D}] units
|
||||
}
|
||||
bind $c <Option-MouseWheel> {
|
||||
%W yview scroll [expr {-10*%D}] units
|
||||
}
|
||||
bind $c <Shift-MouseWheel> {
|
||||
%W xview scroll [expr {-%D}] units
|
||||
}
|
||||
bind $c <Shift-Option-MouseWheel> {
|
||||
%W xview scroll [expr {-10*%D}] units
|
||||
}
|
||||
} else {
|
||||
bind $c <Button-2> "$c scan mark %x %y"
|
||||
bind $c <B2-Motion> "$c scan dragto %x %y"
|
||||
# We must make sure that positive and negative movements are rounded
|
||||
# equally to integers, avoiding the problem that
|
||||
# (int)1/-30 = -1,
|
||||
# but
|
||||
# (int)-1/-30 = 0
|
||||
# The following code ensure equal +/- behaviour.
|
||||
bind $c <MouseWheel> {
|
||||
if {%D >= 0} {
|
||||
%W yview scroll [expr {%D/-30}] units
|
||||
} else {
|
||||
%W yview scroll [expr {(%D-29)/-30}] units
|
||||
}
|
||||
}
|
||||
bind $c <Option-MouseWheel> {
|
||||
if {%D >= 0} {
|
||||
%W yview scroll [expr {%D/-3}] units
|
||||
} else {
|
||||
%W yview scroll [expr {(%D-2)/-3}] units
|
||||
}
|
||||
}
|
||||
bind $c <Shift-MouseWheel> {
|
||||
if {%D >= 0} {
|
||||
%W xview scroll [expr {%D/-30}] units
|
||||
} else {
|
||||
%W xview scroll [expr {(%D-29)/-30}] units
|
||||
}
|
||||
}
|
||||
bind $c <Shift-Option-MouseWheel> {
|
||||
if {%D >= 0} {
|
||||
%W xview scroll [expr {%D/-3}] units
|
||||
} else {
|
||||
%W xview scroll [expr {(%D-2)/-3}] units
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "x11" && ![package vsatisfies [package provide Tk] 8.7-]} {
|
||||
# Support for mousewheels on Linux/Unix commonly comes through mapping
|
||||
# the wheel to the extended buttons. If you have a mousewheel, find
|
||||
# Linux configuration info at:
|
||||
# https://linuxreviews.org/HOWTO_change_the_mouse_speed_in_X
|
||||
bind $c <Button-4> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W yview scroll -5 units
|
||||
}
|
||||
}
|
||||
bind $c <Shift-Button-4> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W xview scroll -5 units
|
||||
}
|
||||
}
|
||||
bind $c <Button-5> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W yview scroll 5 units
|
||||
}
|
||||
}
|
||||
bind $c <Shift-Button-5> {
|
||||
if {!$tk_strictMotif} {
|
||||
%W xview scroll 5 units
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
proc scrollEnter canvas {
|
||||
global oldFill
|
||||
set id [$canvas find withtag current]
|
||||
if {[lsearch [$canvas gettags current] text] >= 0} {
|
||||
set id [expr {$id-1}]
|
||||
}
|
||||
set oldFill [lindex [$canvas itemconfig $id -fill] 4]
|
||||
if {[winfo depth $canvas] > 1} {
|
||||
if {[tk windowingsystem] eq "aqua"} {
|
||||
$canvas itemconfigure $id -fill systemSelectedTextBackgroundColor
|
||||
} else {
|
||||
$canvas itemconfigure $id -fill LightSeaGreen
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc scrollLeave canvas {
|
||||
global oldFill
|
||||
set id [$canvas find withtag current]
|
||||
if {[lsearch [$canvas gettags current] text] >= 0} {
|
||||
set id [expr {$id-1}]
|
||||
}
|
||||
$canvas itemconfigure $id -fill $oldFill
|
||||
}
|
||||
|
||||
proc scrollButton canvas {
|
||||
set id [$canvas find withtag current]
|
||||
if {[lsearch [$canvas gettags current] text] < 0} {
|
||||
set id [expr {$id+1}]
|
||||
}
|
||||
puts stdout "You buttoned at [lindex [$canvas itemconf $id -text] 4]"
|
||||
}
|
||||
@@ -0,0 +1,176 @@
|
||||
# ctext.tcl --
|
||||
#
|
||||
# This demonstration script creates a canvas widget with a text
|
||||
# item that can be edited and reconfigured in various ways.
|
||||
|
||||
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
|
||||
wm title $w "Canvas Text Demonstration"
|
||||
wm iconname $w "Text"
|
||||
positionWindow $w
|
||||
set c $w.c
|
||||
|
||||
label $w.msg -font $font -wraplength 5i -justify left -text "This window displays a string of text to demonstrate the text facilities of canvas widgets. You can click in the boxes to adjust the position of the text relative to its positioning point or change its justification, and on a pie slice to change its angle. The text also supports the following simple bindings for editing:
|
||||
1. You can point, click, and type.
|
||||
2. You can also select with button 1.
|
||||
3. You can copy the selection to the mouse position with button 2.
|
||||
4. Backspace and Control+h delete the selection if there is one;
|
||||
otherwise they delete the character just before the insertion cursor.
|
||||
5. Delete deletes the selection if there is one; otherwise it deletes
|
||||
the character just after the insertion cursor."
|
||||
pack $w.msg -side top
|
||||
|
||||
## 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
|
||||
|
||||
set textFont {Helvetica 24}
|
||||
|
||||
$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 defined to support editing (see above)." -width 440 -anchor n -font $textFont -justify left]
|
||||
$c bind text <Button-1> "textB1Press $c %x %y"
|
||||
$c bind text <B1-Motion> "textB1Move $c %x %y"
|
||||
$c bind text <Shift-Button-1> "$c select adjust current @%x,%y"
|
||||
$c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
|
||||
$c bind text <Key> "textInsert $c %A"
|
||||
$c bind text <Return> "textInsert $c \\n"
|
||||
$c bind text <Control-h> "textBs $c"
|
||||
$c bind text <BackSpace> "textBs $c"
|
||||
$c bind text <Delete> "textDel $c"
|
||||
if {[tk windowingsystem] eq "aqua" && ![package vsatisfies [package provide Tk] 8.7-]} {
|
||||
$c bind text <Button-3> "textPaste $c @%x,%y"
|
||||
} else {
|
||||
$c bind text <Button-2> "textPaste $c @%x,%y"
|
||||
}
|
||||
|
||||
# Next, create some items that allow the text's anchor position
|
||||
# to be edited.
|
||||
|
||||
proc mkTextConfigBox {w x y option value color} {
|
||||
set item [$w create rect $x $y [expr {$x+30}] [expr {$y+30}] \
|
||||
-outline black -fill $color -width 1]
|
||||
$w bind $item <Button-1> "$w itemconf text $option $value"
|
||||
$w addtag config withtag $item
|
||||
}
|
||||
proc mkTextConfigPie {w x y a option value color} {
|
||||
set item [$w create arc $x $y [expr {$x+90}] [expr {$y+90}] \
|
||||
-start [expr {$a-15}] -extent 30 -outline black -fill $color \
|
||||
-width 1]
|
||||
$w bind $item <Button-1> "$w itemconf text $option $value"
|
||||
$w addtag config withtag $item
|
||||
}
|
||||
|
||||
set x 50
|
||||
set y 50
|
||||
set color LightSkyBlue1
|
||||
mkTextConfigBox $c $x $y -anchor se $color
|
||||
mkTextConfigBox $c [expr {$x+30}] [expr {$y }] -anchor s $color
|
||||
mkTextConfigBox $c [expr {$x+60}] [expr {$y }] -anchor sw $color
|
||||
mkTextConfigBox $c [expr {$x }] [expr {$y+30}] -anchor e $color
|
||||
mkTextConfigBox $c [expr {$x+30}] [expr {$y+30}] -anchor center $color
|
||||
mkTextConfigBox $c [expr {$x+60}] [expr {$y+30}] -anchor w $color
|
||||
mkTextConfigBox $c [expr {$x }] [expr {$y+60}] -anchor ne $color
|
||||
mkTextConfigBox $c [expr {$x+30}] [expr {$y+60}] -anchor n $color
|
||||
mkTextConfigBox $c [expr {$x+60}] [expr {$y+60}] -anchor nw $color
|
||||
set item [$c create rect \
|
||||
[expr {$x+40}] [expr {$y+40}] [expr {$x+50}] [expr {$y+50}] \
|
||||
-outline black -fill red]
|
||||
$c bind $item <Button-1> "$c itemconf text -anchor center"
|
||||
$c create text [expr {$x+45}] [expr {$y-5}] \
|
||||
-text {Text Position} -anchor s -font {Times 20} -fill brown
|
||||
|
||||
# Now create some items that allow the text's angle to be changed.
|
||||
|
||||
set x 205
|
||||
set y 50
|
||||
set color Yellow
|
||||
mkTextConfigPie $c $x $y 0 -angle 90 $color
|
||||
mkTextConfigPie $c $x $y 30 -angle 120 $color
|
||||
mkTextConfigPie $c $x $y 60 -angle 150 $color
|
||||
mkTextConfigPie $c $x $y 90 -angle 180 $color
|
||||
mkTextConfigPie $c $x $y 120 -angle 210 $color
|
||||
mkTextConfigPie $c $x $y 150 -angle 240 $color
|
||||
mkTextConfigPie $c $x $y 180 -angle 270 $color
|
||||
mkTextConfigPie $c $x $y 210 -angle 300 $color
|
||||
mkTextConfigPie $c $x $y 240 -angle 330 $color
|
||||
mkTextConfigPie $c $x $y 270 -angle 0 $color
|
||||
mkTextConfigPie $c $x $y 300 -angle 30 $color
|
||||
mkTextConfigPie $c $x $y 330 -angle 60 $color
|
||||
$c create text [expr {$x+45}] [expr {$y-5}] \
|
||||
-text {Text Angle} -anchor s -font {Times 20} -fill brown
|
||||
|
||||
# Lastly, create some items that allow the text's justification to be
|
||||
# changed.
|
||||
|
||||
set x 350
|
||||
set y 50
|
||||
set color SeaGreen2
|
||||
mkTextConfigBox $c $x $y -justify left $color
|
||||
mkTextConfigBox $c [expr {$x+30}] $y -justify center $color
|
||||
mkTextConfigBox $c [expr {$x+60}] $y -justify right $color
|
||||
$c create text [expr {$x+45}] [expr {$y-5}] \
|
||||
-text {Justification} -anchor s -font {Times 20} -fill brown
|
||||
|
||||
$c bind config <Enter> "textEnter $c"
|
||||
$c bind config <Leave> "$c itemconf current -fill \$textConfigFill"
|
||||
|
||||
set textConfigFill {}
|
||||
|
||||
proc textEnter {w} {
|
||||
global textConfigFill
|
||||
set textConfigFill [lindex [$w itemconfig current -fill] 4]
|
||||
$w itemconfig current -fill black
|
||||
}
|
||||
|
||||
proc textInsert {w string} {
|
||||
if {$string == ""} {
|
||||
return
|
||||
}
|
||||
catch {$w dchars text sel.first sel.last}
|
||||
$w insert text insert $string
|
||||
}
|
||||
|
||||
proc textPaste {w pos} {
|
||||
catch {
|
||||
$w insert text $pos [selection get]
|
||||
}
|
||||
}
|
||||
|
||||
proc textB1Press {w x y} {
|
||||
$w icursor current @$x,$y
|
||||
$w focus current
|
||||
focus $w
|
||||
$w select from current @$x,$y
|
||||
}
|
||||
|
||||
proc textB1Move {w x y} {
|
||||
$w select to current @$x,$y
|
||||
}
|
||||
|
||||
proc textBs {w} {
|
||||
if {![catch {$w dchars text sel.first sel.last}]} {
|
||||
return
|
||||
}
|
||||
set char [expr {[$w index text insert] - 1}]
|
||||
if {$char >= 0} {$w dchar text $char}
|
||||
}
|
||||
|
||||
proc textDel {w} {
|
||||
if {![catch {$w dchars text sel.first sel.last}]} {
|
||||
return
|
||||
}
|
||||
$w dchars text insert
|
||||
}
|
||||
@@ -0,0 +1,25 @@
|
||||
# dialog1.tcl --
|
||||
#
|
||||
# This demonstration script creates a dialog box with a local grab.
|
||||
|
||||
interp create child
|
||||
load {} Tk child
|
||||
child eval {
|
||||
wm title . child
|
||||
wm geometry . +700+30
|
||||
pack [text .t -width 30 -height 10]
|
||||
}
|
||||
|
||||
after idle {.dialog1.msg configure -wraplength 4i}
|
||||
set i [tk_dialog .dialog1 "Dialog with local grab" {This is a modal dialog box. It uses Tk's "grab" command to create a "local grab" on the dialog box. The grab prevents any mouse or keyboard events from getting to any other windows in the application until you have answered the dialog by invoking one of the buttons below. However, you can still interact with other applications. For example, you should be able to edit text in the window named "child" which was created by a child interpreter.} \
|
||||
info 0 OK Cancel {Show Code}]
|
||||
|
||||
switch $i {
|
||||
0 {puts "You pressed OK"}
|
||||
1 {puts "You pressed Cancel"}
|
||||
2 {showCode .dialog1}
|
||||
}
|
||||
|
||||
if {[interp exists child]} {
|
||||
interp delete child
|
||||
}
|
||||
@@ -0,0 +1,18 @@
|
||||
# dialog2.tcl --
|
||||
#
|
||||
# This demonstration script creates a dialog box with a global grab.
|
||||
|
||||
after idle {
|
||||
.dialog2.msg configure -wraplength 4i
|
||||
}
|
||||
after 100 {
|
||||
grab -global .dialog2
|
||||
}
|
||||
set i [tk_dialog .dialog2 "Dialog with global grab" {This dialog box uses a global grab. If you are using an X11 window manager you will be prevented from interacting with anything on your display until you invoke one of the buttons below. This is almost always a bad idea; don't use global grabs with X11 unless you're truly desperate. On macOS systems you will not be able to interact with any window belonging to this process, but interaction with other macOS Applications will still be possible.}\
|
||||
warning 0 OK Cancel {Show Code}]
|
||||
|
||||
switch $i {
|
||||
0 {puts "You pressed OK"}
|
||||
1 {puts "You pressed Cancel"}
|
||||
2 {showCode .dialog2}
|
||||
}
|
||||
@@ -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 © %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"
|
||||
@@ -0,0 +1,34 @@
|
||||
# entry1.tcl --
|
||||
#
|
||||
# This demonstration script creates several entry widgets without
|
||||
# scrollbars.
|
||||
|
||||
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
|
||||
wm title $w "Entry Demonstration (no scrollbars)"
|
||||
wm iconname $w "entry1"
|
||||
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 the middle mouse button pressed."
|
||||
pack $w.msg -side top
|
||||
|
||||
## See Code / Dismiss buttons
|
||||
set btns [addSeeDismiss $w.buttons $w]
|
||||
pack $btns -side bottom -fill x
|
||||
|
||||
entry $w.e1
|
||||
entry $w.e2
|
||||
entry $w.e3
|
||||
pack $w.e1 $w.e2 $w.e3 -side top -pady 5 -padx 10 -fill x
|
||||
|
||||
$w.e1 insert 0 "Initial value"
|
||||
$w.e2 insert end "This entry contains a long value, much too long "
|
||||
$w.e2 insert end "to fit in the window at one time, so long in fact "
|
||||
$w.e2 insert end "that you'll have to scan or scroll to see the end."
|
||||
@@ -0,0 +1,46 @@
|
||||
# entry2.tcl --
|
||||
#
|
||||
# This demonstration script is the same as the entry1.tcl script
|
||||
# except that it creates scrollbars for the entries.
|
||||
|
||||
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
|
||||
wm title $w "Entry Demonstration (with scrollbars)"
|
||||
wm iconname $w "entry2"
|
||||
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 the middle mouse button pressed."
|
||||
pack $w.msg -side top
|
||||
|
||||
## 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
|
||||
|
||||
entry $w.frame.e1 -xscrollcommand "$w.frame.s1 set"
|
||||
ttk::scrollbar $w.frame.s1 -orient horiz -command \
|
||||
"$w.frame.e1 xview"
|
||||
frame $w.frame.spacer1 -width 20 -height 10
|
||||
entry $w.frame.e2 -xscrollcommand "$w.frame.s2 set"
|
||||
ttk::scrollbar $w.frame.s2 -orient horiz -command \
|
||||
"$w.frame.e2 xview"
|
||||
frame $w.frame.spacer2 -width 20 -height 10
|
||||
entry $w.frame.e3 -xscrollcommand "$w.frame.s3 set"
|
||||
ttk::scrollbar $w.frame.s3 -orient horiz -command \
|
||||
"$w.frame.e3 xview"
|
||||
pack $w.frame.e1 $w.frame.s1 $w.frame.spacer1 $w.frame.e2 $w.frame.s2 \
|
||||
$w.frame.spacer2 $w.frame.e3 $w.frame.s3 -side top -fill x
|
||||
|
||||
$w.frame.e1 insert 0 "Initial value"
|
||||
$w.frame.e2 insert end "This entry contains a long value, much too long "
|
||||
$w.frame.e2 insert end "to fit in the window at one time, so long in fact "
|
||||
$w.frame.e2 insert end "that you'll have to scan or scroll to see the end."
|
||||
@@ -0,0 +1,185 @@
|
||||
# entry3.tcl --
|
||||
#
|
||||
# This demonstration script creates several entry widgets whose
|
||||
# permitted input is constrained in some way. It also shows off a
|
||||
# password entry.
|
||||
|
||||
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
|
||||
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 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\
|
||||
is made. The third accepts US phone numbers, mapping letters to\
|
||||
their digit equivalent and sounding the bell on encountering an\
|
||||
illegal character or if trying to type over a character that is not\
|
||||
a digit. The fourth is a password field that accepts up to eight\
|
||||
characters (silently ignoring further ones), and displaying them as\
|
||||
asterisk characters."
|
||||
|
||||
## 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
|
||||
# widget and makes the widget flash by exchanging the foreground and
|
||||
# background colours at intervals of 200ms (i.e. at approximately
|
||||
# 2.5Hz).
|
||||
#
|
||||
# Arguments:
|
||||
# W - Name of entry widget to flash
|
||||
# fg - Initial foreground colour
|
||||
# bg - Initial background colour
|
||||
# count - Counter to control the number of times flashed
|
||||
|
||||
proc focusAndFlash {W fg bg {count 9}} {
|
||||
focus -force $W
|
||||
if {$count<1} {
|
||||
$W configure -foreground $fg -background $bg
|
||||
} else {
|
||||
if {$count%2} {
|
||||
$W configure -foreground $bg -background $fg
|
||||
} else {
|
||||
$W configure -foreground $fg -background $bg
|
||||
}
|
||||
after 200 [list focusAndFlash $W $fg $bg [expr {$count-1}]]
|
||||
}
|
||||
}
|
||||
|
||||
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]"
|
||||
pack $w.l1.e -fill x -expand 1 -padx 1m -pady 1m
|
||||
|
||||
labelframe $w.l2 -text "Length-Constrained Entry"
|
||||
entry $w.l2.e -validate key -invcmd bell -vcmd {expr {[string length %P]<10}}
|
||||
pack $w.l2.e -fill x -expand 1 -padx 1m -pady 1m
|
||||
|
||||
### PHONE NUMBER ENTRY ###
|
||||
# Note that the source to this is quite a bit longer as the behaviour
|
||||
# demonstrated is a lot more ambitious than with the others.
|
||||
|
||||
# Initial content for the third entry widget
|
||||
set entry3content "1-(000)-000-0000"
|
||||
# Mapping from alphabetic characters to numbers. This is probably
|
||||
# wrong, but it is the only mapping I have; the UK doesn't really go
|
||||
# for associating letters with digits for some reason.
|
||||
set phoneNumberMap {}
|
||||
foreach {chars digit} {abc 2 def 3 ghi 4 jkl 5 mno 6 pqrs 7 tuv 8 wxyz 9} {
|
||||
foreach char [split $chars ""] {
|
||||
lappend phoneNumberMap $char $digit [string toupper $char] $digit
|
||||
}
|
||||
}
|
||||
|
||||
# validatePhoneChange --
|
||||
# Checks that the replacement (mapped to a digit) of the given
|
||||
# character in an entry widget at the given position will leave a
|
||||
# valid phone number in the widget.
|
||||
#
|
||||
# W - The entry widget to validate
|
||||
# vmode - The widget's validation mode
|
||||
# idx - The index where replacement is to occur
|
||||
# char - The character (or string, though that will always be
|
||||
# refused) to be overwritten at that point.
|
||||
|
||||
proc validatePhoneChange {W vmode idx char} {
|
||||
global phoneNumberMap entry3content
|
||||
if {$idx < 0} {return 1}
|
||||
after idle [list $W configure -validate $vmode -invcmd bell]
|
||||
if {
|
||||
!($idx<3 || $idx==6 || $idx==7 || $idx==11 || $idx>15) &&
|
||||
[string match {[0-9A-Za-z]} $char]
|
||||
} then {
|
||||
$W delete $idx
|
||||
$W insert $idx [string map $phoneNumberMap $char]
|
||||
after idle [list phoneSkipRight $W -1]
|
||||
return 1
|
||||
}
|
||||
return 0
|
||||
}
|
||||
|
||||
# phoneSkipLeft --
|
||||
# Skip over fixed characters in a phone-number string when moving left.
|
||||
#
|
||||
# Arguments:
|
||||
# W - The entry widget containing the phone-number.
|
||||
|
||||
proc phoneSkipLeft {W} {
|
||||
set idx [$W index insert]
|
||||
if {$idx == 8} {
|
||||
# Skip back two extra characters
|
||||
$W icursor [incr idx -2]
|
||||
} elseif {$idx == 7 || $idx == 12} {
|
||||
# Skip back one extra character
|
||||
$W icursor [incr idx -1]
|
||||
} elseif {$idx <= 3} {
|
||||
# Can't move any further
|
||||
bell
|
||||
return -code break
|
||||
}
|
||||
}
|
||||
|
||||
# phoneSkipRight --
|
||||
# Skip over fixed characters in a phone-number string when moving right.
|
||||
#
|
||||
# Arguments:
|
||||
# W - The entry widget containing the phone-number.
|
||||
# add - Offset to add to index before calculation (used by validation.)
|
||||
|
||||
proc phoneSkipRight {W {add 0}} {
|
||||
set idx [$W index insert]
|
||||
if {$idx+$add == 5} {
|
||||
# Skip forward two extra characters
|
||||
$W icursor [incr idx 2]
|
||||
} elseif {$idx+$add == 6 || $idx+$add == 10} {
|
||||
# Skip forward one extra character
|
||||
$W icursor [incr idx]
|
||||
} elseif {$idx+$add == 15 && !$add} {
|
||||
# Can't move any further
|
||||
bell
|
||||
return -code break
|
||||
}
|
||||
}
|
||||
|
||||
labelframe $w.l3 -text "US Phone-Number Entry"
|
||||
entry $w.l3.e -validate key -invcmd bell -textvariable entry3content \
|
||||
-vcmd {validatePhoneChange %W %v %i %S}
|
||||
# Click to focus goes to the first editable character...
|
||||
bind $w.l3.e <FocusIn> {
|
||||
if {"%d" ne "NotifyAncestor"} {
|
||||
%W icursor 3
|
||||
after idle {%W selection clear}
|
||||
}
|
||||
}
|
||||
bind $w.l3.e <<PrevChar>> {phoneSkipLeft %W}
|
||||
bind $w.l3.e <<NextChar>> {phoneSkipRight %W}
|
||||
pack $w.l3.e -fill x -expand 1 -padx 1m -pady 1m
|
||||
|
||||
labelframe $w.l4 -text "Password Entry"
|
||||
entry $w.l4.e -validate key -show "*" -vcmd {expr {[string length %P]<=8}}
|
||||
pack $w.l4.e -fill x -expand 1 -padx 1m -pady 1m
|
||||
|
||||
lower [frame $w.mid]
|
||||
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.mid -fill both -expand 1
|
||||
@@ -0,0 +1,81 @@
|
||||
# filebox.tcl --
|
||||
#
|
||||
# This demonstration script prompts the user to select a file.
|
||||
|
||||
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
|
||||
wm title $w "File Selection Dialogs"
|
||||
wm iconname $w "filebox"
|
||||
positionWindow $w
|
||||
|
||||
ttk::frame $w._bg
|
||||
place $w._bg -x 0 -y 0 -relwidth 1 -relheight 1
|
||||
|
||||
ttk::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
|
||||
|
||||
## See Code / Dismiss buttons
|
||||
set btns [addSeeDismiss $w.buttons $w]
|
||||
pack $btns -side bottom -fill x
|
||||
|
||||
foreach i {open save} {
|
||||
set f [ttk::frame $w.$i]
|
||||
ttk::label $f.lab -text "Select a file to $i: " -anchor e
|
||||
ttk::entry $f.ent -width 20
|
||||
ttk::button $f.but -text "Browse ..." -command "fileDialog $w $f.ent $i"
|
||||
pack $f.lab -side left
|
||||
pack $f.ent -side left -expand yes -fill x
|
||||
pack $f.but -side left
|
||||
pack $f -fill x -padx 1c -pady 3
|
||||
}
|
||||
|
||||
if {[tk windowingsystem] eq "x11"} {
|
||||
ttk::checkbutton $w.strict -text "Use Motif Style Dialog" \
|
||||
-variable tk_strictMotif -onvalue 1 -offvalue 0
|
||||
pack $w.strict -anchor c
|
||||
|
||||
# This binding ensures that we don't run the rest of the demos
|
||||
# with motif style interactions
|
||||
bind $w.strict <Destroy> {set tk_strictMotif 0}
|
||||
}
|
||||
|
||||
proc fileDialog {w ent operation} {
|
||||
# Type names Extension(s) Mac File Type(s)
|
||||
#
|
||||
#---------------------------------------------------------
|
||||
set types {
|
||||
{"Text files" {.txt .doc} }
|
||||
{"Text files" {} TEXT}
|
||||
{"Tcl Scripts" {.tcl} TEXT}
|
||||
{"C Source Files" {.c .h} }
|
||||
{"All Source Files" {.tcl .c .h} }
|
||||
{"Image Files" {.gif} }
|
||||
{"Image Files" {.jpeg .jpg} }
|
||||
{"Image Files" "" {GIFF JPEG}}
|
||||
{"All files" *}
|
||||
}
|
||||
if {$operation == "open"} {
|
||||
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]
|
||||
}
|
||||
if {[string compare $file ""]} {
|
||||
$ent delete 0 end
|
||||
$ent insert 0 $file
|
||||
$ent xview end
|
||||
}
|
||||
}
|
||||
File diff suppressed because it is too large.
Load diff
@@ -0,0 +1,67 @@
|
||||
# fontchoose.tcl --
|
||||
#
|
||||
# Show off the stock font selector dialog
|
||||
|
||||
if {![info exists widgetDemo]} {
|
||||
error "This script should be run from the \"widget\" demo."
|
||||
}
|
||||
|
||||
package require Tk
|
||||
|
||||
set w .fontchoose
|
||||
catch {destroy $w}
|
||||
toplevel $w
|
||||
wm title $w "Font Selection Dialog"
|
||||
wm iconname $w "fontchooser"
|
||||
positionWindow $w
|
||||
|
||||
catch {font create FontchooseDemoFont {*}[font actual TkDefaultFont]}
|
||||
|
||||
# The font chooser needs to be configured and then shown.
|
||||
proc SelectFont {parent} {
|
||||
tk fontchooser configure -font FontchooseDemoFont \
|
||||
-command ApplyFont -parent $parent
|
||||
tk fontchooser show
|
||||
}
|
||||
|
||||
proc ApplyFont {font} {
|
||||
font configure FontchooseDemoFont {*}[font actual $font]
|
||||
}
|
||||
|
||||
# When the visibility of the fontchooser changes, the following event is fired
|
||||
# to the parent widget.
|
||||
#
|
||||
bind $w <<TkFontchooserVisibility>> {
|
||||
if {[tk fontchooser configure -visible]} {
|
||||
%W.f.font state disabled
|
||||
} else {
|
||||
%W.f.font state !disabled
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
set f [ttk::frame $w.f -relief sunken -padding 2]
|
||||
|
||||
text $f.msg -font FontchooseDemoFont -width 40 -height 6 -borderwidth 0 \
|
||||
-yscrollcommand [list $f.vs set]
|
||||
ttk::scrollbar $f.vs -command [list $f.msg yview]
|
||||
|
||||
$f.msg insert end "Press the buttons below to choose a new font for the\
|
||||
text shown in this window.\n" {}
|
||||
|
||||
ttk::button $f.font -text "Set font ..." -command [list SelectFont $w]
|
||||
|
||||
grid $f.msg $f.vs -sticky news
|
||||
grid $f.font - -sticky e
|
||||
grid columnconfigure $f 0 -weight 1
|
||||
grid rowconfigure $f 0 -weight 1
|
||||
|
||||
## See Code / Dismiss buttons
|
||||
set btns [addSeeDismiss $w.buttons $w]
|
||||
|
||||
grid $f -sticky news
|
||||
grid $btns -sticky ew
|
||||
grid columnconfigure $w 0 -weight 1
|
||||
grid rowconfigure $w 0 -weight 1
|
||||
update idletasks
|
||||
grid propagate $f 0
|
||||
@@ -0,0 +1,38 @@
|
||||
# form.tcl --
|
||||
#
|
||||
# This demonstration script creates a simple form with a bunch
|
||||
# of entry widgets.
|
||||
|
||||
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
|
||||
wm title $w "Form Demonstration"
|
||||
wm iconname $w "form"
|
||||
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
|
||||
|
||||
## 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
|
||||
entry $w.$i.entry -relief sunken -width 40
|
||||
label $w.$i.label
|
||||
pack $w.$i.entry -side right
|
||||
pack $w.$i.label -side left
|
||||
}
|
||||
$w.f1.label config -text Name:
|
||||
$w.f2.label config -text Address:
|
||||
$w.f5.label config -text Phone:
|
||||
pack $w.msg $w.f1 $w.f2 $w.f3 $w.f4 $w.f5 -side top -fill x
|
||||
bind $w <Return> "destroy $w"
|
||||
focus $w.f1.entry
|
||||
File diff suppressed because it is too large.
Load diff
@@ -0,0 +1,22 @@
|
||||
#!/bin/sh
|
||||
# the next line restarts using wish \
|
||||
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.
|
||||
|
||||
button .hello -text "Hello, world" -command {
|
||||
puts stdout "Hello, world"; destroy .
|
||||
}
|
||||
pack .hello
|
||||
|
||||
# Local Variables:
|
||||
# mode: tcl
|
||||
# End:
|
||||
@@ -0,0 +1,45 @@
|
||||
# hscale.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 .hscale
|
||||
catch {destroy $w}
|
||||
toplevel $w
|
||||
wm title $w "Horizontal Scale Demonstration"
|
||||
wm iconname $w "hscale"
|
||||
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
|
||||
|
||||
## 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
|
||||
|
||||
canvas $w.frame.canvas -width 50 -height 50 -bd 0 -highlightthickness 0
|
||||
$w.frame.canvas create polygon 0 0 1 1 2 2 -fill DeepSkyBlue3 -tags poly
|
||||
$w.frame.canvas create line 0 0 1 1 2 2 0 0 -fill black -tags line
|
||||
scale $w.frame.scale -orient horizontal -length 284 -from 0 -to 250 \
|
||||
-command "setWidth $w.frame.canvas" -tickinterval 50
|
||||
pack $w.frame.canvas -side top -expand yes -anchor s -fill x -padx 15
|
||||
pack $w.frame.scale -side bottom -expand yes -anchor n
|
||||
$w.frame.scale set 75
|
||||
|
||||
proc setWidth {w width} {
|
||||
incr width 21
|
||||
set x2 [expr {$width - 30}]
|
||||
if {$x2 < 21} {
|
||||
set x2 21
|
||||
}
|
||||
$w coords poly 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15
|
||||
$w coords line 20 15 20 35 $x2 35 $x2 45 $width 25 $x2 5 $x2 15 20 15
|
||||
}
|
||||
@@ -0,0 +1,51 @@
|
||||
# icon.tcl --
|
||||
#
|
||||
# This demonstration script creates a toplevel window containing
|
||||
# buttons that display bitmaps instead of text.
|
||||
|
||||
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
|
||||
wm title $w "Iconic Button Demonstration"
|
||||
wm iconname $w "icon"
|
||||
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
|
||||
|
||||
## 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_demoDirectory images flagup.xbm] \
|
||||
-maskfile [file join $tk_demoDirectory images flagup.xbm]
|
||||
image create bitmap flagdown \
|
||||
-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
|
||||
|
||||
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_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_demoDirectory images letters.xbm] \
|
||||
-variable letters -value full
|
||||
radiobutton $w.frame.left.b4 \
|
||||
-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
|
||||
@@ -0,0 +1,35 @@
|
||||
# image1.tcl --
|
||||
#
|
||||
# This demonstration script displays two image widgets.
|
||||
|
||||
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
|
||||
wm title $w "Image Demonstration #1"
|
||||
wm iconname $w "Image1"
|
||||
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
|
||||
|
||||
## 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_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_demoDirectory images earthris.gif]
|
||||
label $w.l2 -image image1b -bd 1 -relief sunken
|
||||
|
||||
pack $w.l1 $w.l2 -side top -padx .5m -pady .5m
|
||||
@@ -0,0 +1,108 @@
|
||||
# image2.tcl --
|
||||
#
|
||||
# This demonstration script creates a simple collection of widgets
|
||||
# that allow you to select and view images in a Tk label.
|
||||
|
||||
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.
|
||||
#
|
||||
# Arguments:
|
||||
# w - Name of the toplevel window of the demo.
|
||||
|
||||
proc loadDir w {
|
||||
global dirName
|
||||
|
||||
$w.f.list delete 0 end
|
||||
foreach i [lsort [glob -type f -directory $dirName *]] {
|
||||
$w.f.list insert end [file tail $i]
|
||||
}
|
||||
}
|
||||
|
||||
# selectAndLoadDir --
|
||||
# This procedure pops up a dialog to ask for a directory to load into
|
||||
# the listobx and (if the user presses OK) reloads the directory
|
||||
# listbox from the directory named in the demo's entry.
|
||||
#
|
||||
# Arguments:
|
||||
# w - Name of the toplevel window of the demo.
|
||||
|
||||
proc selectAndLoadDir w {
|
||||
global dirName
|
||||
set dir [tk_chooseDirectory -initialdir $dirName -parent $w -mustexist 1]
|
||||
if {$dir ne ""} {
|
||||
set dirName $dir
|
||||
loadDir $w
|
||||
}
|
||||
}
|
||||
|
||||
# loadImage --
|
||||
# Given the name of the toplevel window of the demo and the mouse
|
||||
# position, extracts the directory entry under the mouse and loads
|
||||
# that file into a photo image for display.
|
||||
#
|
||||
# Arguments:
|
||||
# w - Name of the toplevel window of the demo.
|
||||
# x, y- Mouse position within the listbox.
|
||||
|
||||
proc loadImage {w x y} {
|
||||
global dirName
|
||||
|
||||
set file [file join $dirName [$w.f.list get @$x,$y]]
|
||||
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
|
||||
catch {destroy $w}
|
||||
toplevel $w
|
||||
wm title $w "Image Demonstration #2"
|
||||
wm iconname $w "Image2"
|
||||
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
|
||||
|
||||
## 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:"
|
||||
# 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"
|
||||
bind $w.dir.e <Return> "loadDir $w"
|
||||
pack $w.dir.e -side left -fill both -padx 2m -pady 2m -expand true
|
||||
pack $w.dir.b -side left -fill y -padx {0 2m} -pady 2m
|
||||
labelframe $w.f -text "File:" -padx 2m -pady 2m
|
||||
|
||||
listbox $w.f.list -width 20 -height 10 -yscrollcommand "$w.f.scroll set"
|
||||
ttk::scrollbar $w.f.scroll -command "$w.f.list yview"
|
||||
pack $w.f.list $w.f.scroll -side left -fill y -expand 1
|
||||
$w.f.list insert 0 earth.gif earthris.gif teapot.ppm
|
||||
bind $w.f.list <Double-Button-1> "loadImage $w %x %y"
|
||||
|
||||
catch {image delete image2a}
|
||||
image create photo image2a
|
||||
labelframe $w.image -text "Image:"
|
||||
label $w.image.image -image image2a
|
||||
pack $w.image.image -padx 2m -pady 2m
|
||||
|
||||
grid $w.dir - -sticky ew -padx 1m -pady 1m -in $w.mid
|
||||
grid $w.f $w.image -sticky nw -padx 1m -pady 1m -in $w.mid
|
||||
grid columnconfigure $w.mid 1 -weight 1
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 51 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 8.0 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 6.2 KiB |
@@ -0,0 +1,27 @@
|
||||
#define flagdown_width 48
|
||||
#define flagdown_height 48
|
||||
static char flagdown_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x1e, 0x00, 0x00,
|
||||
0x00, 0x00, 0x80, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xe0, 0xe1, 0x00, 0x00,
|
||||
0x00, 0x00, 0x70, 0x80, 0x01, 0x00, 0x00, 0x00, 0x18, 0x00, 0x03, 0x00,
|
||||
0x00, 0x00, 0x0c, 0x00, 0x03, 0x00, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04,
|
||||
0x00, 0x00, 0x03, 0x00, 0x06, 0x06, 0x00, 0x80, 0x01, 0x00, 0x06, 0x07,
|
||||
0x00, 0xc0, 0x1f, 0x00, 0x87, 0x07, 0x00, 0xe0, 0x7f, 0x80, 0xc7, 0x07,
|
||||
0x00, 0x70, 0xe0, 0xc0, 0xe5, 0x07, 0x00, 0x38, 0x80, 0xe1, 0x74, 0x07,
|
||||
0x00, 0x18, 0x80, 0x71, 0x3c, 0x07, 0x00, 0x0c, 0x00, 0x3b, 0x1e, 0x03,
|
||||
0x00, 0x0c, 0x00, 0x1f, 0x0f, 0x00, 0x00, 0x86, 0x1f, 0x8e, 0x07, 0x00,
|
||||
0x00, 0x06, 0x06, 0xc6, 0x05, 0x00, 0x00, 0x06, 0x00, 0xc6, 0x05, 0x00,
|
||||
0x00, 0x06, 0x00, 0xc6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
|
||||
0x7f, 0x06, 0x00, 0x06, 0xe4, 0xff, 0x00, 0x06, 0x00, 0x06, 0x04, 0x00,
|
||||
0x00, 0x06, 0x00, 0x06, 0x04, 0x00, 0x00, 0x06, 0x00, 0x06, 0x06, 0x00,
|
||||
0x00, 0x06, 0x00, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
|
||||
0x00, 0x06, 0x00, 0xc6, 0x00, 0x00, 0x00, 0x06, 0x00, 0x66, 0x00, 0x00,
|
||||
0x00, 0x06, 0x00, 0x36, 0x00, 0x00, 0x00, 0x06, 0x00, 0x3e, 0x00, 0x00,
|
||||
0x00, 0xfe, 0xff, 0x2f, 0x00, 0x00, 0x00, 0xfc, 0xff, 0x27, 0x00, 0x00,
|
||||
0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
|
||||
0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
|
||||
0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
|
||||
0x00, 0x00, 0x88, 0x20, 0x00, 0x00, 0x00, 0x00, 0x88, 0x20, 0x00, 0x00,
|
||||
0xf7, 0xbf, 0x8e, 0xfc, 0xdf, 0xf8, 0x9d, 0xeb, 0x9b, 0x76, 0xd2, 0x7a,
|
||||
0x46, 0x30, 0xe2, 0x0f, 0xe1, 0x47, 0x55, 0x84, 0x48, 0x11, 0x84, 0x19};
|
||||
@@ -0,0 +1,27 @@
|
||||
#define flagup_width 48
|
||||
#define flagup_height 48
|
||||
static char flagup_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00,
|
||||
0x00, 0x00, 0x00, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x00, 0xef, 0x6a, 0x00,
|
||||
0x00, 0x00, 0xc0, 0x7b, 0x75, 0x00, 0x00, 0x00, 0xe0, 0xe0, 0x6a, 0x00,
|
||||
0x00, 0x00, 0x30, 0x60, 0x75, 0x00, 0x00, 0x00, 0x18, 0xe0, 0x7f, 0x00,
|
||||
0x00, 0x00, 0x0c, 0xe0, 0x7f, 0x00, 0x00, 0x00, 0x06, 0xe0, 0x04, 0x00,
|
||||
0x00, 0x00, 0x03, 0xe0, 0x04, 0x00, 0x00, 0x80, 0x01, 0xe0, 0x06, 0x00,
|
||||
0x00, 0xc0, 0x1f, 0xe0, 0x07, 0x00, 0x00, 0xe0, 0x7f, 0xe0, 0x07, 0x00,
|
||||
0x00, 0x70, 0xe0, 0xe0, 0x05, 0x00, 0x00, 0x38, 0x80, 0xe1, 0x04, 0x00,
|
||||
0x00, 0x18, 0x80, 0xf1, 0x04, 0x00, 0x00, 0x0c, 0x00, 0xfb, 0x04, 0x00,
|
||||
0x00, 0x0c, 0x00, 0xff, 0x04, 0x00, 0x00, 0x86, 0x1f, 0xee, 0x04, 0x00,
|
||||
0x00, 0x06, 0x06, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0xe6, 0x04, 0x00,
|
||||
0x00, 0x06, 0x00, 0xe6, 0x04, 0x00, 0x00, 0x06, 0x00, 0x66, 0x04, 0x00,
|
||||
0x7f, 0x56, 0x52, 0x06, 0xe4, 0xff, 0x00, 0x76, 0x55, 0x06, 0x04, 0x00,
|
||||
0x00, 0x56, 0x57, 0x06, 0x04, 0x00, 0x00, 0x56, 0x55, 0x06, 0x06, 0x00,
|
||||
0x00, 0x56, 0xd5, 0x06, 0x03, 0x00, 0x00, 0x06, 0x00, 0x86, 0x01, 0x00,
|
||||
0x54, 0x06, 0x00, 0xc6, 0x54, 0x55, 0xaa, 0x06, 0x00, 0x66, 0xaa, 0x2a,
|
||||
0x54, 0x06, 0x00, 0x36, 0x55, 0x55, 0xaa, 0x06, 0x00, 0xbe, 0xaa, 0x2a,
|
||||
0x54, 0xfe, 0xff, 0x6f, 0x55, 0x55, 0xaa, 0xfc, 0xff, 0xa7, 0xaa, 0x2a,
|
||||
0x54, 0x01, 0x88, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
|
||||
0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
|
||||
0x54, 0x55, 0x8d, 0x60, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa0, 0xaa, 0x2a,
|
||||
0x54, 0x55, 0x8d, 0x50, 0x55, 0x55, 0xaa, 0xaa, 0x8a, 0xa8, 0xaa, 0x2a,
|
||||
0x54, 0x55, 0x95, 0x54, 0x55, 0x55, 0xaa, 0xaa, 0xaa, 0xaa, 0xaa, 0x2a,
|
||||
0x54, 0x55, 0x55, 0x55, 0x55, 0x15, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
|
||||
@@ -0,0 +1,6 @@
|
||||
#define grey_width 16
|
||||
#define grey_height 16
|
||||
static char grey_bits[] = {
|
||||
0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44,
|
||||
0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44,
|
||||
0x11, 0x11, 0x44, 0x44, 0x11, 0x11, 0x44, 0x44};
|
||||
@@ -0,0 +1,27 @@
|
||||
#define letters_width 48
|
||||
#define letters_height 48
|
||||
static char letters_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0xfe, 0xff, 0xff, 0xff, 0x3f, 0x00, 0x02, 0x00, 0x00, 0x00, 0x20,
|
||||
0x00, 0xfa, 0x00, 0x00, 0x00, 0x2e, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2a,
|
||||
0x00, 0x3a, 0x00, 0x00, 0x00, 0x2a, 0x00, 0x02, 0x00, 0x00, 0x00, 0x2e,
|
||||
0xe0, 0xff, 0xff, 0xff, 0xff, 0x21, 0x20, 0x00, 0x00, 0x00, 0x00, 0x21,
|
||||
0xa0, 0x03, 0x00, 0x00, 0x70, 0x21, 0x20, 0x00, 0x00, 0x00, 0x50, 0x21,
|
||||
0xa0, 0x1f, 0x00, 0x00, 0x50, 0x21, 0x20, 0x00, 0x00, 0x00, 0x70, 0x21,
|
||||
0xfe, 0xff, 0xff, 0xff, 0x0f, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21,
|
||||
0xfa, 0x01, 0x00, 0x80, 0x0b, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0a, 0x21,
|
||||
0xba, 0x01, 0x00, 0x80, 0x0a, 0x21, 0x02, 0x00, 0x00, 0x80, 0x0b, 0x21,
|
||||
0x3a, 0x00, 0x00, 0x00, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x21,
|
||||
0x02, 0xc0, 0xfb, 0x03, 0x08, 0x21, 0x02, 0x00, 0x00, 0x00, 0x08, 0x3f,
|
||||
0x02, 0xc0, 0xbd, 0x0f, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01,
|
||||
0x02, 0xc0, 0x7f, 0x7b, 0x08, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x01,
|
||||
0x02, 0x00, 0x00, 0x00, 0xf8, 0x01, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
|
||||
0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
|
||||
0x02, 0x00, 0x00, 0x00, 0x08, 0x00, 0x02, 0x00, 0x00, 0x00, 0x08, 0x00,
|
||||
0xfe, 0xff, 0xff, 0xff, 0x0f, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00};
|
||||
@@ -0,0 +1,27 @@
|
||||
#define noletters_width 48
|
||||
#define noletters_height 48
|
||||
static char noletters_bits[] = {
|
||||
0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00,
|
||||
0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00,
|
||||
0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00,
|
||||
0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01,
|
||||
0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0xc0, 0x03, 0x00, 0x00, 0xe0, 0x07,
|
||||
0xe0, 0x01, 0x00, 0x00, 0xf0, 0x0f, 0xe0, 0x00, 0x00, 0x00, 0x78, 0x0e,
|
||||
0xf0, 0x00, 0x00, 0x00, 0x3c, 0x1e, 0x70, 0x00, 0x00, 0x00, 0x1e, 0x1c,
|
||||
0x38, 0x00, 0x00, 0x00, 0x0f, 0x38, 0x38, 0x00, 0x00, 0x80, 0x07, 0x38,
|
||||
0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x1c, 0x04, 0x00, 0xe0, 0x41, 0x70,
|
||||
0x1c, 0x04, 0x00, 0xf0, 0x40, 0x70, 0x1c, 0x74, 0x00, 0x78, 0x4e, 0x70,
|
||||
0x0e, 0x04, 0x00, 0x3c, 0x4a, 0xe0, 0x0e, 0x74, 0x03, 0x1e, 0x4a, 0xe0,
|
||||
0x0e, 0x04, 0x00, 0x0f, 0x4e, 0xe0, 0x0e, 0x04, 0x80, 0x07, 0x40, 0xe0,
|
||||
0x0e, 0x04, 0xf8, 0x0f, 0x40, 0xe0, 0x0e, 0x04, 0xe0, 0x01, 0x40, 0xe0,
|
||||
0x0e, 0x04, 0xf8, 0x00, 0x40, 0xe0, 0x0e, 0x04, 0x78, 0x00, 0x40, 0xe0,
|
||||
0x0e, 0x04, 0xfc, 0xf3, 0x40, 0xe0, 0x1c, 0x04, 0x1e, 0x00, 0x40, 0x70,
|
||||
0x1c, 0x04, 0x0f, 0x00, 0x40, 0x70, 0x1c, 0x84, 0x07, 0x00, 0x40, 0x70,
|
||||
0x3c, 0xfc, 0xff, 0xff, 0x7f, 0x78, 0x38, 0xe0, 0x01, 0x00, 0x00, 0x38,
|
||||
0x38, 0xf0, 0x00, 0x00, 0x00, 0x38, 0x70, 0x78, 0x00, 0x00, 0x00, 0x1c,
|
||||
0xf0, 0x3c, 0x00, 0x00, 0x00, 0x1e, 0xe0, 0x1e, 0x00, 0x00, 0x00, 0x0e,
|
||||
0xe0, 0x0f, 0x00, 0x00, 0x00, 0x0f, 0xc0, 0x07, 0x00, 0x00, 0x80, 0x07,
|
||||
0x80, 0x07, 0x00, 0x00, 0xc0, 0x03, 0x00, 0x1f, 0x00, 0x00, 0xf0, 0x01,
|
||||
0x00, 0x3e, 0x00, 0x00, 0xf8, 0x00, 0x00, 0xfc, 0x01, 0x00, 0x7f, 0x00,
|
||||
0x00, 0xf0, 0x0f, 0xe0, 0x1f, 0x00, 0x00, 0xc0, 0xff, 0xff, 0x07, 0x00,
|
||||
0x00, 0x00, 0xff, 0xff, 0x01, 0x00, 0x00, 0x00, 0xf0, 0x1f, 0x00, 0x00};
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 53 KiB |
@@ -0,0 +1,6 @@
|
||||
#define foo_width 16
|
||||
#define foo_height 16
|
||||
static char foo_bits[] = {
|
||||
0x60, 0x06, 0x90, 0x09, 0x90, 0x09, 0xb0, 0x0d, 0x4e, 0x72, 0x49, 0x92,
|
||||
0x71, 0x8e, 0x8e, 0x71, 0x8e, 0x71, 0x71, 0x8e, 0x49, 0x92, 0x4e, 0x72,
|
||||
0xb0, 0x0d, 0x90, 0x09, 0x90, 0x09, 0x60, 0x06};
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 2.3 KiB |
@@ -0,0 +1,31 @@
|
||||
P6
|
||||
256 256
|
||||
255
|
||||
\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\Line truncated
|
||||
j5
|
||||
h4
|
||||
g3
|
||||
5$D,K/b; h>"wM1tK.e="a<#cA,U8&E-<(9&.!a0 b1 c1
|
||||
|
||||
+3#@)46G<:HMCIXHK\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\À\ÀU*´vT¿~X¸{YÃk+›W&‰N$|>u:p8k5
|
||||
f3
|
||||
a0 _/ ]. [- �I¡\*ª_(‘LkRMmSMmSMnSMnSMD,R3W5mA"|O0|P1j?"c<!a=%Y7"N1F,;'NCJNCJNDJODJODJODJh>!a: X/K% | ||||