text widget 'peer' subcommand -- TIP#169 implementation

2 files changed, 82 insertions, 20 deletions

diff --git a/library/demos/twind.tcl b/library/demos/twind.tcl
index 48a0c20..91d7158 100644
--- a/library/demos/twind.tcl
+++ b/library/demos/twind.tcl
@@ -3,7 +3,7 @@
 # This demonstration script creates a text widget with a bunch of
 # embedded windows.
 #
-# RCS: @(#) $Id: twind.tcl,v 1.5 2003/12/04 12:28:37 vincentdarley Exp $
+# RCS: @(#) $Id: twind.tcl,v 1.6 2004/09/10 12:13:43 vincentdarley Exp $
 
 if {![info exists widgetDemo]} {
     error "This script should be run from the \"widget\" demo."
@@ -27,7 +27,12 @@ text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \
 pack $t -expand  yes -fill both
 scrollbar $w.scroll -command "$t yview"
 pack $w.scroll -side right -fill y
-pack $w.f -expand yes -fill both
+panedwindow $w.pane
+pack $w.pane -expand yes -fill both
+$w.pane add $w.f
+# Import to raise given creation order above
+raise $w.f
+
 $t tag configure center -justify center -spacing1 5m -spacing3 5m
 $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \
 	-spacing1 3m -spacing2 0 -spacing3 0
@@ -36,10 +41,6 @@ button $t.on -text "Turn On" -command "textWindOn $w" \
 	-cursor top_left_arrow
 button $t.off -text "Turn Off" -command "textWindOff $w" \
 	-cursor top_left_arrow
-button $t.click -text "Click Here" -command "textWindPlot $t" \
-	-cursor top_left_arrow
-button $t.delete -text "Delete" -command "textWindDel $w" \
-	-cursor top_left_arrow
 
 $t insert end "A text widget can contain many different kinds of items, "
 $t insert end "both active and passive.  It can lay these out in various "
@@ -60,15 +61,40 @@ $t window create end -window $t.off
 $t insert end " horizontal scrolling and turn back on word wrapping.\n\n"
 
 $t insert end "Or, here is another example.  If you "
-$t window create end -window $t.click
+$t window create end -create {
+    button %W.click -text "Click Here" -command "textWindPlot %W" \
+	    -cursor top_left_arrow}
+      
 $t insert end " a canvas displaying an x-y plot will appear right here."
 $t mark set plot insert
 $t mark gravity plot left
 $t insert end "  You can drag the data points around with the mouse, "
 $t insert end "or you can click here to "
-$t window create end -window $t.delete
+$t window create end -create {
+    button %W.delete -text "Delete" -command "textWindDel %W" \
+	    -cursor top_left_arrow
+}
 $t insert end " the plot again.\n\n"
 
+$t insert end "You can also create multiple text widgets each of which "
+$t insert end "display the same underlying text. Click this button to "
+$t window create end \
+  -create {button %W.peer -text "Make A Peer" -command "textMakePeer %W" \
+  -cursor top_left_arrow} -padx 3
+$t insert end " widget.  Notice how peer widgets can have different "
+$t insert end "font settings, and by default contain all the images "
+$t insert end "of the 'parent', but many of the embedded windows, "
+$t insert end "such as buttons will not be there.  The easiest way "
+$t insert end "to ensure they are in all peers is to use '-create' "
+$t insert end "embedded window creation scripts "
+$t insert end "(the plot above and the 'Make A Peer' button are "
+$t insert end "designed to show up in all peers).  A good use of "
+$t insert end "peers is for "
+$t window create end \
+  -create {button %W.split -text "Split Windows" -command "textSplitWindow %W" \
+  -cursor top_left_arrow} -padx 3
+$t insert end " \n\n"
+
 $t insert end "You may also find it useful to put embedded windows in "
 $t insert end "a text without any actual text.  In this case the "
 $t insert end "text widget acts like a geometry manager.  For "
@@ -179,6 +205,20 @@ proc textWindPlot t {
     if {[winfo exists $c]} {
 	return
     }
+
+    while {[string first [$t get plot] " \t\n"] >= 0} {
+	$t delete plot
+    }
+    $t insert plot "\n"
+
+    $t window create plot -create {createPlot %W}
+    $t tag add center plot
+    $t insert plot "\n"
+}
+
+proc createPlot {t} {
+    set c $t.c
+
     canvas $c -relief sunken -width 450 -height 300 -cursor top_left_arrow
 
     set font {Helvetica 18}
@@ -214,13 +254,7 @@ proc textWindPlot t {
     $c bind point <1> "embPlotDown $c %x %y"
     $c bind point <ButtonRelease-1> "$c dtag selected"
     bind $c <B1-Motion> "embPlotMove $c %x %y"
-    while {[string first [$t get plot] " \t\n"] >= 0} {
-	$t delete plot
-    }
-    $t insert plot "\n"
-    $t window create plot -window $c
-    $t tag add center plot
-    $t insert plot "\n"
+    return $c
 }
 
 set embPlot(lastX) 0
@@ -242,8 +276,7 @@ proc embPlotMove {w x y} {
     set embPlot(lastY) $y
 }
 
-proc textWindDel w {
-    set t $w.f.text
+proc textWindDel t {
     if {[winfo exists $t.c]} {
 	$t delete $t.c
 	while {[string first [$t get plot] " \t\n"] >= 0} {
@@ -256,3 +289,32 @@ proc textWindDel w {
 proc embDefBg t {
     $t configure -background [lindex [$t configure -background] 3]
 }
+
+proc textMakePeer {parent} {
+    set n 1
+    while {[winfo exists .peer$n]} { incr n }
+    set w [toplevel .peer$n]
+    wm title $w "Text Peer #$n"
+    frame $w.f -highlightthickness 2 -borderwidth 2 -relief sunken
+    set t [$parent peer create $w.f.text -yscrollcommand "$w.scroll set"]
+    pack $t -expand  yes -fill both
+    scrollbar $w.scroll -command "$t yview"
+    pack $w.scroll -side right -fill y
+    pack $w.f -expand yes -fill both
+}
+
+proc textSplitWindow {textW} {
+    if {$textW eq ".twind.f.text"} {
+	if {[winfo exists .twind.peer]} {
+	    destroy .twind.peer
+	} else {
+	    set parent [winfo parent $textW]
+	    set w [winfo parent $parent]
+	    set t [$textW peer create $w.peer \
+	      -yscrollcommand "$w.scroll set"]
+	    $w.pane add $t
+	}
+    } else {
+        return
+    }
+}
diff --git a/library/demos/widget b/library/demos/widget
index 8c59d6c..67d3b6a 100644
--- a/library/demos/widget
+++ b/library/demos/widget
@@ -11,10 +11,10 @@ exec wish "$0" "$@"
 # ".tcl" files is this directory, which are sourced by this script
 # as needed.
 #
-# RCS: @(#) $Id: widget,v 1.23 2004/03/17 18:15:45 das Exp $
+# RCS: @(#) $Id: widget,v 1.24 2004/09/10 12:13:43 vincentdarley Exp $
 
-package require Tcl	8.4
-package require Tk	8.4
+package require Tcl	8.5
+package require Tk	8.5
 package require msgcat
 
 eval destroy [winfo child .]