--- /dev/null
+#!../src/bltwish
+
+if {[lindex $argv end] != "spawn"} {
+ exec [info nameofexecutable] [info script] spawn &
+}
+package require BLT
+# --------------------------------------------------------------------------
+# Starting with Tcl 8.x, the BLT commands are stored in their own
+# namespace called "blt". The idea is to prevent name clashes with
+# Tcl commands and variables from other packages, such as a "table"
+# command in two different packages.
+#
+# You can access the BLT commands in a couple of ways. You can prefix
+# all the BLT commands with the namespace qualifier "blt::"
+#
+# blt::graph .g
+# blt::table . .g -resize both
+#
+# or you can import all the command into the global namespace.
+#
+# namespace import blt::*
+# graph .g
+# table . .g -resize both
+#
+# --------------------------------------------------------------------------
+if { $tcl_version >= 8.0 } {
+ namespace import blt::*
+ namespace import -force blt::tile::*
+}
+source scripts/demo.tcl
+
+if { ([info exists tcl_platform]) && ($tcl_platform(platform) == "windows") } {
+ error "This script works only under X11"
+}
+
+canvas .c -width 320 -height 320 -background white
+
+blt::table . .c -fill both
+
+set lastCell ""
+set cellWidth 1
+set cellHeight 1
+proc RedrawWorld { canvas } {
+ global cells cellWidth cellHeight
+
+ $canvas delete all
+
+ set width [winfo width $canvas]
+ set height [winfo height $canvas]
+
+ set cellWidth [expr $width / 8]
+ set cellHeight [expr $height / 8]
+
+ for { set row 0 } { $row < 8 } { incr row } {
+ set y [expr $row * $cellHeight]
+ set h [expr $y + $cellHeight]
+ for { set column 0 } { $column < 8 } { incr column } {
+ set x [expr $column * $cellWidth]
+ set w [expr $x + $cellWidth]
+ $canvas create rectangle $x $y $w $h -fill white -outline "" \
+ -tags "$row,$column"
+ }
+ }
+
+ for { set row 0 } { $row < 8 } { incr row } {
+ set y [expr $row * $cellHeight]
+ $canvas create line 0 $y $width $y
+ }
+
+ for { set column 0 } { $column < 8 } { incr column } {
+ set x [expr $column * $cellWidth]
+ $canvas create line $x 0 $x $height
+ }
+ foreach name [array names cells] {
+ set rc [split $name ,]
+ set row [lindex $rc 0]
+ set column [lindex $rc 1]
+ set x [expr ($column * $cellWidth) + 5]
+ set y [expr ($row * $cellHeight) + 5]
+ set w [expr $cellWidth - 10]
+ set h [expr $cellHeight - 10]
+ set color [lindex $cells($name) 0]
+ set type [lindex $cells($name) 1]
+ set pi1_2 [expr 3.14159265358979323846/180.0]
+ set points {}
+ switch $type {
+ hexagon {
+ lappend points $x [expr $y + $h/2] [expr $x + $w * 1/3] \
+ $y [expr $x + $w * 2/3] $y [expr $x + $w] [expr $y + $h/2] \
+ [expr $x + $w * 2/3] [expr $y + $h] \
+ [expr $x + $w * 1/3] [expr $y + $h]
+ }
+ parallelogram {
+ lappend points $x [expr $y + $h * 2/3] \
+ [expr $x + $w * 2/3] $y \
+ [expr $x + $w] [expr $y + $h * 1/3] \
+ [expr $x + $w * 1/3] [expr $y + $h]
+ }
+ triangle {
+ lappend points \
+ $x [expr $y + $h] \
+ [expr $x + $w * 1/2] $y \
+ [expr $x + $w] [expr $y + $h]
+ }
+ }
+ eval .c create polygon $points -fill $color -outline black
+ }
+}
+
+bind .c <Configure> { RedrawWorld %W }
+
+# ----------------------------------------------------------------------
+# USAGE: random ?<max>? ?<min>?
+#
+# Returns a random number in the range <min> to <max>.
+# If <min> is not specified, the default is 0; if max is not
+# specified, the default is 1.
+# ----------------------------------------------------------------------
+
+proc random {{max 1.0} {min 0.0}} {
+ global randomSeed
+
+ set randomSeed [expr (7141*$randomSeed+54773) % 259200]
+ set num [expr $randomSeed/259200.0*($max-$min)+$min]
+ return $num
+}
+set randomSeed [clock clicks]
+
+set itemTypes { parallelogram hexagon triangle }
+set itemTypes { hexagon triangle parallelogram }
+
+for { set i 0 } { $i < 20 } { incr i } {
+ while { 1 } {
+ set row [expr int([random 8])]
+ set column [expr int([random 8])]
+ set type [expr int([random 3])]
+ set type [lindex $itemTypes $type]
+ if { ![info exists cells($row,$column)] } {
+ set r [expr int([random 256 128])]
+ set g [expr int([random 256 128])]
+ set b [expr int([random 256 128])]
+ set cells($row,$column) [format "#%.2x%.2x%.2x %s" $r $g $b $type]
+ break
+ }
+ }
+}
+
+proc ScreenToCell { widget x y } {
+ global cellWidth cellHeight
+ set column [expr $x / $cellWidth]
+ set row [expr $y / $cellHeight]
+ return $row,$column
+}
+
+
+set count 0
+foreach i [winfo interps] {
+ puts $i
+ if { [string match "dnd2.tcl*" $i] } {
+ incr count
+ }
+}
+
+if { $count == 1 } {
+ toplevel .info
+ raise .info
+ text .info.text -width 65 -height 12 -font { Helvetica 10 } -bg white \
+ -tabs { 0.25i }
+ .info.text insert end {
+ This is a more involved example of the new "dnd" command.
+ Run this script again to get another window. You can then drag
+ and drop symbols between the windows by clicking with the left
+ mouse button on a symbol.
+
+ It demonstates how to
+ o Drag-and-drop on specific areas (canvas items) of a widget.
+ o How to receive and handle Enter/Leave/Motion events in the target.
+ o How to send drag feedback to the source.
+ o Use a drag threshold.
+ }
+ button .info.quit -text "Dismiss" -command { destroy .info }
+ blt::table .info \
+ 0,0 .info.text -fill both \
+ 1,0 .info.quit
+}
+
+
+# -----------------------------------------------------------------
+#
+# Setup finished. Start of drag-and-drop code here.
+#
+
+# Set up the entire canvas as a drag&drop source.
+
+dnd register .c -source yes -dragthreshold 5 -button 1
+
+# Register code to pick up the information about a canvas item
+
+dnd getdata .c color GetColor
+
+proc GetColor { widget args } {
+ array set info $args
+ global itemInfo
+ set id $itemInfo($info(timestamp))
+ set color [$widget itemcget $id -fill]
+ set ncoords [llength [$widget coords $id]]
+ if { $ncoords == 6 } {
+ set type triangle
+ } elseif { $ncoords == 8 } {
+ set type parallelogram
+ } elseif { $ncoords == 12 } {
+ set type hexagon
+ } else {
+ error "unknown type n=$ncoords"
+ }
+ return [list $color $type]
+}
+
+dnd configure .c -package PackageSample
+
+proc PackageSample { widget args } {
+ array set info $args
+
+ # Check if we're over a canvas item
+ set items [$widget find overlapping $info(x) $info(y) $info(x) $info(y)]
+ set pickedItem ""
+ foreach i $items {
+ if { [$widget type $i] == "polygon" } {
+ set pickedItem $i
+ break
+ }
+ }
+ if { $pickedItem == "" } {
+ # Cancel the drag
+ puts "Cancel the drag x=$info(x) y=$info(y)"
+ return 0
+ }
+ set fill [$widget itemcget $pickedItem -fill]
+ set outline [$widget itemcget $pickedItem -outline]
+
+ set ncoords [llength [$widget coords $pickedItem]]
+ if { $ncoords == 6 } {
+ set type triangle
+ } elseif { $ncoords == 8 } {
+ set type parallelogram
+ } elseif { $ncoords == 12 } {
+ set type hexagon
+ } else {
+ error "unknown type n=$ncoords"
+ }
+ set tag [ScreenToCell $widget $info(x) $info(y)]
+ $info(token).label configure -background $fill -foreground $outline \
+ -text $type
+ update idletasks
+ update
+ global itemInfo
+ set itemInfo($info(timestamp)) $pickedItem
+ return 1
+}
+
+# Configure a set of animated cursors.
+
+dnd configure .c -cursors {
+ { @bitmaps/hand/hand01.xbm bitmaps/hand/hand01m.xbm black white }
+ { @bitmaps/hand/hand02.xbm bitmaps/hand/hand02m.xbm black white }
+ { @bitmaps/hand/hand03.xbm bitmaps/hand/hand03m.xbm black white }
+ { @bitmaps/hand/hand04.xbm bitmaps/hand/hand04m.xbm black white }
+ { @bitmaps/hand/hand05.xbm bitmaps/hand/hand05m.xbm black white }
+ { @bitmaps/hand/hand06.xbm bitmaps/hand/hand06m.xbm black white }
+ { @bitmaps/hand/hand07.xbm bitmaps/hand/hand07m.xbm black white }
+ { @bitmaps/hand/hand08.xbm bitmaps/hand/hand08m.xbm black white }
+ { @bitmaps/hand/hand09.xbm bitmaps/hand/hand09m.xbm black white }
+ { @bitmaps/hand/hand10.xbm bitmaps/hand/hand10m.xbm black white }
+ { @bitmaps/hand/hand11.xbm bitmaps/hand/hand11m.xbm black white }
+ { @bitmaps/hand/hand12.xbm bitmaps/hand/hand12m.xbm black white }
+ { @bitmaps/hand/hand13.xbm bitmaps/hand/hand13m.xbm black white }
+ { @bitmaps/hand/hand14.xbm bitmaps/hand/hand14m.xbm black white }
+}
+
+# Create a widget to place in the drag-and-drop token
+
+set token [dnd token window .c]
+
+label $token.label -bd 2 -highlightthickness 1
+pack $token.label
+dnd token configure .c \
+ -borderwidth 2 \
+ -relief raised -activerelief raised \
+ -outline pink -fill red \
+ -anchor s
+
+
+dnd configure .c -target yes
+
+dnd setdata .c color {
+ NewObject
+}
+
+proc NewObject { widget args } {
+ array set info $args
+ set tag [ScreenToCell $widget $info(x) $info(y)]
+ global cells
+ if { [info exists cells($tag)] } {
+ error "Cell already exists"
+ }
+ set cells($tag) $info(value)
+ RedrawWorld $widget
+
+}
+
+dnd configure .c -onmotion OnMotion -onenter OnMotion -onleave OnMotion
+
+proc OnMotion { widget args } {
+ global cells lastCell
+
+ array set info $args
+ set tag [ScreenToCell $widget $info(x) $info(y)]
+ if { $lastCell != "" } {
+ $widget itemconfigure $lastCell -fill white -outline "" -width 1 \
+ -stipple ""
+ }
+ # Check that we're not over a canvas item
+ if { ![info exists cells($tag)] } {
+ $widget itemconfigure $tag -outline lightblue -fill lightblue \
+ -width 2 -stipple BLT
+ set lastCell $tag
+ return 1
+ }
+ return 0
+}
+
OSDN Git Service
