I386LINUX/util/I386LINUX/lib/blt2.4/demos/dnd2.tcl

   1 #!../src/bltwish
   2
   3 package require BLT
   4 # --------------------------------------------------------------------------
   5 # Starting with Tcl 8.x, the BLT commands are stored in their own
   6 # namespace called "blt".  The idea is to prevent name clashes with
   7 # Tcl commands and variables from other packages, such as a "table"
   8 # command in two different packages.
   9 #
  10 # You can access the BLT commands in a couple of ways.  You can prefix
  11 # all the BLT commands with the namespace qualifier "blt::"
  12 #
  13 #    blt::graph .g
  14 #    blt::table . .g -resize both
  15 #
  16 # or you can import all the command into the global namespace.
  17 #
  18 #    namespace import blt::*
  19 #    graph .g
  20 #    table . .g -resize both
  21 #
  22 # --------------------------------------------------------------------------
  23 if { $tcl_version >= 8.0 } {
  24     namespace import blt::*
  25     namespace import -force blt::tile::*
  26 }
  27 source scripts/demo.tcl
  28
  29 if { ([info exists tcl_platform]) && ($tcl_platform(platform) == "windows") } {
  30     error "This script works only under X11"
  31 }
  32
  33 canvas .c -width 320 -height 320 -background white
  34
  35 blt::table . .c -fill both
  36
  37 set lastCell ""
  38 set cellWidth 1
  39 set cellHeight 1
  40 proc RedrawWorld { canvas } {
  41     global cells cellWidth cellHeight
  42
  43     $canvas delete all
  44
  45     set width [winfo width $canvas]
  46     set height [winfo height $canvas]
  47
  48     set cellWidth [expr $width / 8]
  49     set cellHeight [expr $height / 8]
  50
  51     for { set row 0 } { $row < 8 } { incr row } {
  52         set y [expr $row * $cellHeight]
  53         set h [expr $y + $cellHeight]
  54         for { set column 0 } { $column < 8 } { incr column } {
  55             set x [expr $column * $cellWidth]
  56             set w [expr $x + $cellWidth]
  57             $canvas create rectangle $x $y $w $h -fill white -outline "" \
  58                 -tags "$row,$column"
  59         }
  60     }
  61
  62     for { set row 0 } { $row < 8 } { incr row } {
  63         set y [expr $row * $cellHeight]
  64         $canvas create line 0 $y $width $y
  65     }
  66
  67     for { set column 0 } { $column < 8 } { incr column } {
  68         set x [expr $column * $cellWidth]
  69         $canvas create line $x 0 $x $height
  70     }
  71     foreach name [array names cells] {
  72         set rc [split $name ,]
  73         set row [lindex $rc 0]
  74         set column [lindex $rc 1]
  75         set x [expr ($column * $cellWidth) + 5]
  76         set y [expr ($row * $cellHeight) + 5]
  77         set w [expr $cellWidth - 10]
  78         set h [expr $cellHeight - 10]
  79         set color [lindex $cells($name) 0]
  80         set type [lindex $cells($name) 1]
  81         set pi1_2 [expr 3.14159265358979323846/180.0]
  82         set points {}
  83         switch $type {
  84             hexagon {
  85                 lappend points $x [expr $y + $h/2] [expr $x + $w * 1/3] \
  86                     $y [expr $x + $w * 2/3] $y [expr $x + $w] [expr $y + $h/2] \
  87                     [expr $x + $w * 2/3] [expr $y + $h] \
  88                     [expr $x + $w * 1/3] [expr $y + $h]
  89             }
  90             parallelogram   {
  91                 lappend points $x [expr $y + $h * 2/3] \
  92                     [expr $x + $w * 2/3] $y \
  93                     [expr $x + $w] [expr $y + $h * 1/3] \
  94                     [expr $x + $w * 1/3] [expr $y + $h]
  95             }
  96             triangle {
  97                 lappend points \
  98                     $x [expr $y + $h] \
  99                     [expr $x + $w * 1/2] $y \
 100                     [expr $x + $w] [expr $y + $h]
 101             }
 102         }
 103         eval .c create polygon $points -fill $color -outline black
 104     }
 105 }
 106
 107 bind .c <Configure> { RedrawWorld %W }
 108
 109 # ----------------------------------------------------------------------
 110 #  USAGE:  random ?<max>? ?<min>?
 111 #
 112 #  Returns a random number in the range <min> to <max>.
 113 #  If <min> is not specified, the default is 0; if max is not
 114 #  specified, the default is 1.
 115 # ----------------------------------------------------------------------
 116
 117 proc random {{max 1.0} {min 0.0}} {
 118     global randomSeed
 119
 120     set randomSeed [expr (7141*$randomSeed+54773) % 259200]
 121     set num  [expr $randomSeed/259200.0*($max-$min)+$min]
 122     return $num
 123 }
 124 set randomSeed [clock clicks]
 125
 126 set itemTypes { parallelogram hexagon triangle }
 127 set itemTypes { hexagon triangle parallelogram }
 128
 129 for { set i 0 } { $i < 20 } { incr i } {
 130     while { 1 } {
 131         set row [expr int([random 8])]
 132         set column [expr int([random 8])]
 133         set type [expr int([random 3])]
 134         set type [lindex $itemTypes $type]
 135         if { ![info exists cells($row,$column)] } {
 136             set r [expr int([random 256 128])]
 137             set g [expr int([random 256 128])]
 138             set b [expr int([random 256 128])]
 139             set cells($row,$column) [format "#%.2x%.2x%.2x %s" $r $g $b $type]
 140             break
 141         }
 142     }
 143 }
 144
 145 proc ScreenToCell { widget x y }  {
 146     global cellWidth cellHeight
 147     set column [expr $x / $cellWidth]
 148     set row [expr $y / $cellHeight]
 149     return $row,$column
 150 }
 151
 152
 153 set count 0
 154 foreach i [winfo interps] {
 155     puts $i
 156     if { [string match "dnd2.tcl*" $i] } {
 157         incr count
 158     }
 159 }
 160
 161 if { $count == 1 }  {
 162     toplevel .info
 163     raise .info
 164     text .info.text -width 65 -height 12 -font { Helvetica 10 } -bg white \
 165         -tabs { 0.25i }
 166     .info.text insert end {
 167         This is a more involved example of the new "dnd" command.
 168         Run this script again to get another window. You can then drag
 169         and drop symbols between the windows by clicking with the left
 170         mouse button on a symbol.
 171
 172         It demonstates how to
 173                 o Drag-and-drop on specific areas (canvas items) of a widget.
 174                 o How to receive and handle Enter/Leave/Motion events in the target.
 175                 o How to send drag feedback to the source.
 176                 o Use a drag threshold.
 177     }
 178     button .info.quit -text "Dismiss" -command { destroy .info }
 179     blt::table .info \
 180         0,0 .info.text -fill both \
 181         1,0 .info.quit
 182 }
 183
 184
 185 # -----------------------------------------------------------------
 186 #
 187 #  Setup finished.  Start of drag-and-drop code here.
 188 #
 189
 190 # Set up the entire canvas as a drag&drop source.
 191
 192 dnd register .c -source yes  -dragthreshold 5 -button 1
 193
 194 # Register code to pick up the information about a canvas item
 195
 196 dnd getdata .c color GetColor
 197
 198 proc GetColor { widget args } {
 199     array set info $args
 200     global itemInfo
 201     set id $itemInfo($info(timestamp))
 202     set color [$widget itemcget $id -fill]
 203     set ncoords [llength [$widget coords $id]]
 204     if { $ncoords == 6 } {
 205         set type triangle
 206     } elseif { $ncoords == 8 } {
 207         set type parallelogram
 208     } elseif { $ncoords ==  12 } {
 209         set type hexagon
 210     } else {
 211         error "unknown type n=$ncoords"
 212     }
 213     return [list $color $type]
 214 }
 215
 216 dnd configure .c -package PackageSample
 217
 218 proc PackageSample { widget args } {
 219     array set info $args
 220
 221     # Check if we're over a canvas item
 222     set items [$widget find overlapping $info(x) $info(y) $info(x) $info(y)]
 223     set pickedItem ""
 224     foreach i $items {
 225         if { [$widget type $i] == "polygon" } {
 226             set pickedItem $i
 227             break
 228         }
 229     }
 230     if { $pickedItem == "" } {
 231         # Cancel the drag
 232         puts "Cancel the drag x=$info(x) y=$info(y)"
 233         return 0
 234     }
 235     set fill [$widget itemcget $pickedItem -fill]
 236     set outline [$widget itemcget $pickedItem -outline]
 237
 238     set ncoords [llength [$widget coords $pickedItem]]
 239     if { $ncoords == 6 } {
 240         set type triangle
 241     } elseif { $ncoords == 8 } {
 242         set type parallelogram
 243     } elseif { $ncoords ==  12 } {
 244         set type hexagon
 245     } else {
 246         error "unknown type n=$ncoords"
 247     }
 248     set tag [ScreenToCell $widget $info(x) $info(y)]
 249     $info(token).label configure -background $fill -foreground $outline \
 250         -text $type
 251     update idletasks
 252     update
 253     global itemInfo
 254     set itemInfo($info(timestamp)) $pickedItem
 255     return 1
 256 }
 257
 258 # Configure a set of animated cursors.
 259
 260 dnd configure .c -cursors {
 261     { @bitmaps/hand/hand01.xbm bitmaps/hand/hand01m.xbm  black white }
 262     { @bitmaps/hand/hand02.xbm bitmaps/hand/hand02m.xbm  black white }
 263     { @bitmaps/hand/hand03.xbm bitmaps/hand/hand03m.xbm  black white }
 264     { @bitmaps/hand/hand04.xbm bitmaps/hand/hand04m.xbm  black white }
 265     { @bitmaps/hand/hand05.xbm bitmaps/hand/hand05m.xbm  black white }
 266     { @bitmaps/hand/hand06.xbm bitmaps/hand/hand06m.xbm  black white }
 267     { @bitmaps/hand/hand07.xbm bitmaps/hand/hand07m.xbm  black white }
 268     { @bitmaps/hand/hand08.xbm bitmaps/hand/hand08m.xbm  black white }
 269     { @bitmaps/hand/hand09.xbm bitmaps/hand/hand09m.xbm  black white }
 270     { @bitmaps/hand/hand10.xbm bitmaps/hand/hand10m.xbm  black white }
 271     { @bitmaps/hand/hand11.xbm bitmaps/hand/hand11m.xbm  black white }
 272     { @bitmaps/hand/hand12.xbm bitmaps/hand/hand12m.xbm  black white }
 273     { @bitmaps/hand/hand13.xbm bitmaps/hand/hand13m.xbm  black white }
 274     { @bitmaps/hand/hand14.xbm bitmaps/hand/hand14m.xbm  black white }
 275 }
 276
 277 # Create a widget to place in the drag-and-drop token
 278
 279 set token [dnd token window .c]
 280
 281 label $token.label -bd 2 -highlightthickness 1
 282 pack $token.label
 283 dnd token configure .c \
 284     -borderwidth 2 \
 285     -relief raised -activerelief raised  \
 286     -outline pink -fill red \
 287     -anchor s
 288
 289
 290 dnd configure .c -target yes
 291
 292 dnd setdata .c color {
 293     NewObject
 294 }
 295
 296 proc NewObject { widget args } {
 297     array set info $args
 298     set tag [ScreenToCell $widget $info(x) $info(y)]
 299     global cells
 300     if { [info exists cells($tag)] } {
 301         error "Cell already exists"
 302     }
 303     set cells($tag) $info(value)
 304     RedrawWorld $widget
 305
 306 }
 307
 308 dnd configure .c -onmotion OnMotion -onenter OnMotion -onleave OnMotion
 309
 310 proc OnMotion { widget args } {
 311     global cells lastCell
 312
 313     array set info $args
 314     set tag [ScreenToCell $widget $info(x) $info(y)]
 315     if { $lastCell != "" } {
 316         $widget itemconfigure $lastCell -fill white -outline "" -width 1 \
 317             -stipple ""
 318     }
 319     # Check that we're not over a canvas item
 320     if { ![info exists cells($tag)] } {
 321         $widget itemconfigure $tag -outline lightblue -fill lightblue \
 322             -width 2 -stipple BLT
 323         set lastCell $tag
 324         return 1
 325     }
 326     return 0
 327 }
 328