source: proiecte/pmake3d/make3d_original/Make3dSingleImageStanford_version0.1/third_party/vrippack-0.31/src/vrip/lib/tk/clrpick.tcl @ 37

Last change on this file since 37 was 37, checked in by (none), 14 years ago

Added original make3d
File size: 19.2 KB
Line 
1# clrpick.tcl --
2#
3#       Color selection dialog for platforms that do not support a
4#       standard color selection dialog.
5#
6# RCS: @(#) $Id: clrpick.tcl,v 1.10 2000/04/04 08:09:24 hobbs Exp $
7#
8# Copyright (c) 1996 Sun Microsystems, Inc.
9#
10# See the file "license.terms" for information on usage and redistribution
11# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12#
13# ToDo:
14#
15#       (1): Find out how many free colors are left in the colormap and
16#            don't allocate too many colors.
17#       (2): Implement HSV color selection.
18#
19
20# tkColorDialog --
21#
22#       Create a color dialog and let the user choose a color. This function
23#       should not be called directly. It is called by the tk_chooseColor
24#       function when a native color selector widget does not exist
25#
26proc tkColorDialog {args} {
27    global tkPriv
28    set w .__tk__color
29    upvar #0 $w data
30
31    # The lines variables track the start and end indices of the line
32    # elements in the colorbar canvases.
33    set data(lines,red,start)   0
34    set data(lines,red,last)   -1
35    set data(lines,green,start) 0
36    set data(lines,green,last) -1
37    set data(lines,blue,start)  0
38    set data(lines,blue,last)  -1
39
40    # This is the actual number of lines that are drawn in each color strip.
41    # Note that the bars may be of any width.
42    # However, NUM_COLORBARS must be a number that evenly divides 256.
43    # Such as 256, 128, 64, etc.
44    set data(NUM_COLORBARS) 8
45
46    # BARS_WIDTH is the number of pixels wide the color bar portion of the
47    # canvas is. This number must be a multiple of NUM_COLORBARS
48    set data(BARS_WIDTH) 128
49
50    # PLGN_WIDTH is the number of pixels wide of the triangular selection
51    # polygon. This also results in the definition of the padding on the
52    # left and right sides which is half of PLGN_WIDTH. Make this number even.
53    set data(PLGN_HEIGHT) 10
54
55    # PLGN_HEIGHT is the height of the selection polygon and the height of the
56    # selection rectangle at the bottom of the color bar. No restrictions.
57    set data(PLGN_WIDTH) 10
58
59    tkColorDialog_Config $w $args
60    tkColorDialog_InitValues $w
61
62    set sc [winfo screen $data(-parent)]
63    set winExists [winfo exists $w]
64    if {!$winExists || [string compare $sc [winfo screen $w]]} {
65        if {$winExists} {
66            destroy $w
67        }
68        toplevel $w -class tkColorDialog -screen $sc
69        tkColorDialog_BuildDialog $w
70    }
71
72    wm transient $w $data(-parent)
73
74    # 5. Withdraw the window, then update all the geometry information
75    # so we know how big it wants to be, then center the window in the
76    # display and de-iconify it.
77
78    ::tk::PlaceWindow $w widget $data(-parent)
79    wm title $w $data(-title)
80
81    # 6. Set a grab and claim the focus too.
82
83    ::tk::SetFocusGrab $w $data(okBtn)
84
85    # 7. Wait for the user to respond, then restore the focus and
86    # return the index of the selected button.  Restore the focus
87    # before deleting the window, since otherwise the window manager
88    # may take the focus away so we can't redirect it.  Finally,
89    # restore any grab that was in effect.
90
91    vwait tkPriv(selectColor)
92    ::tk::RestoreFocusGrab $w $data(okBtn)
93    unset data
94
95    return $tkPriv(selectColor)
96}
97
98# tkColorDialog_InitValues --
99#
100#       Get called during initialization or when user resets NUM_COLORBARS
101#
102proc tkColorDialog_InitValues {w} {
103    upvar #0 $w data
104
105    # IntensityIncr is the difference in color intensity between a colorbar
106    # and its neighbors.
107    set data(intensityIncr) [expr {256 / $data(NUM_COLORBARS)}]
108
109    # ColorbarWidth is the width of each colorbar
110    set data(colorbarWidth) \
111            [expr {$data(BARS_WIDTH) / $data(NUM_COLORBARS)}]
112
113    # Indent is the width of the space at the left and right side of the
114    # colorbar. It is always half the selector polygon width, because the
115    # polygon extends into the space.
116    set data(indent) [expr {$data(PLGN_WIDTH) / 2}]
117
118    set data(colorPad) 2
119    set data(selPad)   [expr {$data(PLGN_WIDTH) / 2}]
120
121    #
122    # minX is the x coordinate of the first colorbar
123    #
124    set data(minX) $data(indent)
125
126    #
127    # maxX is the x coordinate of the last colorbar
128    #
129    set data(maxX) [expr {$data(BARS_WIDTH) + $data(indent)-1}]
130
131    #
132    # canvasWidth is the width of the entire canvas, including the indents
133    #
134    set data(canvasWidth) [expr {$data(BARS_WIDTH) + $data(PLGN_WIDTH)}]
135
136    # Set the initial color, specified by -initialcolor, or the
137    # color chosen by the user the last time.
138    set data(selection) $data(-initialcolor)
139    set data(finalColor)  $data(-initialcolor)
140    set rgb [winfo rgb . $data(selection)]
141
142    set data(red,intensity)   [expr {[lindex $rgb 0]/0x100}]
143    set data(green,intensity) [expr {[lindex $rgb 1]/0x100}]
144    set data(blue,intensity)  [expr {[lindex $rgb 2]/0x100}]
145}
146
147# tkColorDialog_Config  --
148#
149#       Parses the command line arguments to tk_chooseColor
150#
151proc tkColorDialog_Config {w argList} {
152    global tkPriv
153    upvar #0 $w data
154
155    # 1: the configuration specs
156    #
157    if {[info exists tkPriv(selectColor)] && \
158            [string compare $tkPriv(selectColor) ""]} {
159        set defaultColor $tkPriv(selectColor)
160    } else {
161        set defaultColor [. cget -background]
162    }
163
164    set specs [list \
165            [list -initialcolor "" "" $defaultColor] \
166            [list -parent "" "" "."] \
167            [list -title "" "" "Color"] \
168            ]
169
170    # 2: parse the arguments
171    #
172    tclParseConfigSpec $w $specs "" $argList
173
174    if {[string equal $data(-title) ""]} {
175        set data(-title) " "
176    }
177    if {[catch {winfo rgb . $data(-initialcolor)} err]} {
178        error $err
179    }
180
181    if {![winfo exists $data(-parent)]} {
182        error "bad window path name \"$data(-parent)\""
183    }
184}
185
186# tkColorDialog_BuildDialog --
187#
188#       Build the dialog.
189#
190proc tkColorDialog_BuildDialog {w} {
191    upvar #0 $w data
192
193    # TopFrame contains the color strips and the color selection
194    #
195    set topFrame [frame $w.top -relief raised -bd 1]
196
197    # StripsFrame contains the colorstrips and the individual RGB entries
198    set stripsFrame [frame $topFrame.colorStrip]
199
200    foreach c { Red Green Blue } {
201        set color [string tolower $c]
202
203        # each f frame contains an [R|G|B] entry and the equiv. color strip.
204        set f [frame $stripsFrame.$color]
205
206        # The box frame contains the label and entry widget for an [R|G|B]
207        set box [frame $f.box]
208
209        label $box.label -text $c: -width 6 -under 0 -anchor ne
210        entry $box.entry -textvariable [format %s $w]($color,intensity) \
211            -width 4
212        pack $box.label -side left -fill y -padx 2 -pady 3
213        pack $box.entry -side left -anchor n -pady 0
214        pack $box -side left -fill both
215
216        set height [expr \
217            {[winfo reqheight $box.entry] - \
218            2*([$box.entry cget -highlightthickness] + [$box.entry cget -bd])}]
219
220        canvas $f.color -height $height\
221            -width $data(BARS_WIDTH) -relief sunken -bd 2
222        canvas $f.sel -height $data(PLGN_HEIGHT) \
223            -width $data(canvasWidth) -highlightthickness 0
224        pack $f.color -expand yes -fill both
225        pack $f.sel -expand yes -fill both
226
227        pack $f -side top -fill x -padx 0 -pady 2
228
229        set data($color,entry) $box.entry
230        set data($color,col) $f.color
231        set data($color,sel) $f.sel
232
233        bind $data($color,col) <Configure> \
234            [list tkColorDialog_DrawColorScale $w $color 1]
235        bind $data($color,col) <Enter> \
236            [list tkColorDialog_EnterColorBar $w $color]
237        bind $data($color,col) <Leave> \
238            [list tkColorDialog_LeaveColorBar $w $color]
239
240        bind $data($color,sel) <Enter> \
241            [list tkColorDialog_EnterColorBar $w $color]
242        bind $data($color,sel) <Leave> \
243            [list tkColorDialog_LeaveColorBar $w $color]
244
245        bind $box.entry <Return> [list tkColorDialog_HandleRGBEntry $w]
246    }
247
248    pack $stripsFrame -side left -fill both -padx 4 -pady 10
249
250    # The selFrame contains a frame that demonstrates the currently
251    # selected color
252    #
253    set selFrame [frame $topFrame.sel]
254    set lab [label $selFrame.lab -text "Selection:" -under 0 -anchor sw]
255    set ent [entry $selFrame.ent -textvariable [format %s $w](selection) \
256        -width 16]
257    set f1  [frame $selFrame.f1 -relief sunken -bd 2]
258    set data(finalCanvas) [frame $f1.demo -bd 0 -width 100 -height 70]
259
260    pack $lab $ent -side top -fill x -padx 4 -pady 2
261    pack $f1 -expand yes -anchor nw -fill both -padx 6 -pady 10
262    pack $data(finalCanvas) -expand yes -fill both
263
264    bind $ent <Return> [list tkColorDialog_HandleSelEntry $w]
265
266    pack $selFrame -side left -fill none -anchor nw
267    pack $topFrame -side top -expand yes -fill both -anchor nw
268
269    # the botFrame frame contains the buttons
270    #
271    set botFrame [frame $w.bot -relief raised -bd 1]
272    button $botFrame.ok     -text OK            -width 8 -under 0 \
273        -command [list tkColorDialog_OkCmd $w]
274    button $botFrame.cancel -text Cancel        -width 8 -under 0 \
275        -command [list tkColorDialog_CancelCmd $w]
276
277    set data(okBtn)      $botFrame.ok
278    set data(cancelBtn)  $botFrame.cancel
279 
280    pack $botFrame.ok $botFrame.cancel \
281        -padx 10 -pady 10 -expand yes -side left
282    pack $botFrame -side bottom -fill x
283
284
285    # Accelerator bindings
286
287    bind $w <Alt-r> [list focus $data(red,entry)]
288    bind $w <Alt-g> [list focus $data(green,entry)]
289    bind $w <Alt-b> [list focus $data(blue,entry)]
290    bind $w <Alt-s> [list focus $ent]
291    bind $w <KeyPress-Escape> [list tkButtonInvoke $data(cancelBtn)]
292    bind $w <Alt-c> [list tkButtonInvoke $data(cancelBtn)]
293    bind $w <Alt-o> [list tkButtonInvoke $data(okBtn)]
294
295    wm protocol $w WM_DELETE_WINDOW [list tkColorDialog_CancelCmd $w]
296}
297
298# tkColorDialog_SetRGBValue --
299#
300#       Sets the current selection of the dialog box
301#
302proc tkColorDialog_SetRGBValue {w color} {
303    upvar #0 $w data
304
305    set data(red,intensity)   [lindex $color 0]
306    set data(green,intensity) [lindex $color 1]
307    set data(blue,intensity)  [lindex $color 2]
308   
309    tkColorDialog_RedrawColorBars $w all
310
311    # Now compute the new x value of each colorbars pointer polygon
312    foreach color { red green blue } {
313        set x [tkColorDialog_RgbToX $w $data($color,intensity)]
314        tkColorDialog_MoveSelector $w $data($color,sel) $color $x 0
315    }
316}
317
318# tkColorDialog_XToRgb --
319#
320#       Converts a screen coordinate to intensity
321#
322proc tkColorDialog_XToRgb {w x} {
323    upvar #0 $w data
324   
325    return [expr {($x * $data(intensityIncr))/ $data(colorbarWidth)}]
326}
327
328# tkColorDialog_RgbToX
329#
330#       Converts an intensity to screen coordinate.
331#
332proc tkColorDialog_RgbToX {w color} {
333    upvar #0 $w data
334   
335    return [expr {($color * $data(colorbarWidth)/ $data(intensityIncr))}]
336}
337
338
339# tkColorDialog_DrawColorScale --
340#
341#       Draw color scale is called whenever the size of one of the color
342#       scale canvases is changed.
343#
344proc tkColorDialog_DrawColorScale {w c {create 0}} {
345    global lines
346    upvar #0 $w data
347
348    # col: color bar canvas
349    # sel: selector canvas
350    set col $data($c,col)
351    set sel $data($c,sel)
352
353    # First handle the case that we are creating everything for the first time.
354    if {$create} {
355        # First remove all the lines that already exist.
356        if { $data(lines,$c,last) > $data(lines,$c,start)} {
357            for {set i $data(lines,$c,start)} \
358                {$i <= $data(lines,$c,last)} { incr i} {
359                $sel delete $i
360            }
361        }
362        # Delete the selector if it exists
363        if {[info exists data($c,index)]} {
364            $sel delete $data($c,index)
365        }
366       
367        # Draw the selection polygons
368        tkColorDialog_CreateSelector $w $sel $c
369        $sel bind $data($c,index) <ButtonPress-1> \
370                [list tkColorDialog_StartMove $w $sel $c %x $data(selPad) 1]
371        $sel bind $data($c,index) <B1-Motion> \
372                [list tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)]
373        $sel bind $data($c,index) <ButtonRelease-1> \
374                [list tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)]
375
376        set height [winfo height $col]
377        # Create an invisible region under the colorstrip to catch mouse clicks
378        # that aren't on the selector.
379        set data($c,clickRegion) [$sel create rectangle 0 0 \
380                $data(canvasWidth) $height -fill {} -outline {}]
381
382        bind $col <ButtonPress-1> \
383                [list tkColorDialog_StartMove $w $sel $c %x $data(colorPad)]
384        bind $col <B1-Motion> \
385                [list tkColorDialog_MoveSelector $w $sel $c %x $data(colorPad)]
386        bind $col <ButtonRelease-1> \
387                [list tkColorDialog_ReleaseMouse $w $sel $c %x $data(colorPad)]
388
389        $sel bind $data($c,clickRegion) <ButtonPress-1> \
390                [list tkColorDialog_StartMove $w $sel $c %x $data(selPad)]
391        $sel bind $data($c,clickRegion) <B1-Motion> \
392                [list tkColorDialog_MoveSelector $w $sel $c %x $data(selPad)]
393        $sel bind $data($c,clickRegion) <ButtonRelease-1> \
394                [list tkColorDialog_ReleaseMouse $w $sel $c %x $data(selPad)]
395    } else {
396        # l is the canvas index of the first colorbar.
397        set l $data(lines,$c,start)
398    }
399   
400    # Draw the color bars.
401    set highlightW [expr {[$col cget -highlightthickness] + [$col cget -bd]}]
402    for {set i 0} { $i < $data(NUM_COLORBARS)} { incr i} {
403        set intensity [expr {$i * $data(intensityIncr)}]
404        set startx [expr {$i * $data(colorbarWidth) + $highlightW}]
405        if {[string equal $c "red"]} {
406            set color [format "#%02x%02x%02x" \
407                           $intensity \
408                           $data(green,intensity) \
409                           $data(blue,intensity)]
410        } elseif {[string equal $c "green"]} {
411            set color [format "#%02x%02x%02x" \
412                           $data(red,intensity) \
413                           $intensity \
414                           $data(blue,intensity)]
415        } else {
416            set color [format "#%02x%02x%02x" \
417                           $data(red,intensity) \
418                           $data(green,intensity) \
419                           $intensity]
420        }
421
422        if {$create} {
423            set index [$col create rect $startx $highlightW \
424                    [expr {$startx +$data(colorbarWidth)}] \
425                    [expr {[winfo height $col] + $highlightW}]\
426                -fill $color -outline $color]
427        } else {
428            $col itemconfigure $l -fill $color -outline $color
429            incr l
430        }
431    }
432    $sel raise $data($c,index)
433
434    if {$create} {
435        set data(lines,$c,last) $index
436        set data(lines,$c,start) [expr {$index - $data(NUM_COLORBARS) + 1}]
437    }
438
439    tkColorDialog_RedrawFinalColor $w
440}
441
442# tkColorDialog_CreateSelector --
443#
444#       Creates and draws the selector polygon at the position
445#       $data($c,intensity).
446#
447proc tkColorDialog_CreateSelector {w sel c } {
448    upvar #0 $w data
449    set data($c,index) [$sel create polygon \
450        0 $data(PLGN_HEIGHT) \
451        $data(PLGN_WIDTH) $data(PLGN_HEIGHT) \
452        $data(indent) 0]
453    set data($c,x) [tkColorDialog_RgbToX $w $data($c,intensity)]
454    $sel move $data($c,index) $data($c,x) 0
455}
456
457# tkColorDialog_RedrawFinalColor
458#
459#       Combines the intensities of the three colors into the final color
460#
461proc tkColorDialog_RedrawFinalColor {w} {
462    upvar #0 $w data
463
464    set color [format "#%02x%02x%02x" $data(red,intensity) \
465        $data(green,intensity) $data(blue,intensity)]
466   
467    $data(finalCanvas) configure -bg $color
468    set data(finalColor) $color
469    set data(selection) $color
470    set data(finalRGB) [list \
471            $data(red,intensity) \
472            $data(green,intensity) \
473            $data(blue,intensity)]
474}
475
476# tkColorDialog_RedrawColorBars --
477#
478# Only redraws the colors on the color strips that were not manipulated.
479# Params: color of colorstrip that changed. If color is not [red|green|blue]
480#         Then all colorstrips will be updated
481#
482proc tkColorDialog_RedrawColorBars {w colorChanged} {
483    upvar #0 $w data
484
485    switch $colorChanged {
486        red { 
487            tkColorDialog_DrawColorScale $w green
488            tkColorDialog_DrawColorScale $w blue
489        }
490        green {
491            tkColorDialog_DrawColorScale $w red
492            tkColorDialog_DrawColorScale $w blue
493        }
494        blue {
495            tkColorDialog_DrawColorScale $w red
496            tkColorDialog_DrawColorScale $w green
497        }
498        default {
499            tkColorDialog_DrawColorScale $w red
500            tkColorDialog_DrawColorScale $w green
501            tkColorDialog_DrawColorScale $w blue
502        }
503    }
504    tkColorDialog_RedrawFinalColor $w
505}
506
507#----------------------------------------------------------------------
508#                       Event handlers
509#----------------------------------------------------------------------
510
511# tkColorDialog_StartMove --
512#
513#       Handles a mousedown button event over the selector polygon.
514#       Adds the bindings for moving the mouse while the button is
515#       pressed.  Sets the binding for the button-release event.
516#
517# Params: sel is the selector canvas window, color is the color of the strip.
518#
519proc tkColorDialog_StartMove {w sel color x delta {dontMove 0}} {
520    upvar #0 $w data
521
522    if {!$dontMove} {
523        tkColorDialog_MoveSelector $w $sel $color $x $delta
524    }
525}
526
527# tkColorDialog_MoveSelector --
528#
529# Moves the polygon selector so that its middle point has the same
530# x value as the specified x. If x is outside the bounds [0,255],
531# the selector is set to the closest endpoint.
532#
533# Params: sel is the selector canvas, c is [red|green|blue]
534#         x is a x-coordinate.
535#
536proc tkColorDialog_MoveSelector {w sel color x delta} {
537    upvar #0 $w data
538
539    incr x -$delta
540
541    if { $x < 0 } {
542        set x 0
543    } elseif { $x >= $data(BARS_WIDTH)} {
544        set x [expr {$data(BARS_WIDTH) - 1}]
545    }
546    set diff [expr {$x - $data($color,x)}]
547    $sel move $data($color,index) $diff 0
548    set data($color,x) [expr {$data($color,x) + $diff}]
549   
550    # Return the x value that it was actually set at
551    return $x
552}
553
554# tkColorDialog_ReleaseMouse
555#
556# Removes mouse tracking bindings, updates the colorbars.
557#
558# Params: sel is the selector canvas, color is the color of the strip,
559#         x is the x-coord of the mouse.
560#
561proc tkColorDialog_ReleaseMouse {w sel color x delta} {
562    upvar #0 $w data
563
564    set x [tkColorDialog_MoveSelector $w $sel $color $x $delta]
565   
566    # Determine exactly what color we are looking at.
567    set data($color,intensity) [tkColorDialog_XToRgb $w $x]
568
569    tkColorDialog_RedrawColorBars $w $color
570}
571
572# tkColorDialog_ResizeColorbars --
573#
574#       Completely redraws the colorbars, including resizing the
575#       colorstrips
576#
577proc tkColorDialog_ResizeColorBars {w} {
578    upvar #0 $w data
579   
580    if { ($data(BARS_WIDTH) < $data(NUM_COLORBARS)) || 
581         (($data(BARS_WIDTH) % $data(NUM_COLORBARS)) != 0)} {
582        set data(BARS_WIDTH) $data(NUM_COLORBARS)
583    }
584    tkColorDialog_InitValues $w
585    foreach color { red green blue } {
586        $data($color,col) configure -width $data(canvasWidth)
587        tkColorDialog_DrawColorScale $w $color 1
588    }
589}
590
591# tkColorDialog_HandleSelEntry --
592#
593#       Handles the return keypress event in the "Selection:" entry
594#
595proc tkColorDialog_HandleSelEntry {w} {
596    upvar #0 $w data
597
598    set text [string trim $data(selection)]
599    # Check to make sure that the color is valid
600    if {[catch {set color [winfo rgb . $text]} ]} {
601        set data(selection) $data(finalColor)
602        return
603    }
604   
605    set R [expr {[lindex $color 0]/0x100}]
606    set G [expr {[lindex $color 1]/0x100}]
607    set B [expr {[lindex $color 2]/0x100}]
608
609    tkColorDialog_SetRGBValue $w "$R $G $B"
610    set data(selection) $text
611}
612
613# tkColorDialog_HandleRGBEntry --
614#
615#       Handles the return keypress event in the R, G or B entry
616#
617proc tkColorDialog_HandleRGBEntry {w} {
618    upvar #0 $w data
619
620    foreach c {red green blue} {
621        if {[catch {
622            set data($c,intensity) [expr {int($data($c,intensity))}]
623        }]} {
624            set data($c,intensity) 0
625        }
626
627        if {$data($c,intensity) < 0} {
628            set data($c,intensity) 0
629        }
630        if {$data($c,intensity) > 255} {
631            set data($c,intensity) 255
632        }
633    }
634
635    tkColorDialog_SetRGBValue $w "$data(red,intensity) $data(green,intensity) \
636        $data(blue,intensity)"
637}   
638
639# mouse cursor enters a color bar
640#
641proc tkColorDialog_EnterColorBar {w color} {
642    upvar #0 $w data
643
644    $data($color,sel) itemconfig $data($color,index) -fill red
645}
646
647# mouse leaves enters a color bar
648#
649proc tkColorDialog_LeaveColorBar {w color} {
650    upvar #0 $w data
651
652    $data($color,sel) itemconfig $data($color,index) -fill black
653}
654
655# user hits OK button
656#
657proc tkColorDialog_OkCmd {w} {
658    global tkPriv
659    upvar #0 $w data
660
661    set tkPriv(selectColor) $data(finalColor)
662}
663
664# user hits Cancel button
665#
666proc tkColorDialog_CancelCmd {w} {
667    global tkPriv
668
669    set tkPriv(selectColor) ""
670}
671
Note: See TracBrowser for help on using the repository browser.