"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tltcl/lib/tk8.6/demos/ctext.tcl" (17 Mar 2020, 6014 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 # 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 if {![info exists widgetDemo]} {
    7     error "This script should be run from the \"widget\" demo."
    8 }
    9 
   10 package require Tk
   11 
   12 set w .ctext
   13 catch {destroy $w}
   14 toplevel $w
   15 wm title $w "Canvas Text Demonstration"
   16 wm iconname $w "Text"
   17 positionWindow $w
   18 set c $w.c
   19 
   20 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:
   21   1. You can point, click, and type.
   22   2. You can also select with button 1.
   23   3. You can copy the selection to the mouse position with button 2.
   24   4. Backspace and Control+h delete the selection if there is one;
   25      otherwise they delete the character just before the insertion cursor.
   26   5. Delete deletes the selection if there is one; otherwise it deletes
   27      the character just after the insertion cursor."
   28 pack $w.msg -side top
   29 
   30 ## See Code / Dismiss buttons
   31 set btns [addSeeDismiss $w.buttons $w]
   32 pack $btns -side bottom -fill x
   33 
   34 canvas $c -relief flat -borderwidth 0 -width 500 -height 350
   35 pack $w.c -side top -expand yes -fill both
   36 
   37 set textFont {Helvetica 24}
   38 
   39 $c create rectangle 245 195 255 205 -outline black -fill red
   40 
   41 # First, create the text item and give it bindings so it can be edited.
   42 
   43 $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]
   44 $c bind text <1> "textB1Press $c %x %y"
   45 $c bind text <B1-Motion> "textB1Move $c %x %y"
   46 $c bind text <Shift-1> "$c select adjust current @%x,%y"
   47 $c bind text <Shift-B1-Motion> "textB1Move $c %x %y"
   48 $c bind text <KeyPress> "textInsert $c %A"
   49 $c bind text <Return> "textInsert $c \\n"
   50 $c bind text <Control-h> "textBs $c"
   51 $c bind text <BackSpace> "textBs $c"
   52 $c bind text <Delete> "textDel $c"
   53 $c bind text <2> "textPaste $c @%x,%y"
   54 
   55 # Next, create some items that allow the text's anchor position
   56 # to be edited.
   57 
   58 proc mkTextConfigBox {w x y option value color} {
   59     set item [$w create rect $x $y [expr {$x+30}] [expr {$y+30}] \
   60         -outline black -fill $color -width 1]
   61     $w bind $item <1> "$w itemconf text $option $value"
   62     $w addtag config withtag $item
   63 }
   64 proc mkTextConfigPie {w x y a option value color} {
   65     set item [$w create arc $x $y [expr {$x+90}] [expr {$y+90}] \
   66         -start [expr {$a-15}] -extent 30 -outline black -fill $color \
   67         -width 1]
   68     $w bind $item <1> "$w itemconf text $option $value"
   69     $w addtag config withtag $item
   70 }
   71 
   72 set x 50
   73 set y 50
   74 set color LightSkyBlue1
   75 mkTextConfigBox $c $x $y -anchor se $color
   76 mkTextConfigBox $c [expr {$x+30}] [expr {$y   }] -anchor s      $color
   77 mkTextConfigBox $c [expr {$x+60}] [expr {$y   }] -anchor sw     $color
   78 mkTextConfigBox $c [expr {$x   }] [expr {$y+30}] -anchor e      $color
   79 mkTextConfigBox $c [expr {$x+30}] [expr {$y+30}] -anchor center $color
   80 mkTextConfigBox $c [expr {$x+60}] [expr {$y+30}] -anchor w      $color
   81 mkTextConfigBox $c [expr {$x   }] [expr {$y+60}] -anchor ne     $color
   82 mkTextConfigBox $c [expr {$x+30}] [expr {$y+60}] -anchor n      $color
   83 mkTextConfigBox $c [expr {$x+60}] [expr {$y+60}] -anchor nw     $color
   84 set item [$c create rect \
   85     [expr {$x+40}] [expr {$y+40}] [expr {$x+50}] [expr {$y+50}] \
   86     -outline black -fill red]
   87 $c bind $item <1> "$c itemconf text -anchor center"
   88 $c create text [expr {$x+45}] [expr {$y-5}] \
   89     -text {Text Position}  -anchor s  -font {Times 20}  -fill brown
   90 
   91 # Now create some items that allow the text's angle to be changed.
   92 
   93 set x 205
   94 set y 50
   95 set color Yellow
   96 mkTextConfigPie $c $x $y   0 -angle  90 $color
   97 mkTextConfigPie $c $x $y  30 -angle 120 $color
   98 mkTextConfigPie $c $x $y  60 -angle 150 $color
   99 mkTextConfigPie $c $x $y  90 -angle 180 $color
  100 mkTextConfigPie $c $x $y 120 -angle 210 $color
  101 mkTextConfigPie $c $x $y 150 -angle 240 $color
  102 mkTextConfigPie $c $x $y 180 -angle 270 $color
  103 mkTextConfigPie $c $x $y 210 -angle 300 $color
  104 mkTextConfigPie $c $x $y 240 -angle 330 $color
  105 mkTextConfigPie $c $x $y 270 -angle   0 $color
  106 mkTextConfigPie $c $x $y 300 -angle  30 $color
  107 mkTextConfigPie $c $x $y 330 -angle  60 $color
  108 $c create text [expr {$x+45}] [expr {$y-5}] \
  109     -text {Text Angle}  -anchor s  -font {Times 20}  -fill brown
  110 
  111 # Lastly, create some items that allow the text's justification to be
  112 # changed.
  113 
  114 set x 350
  115 set y 50
  116 set color SeaGreen2
  117 mkTextConfigBox $c $x $y -justify left $color
  118 mkTextConfigBox $c [expr {$x+30}] $y -justify center $color
  119 mkTextConfigBox $c [expr {$x+60}] $y -justify right $color
  120 $c create text [expr {$x+45}] [expr {$y-5}] \
  121     -text {Justification}  -anchor s  -font {Times 20}  -fill brown
  122 
  123 $c bind config <Enter> "textEnter $c"
  124 $c bind config <Leave> "$c itemconf current -fill \$textConfigFill"
  125 
  126 set textConfigFill {}
  127 
  128 proc textEnter {w} {
  129     global textConfigFill
  130     set textConfigFill [lindex [$w itemconfig current -fill] 4]
  131     $w itemconfig current -fill black
  132 }
  133 
  134 proc textInsert {w string} {
  135     if {$string == ""} {
  136     return
  137     }
  138     catch {$w dchars text sel.first sel.last}
  139     $w insert text insert $string
  140 }
  141 
  142 proc textPaste {w pos} {
  143     catch {
  144     $w insert text $pos [selection get]
  145     }
  146 }
  147 
  148 proc textB1Press {w x y} {
  149     $w icursor current @$x,$y
  150     $w focus current
  151     focus $w
  152     $w select from current @$x,$y
  153 }
  154 
  155 proc textB1Move {w x y} {
  156     $w select to current @$x,$y
  157 }
  158 
  159 proc textBs {w} {
  160     if {![catch {$w dchars text sel.first sel.last}]} {
  161     return
  162     }
  163     set char [expr {[$w index text insert] - 1}]
  164     if {$char >= 0} {$w dchar text $char}
  165 }
  166 
  167 proc textDel {w} {
  168     if {![catch {$w dchars text sel.first sel.last}]} {
  169     return
  170     }
  171     $w dchars text insert
  172 }