Some neatening up of the widget demo launcher, and a new validated entry demo

3 files changed, 264 insertions, 109 deletions

diff --git a/ChangeLog b/ChangeLog
index 6ebff77..0de2a7e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2001-11-19  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
+
+	* library/demos/entry3.tcl: New demo showing off validation and
+	password entry.
+
+	* library/demos/widget: Some reorganization to make the code
+	simpler, plus a new entry demo.
+
 2001-11-17  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* win/tkWinButton.c (TkpComputeButtonGeometry): corrected the
diff --git a/library/demos/entry3.tcl b/library/demos/entry3.tcl
new file mode 100644
index 0000000..3e88a7a
--- /dev/null
+++ b/library/demos/entry3.tcl
@@ -0,0 +1,187 @@
+# entry2.tcl --
+#
+# This demonstration script creates several entry widgets whose
+# permitted input is constrained in some way.  It also shows off a
+# password entry.
+#
+# RCS: @(#) $Id: entry3.tcl,v 1.1 2001/11/19 14:02:29 dkf Exp $
+
+if {![info exists widgetDemo]} {
+    error "This script should be run from the \"widget\" demo."
+}
+
+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 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."
+
+frame $w.buttons
+button $w.buttons.dismiss -text Dismiss -command "destroy $w"
+button $w.buttons.code -text "See Code" -command "showCode $w"
+pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
+
+
+# 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"
+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 == -1} {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 <Left>  {phoneSkipLeft  %W}
+bind $w.l3.e <Right> {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.buttons -side bottom -fill x -pady 2m
+pack $w.mid -fill both -expand 1
diff --git a/library/demos/widget b/library/demos/widget
index 0dbb6df..349667a 100644
--- a/library/demos/widget
+++ b/library/demos/widget
@@ -11,7 +11,7 @@ exec wish "$0" "$@"
 # ".tcl" files is this directory, which are sourced by this script
 # as needed.
 #
-# RCS: @(#) $Id: widget,v 1.4 2001/10/30 11:21:50 dkf Exp $
+# RCS: @(#) $Id: widget,v 1.5 2001/11/19 14:02:29 dkf Exp $
 
 eval destroy [winfo child .]
 wm title . "Widget Demonstration"
@@ -120,117 +120,76 @@ set lastLine ""
 
 # Create the text for the text widget.
 
+proc addDemoSection {title demos} {
+    .t insert end "\n" {} $title title " \n " demospace
+    set num 0
+    foreach {name description} $demos {
+	.t insert end "[incr num]. $description." [list demo demo-$name]
+	.t insert end " \n " demospace
+    }
+}
+
 .t insert end "Tk Widget Demonstrations\n" title
 .t insert end {
 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 "See Code" button to see the Tcl/Tk code that created the demonstration.  If you wish, you can edit the code and click the "Rerun Demo" button in the code window to reinvoke the demonstration with the modified code.
-
 }
-.t insert end "Labels, buttons, checkbuttons, and radiobuttons" title
-.t insert end " \n " {demospace}
-.t insert end "1. Labels (text and bitmaps)." {demo demo-label}
-.t insert end " \n " {demospace}
-.t insert end "2. Buttons." {demo demo-button}
-.t insert end " \n " {demospace}
-.t insert end "3. Checkbuttons (select any of a group)." {demo demo-check}
-.t insert end " \n " {demospace}
-.t insert end "4. Radiobuttons (select one of a group)." {demo demo-radio}
-.t insert end " \n " {demospace}
-.t insert end "5. A 15-puzzle game made out of buttons." {demo demo-puzzle}
-.t insert end " \n " {demospace}
-.t insert end "6. Iconic buttons that use bitmaps." {demo demo-icon}
-.t insert end " \n " {demospace}
-.t insert end "7. Two labels displaying images." {demo demo-image1}
-.t insert end " \n " {demospace}
-.t insert end "8. A simple user interface for viewing images." \
-    {demo demo-image2}
-.t insert end " \n " {demospace}
-.t insert end "9. Labelled frames." {demo demo-labelframe}
-.t insert end " \n " {demospace}
-
-.t insert end \n {} "Listboxes" title
-.t insert end " \n " {demospace}
-.t insert end "1. 50 states." {demo demo-states}
-.t insert end " \n " {demospace}
-.t insert end "2. Colors: change the color scheme for the application." \
-	{demo demo-colors}
-.t insert end " \n " {demospace}
-.t insert end "3. A collection of famous sayings." {demo demo-sayings}
-.t insert end " \n " {demospace}
-
-.t insert end \n {} "Entries and Spin-boxes" title
-.t insert end " \n " {demospace}
-.t insert end "1. Entries without scrollbars." {demo demo-entry1}
-.t insert end " \n " {demospace}
-.t insert end "2. Entries with scrollbars." {demo demo-entry2}
-.t insert end " \n " {demospace}
-.t insert end "3. Spin-boxes." {demo demo-spin}
-.t insert end " \n " {demospace}
-.t insert end "4. Simple Rolodex-like form." {demo demo-form}
-.t insert end " \n " {demospace}
-
-.t insert end \n {} "Text" title
-.t insert end " \n " {demospace}
-.t insert end "1. Basic editable text." {demo demo-text}
-.t insert end " \n " {demospace}
-.t insert end "2. Text display styles." {demo demo-style}
-.t insert end " \n " {demospace}
-.t insert end "3. Hypertext (tag bindings)." {demo demo-bind}
-.t insert end " \n " {demospace}
-.t insert end "4. A text widget with embedded windows." {demo demo-twind}
-.t insert end " \n " {demospace}
-.t insert end "5. A search tool built with a text widget." {demo demo-search}
-.t insert end " \n " {demospace}
-
-.t insert end \n {} "Canvases" title
-.t insert end " \n " {demospace}
-.t insert end "1. The canvas item types." {demo demo-items}
-.t insert end " \n " {demospace}
-.t insert end "2. A simple 2-D plot." {demo demo-plot}
-.t insert end " \n " {demospace}
-.t insert end "3. Text items in canvases." {demo demo-ctext}
-.t insert end " \n " {demospace}
-.t insert end "4. An editor for arrowheads on canvas lines." {demo demo-arrow}
-.t insert end " \n " {demospace}
-.t insert end "5. A ruler with adjustable tab stops." {demo demo-ruler}
-.t insert end " \n " {demospace}
-.t insert end "6. A building floor plan." {demo demo-floor}
-.t insert end " \n " {demospace}
-.t insert end "7. A simple scrollable canvas." {demo demo-cscroll}
-.t insert end " \n " {demospace}
-
-.t insert end \n {} "Scales" title
-.t insert end " \n " {demospace}
-.t insert end "1. Vertical scale." {demo demo-vscale}
-.t insert end " \n " {demospace}
-.t insert end "2. Horizontal scale." {demo demo-hscale}
-.t insert end " \n " {demospace}
-
-.t insert end \n {} "Menus" title
-.t insert end " \n " {demospace}
-.t insert end "1. Menus and cascades." \
-	{demo demo-menu}
-.t insert end " \n " {demospace}
-.t insert end "2. Menubuttons"\
-	{demo demo-menubu}
-.t insert end " \n " {demospace}
-
-.t insert end \n {} "Common Dialogs" title
-.t insert end " \n " {demospace}
-.t insert end "1. Message boxes." {demo demo-msgbox}
-.t insert end " \n " {demospace}
-.t insert end "2. File selection dialog." {demo demo-filebox}
-.t insert end " \n " {demospace}
-.t insert end "3. Color picker." {demo demo-clrpick}
-.t insert end " \n " {demospace}
-
-.t insert end \n {} "Miscellaneous" title
-.t insert end " \n " {demospace}
-.t insert end "1. The built-in bitmaps." {demo demo-bitmap}
-.t insert end " \n " {demospace}
-.t insert end "2. A dialog box with a local grab." {demo demo-dialog1}
-.t insert end " \n " {demospace}
-.t insert end "3. A dialog box with a global grab." {demo demo-dialog2}
-.t insert end " \n " {demospace}
+addDemoSection "Labels, buttons, checkbuttons, and radiobuttons" {
+    label	"Labels (text and bitmaps)"
+    button	"Buttons"
+    check	"Check-buttons (select any of a group)"
+    radio	"Radio-buttons (select one of a group)"
+    puzzle	"A 15-puzzle game made out of buttons"
+    icon	"Iconic buttons that use bitmaps"
+    image1	"Two labels displaying images"
+    image2	"A simple user interface for viewing images"
+    labelframe	"Labelled frames"
+}
+addDemoSection "Listboxes" {
+    states	"The 50 states"
+    colors	"Colors: change the color scheme for the application"
+    sayings	"A collection of famous and infamous sayings"
+}
+addDemoSection "Entries and Spin-boxes" {
+    entry1	"Entries without scrollbars"
+    entry2	"Entries with scrollbars"
+    entry3	"Validated entries and password fields"
+    spin	"Spin-boxes"
+    form	"Simple Rolodex-like form"
+}
+addDemoSection "Text" {
+    text	"Basic editable text"
+    style	"Text display styles"
+    bind	"Hypertext (tag bindings)"
+    twind	"A text widget with embedded windows"
+    search	"A search tool built with a text widget"
+}
+addDemoSection "Canvases" {
+    items	"The canvas item types"
+    plot	"A simple 2-D plot"
+    ctext	"Text items in canvases"
+    arrow	"An editor for arrowheads on canvas lines"
+    ruler	"A ruler with adjustable tab stops"
+    floor	"A building floor plan"
+    cscroll	"A simple scrollable canvas"
+}
+addDemoSection "Scales" {
+    vscale	"Vertical scale"
+    hscale	"Horizontal scale"
+}
+addDemoSection "Menus" {
+    menu	"Menus and cascades (sub-menus)"
+    menubu	"Menu-buttons"
+}
+addDemoSection "Common Dialogs" {
+    msgbox	"Message boxes"
+    filebox	"File selection dialog"
+    clrpick	"Color picker"
+}
+addDemoSection "Miscellaneous" {
+    bitmap	"The built-in bitmaps"
+    dialog1	"A dialog box with a local grab"
+    dialog2	"A dialog box with a global grab"
+}
 
 .t configure -state disabled
 focus .s
@@ -390,7 +349,8 @@ proc showCode w {
 proc aboutBox {} {
     tk_messageBox -icon info -type ok -title "About Widget Demo" -message \
 "Tk widget demonstration\n\n\
-Copyright (c) 1996-1997 Sun Microsystems, Inc."
+Copyright (c) 1996-1997 Sun Microsystems, Inc.\n
+Copyright (c) 2001 Donal K. Fellows"
 }
 
 # Local Variables: