1 #*************************************************************************
3 #* NAME : ibrowser.tcl * PROJECT : MARACAS *
4 #* AUTHOR : Leonardo Flórez/Kyron * TYPE : TCL/TK widget def. *
5 #* VERSION : v2.0 * CREATION : 06/05/2001 *
6 #* LANGUAGE : TCL * REVISION : 16/07/2001 *
8 #*************************************************************************
10 #* Description : This file defines a new TCL/TK widget that allows the *
11 #* user to browse a serie of image thumbnails. It has a *
12 #* dinamical scroll bar, so, don't worry about use one. *
14 #* The basic use of this widget is: *
16 #* 1. Create a new widget: "ibrowser <name> <options>" *
17 #* Options given are a list of '-<option> <value>' pairs. *
18 #* Supported options are: *
19 #* +-----------------+--------------------------------------+ *
20 #* | OPTION | DESCRIPTION | *
21 #* +-----------------+--------------------------------------+ *
22 #* | -background | Background color | *
23 #* | -borderwidth | Border width | *
24 #* | -closeenough | Proximity value | *
25 #* +-----------------+--------------------------------------+ *
26 #* | -cache | Indicates if ibrowser must save real | *
28 #* | -cursor | Cursor value | *
29 #* | -fontcolor | Font color | *
30 #* +-----------------+--------------------------------------+ *
31 #* | -gap | Distance between thumbnails | *
32 #* | -height | Height of widget | *
33 #* | -multisel | Allows multiselection | *
34 #* +-----------------+--------------------------------------+ *
35 #* | -primarycolor | Primary selection color | *
36 #* | -relief | Type of border | *
37 #* | -secondarycolor | Secondary selection color | *
38 #* +-----------------+--------------------------------------+ *
39 #* | -takefocus | Indicates if widget have focus | *
40 #* | -thumbheight | Height of thumbnails | *
41 #* | -thumbwidth | Width of thumbnails | *
42 #* +-----------------+--------------------------------------+ *
43 #* | -width | Width of widget | *
44 #* +-----------------+--------------------------------------+ *
46 #* 2. Pack this new widget in your hierarchy: *
47 #* (pack/place/grid) <name> <pack options> *
49 #* 3. Interact with the new widget by using their sub-commands *
50 #* interface. Sub-commands defined are: *
51 #* add, cget, configure, curselection, delete, find, lastimage, *
54 #* 4. Optional: use the <<AfterSelectImage>> event definition to *
55 #* grab mouse interaction. Mouse events supported are: *
56 #* Button1 = Basic single selection *
57 #* Button2 = Multiple selection *
58 #* Button3 = Multiple selection *
59 #* Shift+Button1 = Multiple selection *
61 #*************************************************************************
66 #*************************************************************************
69 #* (NOTE: Please, don't let this file became a mess. ;-) ) *
71 #* +------------+----------------+-------------------------------------+ *
72 #* | DATE | AUTHOR | DESCRIPTION | *
73 #* +------------+----------------+-------------------------------------+ *
74 #* | 06/05/2001 | Kyron | Initial implementation. | *
75 #* +------------+----------------+-------------------------------------+ *
76 #* | 16/07/2001 | Kyron | Documentation & conflicts revision. | *
77 #* +------------+----------------+-------------------------------------+ *
79 #*************************************************************************
81 package require Tk 8.0
83 #* NAMESPACE DESCRIPTION *************************************************
85 #* ::ibrowser (namespace) *
87 #* DESCRIPTION : Global namespace that contains all ibrowser widgets in *
88 #* current interpreter (actual TCL work instance). *
93 #* EXPORTS : proc ibrowser { name options } *
96 #* Namespace components : *
97 #* widgetOptions : list. List of supported options. *
98 #* widgetCommands : list. List of supported sub-commands. *
100 #******************************************************* END DESCRIPTION *
101 package provide ibrowser 2.0
102 namespace eval ::ibrowser {
105 namespace export ibrowser
108 variable widgetOptions
109 variable widgetCommands
113 #* PROCEDURE DESCRIPTION *************************************************
115 #* ::ibrowser::ibrowser (procedure) *
117 #* DESCRIPTION : Creator of new widgets. Call it in an TK hierarchy *
118 #* creation process. *
120 #* SYNTAX : ibrowser <name> -<option1> <value1> ... -<optionn> <valuen> *
122 #* RETURN : New widget name, if success. *
125 #* name : string. Name for the new widget. To use it in a TK widget *
126 #* hierarchy, this name should be ".<f1>.<f2>...<n>" *
128 #******************************************************* END DESCRIPTION *
129 proc ::ibrowser::ibrowser { name args } {
131 # Namespace variables used in this procedure
132 upvar ::ibrowser::widgetOptions widgetOptions
134 # If global namespace doesn't exists yet then initialize it
135 if { ![ info exists widgetOptions ] } { ::ibrowser::initIbrowser }
137 # Given name exists?. If so, raise an error and finish
138 if { [ winfo exists $name ] } {
139 error "Widget \"$name\" already exists."
142 # Create the new command and return success
143 set name [ eval ::ibrowser::buildIbrowser $name $args ]
148 #* PROCEDURE DESCRIPTION *************************************************
150 #* ::ibrowser::initIbrowser (procedure) *
152 #* DESCRIPTION : Initializes the class manager, i.e., creates the global *
154 #* This is a dummy proc, don't call it in your code. *
156 #* SYNTAX : ::ibrowser::initIbrowser *
163 #******************************************************* END DESCRIPTION *
164 proc ::ibrowser::initIbrowser { } {
166 # Namespace variables used in this procedure
167 upvar ::ibrowser::widgetOptions widgetOptions
168 upvar ::ibrowser::widgetCommands widgetCommands
170 # All posible options for the widget
171 array set widgetOptions [ list \
172 -background { background Background } \
173 -borderwidth { borderWidth BorderWidth } \
174 -closeenough { closeEnough CloseEnough } \
175 -cache { cache Thumbnails } \
176 -cursor { cursor Cursor } \
177 -fontcolor { fontColor Thumbnails } \
178 -gap { gap Thumbnails } \
179 -height { height Height } \
180 -multisel { multiSel Thumbnails } \
181 -primarycolor { primaryColor Thumbnails } \
182 -relief { relief Relief } \
183 -secondarycolor { secondaryColor Thumbnails } \
184 -takefocus { takeFocus TakeFocus } \
185 -thumbheight { thumbHeight Thumbnails } \
186 -thumbwidth { thumbWidth Thumbnails } \
187 -width { width Width } \
190 # All posible commands for the widget
191 set widgetCommands [ list \
192 add cget configure curselection \
193 delete find lastimage select \
197 # New event definition
198 event add <<AfterSelectImage>> \
202 <Shift-ButtonPress-1>
204 # Default initialization... only if Tk exists
205 if { [ lsearch -exact [ package names ] "Tk" ] != -1 } {
207 option add *Ibrowser.background #c0c0c0 widgetDefault
208 option add *Ibrowser.borderWidth 0 widgetDefault
209 option add *Ibrowser.closeEnough 1.0 widgetDefault
210 option add *Ibrowser.cache 0 widgetDefault
211 option add *Ibrowser.cursor {} widgetDefault
212 option add *Ibrowser.fontColor #ffff00 widgetDefault
213 option add *Ibrowser.gap 5 widgetDefault
214 option add *Ibrowser.height 100 widgetDefault
215 option add *Ibrowser.multiSel 0 widgetDefault
216 option add *Ibrowser.primaryColor #ff0000 widgetDefault
217 option add *Ibrowser.relief flat widgetDefault
218 option add *Ibrowser.secondaryColor #00ff00 widgetDefault
219 option add *Ibrowser.takeFocus 0 widgetDefault
220 option add *Ibrowser.thumbHeight 50 widgetDefault
221 option add *Ibrowser.thumbWidth 50 widgetDefault
222 option add *Ibrowser.width 100 widgetDefault
226 # set global bindings
227 ::ibrowser::setClassIbrowserBindings
231 #* PROCEDURE DESCRIPTION *************************************************
233 #* ::ibrowser::setClassIbrowserBindings (procedure) *
235 #* DESCRIPTION : Default namespace bindings. *
236 #* This is a dummy proc, don't call it in your code. *
238 #* SYNTAX : ::ibrowser::setClassIbrowserBindings *
245 #******************************************************* END DESCRIPTION *
246 proc ::ibrowser::setClassIbrowserBindings { } {
248 bind Ibrowser <Destroy> [ list ::ibrowser::ibrowserDestroyHandler %W ]
252 #* PROCEDURE DESCRIPTION *************************************************
254 #* ::ibrowser::buildIbrowser (procedure) *
256 #* DESCRIPTION : This does all of the work necessary to create a basic *
257 #* ibrowser widget. Creates a new command (widget) with *
258 #* the given name. Also creates a new namespace as a child *
259 #* namespace of ::ibrowser. *
260 #* This is a dummy proc, don't call it in your code. *
262 #* SYNTAX : set wname [ ::ibrowser::buildIbrowser $name $options ] *
264 #* RETURN : New widget hierarchy name *
267 #* w : string. New widget name. *
268 #* args : list. Option/value pairs list. *
270 #******************************************************* END DESCRIPTION *
271 proc ::ibrowser::buildIbrowser { w args } {
273 # Namespace variables used in this procedure
274 upvar ::ibrowser::widgetOptions widgetOptions
276 # Child namespace. There's one for each defined widget.
277 namespace eval ::ibrowser::$w {
289 # import variables, for programming facilities
290 upvar ::ibrowser::${w}::widgets widgets
291 upvar ::ibrowser::${w}::options options
293 # Main frame that contains an ibrowser
294 set widgets(this) [ \
302 # Canvas that contains all graphical data
303 set widgets(canvas) [ canvas $w.canvas -takefocus 1 ]
305 # Dinamical vertical scroll
306 set widgets(scroll) ""
309 foreach name [ array names widgetOptions ] {
311 set optName [ lindex $widgetOptions($name) 0 ]
312 set optClass [ lindex $widgetOptions($name) 1 ]
313 set value [ option get $w $optName $optClass ]
314 set options($name) $value
319 if { [ llength $args ] > 0 } { array set options $args }
321 # move the name to ibrowser class' namespace...
322 set widgets(frame) ::ibrowser::${w}::$w
323 rename ::$w $widgets(frame)
325 # set canvas options...
326 $widgets(canvas) configure -background $options(-background)
327 $widgets(canvas) configure -borderwidth $options(-borderwidth)
328 $widgets(canvas) configure -closeenough $options(-closeenough)
329 $widgets(canvas) configure -cursor $options(-cursor)
330 $widgets(canvas) configure -height $options(-height)
331 $widgets(canvas) configure -relief $options(-relief)
332 $widgets(canvas) configure -takefocus $options(-takefocus)
333 $widgets(canvas) configure -width $options(-width)
336 pack $widgets(canvas) -fill both -expand 1
338 # local event binding stuff...
339 bind $widgets(canvas) <ButtonPress-1> "::ibrowser::sFImage $widgets(this) %x %y"
340 bind $widgets(canvas) <Shift-ButtonPress-1> "::ibrowser::sLImage $widgets(this) %x %y"
341 bind $widgets(canvas) <ButtonPress-2> "::ibrowser::sLImage $widgets(this) %x %y"
342 bind $widgets(canvas) <ButtonPress-3> "::ibrowser::sLImage $widgets(this) %x %y"
343 bind $widgets(canvas) <Configure> "::ibrowser::resize $widgets(this) %w %h"
345 # >>>>>>>>>>>>>>>>>>> HERE, AT LAST, THE NEW COMMAND IS CREATED <<<<<<<<<<<<<<<<<< #
346 proc ::$w { command args } "eval ::ibrowser::ibrowserWidgetProc $w \$command \$args"
347 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< #
349 # Last configuration stuff
350 if { [ catch "::ibrowser::configureIbrowser $widgets(this) [ array get options ]" error ] } {
362 #* PROCEDURE DESCRIPTION *************************************************
364 #* ::ibrowser::configureIbrowser (procedure) *
366 #* DESCRIPTION : This does the configuration process, i.e., change of *
368 #* This is a dummy proc, don't call it in your code. *
370 #* SYNTAX : set ret [ ::ibrowser::configureIbrowser $widget $options ] *
372 #* RETURN : All options, if args is empty. If length args == 1 then *
373 #* returns current value. Empty string otherwise. *
376 #* w : string. Widget name. *
377 #* args : list. Option/value pairs list. *
379 #******************************************************* END DESCRIPTION *
380 proc ::ibrowser::configureIbrowser { w args } {
382 # For namespace access
383 upvar ::ibrowser::widgetOptions widgetOptions
384 upvar ::ibrowser::${w}::options options
385 upvar ::ibrowser::${w}::widgets widgets
386 upvar ::ibrowser::${w}::currsel currsel
387 upvar ::ibrowser::${w}::lastsel lastsel
388 upvar ::ibrowser::${w}::images images
389 upvar ::ibrowser::${w}::nMaxX nMaxX
391 # Sends all information to the user...
392 if { [ llength $args ] == 0 } {
395 foreach opt [ lsort [ array names widgetOptions ] ] {
397 if { [ llength $widgetOptions($opt) ] == 1 } {
399 set alias $widgetOptions($opt)
400 set optName $widgetOptions($alias)
401 lappend results [ list $opt $optName ]
405 set optName [ lindex $widgetOptions($opt) 0 ]
406 set optClass [ lindex $widgetOptions($opt) 1 ]
407 set default [ option get $w $optName $optClass ]
408 lappend results [ list $opt $optName $optClass $default $options($opt) ]
417 # or single information...
418 if { [ llength $args ] == 1 } {
420 set opt [ ::ibrowser::canonizeIbrowser $w option [ lindex $args 0 ] ]
421 set optName [ lindex $widgetOptions($opt) 0 ]
422 set optClass [ lindex $widgetOptions($opt) 1 ]
423 set default [ option get $w $optName $optClass ]
424 set results [ list $opt $optName $optClass $default $options($opt) ]
429 # check if the list is given in pairs
430 if { [ expr { [ llength $args ] % 2 } ] == 1 } {
431 error "some values for \"$args\" are missing"
434 # check if all given options exists...
435 foreach { name value } $args {
437 set name [ ::ibrowser::canonizeIbrowser $w option $name ]
438 set opts($name) $value
443 foreach option [ array names opts ] {
445 set newValue $opts($option)
450 if { $newValue == 0 || $newValue == 1 } {
451 set options(-cache) $newValue
452 } else { error "\"-cache\" option must be: 0/1" }
457 if { $newValue == 0 || $newValue == 1 } {
458 set options(-multisel) $newValue
459 } else { error "\"-multisel\" option must be: 0/1" }
464 set options(-gap) $newValue
465 set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
466 $options(-thumbwidth) \
473 set options(-width) [ expr $options(-thumbwidth) + $options(-gap) ]
474 set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
475 $options(-thumbwidth) \
480 $widgets(canvas) configure -width $options(-width)
487 set options(-thumbwidth) $newValue
488 set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
489 $options(-thumbwidth) \
496 set options(-width) [ expr $options(-thumbwidth) + $options(-gap) ]
497 set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
498 $options(-thumbwidth) \
503 $widgets(canvas) configure -width $options(-width)
508 -fontcolor { set options(-fontcolor) $newValue }
509 -primarycolor { set options(-primarycolor) $newValue }
510 -secondarycolor { set options(-secondarycolor) $newValue }
511 -thumbheight { set options(-thumbheight) $newValue }
512 default { eval "$widgets(canvas) configure $option $newValue" }
520 #* PROCEDURE DESCRIPTION *************************************************
522 #* ::ibrowser::canonizeIbrowser (procedure) *
524 #* DESCRIPTION : Takes a option or command and canonizes it. Returns *
525 #* either the canonical form of an option or command, or *
526 #* raises an error if the option or command is unknown or *
528 #* This is a dummy proc, don't call it in your code. *
530 #* SYNTAX : set c [ ::ibrowser::canonizeIbrowser $w option $args ] *
532 #* RETURN : Option or command canonical form *
535 #* w : string. Widget name. *
536 #* object : string. option/command id. *
537 #* opt : string. Option/command value. *
539 #******************************************************* END DESCRIPTION *
540 proc ::ibrowser::canonizeIbrowser { w object opt } {
542 # Namespace variables used in this procedure
543 upvar ::ibrowser::widgetOptions widgetOptions
544 upvar ::ibrowser::widgetCommands widgetCommands
550 if { [ lsearch -exact $widgetCommands $opt ] >= 0 } { return $opt }
551 set list $widgetCommands
552 foreach element $list { set tmp($element) "" }
553 set matches [ array names tmp ${opt}* ]
558 if { [ info exists widgetOptions($opt) ] && \
559 [ llength $widgetOptions($opt) ] == 2 \
561 set list [ array names widgetOptions ]
562 set matches [ array names widgetOptions ${opt}* ]
567 if { [ llength $matches ] == 0 } {
568 error "unknown $object \"$opt\"; must be one of $list"
569 } elseif { [ llength $matches ] == 1 } {
571 set opt [ lindex $matches 0 ]
577 set opt [ lindex $matches 0 ]
578 if { [ llength $widgetOptions($opt) ] == 1 } { set opt $widgetOptions($opt) }
585 } else { error "ambiguous $object \"$opt\"; must be one of $list" }
589 #* PROCEDURE DESCRIPTION *************************************************
591 #* ::ibrowser::ibrowserDestroyHandler (procedure) *
593 #* DESCRIPTION : Handles the destroy event. *
594 #* This is a dummy proc, don't call it in your code. *
596 #* SYNTAX : ::ibrowser::ibrowserDestroyHandler $w *
601 #* w : string. Widget name. *
603 #******************************************************* END DESCRIPTION *
604 proc ::ibrowser::ibrowserDestroyHandler { w } {
606 if { [ string compare [ winfo class $w ] "Ibrowser" ] == 0 } {
608 # Namespace variables used in this procedure
609 upvar ::ibrowser::${w}::options options
610 upvar ::ibrowser::${w}::widgets widgets
611 upvar ::ibrowser::${w}::currsel currsel
612 upvar ::ibrowser::${w}::lastsel lastsel
613 upvar ::ibrowser::${w}::images images
614 upvar ::ibrowser::${w}::nMaxX nMaxX
616 # Deletes all images... if any
617 foreach img $images {
619 if { [ lindex $img 1 ] != "" } { image delete [ lindex $img 1 ] }
622 namespace delete ::ibrowser::$w
630 #* PROCEDURE DESCRIPTION *************************************************
632 #* ::ibrowser::ibrowserWidgetProc (procedure) *
634 #* DESCRIPTION : Main procedure. This executes all sub-commands for the *
637 #* SYNTAX : ::ibrowser::ibrowserWidgetProc $widget $command $args *
638 #* This is a dummy proc, don't call it in your code. *
640 #* RETURN : Depends on each sub-command *
643 #* w : string. Widget name. *
644 #* command : string. Sub-command name. *
645 #* args : list. Arguments for sub-command. *
647 #******************************************************* END DESCRIPTION *
648 proc ::ibrowser::ibrowserWidgetProc { w command args } {
651 upvar ::ibrowser::${w}::options options
652 upvar ::ibrowser::${w}::widgets widgets
653 upvar ::ibrowser::${w}::currsel currsel
654 upvar ::ibrowser::${w}::lastsel lastsel
655 upvar ::ibrowser::${w}::images images
656 upvar ::ibrowser::${w}::nMaxX nMaxX
658 # given command exists?
659 set command [ ::ibrowser::canonizeIbrowser $w command $command ]
663 # execute subcommands
666 add { set result [ eval ::ibrowser::addImageIbrowser {$w} $args ] }
667 cget { set result [ eval ::ibrowser::cgetIbrowser {$w} $args ] }
668 configure { set result [ eval ::ibrowser::configureIbrowser {$w} $args ] }
669 curselection { set result [ eval ::ibrowser::curSelectionIbrowser {$w} $args ] }
670 delete { set result [ eval ::ibrowser::deleteImageIbrowser {$w} $args ] }
671 find { set result [ eval ::ibrowser::findImageIbrowser {$w} $args ] }
672 lastimage { set result $lastsel }
673 select { set result [ eval ::ibrowser::selectImageIbrowser {$w} $args ] }
674 size { set result [ llength $images ] }
681 #* PROCEDURE DESCRIPTION *************************************************
683 #* ::ibrowser::addImageIbrowser (procedure) *
685 #* DESCRIPTION : Executes the "add" sub-command. This can add a tkimage, *
686 #* load an image from disk, make references with tags, and *
687 #* gives a title to show with the image. *
688 #* This is a dummy proc, don't call it in your code. *
689 #* Use your widget definition and the sub-command. *
691 #* SYNTAX : set ret [ ::ibrowser::addImageIbrowser $w $args ] *
693 #* ?-image <tkimage>? *
694 #* ?-file <filename> -format <fileformat>? *
696 #* ?-title <title>? *
698 #* RETURN : 0/1 Error/Success *
701 #* w : string. Widget name. *
702 #* args : list. Arguments for sub-command. *
704 #******************************************************* END DESCRIPTION *
705 proc ::ibrowser::addImageIbrowser { w args } {
707 # For namespace access
708 upvar ::ibrowser::${w}::options options
709 upvar ::ibrowser::${w}::widgets widgets
710 upvar ::ibrowser::${w}::currsel currsel
711 upvar ::ibrowser::${w}::lastsel lastsel
712 upvar ::ibrowser::${w}::images images
713 upvar ::ibrowser::${w}::nMaxX nMaxX
716 if { [ llength $args ] % 2 == 0 } {
718 # an associative array is easier...
722 set inds [ array names opt ]
725 if { $ind != "-image" && \
727 $ind != "-format" && \
730 } { error "unknown add option \"$ind\"" }
735 if { [ lsearch -exact $inds "-title" ] != -1 } {
737 } else { set txt "NO_TITLE" }
739 # extract real image...
741 if { [ lsearch -exact $inds "-image" ] != -1 } {
743 } elseif { [ lsearch -exact $inds "-file" ] != -1 && \
744 [ lsearch -exact $inds "-format" ] != -1 \
747 set img [ image create photo -file $opt(-file) -format $opt(-format) ]
750 } else { error "no image to add" }
753 if { [ lsearch -exact $inds "-tags" ] != -1 } {
755 } else { error "\"-tags\" options not found" }
757 # subsample real image and generate thumbnail...
758 set dimX [ image width $img ]
759 set dimY [ image height $img ]
760 set rx [ expr $dimX / $options(-thumbwidth) ]
761 set ry [ expr $dimY / $options(-thumbheight) ]
762 set thumb [ image create photo \
763 -width $options(-thumbwidth) \
764 -height $options(-thumbheight) \
766 if { $rx == 0 || $ry == 0 } {
768 } else { $thumb copy $img -subsample $rx $ry }
770 # add nImg to canvas...
771 set pos [ llength $images ]
772 set px [ expr ( ( $pos % $nMaxX ) * ( $options(-gap) + $options(-thumbwidth) ) ) + \
775 set py [ expr ( ( $pos / $nMaxX ) * ( $options(-gap) + $options(-thumbheight) ) ) + \
779 set id [ $widgets(canvas) create image $px $py \
784 $widgets(canvas) create text $px $py \
786 -fill $options(-fontcolor) \
788 -tags "text_$id text"
791 if { $options(-cache) == 0 } {
793 lappend images [ list $id {} $tags ]
794 if { $img_erase == 1 } { image delete $img }
796 } else { lappend images [ list $id $img $tags ] }
799 } else { error "\"add\" command with incorrect number of arguments \"$args\"" }
805 #* PROCEDURE DESCRIPTION *************************************************
807 #* ::ibrowser::cgetIbrowser (procedure) *
809 #* DESCRIPTION : Executes the "cget" sub-command. Returns information *
810 #* about certain widget option. *
811 #* This is a dummy proc, don't call it in your code. *
812 #* Use your widget definition and the sub-command. *
814 #* SYNTAX : set ret [ ::ibrowser::cgetIbrowser $w $args ] *
815 #* <widget> cget ?-<option>? *
817 #* RETURN : Option value. *
820 #* w : string. Widget name. *
821 #* args : list. Arguments for sub-command. *
823 #******************************************************* END DESCRIPTION *
824 proc ::ibrowser::cgetIbrowser { w args } {
826 # For namespace access
827 upvar ::ibrowser::${w}::options options
828 upvar ::ibrowser::${w}::widgets widgets
829 upvar ::ibrowser::${w}::currsel currsel
830 upvar ::ibrowser::${w}::lastsel lastsel
831 upvar ::ibrowser::${w}::images images
832 upvar ::ibrowser::${w}::nMaxX nMaxX
835 if { [ llength $args ] == 1 } {
837 set opt [ ::ibrowser::canonizeIbrowser $w option $args ]
838 set ret $options($opt)
840 } else { error "\"cget\" command only accepts one argument" }
845 #* PROCEDURE DESCRIPTION *************************************************
847 #* ::ibrowser::curSelectionIbrowser (procedure) *
849 #* DESCRIPTION : Executes the "curselection" sub-command. Returns a list *
850 #* with all selected thumbnails. This list has the format: *
851 #* [ <id tkimage <tags>> ]. *
852 #* This is a dummy proc, don't call it in your code. *
853 #* Use your widget definition and the sub-command. *
855 #* SYNTAX : set ret [ ::ibrowser::curSelectionIbrowser $w $args ] *
856 #* <widget> curselection *
858 #* RETURN : Selected images. *
861 #* w : string. Widget name. *
862 #* args : list. Arguments for sub-command. *
864 #******************************************************* END DESCRIPTION *
865 proc ::ibrowser::curSelectionIbrowser { w args } {
868 upvar ::ibrowser::${w}::options options
869 upvar ::ibrowser::${w}::widgets widgets
870 upvar ::ibrowser::${w}::currsel currsel
871 upvar ::ibrowser::${w}::lastsel lastsel
872 upvar ::ibrowser::${w}::images images
873 upvar ::ibrowser::${w}::nMaxX nMaxX
875 # Get range. To manage this range, the widget uses two rectangles to
876 # show the selection, the range is defined as the first rentangle
877 # (frect) to the last (lrect).
878 set f_id [ $widgets(canvas) find withtag "frect" ]
879 set l_id [ $widgets(canvas) find withtag "lrect" ]
881 set f_id [ lindex [ $widgets(canvas) gettags $f_id ] 1 ]
882 } else { set f_id [ llength $images ] }
884 set l_id [ lindex [ $widgets(canvas) gettags $l_id ] 1 ]
885 } else { set l_id -1 }
889 foreach img $images {
891 if { [ lindex $img 0 ] == $f } { set f $i }
892 if { [ lindex $img 0 ] == $l } { set l $i }
898 set f [ expr ( $f == [ llength $images ] )? $l: $f ]
899 set l [ expr ( $l == -1 )? $f: $l ]
900 set min [ expr ( $f < $l )? $f: $l ]
901 set max [ expr ( $f >= $l )? $f: $l ]
903 # set return variable...
905 for { set i $min } { $i <= $max && $i >= 0 } { incr i } {
907 lappend ret [ lindex $images $i ]
916 #* PROCEDURE DESCRIPTION *************************************************
918 #* ::ibrowser::deleteImageIbrowser (procedure) *
920 #* DESCRIPTION : Executes the "delete" sub-command. Starting from a tag, *
921 #* delete one thumbnail. *
922 #* This is a dummy proc, don't call it in your code. *
923 #* Use your widget definition and the sub-command. *
925 #* SYNTAX : set ret [ ::ibrowser::deleteImageIbrowser $w $args ] *
926 #* <widget> delete -tags <tags> *
931 #* w : string. Widget name. *
932 #* args : list. Arguments for sub-command. *
934 #******************************************************* END DESCRIPTION *
935 proc ::ibrowser::deleteImageIbrowser { w args } {
937 # For namespace access
938 upvar ::ibrowser::${w}::options options
939 upvar ::ibrowser::${w}::widgets widgets
940 upvar ::ibrowser::${w}::currsel currsel
941 upvar ::ibrowser::${w}::lastsel lastsel
942 upvar ::ibrowser::${w}::images images
943 upvar ::ibrowser::${w}::nMaxX nMaxX
945 if { [ llength $args ] % 2 == 0 } {
947 # an associative array is easier...
951 set inds [ array names opt ]
954 if { $ind != "-tags" } { error "unknown delete option \"$ind\"" }
958 # select images to delete
960 if { [ lsearch -exact $inds "-tags" ] != -1 } {
963 foreach img $images {
965 set itags [ lindex $img 2 ]
967 foreach t $itags { if { [ lsearch -exact $tags $t ] != -1 } { incr c } }
968 if { $c == [ llength $tags ] } { lappend del $img }
972 } else { error "\"delete\" subcommand without \"-tags\" option" }
974 # real delete process
975 $widgets(canvas) delete "frect"
976 $widgets(canvas) delete "lrect"
979 # delete from canvas...
980 set ind [ lindex $d 0 ]
981 $widgets(canvas) delete $ind
982 $widgets(canvas) delete "text_$ind"
985 if { [ lindex $d 1 ] != "" } { image delete [ lindex $d 1 ] }
988 set i [ lsearch -exact $images $d ]
989 set images [ lreplace $images $i $i ]
996 } else { error "wrong number of arguments in \"delete\" command" }
1000 #* PROCEDURE DESCRIPTION *************************************************
1002 #* ::ibrowser::findImageIbrowser (procedure) *
1004 #* DESCRIPTION : Executes the "find" sub-command. Starting from a tag, *
1005 #* searchs for thumbnails. Returns a list with images. *
1006 #* [ <id tkimage <tags>> ]. *
1007 #* This is a dummy proc, don't call it in your code. *
1008 #* Use your widget definition and the sub-command. *
1010 #* SYNTAX : set ret [ ::ibrowser::findImageIbrowser $w $args ] *
1011 #* <widget> find -tags <tags> *
1013 #* RETURN : -NONE- *
1016 #* w : string. Widget name. *
1017 #* args : list. Arguments for sub-command. *
1019 #******************************************************* END DESCRIPTION *
1020 proc ::ibrowser::findImageIbrowser { w args } {
1022 # For namespace access
1023 upvar ::ibrowser::${w}::options options
1024 upvar ::ibrowser::${w}::widgets widgets
1025 upvar ::ibrowser::${w}::currsel currsel
1026 upvar ::ibrowser::${w}::lastsel lastsel
1027 upvar ::ibrowser::${w}::images images
1028 upvar ::ibrowser::${w}::nMaxX nMaxX
1031 set tags [ lindex $args 1 ]
1032 if { [ llength $tags ] > 0 } {
1034 foreach img $images {
1036 set itags [ lindex $img 2 ]
1038 # if counter c, equals the number of given tags, then
1039 # actual image is of our interest
1041 foreach t $itags { if { [ lsearch -exact $tags $t ] != -1 } { incr c } }
1042 if { $c == [ llength $tags ] } { lappend ret $img }
1051 #* PROCEDURE DESCRIPTION *************************************************
1053 #* ::ibrowser::selectImageIbrowser (procedure) *
1055 #* DESCRIPTION : Executes the "select" sub-command. Starting from a tag, *
1056 #* selects the first thumbnail. If the -secondary option *
1057 #* is specified, then do a secondary selection *
1058 #* (right mouse button). *
1059 #* This is a dummy proc, don't call it in your code. *
1060 #* Use your widget definition and the sub-command. *
1062 #* SYNTAX : set ret [ ::ibrowser::selectImageIbrowser $w $args ] *
1063 #* <widget> select -tags <tags> ?-secondary? *
1065 #* RETURN : -NONE- *
1068 #* w : string. Widget name. *
1069 #* args : list. Arguments for sub-command. *
1071 #******************************************************* END DESCRIPTION *
1072 proc ::ibrowser::selectImageIbrowser { w args } {
1074 # For namespace access
1075 upvar ::ibrowser::${w}::options options
1076 upvar ::ibrowser::${w}::widgets widgets
1077 upvar ::ibrowser::${w}::currsel currsel
1078 upvar ::ibrowser::${w}::lastsel lastsel
1079 upvar ::ibrowser::${w}::images images
1080 upvar ::ibrowser::${w}::nMaxX nMaxX
1082 # arguments verif...
1084 set l [ llength $args ]
1085 if { $l == 2 || $l == 3 } {
1087 set tind [ lsearch -exact $args "-tags" ]
1088 set prim [ expr ( [ lsearch -exact $args "-secondary" ] != -1 )? 0: 1 ]
1089 if { $tind != -1 } {
1091 set tags [ lindex $args [ expr $tind + 1 ] ]
1092 if { $tags != "" } {
1094 foreach img $images {
1096 set itags [ lindex $img 2 ]
1098 # if counter c, equals the number of given tags, then
1099 # actual image is of our interest
1101 foreach t $itags { if { [ lsearch -exact $tags $t ] != -1 } { incr c } }
1102 if { $c == [ llength $tags ] } {
1104 set ind [ lindex $img 0 ]
1110 if { $prim == 1 } { sFImage $w 0 0 $ind } else { sLImage $w 0 0 $ind }
1116 } else { error "Wrong number of arguments for \"select\" subcommand." }
1120 #* PROCEDURE DESCRIPTION *************************************************
1122 #* ::ibrowser::sFImage (procedure) *
1124 #* DESCRIPTION : Event callback. Mouse left button action. *
1125 #* This is a dummy proc, don't call it in your code. *
1127 #* SYNTAX : ::ibrowser::sFImage %W %x %y $i *
1129 #* RETURN : -NONE- *
1132 #* w : string. Widget name. *
1133 #* x : string. x-coordinate. *
1134 #* y : string. y-coordinate. *
1135 #* i : string. (optional) Image index to select. *
1137 #******************************************************* END DESCRIPTION *
1138 proc ::ibrowser::sFImage { w x y { i -1 } } {
1140 # For namespace access
1141 upvar ::ibrowser::${w}::options options
1142 upvar ::ibrowser::${w}::widgets widgets
1143 upvar ::ibrowser::${w}::currsel currsel
1144 upvar ::ibrowser::${w}::lastsel lastsel
1145 upvar ::ibrowser::${w}::images images
1146 upvar ::ibrowser::${w}::nMaxX nMaxX
1148 # is manual selection?
1151 set ima [ $widgets(canvas) gettags current ]
1152 set i [ $widgets(canvas) find withtag current ]
1154 } else { set ima [ $widgets(canvas) gettags $i ] }
1156 $widgets(canvas) delete "frect"
1159 if { [ string compare [ lindex $ima 0 ] "image" ] == 0 } {
1161 set co [ $widgets(canvas) coords $i ]
1162 set x [ lindex $co 0 ]
1163 set y [ lindex $co 1 ]
1164 set px [ expr $x - $options(-gap) / 2 ]
1165 set py [ expr $y - $options(-gap) / 2 ]
1166 set fx [ expr $px + $options(-thumbwidth) + $options(-gap) / 2 ]
1167 set fy [ expr $py + $options(-thumbheight) + $options(-gap) / 2 ]
1168 $widgets(canvas) create rect $px $py $fx $fy \
1169 -outline $options(-primarycolor) \
1171 -tags "frect $i rects"
1173 set lastsel [ list -1 "" {} ]
1174 foreach img $images {
1176 if { [ lindex $img 0 ] == $i } {
1185 # fire selection event
1186 event generate $widgets(this) <<AfterSelectImage>>
1192 #* PROCEDURE DESCRIPTION *************************************************
1194 #* ::ibrowser::sLImage (procedure) *
1196 #* DESCRIPTION : Event callback. Mouse right button action. *
1197 #* This is a dummy proc, don't call it in your code. *
1199 #* SYNTAX : ::ibrowser::sLImage %W %x %y $i *
1201 #* RETURN : -NONE- *
1204 #* w : string. Widget name. *
1205 #* x : string. x-coordinate. *
1206 #* y : string. y-coordinate. *
1207 #* i : string. (optional) Image index to select. *
1209 #******************************************************* END DESCRIPTION *
1210 proc ::ibrowser::sLImage { w x y { i -1 } } {
1212 # For namespace access
1213 upvar ::ibrowser::${w}::options options
1214 upvar ::ibrowser::${w}::widgets widgets
1215 upvar ::ibrowser::${w}::currsel currsel
1216 upvar ::ibrowser::${w}::lastsel lastsel
1217 upvar ::ibrowser::${w}::images images
1218 upvar ::ibrowser::${w}::nMaxX nMaxX
1220 if { $options(-multisel) == 1 } {
1222 # is manual selection?
1225 set ima [ $widgets(canvas) gettags current ]
1226 set i [ $widgets(canvas) find withtag current ]
1228 } else { set ima [ $widgets(canvas) gettags $i ] }
1231 $widgets(canvas) delete "lrect"
1233 if { [ string compare [ lindex $ima 0 ] "image" ] == 0 } {
1235 set co [ $widgets(canvas) coords $i ]
1236 set x [ lindex $co 0 ]
1237 set y [ lindex $co 1 ]
1238 set px [ expr $x - $options(-gap) / 2 ]
1239 set py [ expr $y - $options(-gap) / 2 ]
1240 set fx [ expr $px + $options(-thumbwidth) + $options(-gap) / 2 ]
1241 set fy [ expr $py + $options(-thumbheight) + $options(-gap) / 2 ]
1242 $widgets(canvas) create rect $px $py $fx $fy \
1243 -outline $options(-secondarycolor) \
1245 -tags "lrect $i rects"
1247 set lastsel [ list -1 "" {} ]
1248 foreach img $images {
1250 if { [ lindex $img 0 ] == $i } {
1259 # fire selection event
1260 event generate $widgets(this) <<AfterSelectImage>>
1268 #* PROCEDURE DESCRIPTION *************************************************
1270 #* ::ibrowser::repos (procedure) *
1272 #* DESCRIPTION : Event callback. Repositionate images. *
1273 #* This is a dummy proc, don't call it in your code. *
1275 #* SYNTAX : ::ibrowser::repos %W *
1277 #* RETURN : -NONE- *
1280 #* w : string. Widget name. *
1282 #******************************************************* END DESCRIPTION *
1283 proc ::ibrowser::repos { w } {
1285 # For namespace access
1286 upvar ::ibrowser::${w}::options options
1287 upvar ::ibrowser::${w}::widgets widgets
1288 upvar ::ibrowser::${w}::currsel currsel
1289 upvar ::ibrowser::${w}::lastsel lastsel
1290 upvar ::ibrowser::${w}::images images
1291 upvar ::ibrowser::${w}::nMaxX nMaxX
1293 set itms [ $widgets(canvas) find withtag "image" ]
1297 set px [ expr ( ( $pos % $nMaxX ) * ( $options(-gap) + $options(-thumbwidth) ) ) + \
1300 set py [ expr ( ( $pos / $nMaxX ) * ( $options(-gap) + $options(-thumbheight) ) ) + \
1303 $widgets(canvas) coords $itm $px $py
1308 set itms [ $widgets(canvas) find withtag "text" ]
1312 set px [ expr ( ( $pos % $nMaxX ) * ( $options(-gap) + $options(-thumbwidth) ) ) + \
1315 set py [ expr ( ( $pos / $nMaxX ) * ( $options(-gap) + $options(-thumbheight) ) ) + \
1318 $widgets(canvas) coords $itm $px $py
1323 set rects [ $widgets(canvas) find withtag "rects" ]
1326 set info [ $widgets(canvas) gettags $r ]
1327 set co [ $widgets(canvas) coords [ lindex $info 1 ] ]
1328 set x [ lindex $co 0 ]
1329 set y [ lindex $co 1 ]
1330 set px [ expr $x - $options(-gap) / 2 ]
1331 set py [ expr $y - $options(-gap) / 2 ]
1332 set fx [ expr $px + $options(-thumbwidth) + $options(-gap) / 2 ]
1333 set fy [ expr $py + $options(-thumbheight) + $options(-gap) / 2 ]
1334 $widgets(canvas) coords $r $px $py $fx $fy
1337 ::ibrowser::configureSlider $w
1341 #* PROCEDURE DESCRIPTION *************************************************
1343 #* ::ibrowser::resize (procedure) *
1345 #* DESCRIPTION : Event callback. Resize widget. *
1346 #* This is a dummy proc, don't call it in your code. *
1348 #* SYNTAX : ::ibrowser::resize %W %w %h *
1350 #* RETURN : -NONE- *
1353 #* w : string. Widget name. *
1354 #* width : string. Widget width. *
1355 #* height : string. Widget height. *
1357 #******************************************************* END DESCRIPTION *
1358 proc ::ibrowser::resize { w width height } {
1360 # For namespace access
1361 upvar ::ibrowser::${w}::options options
1362 upvar ::ibrowser::${w}::widgets widgets
1363 upvar ::ibrowser::${w}::currsel currsel
1364 upvar ::ibrowser::${w}::lastsel lastsel
1365 upvar ::ibrowser::${w}::images images
1366 upvar ::ibrowser::${w}::nMaxX nMaxX
1368 if { $options(-width) != $width || $options(-height) != $height } {
1370 set options(-width) $width
1371 set options(-height) $height
1372 set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
1373 $options(-thumbwidth) \
1378 if { $nMaxX == 0 } {
1380 set options(-width) [ expr $options(-thumbwidth) + $options(-gap) ]
1381 set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
1382 $options(-thumbwidth) \
1387 $widgets(canvas) configure -width $options(-width)
1390 ::ibrowser::repos $w
1397 #* PROCEDURE DESCRIPTION *************************************************
1399 #* ::ibrowser::configureSlider (procedure) *
1401 #* DESCRIPTION : Puts or erases a slider, if necessary. *
1402 #* This is a dummy proc, don't call it in your code. *
1404 #* SYNTAX : ::ibrowser::configureSlider $widget *
1406 #* RETURN : -NONE- *
1409 #* w : string. Widget name. *
1411 #******************************************************* END DESCRIPTION *
1412 proc ::ibrowser::configureSlider { w } {
1414 # For namespace access
1415 upvar ::ibrowser::${w}::options options
1416 upvar ::ibrowser::${w}::widgets widgets
1417 upvar ::ibrowser::${w}::currsel currsel
1418 upvar ::ibrowser::${w}::lastsel lastsel
1419 upvar ::ibrowser::${w}::images images
1420 upvar ::ibrowser::${w}::nMaxX nMaxX
1422 set s [ llength $images ]
1423 set y [ expr ceil ( $s.0 / $nMaxX.0 ) ]
1424 set need [ expr $y * ( $options(-thumbheight) + $options(-gap) ) + $options(-gap) ]
1425 set rh $options(-height)
1427 $widgets(canvas) configure -scrollregion "0 0 $options(-width) $need"
1428 if { $need >= $rh && ! [ winfo exists $w.scroll ] } {
1430 set widgets(scroll) [ scrollbar $w.scroll -command "$widgets(canvas) yview" ]
1431 $widgets(canvas) configure -yscrollcommand "$widgets(scroll) set"
1432 grid $widgets(canvas) \
1433 -in $widgets(this) \
1439 grid $widgets(scroll) -row 0 -column 1 -rowspan 1 -columnspan 1 -sticky news
1440 grid rowconfig $widgets(this) 0 -weight 1 -minsize 0
1441 grid columnconfig $widgets(this) 0 -weight 1 -minsize 0
1443 } elseif { $need < $rh && [ winfo exists $w.scroll ] } {
1445 $widgets(canvas) configure -yscrollcommand ""
1447 set widgets(scroll) ""
1453 # EOF - ibrowser.tcl