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

   1 #!../src/bltwish
   2
   3 package require BLT
   4
   5 # --------------------------------------------------------------------------
   6 # Starting with Tcl 8.x, the BLT commands are stored in their own
   7 # namespace called "blt".  The idea is to prevent name clashes with
   8 # Tcl commands and variables from other packages, such as a "table"
   9 # command in two different packages.
  10 #
  11 # You can access the BLT commands in a couple of ways.  You can prefix
  12 # all the BLT commands with the namespace qualifier "blt::"
  13 #
  14 #    blt::graph .g
  15 #    blt::table . .g -resize both
  16 #
  17 # or you can import all the command into the global namespace.
  18 #
  19 #    namespace import blt::*
  20 #    graph .g
  21 #    table . .g -resize both
  22 #
  23 # --------------------------------------------------------------------------
  24 if { $tcl_version >= 8.0 } {
  25     namespace import blt::*
  26     namespace import -force blt::tile::*
  27 }
  28 source scripts/demo.tcl
  29
  30 if { ([info exists tcl_platform]) && ($tcl_platform(platform) == "windows") } {
  31     source scripts/send.tcl
  32     SendInit
  33     SendVerify
  34 }
  35
  36 proc OnEnter { widget args } {
  37     array set info $args
  38     $widget configure -highlightbackground red
  39     return 1
  40 }
  41
  42 proc OnMotion { widget args } {
  43     array set info $args
  44     set x1 [$widget cget -bd]
  45     set x1 20
  46     set y1 $x1
  47     set x2 [expr [winfo width $widget] - $x1]
  48     set y2 [expr [winfo height $widget] - $y1]
  49     if { ($info(x) >= $x1) && ($info(x) <= $x2) &&
  50          ($info(y) >= $y1) && ($info(y) <= $y2) } {
  51         $widget configure -highlightbackground red
  52         return 1
  53     }
  54     $widget configure -highlightbackground grey
  55     return 0
  56 }
  57
  58 proc OnLeave { widget args } {
  59     $widget configure -highlightbackground grey
  60     return 0
  61 }
  62
  63 option add *OnEnter     OnEnter
  64 option add *OnLeave     OnLeave
  65 option add *OnMotion    OnMotion
  66
  67 # ----------------------------------------------------------------------
  68 # This procedure is invoked each time a token is grabbed from the
  69 # sample window.  It configures the token to display the current
  70 # color, and returns the color value that is later passed to the
  71 # target handler.
  72 # ----------------------------------------------------------------------
  73
  74 proc PackageSample { widget args } {
  75     array set info $args
  76     set bg [.sample cget -background]
  77     set fg [.sample cget -foreground]
  78     $info(token).label configure -background $bg -foreground $fg
  79     return 1
  80 }
  81
  82 proc ShowResult { widget args } {
  83     array set info $args
  84     puts "drop transaction($info(timestamp)) completed: result was $info(action)"
  85 }
  86
  87
  88 # ----------------------------------------------------------------------
  89 # Main application window...
  90 # ----------------------------------------------------------------------
  91 image create photo openFolder -format gif -data {
  92 R0lGODdhEAAOAPIAAP///wAAAH9/f9nZ2f//AAAAAAAAAAAAACwAAAAAEAAOAAADOwgqzPoQ
  93 iDjjAoPkIZuTgCZykBCA2ziaXusRrFUGQ5zeRMCcE76xvJBPozuBVCmT0eUKGAHOqFQqqwIS
  94 ADs=
  95     }
  96 label .sample -text "Color" -height 12 -width 20 -bd 2 -relief raised  \
  97     -highlightthickness 2
  98
  99 set cursors {
 100     { @bitmaps/hand/hand01.xbm bitmaps/hand/hand01m.xbm  black white }
 101     { @bitmaps/hand/hand02.xbm bitmaps/hand/hand02m.xbm  black white }
 102     { @bitmaps/hand/hand03.xbm bitmaps/hand/hand03m.xbm  black white }
 103     { @bitmaps/hand/hand04.xbm bitmaps/hand/hand04m.xbm  black white }
 104     { @bitmaps/hand/hand05.xbm bitmaps/hand/hand05m.xbm  black white }
 105     { @bitmaps/hand/hand06.xbm bitmaps/hand/hand06m.xbm  black white }
 106     { @bitmaps/hand/hand07.xbm bitmaps/hand/hand07m.xbm  black white }
 107     { @bitmaps/hand/hand08.xbm bitmaps/hand/hand08m.xbm  black white }
 108     { @bitmaps/hand/hand09.xbm bitmaps/hand/hand09m.xbm  black white }
 109     { @bitmaps/hand/hand10.xbm bitmaps/hand/hand10m.xbm  black white }
 110     { @bitmaps/hand/hand11.xbm bitmaps/hand/hand11m.xbm  black white }
 111     { @bitmaps/hand/hand12.xbm bitmaps/hand/hand12m.xbm  black white }
 112     { @bitmaps/hand/hand13.xbm bitmaps/hand/hand13m.xbm  black white }
 113     { @bitmaps/hand/hand14.xbm bitmaps/hand/hand14m.xbm  black white }
 114 }
 115
 116
 117 # Set up the color sample as a drag&drop source and target for "color" values:
 118 dnd register .sample -source yes -target yes \
 119     -package PackageSample \
 120     -result ShowResult \
 121     -cursors $cursors
 122
 123 dnd getdata .sample color GetColor
 124 dnd setdata .sample color SetColor
 125
 126 # Establish the appearance of the token window:
 127 set token [dnd token window .sample]
 128 label $token.label -text "Color" -bd 2 -highlightthickness 1
 129 pack $token.label
 130 dnd token configure .sample -borderwidth 2 \
 131     -relief raised -activerelief raised  \
 132     -outline pink -fill red \
 133     -anchor s
 134
 135 if 1 {
 136 scale .redScale -label "Red" -orient horizontal \
 137     -from 0 -to 255 -command adjust_color
 138 frame .red -width 20 -height 20 -borderwidth 3 -relief sunken
 139
 140 scale .greenScale -label "Green" -orient horizontal \
 141     -from 0 -to 255 -command adjust_color
 142 frame .green -width 20 -height 20 -borderwidth 3 -relief sunken
 143
 144 scale .blueScale -label "Blue" -orient horizontal \
 145     -from 0 -to 255 -command adjust_color
 146 frame .blue -width 20 -height 20 -borderwidth 3 -relief sunken
 147
 148 # ----------------------------------------------------------------------
 149 # This procedure loads a new color value into this editor.
 150 # ----------------------------------------------------------------------
 151 proc GetColor { widget args } {
 152     return [$widget cget -bg]
 153 }
 154
 155 proc SetColor { widget args } {
 156     array set info $args
 157     set rgb [winfo rgb . $info(value)]
 158     set r [lindex $rgb 0]
 159     set g [lindex $rgb 1]
 160     set b [lindex $rgb 2]
 161
 162     .redScale set [expr round($r/65535.0 * 255)]
 163     .greenScale set [expr round($g/65535.0 * 255)]
 164     .blueScale set [expr round($b/65535.0 * 255)]
 165 }
 166
 167 # ----------------------------------------------------------------------
 168 # This procedure is invoked whenever an RGB slider changes to
 169 # update the color samples in this display.
 170 # ----------------------------------------------------------------------
 171 proc adjust_color {args} {
 172     set rval [.redScale get]
 173     .red configure -background [format "#%.2x0000" $rval]
 174     set gval [.greenScale get]
 175     .green configure -background [format "#00%.2x00" $gval]
 176     set bval [.blueScale get]
 177     .blue configure -background [format "#0000%.2x" $bval]
 178
 179     .sample configure -background \
 180         [format "#%.2x%.2x%.2x" $rval $gval $bval]
 181     if {$rval+$gval+$bval < 1.5*255} {
 182         .sample configure -foreground white
 183     } else {
 184         .sample configure -foreground black
 185     }
 186 }
 187 table . .redScale    1,0 -fill both
 188 table . .red         1,1 -fill both
 189 table . .greenScale  2,0 -fill both
 190 table . .green       2,1 -fill both
 191 table . .blueScale   3,0 -fill both
 192 table . .blue        3,1 -fill both
 193
 194 }
 195 table . .sample      0,0 -columnspan 2 -fill both -pady {0 4}
 196
 197 proc random {{max 1.0} {min 0.0}} {
 198     global randomSeed
 199
 200     set randomSeed [expr (7141*$randomSeed+54773) % 259200]
 201     set num  [expr $randomSeed/259200.0*($max-$min)+$min]
 202     return $num
 203 }
 204 set randomSeed [clock clicks]
 205
 206 .redScale set [expr round([random 255.0])]
 207 .blueScale set [expr round([random 255.0])]
 208 .greenScale set [expr round([random 255.0])]
 209 bind .sample <KeyPress-Escape> { dnd cancel .sample }
 210 focus .sample
 211
 212