util/src/TclTk/blt2.5/demos/dnd2.tcl

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