"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/lib/tk8.6/demos/twind.tcl" (17 Mar 2020, 11655 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 # twind.tcl --
    2 #
    3 # This demonstration script creates a text widget with a bunch of
    4 # embedded windows.
    5 
    6 if {![info exists widgetDemo]} {
    7     error "This script should be run from the \"widget\" demo."
    8 }
    9 
   10 package require Tk
   11 
   12 # Make an Aqua button's fill color match its parent's background
   13 proc blend {bt} {
   14     if {[tk windowingsystem] eq "aqua"} {
   15     $bt configure -highlightbackground [[winfo parent $bt] cget -background]
   16     }
   17     return $bt
   18 }
   19 
   20 set w .twind
   21 catch {destroy $w}
   22 toplevel $w
   23 wm title $w "Text Demonstration - Embedded Windows and Other Features"
   24 wm iconname $w "Embedded Windows"
   25 positionWindow $w
   26 
   27 ## See Code / Dismiss buttons
   28 set btns [addSeeDismiss $w.buttons $w]
   29 pack $btns -side bottom -fill x
   30 
   31 frame $w.f -highlightthickness 1 -borderwidth 1 -relief sunken
   32 set t $w.f.text
   33 text $t -yscrollcommand "$w.scroll set" -setgrid true -font $font -width 70 \
   34     -height 35 -wrap word -highlightthickness 0 -borderwidth 0
   35 pack $t -expand  yes -fill both
   36 ttk::scrollbar $w.scroll -command "$t yview"
   37 pack $w.scroll -side right -fill y
   38 panedwindow $w.pane
   39 pack $w.pane -expand yes -fill both
   40 $w.pane add $w.f
   41 # Import to raise given creation order above
   42 raise $w.f
   43 
   44 $t tag configure center -justify center -spacing1 5m -spacing3 5m
   45 $t tag configure buttons -lmargin1 1c -lmargin2 1c -rmargin 1c \
   46     -spacing1 3m -spacing2 0 -spacing3 0
   47 
   48 button $t.on -text "Turn On" -command "textWindOn $w" \
   49     -cursor top_left_arrow
   50 button $t.off -text "Turn Off" -command "textWindOff $w" \
   51     -cursor top_left_arrow
   52 
   53 $t insert end "A text widget can contain many different kinds of items, "
   54 $t insert end "both active and passive.  It can lay these out in various "
   55 $t insert end "ways, with wrapping, tabs, centering, etc.  In addition, "
   56 $t insert end "when the contents are too big for the window, smooth "
   57 $t insert end "scrolling in all directions is provided.\n\n"
   58 
   59 $t insert end "A text widget can contain other widgets embedded "
   60 $t insert end "it.  These are called \"embedded windows\", "
   61 $t insert end "and they can consist of arbitrary widgets.  "
   62 $t insert end "For example, here are two embedded button "
   63 $t insert end "widgets.  You can click on the first button to "
   64 $t window create end -window [blend $t.on]
   65 $t insert end " horizontal scrolling, which also turns off "
   66 $t insert end "word wrapping.  Or, you can click on the second "
   67 $t insert end "button to\n"
   68 $t window create end -window [blend $t.off]
   69 $t insert end " horizontal scrolling and turn back on word wrapping.\n\n"
   70 
   71 $t insert end "Or, here is another example.  If you "
   72 $t window create end -create {
   73     button %W.click -text "Click Here" -command "textWindPlot %W" \
   74     -cursor top_left_arrow
   75     blend %W.click
   76 }
   77 
   78 $t insert end " a canvas displaying an x-y plot will appear right here."
   79 $t mark set plot insert
   80 $t mark gravity plot left
   81 $t insert end "  You can drag the data points around with the mouse, "
   82 $t insert end "or you can click here to "
   83 $t window create end -create {
   84     button %W.delete -text "Delete" -command "textWindDel %W" \
   85     -cursor top_left_arrow
   86     blend %W.delete
   87 }
   88 $t insert end " the plot again.\n\n"
   89 
   90 $t insert end "You can also create multiple text widgets each of which "
   91 $t insert end "display the same underlying text. Click this button to "
   92 $t window create end \
   93   -create {button %W.peer -text "Make A Peer" -command "textMakePeer %W" \
   94            -cursor top_left_arrow
   95       blend %W.peer} -padx 3
   96 $t insert end " widget.  Notice how peer widgets can have different "
   97 $t insert end "font settings, and by default contain all the images "
   98 $t insert end "of the 'parent', but that the embedded windows, "
   99 $t insert end "such as buttons may not appear in the peer.  To ensure "
  100 $t insert end "that embedded windows appear in all peers you can set the "
  101 $t insert end "'-create' option to a script or a string containing %W.  "
  102 $t insert end "(The plot above and the 'Make A Peer' button are "
  103 $t insert end "designed to show up in all peers.)  A good use of "
  104 $t insert end "peers is for "
  105 $t window create end \
  106   -create {button %W.split -text "Split Windows" -command "textSplitWindow %W" \
  107            -cursor top_left_arrow
  108       blend %W.split} -padx 3
  109 $t insert end " \n\n"
  110 
  111 $t insert end "Users of previous versions of Tk will also be interested "
  112 $t insert end "to note that now cursor movement is now by visual line by "
  113 $t insert end "default, and that all scrolling of this widget is by pixel.\n\n"
  114 
  115 $t insert end "You may also find it useful to put embedded windows in "
  116 $t insert end "a text without any actual text.  In this case the "
  117 $t insert end "text widget acts like a geometry manager.  For "
  118 $t insert end "example, here is a collection of buttons laid out "
  119 $t insert end "neatly into rows by the text widget.  These buttons "
  120 $t insert end "can be used to change the background color of the "
  121 $t insert end "text widget (\"Default\" restores the color to "
  122 $t insert end "its default).  If you click on the button labeled "
  123 $t insert end "\"Short\", it changes to a longer string so that "
  124 $t insert end "you can see how the text widget automatically "
  125 $t insert end "changes the layout.  Click on the button again "
  126 $t insert end "to restore the short string.\n"
  127 
  128 $t insert end "\nNOTE: these buttons will not appear in peers!\n" "peer_warning"
  129 button $t.default -text Default -command "embDefBg $t" \
  130     -cursor top_left_arrow
  131 $t window create end -window $t.default -padx 3
  132 global embToggle
  133 set embToggle Short
  134 checkbutton $t.toggle -textvariable embToggle -indicatoron 0 \
  135     -variable embToggle -onvalue "A much longer string" \
  136     -offvalue "Short" -cursor top_left_arrow -pady 5 -padx 2
  137 $t window create end -window $t.toggle -padx 3 -pady 2
  138 set i 1
  139 foreach color {AntiqueWhite3 Bisque1 Bisque2 Bisque3 Bisque4
  140     SlateBlue3 RoyalBlue1 SteelBlue2 DeepSkyBlue3 LightBlue1
  141     DarkSlateGray1 Aquamarine2 DarkSeaGreen2 SeaGreen1
  142     Yellow1 IndianRed1 IndianRed2 Tan1 Tan4} {
  143     button $t.color$i -text $color -cursor top_left_arrow -command \
  144         "changeBg $t $color"
  145     $t window create end -window [blend $t.color$i] -padx 3 -pady 2
  146     incr i
  147 }
  148 $t tag add buttons [blend $t.default] end
  149 
  150 button $t.bigB -text "Big borders" -command "textWindBigB $t" \
  151   -cursor top_left_arrow
  152 button $t.smallB -text "Small borders" -command "textWindSmallB $t" \
  153   -cursor top_left_arrow
  154 button $t.bigH -text "Big highlight" -command "textWindBigH $t" \
  155   -cursor top_left_arrow
  156 button $t.smallH -text "Small highlight" -command "textWindSmallH $t" \
  157   -cursor top_left_arrow
  158 button $t.bigP -text "Big pad" -command "textWindBigP $t" \
  159   -cursor top_left_arrow
  160 button $t.smallP -text "Small pad" -command "textWindSmallP $t" \
  161   -cursor top_left_arrow
  162 
  163 set text_normal(border) [$t cget -borderwidth]
  164 set text_normal(highlight) [$t cget -highlightthickness]
  165 set text_normal(pad) [$t cget -padx]
  166 
  167 $t insert end "\nYou can also change the usual border width and "
  168 $t insert end "highlightthickness and padding.\n"
  169 $t window create end -window [blend $t.bigB]
  170 $t window create end -window [blend $t.smallB]
  171 $t window create end -window [blend $t.bigH]
  172 $t window create end -window [blend $t.smallH]
  173 $t window create end -window [blend $t.bigP]
  174 $t window create end -window [blend $t.smallP]
  175 
  176 $t insert end "\n\nFinally, images fit comfortably in text widgets too:"
  177 
  178 $t image create end -image \
  179     [image create photo -file [file join $tk_demoDirectory images ouster.png]]
  180 
  181 proc textWindBigB w {
  182     $w configure -borderwidth 15
  183 }
  184 
  185 proc textWindBigH w {
  186     $w configure -highlightthickness 15
  187 }
  188 
  189 proc textWindBigP w {
  190     $w configure -padx 15 -pady 15
  191 }
  192 
  193 proc textWindSmallB w {
  194     $w configure -borderwidth $::text_normal(border)
  195 }
  196 
  197 proc textWindSmallH w {
  198     $w configure -highlightthickness $::text_normal(highlight)
  199 }
  200 
  201 proc textWindSmallP w {
  202     $w configure -padx $::text_normal(pad) -pady $::text_normal(pad)
  203 }
  204 
  205 proc textWindOn w {
  206     catch {destroy $w.scroll2}
  207     set t $w.f.text
  208     ttk::scrollbar $w.scroll2 -orient horizontal -command "$t xview"
  209     pack $w.scroll2 -after $w.buttons -side bottom -fill x
  210     $t configure -xscrollcommand "$w.scroll2 set" -wrap none
  211 }
  212 
  213 proc textWindOff w {
  214     catch {destroy $w.scroll2}
  215     set t $w.f.text
  216     $t configure -xscrollcommand {} -wrap word
  217 }
  218 
  219 proc textWindPlot t {
  220     set c $t.c
  221     if {[winfo exists $c]} {
  222     return
  223     }
  224 
  225     while {[string first [$t get plot] " \t\n"] >= 0} {
  226     $t delete plot
  227     }
  228     $t insert plot "\n"
  229 
  230     $t window create plot -create {createPlot %W}
  231     $t tag add center plot
  232     $t insert plot "\n"
  233 }
  234 
  235 proc createPlot {t} {
  236     set c $t.c
  237 
  238     canvas $c -relief sunken -width 450 -height 300 -cursor top_left_arrow
  239 
  240     set font {Helvetica 18}
  241 
  242     $c create line 100 250 400 250 -width 2
  243     $c create line 100 250 100 50 -width 2
  244     $c create text 225 20 -text "A Simple Plot" -font $font -fill brown
  245 
  246     for {set i 0} {$i <= 10} {incr i} {
  247     set x [expr {100 + ($i*30)}]
  248     $c create line $x 250 $x 245 -width 2
  249     $c create text $x 254 -text [expr {10*$i}] -anchor n -font $font
  250     }
  251     for {set i 0} {$i <= 5} {incr i} {
  252     set y [expr {250 - ($i*40)}]
  253     $c create line 100 $y 105 $y -width 2
  254     $c create text 96 $y -text [expr {$i*50}].0 -anchor e -font $font
  255     }
  256 
  257     foreach point {
  258     {12 56} {20 94} {33 98} {32 120} {61 180} {75 160} {98 223}
  259     } {
  260     set x [expr {100 + (3*[lindex $point 0])}]
  261     set y [expr {250 - (4*[lindex $point 1])/5}]
  262     set item [$c create oval [expr {$x-6}] [expr {$y-6}] \
  263         [expr {$x+6}] [expr {$y+6}] -width 1 -outline black \
  264         -fill SkyBlue2]
  265     $c addtag point withtag $item
  266     }
  267 
  268     $c bind point <Any-Enter> "$c itemconfig current -fill red"
  269     $c bind point <Any-Leave> "$c itemconfig current -fill SkyBlue2"
  270     $c bind point <1> "embPlotDown $c %x %y"
  271     $c bind point <ButtonRelease-1> "$c dtag selected"
  272     bind $c <B1-Motion> "embPlotMove $c %x %y"
  273     return $c
  274 }
  275 
  276 set embPlot(lastX) 0
  277 set embPlot(lastY) 0
  278 
  279 proc embPlotDown {w x y} {
  280     global embPlot
  281     $w dtag selected
  282     $w addtag selected withtag current
  283     $w raise current
  284     set embPlot(lastX) $x
  285     set embPlot(lastY) $y
  286 }
  287 
  288 proc embPlotMove {w x y} {
  289     global embPlot
  290     $w move selected [expr {$x-$embPlot(lastX)}] [expr {$y-$embPlot(lastY)}]
  291     set embPlot(lastX) $x
  292     set embPlot(lastY) $y
  293 }
  294 
  295 proc textWindDel t {
  296     if {[winfo exists $t.c]} {
  297     $t delete $t.c
  298     while {[string first [$t get plot] " \t\n"] >= 0} {
  299         $t delete plot
  300     }
  301     $t insert plot "  "
  302     }
  303 }
  304 
  305 proc changeBg {t c} {
  306     $t configure -background $c
  307     if {[tk windowingsystem] eq "aqua"} {
  308     foreach b [$t window names] {
  309         if {[winfo class $b] eq "Button"} {
  310         $b configure -highlightbackground $c
  311         }
  312     }
  313     }
  314 }
  315 
  316 proc embDefBg t {
  317     set bg [lindex [$t configure -background] 3]
  318     changeBg $t $bg
  319 }
  320 
  321 proc textMakePeer {parent} {
  322     set n 1
  323     while {[winfo exists .peer$n]} { incr n }
  324     set w [toplevel .peer$n]
  325     wm title $w "Text Peer #$n"
  326     frame $w.f -highlightthickness 1 -borderwidth 1 -relief sunken
  327     set t [$parent peer create $w.f.text -yscrollcommand "$w.scroll set" \
  328            -borderwidth 0 -highlightthickness 0]
  329     $t tag configure peer_warning -font boldFont
  330     pack $t -expand  yes -fill both
  331     ttk::scrollbar $w.scroll -command "$t yview"
  332     pack $w.scroll -side right -fill y
  333     pack $w.f -expand yes -fill both
  334 }
  335 
  336 proc textSplitWindow {textW} {
  337     if {$textW eq ".twind.f.text"} {
  338     if {[winfo exists .twind.peer]} {
  339         destroy .twind.peer
  340     } else {
  341         set parent [winfo parent $textW]
  342         set w [winfo parent $parent]
  343         set t [$textW peer create $w.peer \
  344           -yscrollcommand "$w.scroll set"]
  345         $t tag configure peer_warning -font boldFont
  346         $w.pane add $t
  347     }
  348     } else {
  349         return
  350     }
  351 }