1# ctext.tcl --
2#
3# This demonstration script creates a canvas widget with a text
4# item that can be edited and reconfigured in various ways.
5#
6# SCCS: @(#) ctext.tcl 1.4 96/02/16 10:49:16
7
8set w .ctext
9catch {destroy $w}
10toplevel $w
11wm title $w "Canvas Text Demonstration"
12wm iconname $w "Text"
13positionWindow $w
14set c $w.c
15
16label $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.  The text also supports the following simple bindings for editing:
17  1. You can point, click, and type.
18  2. You can also select with button 1.
19  3. You can copy the selection to the mouse position with button 2.
20  4. Backspace and Control+h delete the selection if there is one;
21     otherwise they delete the character just before the insertion cursor.
22  5. Delete deletes the selection if there is one; otherwise it deletes
23     the character just after the insertion cursor."
24pack $w.msg -side top
25
26frame $w.buttons
27pack $w.buttons -side bottom -fill x -pady 2m
28button $w.buttons.dismiss -text Dismiss -command "destroy $w"
29button $w.buttons.code -text "See Code" -command "showCode $w"
30pack $w.buttons.dismiss $w.buttons.code -side left -expand 1
31
32canvas $c -relief flat -borderwidth 0 -width 500 -height 350
33pack $w.c -side top -expand yes -fill both
34
35set textFont -*-Helvetica-Medium-R-Normal--*-240-*-*-*-*-*-*
36
37$c create rectangle 245 195 255 205 -outline black -fill red
38
39# First, create the text item and give it bindings so it can be edited.
40
41$c addtag text withtag [$c create text 250 200 -text "This is just a string of text to demonstrate the text facilities of canvas widgets. Bindings have been been defined to support editing (see above)." -width 440 -anchor n -font -*-Helvetica-Medium-R-Normal--*-240-*-*-*-*-*-* -justify left]
42$c bind text <1> "textB1Press $c %x %y"
43$c bind text <B1-Motion> "textB1Move $c %x %y"
44$c bind text <Shift-1> "$c select adjust current @%x,%y"
45$c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
46$c bind text <KeyPress> "textInsert $c %A"
47$c bind text <Return> "textInsert $c \\n"
48$c bind text <Control-h> "textBs $c"
49$c bind text <BackSpace> "textBs $c"
50$c bind text <Delete> "textDel $c"
51$c bind text <2> "textPaste $c @%x,%y"
52
53# Next, create some items that allow the text's anchor position
54# to be edited.
55
56proc mkTextConfig {w x y option value color} {
57    set item [$w create rect [expr $x] [expr $y] [expr $x+30] [expr $y+30] \
58	    -outline black -fill $color -width 1]
59    $w bind $item <1> "$w itemconf text $option $value"
60    $w addtag config withtag $item
61}
62
63set x 50
64set y 50
65set color LightSkyBlue1
66mkTextConfig $c $x $y -anchor se $color
67mkTextConfig $c [expr $x+30] [expr $y] -anchor s $color
68mkTextConfig $c [expr $x+60] [expr $y] -anchor sw $color
69mkTextConfig $c [expr $x] [expr $y+30] -anchor e $color
70mkTextConfig $c [expr $x+30] [expr $y+30] -anchor center $color
71mkTextConfig $c [expr $x+60] [expr $y+30] -anchor w $color
72mkTextConfig $c [expr $x] [expr $y+60] -anchor ne $color
73mkTextConfig $c [expr $x+30] [expr $y+60] -anchor n $color
74mkTextConfig $c [expr $x+60] [expr $y+60] -anchor nw $color
75set item [$c create rect [expr $x+40] [expr $y+40] [expr $x+50] [expr $y+50] \
76	-outline black -fill red]
77$c bind $item <1> "$c itemconf text -anchor center"
78$c create text [expr $x+45] [expr $y-5] -text {Text Position} -anchor s \
79	-font -*-times-medium-r-normal--*-240-*-*-*-*-*-* -fill brown
80
81# Lastly, create some items that allow the text's justification to be
82# changed.
83
84set x 350
85set y 50
86set color SeaGreen2
87mkTextConfig $c $x $y -justify left $color
88mkTextConfig $c [expr $x+30] [expr $y] -justify center $color
89mkTextConfig $c [expr $x+60] [expr $y] -justify right $color
90$c create text [expr $x+45] [expr $y-5] -text {Justification} -anchor s \
91	-font -*-times-medium-r-normal--*-240-*-*-*-*-*-* -fill brown
92
93$c bind config <Enter> "textEnter $c"
94$c bind config <Leave> "$c itemconf current -fill \$textConfigFill"
95
96set textConfigFill {}
97
98proc textEnter {w} {
99    global textConfigFill
100    set textConfigFill [lindex [$w itemconfig current -fill] 4]
101    $w itemconfig current -fill black
102}
103
104proc textInsert {w string} {
105    if {$string == ""} {
106	return
107    }
108    catch {$w dchars text sel.first sel.last}
109    $w insert text insert $string
110}
111
112proc textPaste {w pos} {
113    catch {
114	$w insert text $pos [selection get]
115    }
116}
117
118proc textB1Press {w x y} {
119    $w icursor current @$x,$y
120    $w focus current
121    focus $w
122    $w select from current @$x,$y
123}
124
125proc textB1Move {w x y} {
126    $w select to current @$x,$y
127}
128
129proc textBs {w} {
130    if ![catch {$w dchars text sel.first sel.last}] {
131	return
132    }
133    set char [expr {[$w index text insert] - 1}]
134    if {$char >= 0} {$w dchar text $char}
135}
136
137proc textDel {w} {
138    if ![catch {$w dchars text sel.first sel.last}] {
139	return
140    }
141    $w dchars text insert
142}
143