lib/maracasVisuLib/src/interface/tcl/tkwidgets/ibrowser.tcl

   1 #*************************************************************************
   2 #*                                  *                                    *
   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              *
   7 #*                                  *                                    *
   8 #*************************************************************************
   9 #*                                                                       *
  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.   *
  13 #*                                                                       *
  14 #*  The basic use of this widget is:                                     *
  15 #*                                                                       *
  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 |    *
  27 #*         |                 | images.                              |    *
  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 #*         +-----------------+--------------------------------------+    *
  45 #*                                                                       *
  46 #*      2. Pack this new widget in your hierarchy:                       *
  47 #*         (pack/place/grid) <name> <pack options>                       *
  48 #*                                                                       *
  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,  *
  52 #*         select, size.                                                 *
  53 #*                                                                       *
  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                           *
  60 #*                                                                       *
  61 #*************************************************************************
  62 #*                                                                       *
  63 #*  USED MODULES :                                                       *
  64 #*                     TK >= v8.0                                        *
  65 #*                                                                       *
  66 #*************************************************************************
  67 #*                                                                       *
  68 #* REVISIONS :                                                           *
  69 #* (NOTE: Please, don't let this file became a mess. ;-) )               *
  70 #*                                                                       *
  71 #* +------------+----------------+-------------------------------------+ *
  72 #* | DATE       | AUTHOR         | DESCRIPTION                         | *
  73 #* +------------+----------------+-------------------------------------+ *
  74 #* | 06/05/2001 | Kyron          | Initial implementation.             | *
  75 #* +------------+----------------+-------------------------------------+ *
  76 #* | 16/07/2001 | Kyron          | Documentation & conflicts revision. | *
  77 #* +------------+----------------+-------------------------------------+ *
  78 #*                                                                       *
  79 #*************************************************************************
  80
  81 package require Tk 8.0
  82
  83 #* NAMESPACE DESCRIPTION *************************************************
  84 #*                                                                       *
  85 #* ::ibrowser (namespace)                                                *
  86 #*                                                                       *
  87 #* DESCRIPTION : Global namespace that contains all ibrowser widgets in  *
  88 #*               current interpreter (actual TCL work instance).         *
  89 #*                                                                       *
  90 #* SYNTAX : -NONE-                                                       *
  91 #*                                                                       *
  92 #* RETURN :                                                              *
  93 #*        EXPORTS : proc ibrowser { name options }                       *
  94 #*                                                                       *
  95 #* PARAMETERS :                                                          *
  96 #*            Namespace components :                                     *
  97 #*              widgetOptions  : list. List of supported options.        *
  98 #*              widgetCommands : list. List of supported sub-commands.   *
  99 #*                                                                       *
 100 #******************************************************* END DESCRIPTION *
 101 package provide ibrowser 2.0
 102 namespace eval ::ibrowser {
 103
 104     # public interface
 105     namespace export ibrowser
 106
 107     # variables
 108     variable widgetOptions
 109     variable widgetCommands
 110
 111 }
 112
 113 #* PROCEDURE DESCRIPTION *************************************************
 114 #*                                                                       *
 115 #* ::ibrowser::ibrowser (procedure)                                      *
 116 #*                                                                       *
 117 #* DESCRIPTION : Creator of new widgets. Call it in an TK hierarchy      *
 118 #*               creation process.                                       *
 119 #*                                                                       *
 120 #* SYNTAX : ibrowser <name> -<option1> <value1> ... -<optionn> <valuen>  *
 121 #*                                                                       *
 122 #* RETURN : New widget name, if success.                                 *
 123 #*                                                                       *
 124 #* PARAMETERS :                                                          *
 125 #*      name : string. Name for the new widget. To use it in a TK widget *
 126 #*                     hierarchy, this name should be ".<f1>.<f2>...<n>" *
 127 #*                                                                       *
 128 #******************************************************* END DESCRIPTION *
 129 proc ::ibrowser::ibrowser { name args } {
 130
 131     # Namespace variables used in this procedure
 132     upvar ::ibrowser::widgetOptions widgetOptions
 133
 134     # If global namespace doesn't exists yet then initialize it
 135     if { ![ info exists widgetOptions ] } { ::ibrowser::initIbrowser }
 136
 137     # Given name exists?. If so, raise an error and finish
 138     if { [ winfo exists $name ] } {
 139         error "Widget \"$name\" already exists."
 140     }
 141
 142     # Create the new command and return success
 143     set name [ eval ::ibrowser::buildIbrowser $name $args ]
 144     return $name
 145
 146 }
 147
 148 #* PROCEDURE DESCRIPTION *************************************************
 149 #*                                                                       *
 150 #* ::ibrowser::initIbrowser (procedure)                                  *
 151 #*                                                                       *
 152 #* DESCRIPTION : Initializes the class manager, i.e., creates the global *
 153 #*               namespace.                                              *
 154 #*               This is a dummy proc, don't call it in your code.       *
 155 #*                                                                       *
 156 #* SYNTAX : ::ibrowser::initIbrowser                                     *
 157 #*                                                                       *
 158 #* RETURN : -NONE-                                                       *
 159 #*                                                                       *
 160 #* PARAMETERS :                                                          *
 161 #*      -NONE-                                                           *
 162 #*                                                                       *
 163 #******************************************************* END DESCRIPTION *
 164 proc ::ibrowser::initIbrowser { } {
 165
 166     # Namespace variables used in this procedure
 167     upvar ::ibrowser::widgetOptions  widgetOptions
 168     upvar ::ibrowser::widgetCommands widgetCommands
 169
 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       } \
 188     ]
 189
 190     # All posible commands for the widget
 191     set widgetCommands [ list                    \
 192         add     cget    configure   curselection \
 193         delete  find    lastimage   select       \
 194         size                                     \
 195     ]
 196
 197     # New event definition
 198     event add <<AfterSelectImage>> \
 199         <ButtonPress-1>            \
 200         <ButtonPress-2>            \
 201         <ButtonPress-3>            \
 202         <Shift-ButtonPress-1>
 203
 204     # Default initialization... only if Tk exists
 205     if { [ lsearch -exact [ package names ] "Tk" ] != -1 } {
 206
 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
 223
 224     }
 225
 226     # set global bindings
 227     ::ibrowser::setClassIbrowserBindings
 228
 229 }
 230
 231 #* PROCEDURE DESCRIPTION *************************************************
 232 #*                                                                       *
 233 #* ::ibrowser::setClassIbrowserBindings (procedure)                      *
 234 #*                                                                       *
 235 #* DESCRIPTION : Default namespace bindings.                             *
 236 #*               This is a dummy proc, don't call it in your code.       *
 237 #*                                                                       *
 238 #* SYNTAX : ::ibrowser::setClassIbrowserBindings                         *
 239 #*                                                                       *
 240 #* RETURN : -NONE-                                                       *
 241 #*                                                                       *
 242 #* PARAMETERS :                                                          *
 243 #*      -NONE-                                                           *
 244 #*                                                                       *
 245 #******************************************************* END DESCRIPTION *
 246 proc ::ibrowser::setClassIbrowserBindings { } {
 247
 248     bind Ibrowser <Destroy> [ list ::ibrowser::ibrowserDestroyHandler %W ]
 249
 250 }
 251
 252 #* PROCEDURE DESCRIPTION *************************************************
 253 #*                                                                       *
 254 #* ::ibrowser::buildIbrowser (procedure)                                 *
 255 #*                                                                       *
 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.       *
 261 #*                                                                       *
 262 #* SYNTAX : set wname [ ::ibrowser::buildIbrowser $name $options ]       *
 263 #*                                                                       *
 264 #* RETURN : New widget hierarchy name                                    *
 265 #*                                                                       *
 266 #* PARAMETERS :                                                          *
 267 #*      w    : string. New widget name.                                  *
 268 #*      args : list. Option/value pairs list.                            *
 269 #*                                                                       *
 270 #******************************************************* END DESCRIPTION *
 271 proc ::ibrowser::buildIbrowser { w args } {
 272
 273     # Namespace variables used in this procedure
 274     upvar ::ibrowser::widgetOptions widgetOptions
 275
 276     # Child namespace. There's one for each defined widget.
 277     namespace eval ::ibrowser::$w {
 278
 279         variable this
 280         variable options
 281         variable widgets
 282         variable currsel {}
 283         variable lastsel {}
 284         variable images  {}
 285         variable nMaxX   0
 286
 287     }
 288
 289     # import variables, for programming facilities
 290     upvar ::ibrowser::${w}::widgets widgets
 291     upvar ::ibrowser::${w}::options options
 292
 293     # Main frame that contains an ibrowser
 294     set widgets(this) [     \
 295         frame $w            \
 296             -class Ibrowser \
 297             -takefocus 0    \
 298             -relief flat    \
 299             -borderwidth 0  \
 300     ]
 301
 302     # Canvas that contains all graphical data
 303     set widgets(canvas) [ canvas $w.canvas -takefocus 1 ]
 304
 305     # Dinamical vertical scroll
 306     set widgets(scroll) ""
 307
 308     # Set default values
 309     foreach name [ array names widgetOptions ] {
 310
 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
 315
 316     }
 317
 318     # set user values...
 319     if { [ llength $args ] > 0 } { array set options $args }
 320
 321     # move the name to ibrowser class' namespace...
 322     set widgets(frame) ::ibrowser::${w}::$w
 323     rename ::$w $widgets(frame)
 324
 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)
 334
 335     # pack the canvas...
 336     pack $widgets(canvas) -fill both -expand 1
 337
 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"
 344
 345     # >>>>>>>>>>>>>>>>>>> HERE, AT LAST, THE NEW COMMAND IS CREATED <<<<<<<<<<<<<<<<<< #
 346     proc ::$w { command args } "eval ::ibrowser::ibrowserWidgetProc $w \$command \$args"
 347     # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< #
 348
 349     # Last configuration stuff
 350     if { [ catch "::ibrowser::configureIbrowser $widgets(this) [ array get options ]" error ] } {
 351
 352         catch { destroy $w }
 353         error $error
 354
 355     }
 356
 357     # have fun ;-)
 358     return ""
 359
 360 }
 361
 362 #* PROCEDURE DESCRIPTION *************************************************
 363 #*                                                                       *
 364 #* ::ibrowser::configureIbrowser (procedure)                             *
 365 #*                                                                       *
 366 #* DESCRIPTION : This does the configuration process, i.e., change of    *
 367 #*               any option.                                             *
 368 #*               This is a dummy proc, don't call it in your code.       *
 369 #*                                                                       *
 370 #* SYNTAX : set ret [ ::ibrowser::configureIbrowser $widget $options ]   *
 371 #*                                                                       *
 372 #* RETURN : All options, if args is empty. If length args == 1 then      *
 373 #*          returns current value. Empty string otherwise.               *
 374 #*                                                                       *
 375 #* PARAMETERS :                                                          *
 376 #*      w    : string. Widget name.                                      *
 377 #*      args : list. Option/value pairs list.                            *
 378 #*                                                                       *
 379 #******************************************************* END DESCRIPTION *
 380 proc ::ibrowser::configureIbrowser { w args } {
 381
 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
 390
 391     # Sends all information to the user...
 392     if { [ llength $args ] == 0 } {
 393
 394         set results {}
 395         foreach opt [ lsort [ array names widgetOptions ] ] {
 396
 397             if { [ llength $widgetOptions($opt) ] == 1 } {
 398
 399                 set alias $widgetOptions($opt)
 400                 set optName $widgetOptions($alias)
 401                 lappend results [ list $opt $optName ]
 402
 403             } else {
 404
 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) ]
 409
 410             }
 411
 412         }
 413         return $results
 414
 415     }
 416
 417     # or single information...
 418     if { [ llength $args ] == 1 } {
 419
 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) ]
 425         return $results
 426
 427     }
 428
 429     # check if the list is given in pairs
 430     if { [ expr { [ llength $args ] % 2 } ] == 1 } {
 431         error "some values for \"$args\" are missing"
 432     }
 433
 434     # check if all given options exists...
 435     foreach { name value } $args {
 436
 437         set name [ ::ibrowser::canonizeIbrowser $w option $name ]
 438         set opts($name) $value
 439
 440     }
 441
 442     # and set values...
 443     foreach option [ array names opts ] {
 444
 445         set newValue $opts($option)
 446         switch -- $option {
 447
 448             -cache {
 449
 450                 if { $newValue == 0 || $newValue == 1 } {
 451                     set options(-cache) $newValue
 452                 } else { error "\"-cache\" option must be: 0/1" }
 453
 454             }
 455             -multisel {
 456
 457                 if { $newValue == 0 || $newValue == 1 } {
 458                     set options(-multisel) $newValue
 459                 } else { error "\"-multisel\" option must be: 0/1" }
 460
 461             }
 462             -gap {
 463
 464                 set options(-gap) $newValue
 465                 set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
 466                                                                    $options(-thumbwidth) \
 467                                                                  ) \
 468                                             ) \
 469                                     ) \
 470                 ]
 471                 if { $nMaxX == 0 } {
 472
 473                     set options(-width) [ expr $options(-thumbwidth) + $options(-gap) ]
 474                     set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
 475                                                                        $options(-thumbwidth) \
 476                                                                      ) \
 477                                                 ) \
 478                                         ) \
 479                     ]
 480                     $widgets(canvas) configure -width $options(-width)
 481
 482                 }
 483
 484             }
 485             -thumbwidth {
 486
 487                 set options(-thumbwidth) $newValue
 488                 set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
 489                                                                    $options(-thumbwidth) \
 490                                                                  ) \
 491                                             ) \
 492                                     ) \
 493                 ]
 494                 if { $nMaxX == 0 } {
 495
 496                     set options(-width) [ expr $options(-thumbwidth) + $options(-gap) ]
 497                     set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
 498                                                                        $options(-thumbwidth) \
 499                                                                      ) \
 500                                                 ) \
 501                                         ) \
 502                     ]
 503                     $widgets(canvas) configure -width $options(-width)
 504
 505                 }
 506
 507             }
 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" }
 513
 514         }
 515
 516     }
 517
 518 }
 519
 520 #* PROCEDURE DESCRIPTION *************************************************
 521 #*                                                                       *
 522 #* ::ibrowser::canonizeIbrowser (procedure)                              *
 523 #*                                                                       *
 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  *
 527 #*               ambiguous.                                              *
 528 #*               This is a dummy proc, don't call it in your code.       *
 529 #*                                                                       *
 530 #* SYNTAX : set c [ ::ibrowser::canonizeIbrowser $w option $args ]       *
 531 #*                                                                       *
 532 #* RETURN : Option or command canonical form                             *
 533 #*                                                                       *
 534 #* PARAMETERS :                                                          *
 535 #*      w      : string. Widget name.                                    *
 536 #*      object : string. option/command id.                              *
 537 #*      opt    : string. Option/command value.                           *
 538 #*                                                                       *
 539 #******************************************************* END DESCRIPTION *
 540 proc ::ibrowser::canonizeIbrowser { w object opt } {
 541
 542     # Namespace variables used in this procedure
 543     upvar ::ibrowser::widgetOptions  widgetOptions
 544     upvar ::ibrowser::widgetCommands widgetCommands
 545
 546     switch $object {
 547
 548         command {
 549
 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}* ]
 554
 555         }
 556         option {
 557
 558             if { [ info exists widgetOptions($opt) ] && \
 559                  [ llength $widgetOptions($opt) ] == 2 \
 560             } { return $opt }
 561             set list [ array names widgetOptions ]
 562             set matches [ array names widgetOptions ${opt}* ]
 563
 564         }
 565
 566     }
 567     if { [ llength $matches ] == 0 } {
 568         error "unknown $object \"$opt\"; must be one of $list"
 569     } elseif { [ llength $matches ] == 1 } {
 570
 571         set opt [ lindex $matches 0 ]
 572
 573         switch $object {
 574
 575             option {
 576
 577                 set opt [ lindex $matches 0 ]
 578                 if { [ llength $widgetOptions($opt) ] == 1 } { set opt $widgetOptions($opt) }
 579
 580             }
 581
 582         }
 583         return $opt
 584
 585     } else { error "ambiguous $object \"$opt\"; must be one of $list" }
 586
 587 }
 588
 589 #* PROCEDURE DESCRIPTION *************************************************
 590 #*                                                                       *
 591 #* ::ibrowser::ibrowserDestroyHandler (procedure)                        *
 592 #*                                                                       *
 593 #* DESCRIPTION : Handles the destroy event.                              *
 594 #*               This is a dummy proc, don't call it in your code.       *
 595 #*                                                                       *
 596 #* SYNTAX : ::ibrowser::ibrowserDestroyHandler $w                        *
 597 #*                                                                       *
 598 #* RETURN : -NONE-                                                       *
 599 #*                                                                       *
 600 #* PARAMETERS :                                                          *
 601 #*      w      : string. Widget name.                                    *
 602 #*                                                                       *
 603 #******************************************************* END DESCRIPTION *
 604 proc ::ibrowser::ibrowserDestroyHandler { w } {
 605
 606     if { [ string compare [ winfo class $w ] "Ibrowser" ] == 0 } {
 607
 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
 615
 616         # Deletes all images... if any
 617         foreach img $images {
 618
 619             if { [ lindex $img 1 ] != "" } { image delete [ lindex $img 1 ] }
 620
 621         }
 622         namespace delete ::ibrowser::$w
 623         rename $w {}
 624
 625     }
 626     return ""
 627
 628 }
 629
 630 #* PROCEDURE DESCRIPTION *************************************************
 631 #*                                                                       *
 632 #* ::ibrowser::ibrowserWidgetProc (procedure)                            *
 633 #*                                                                       *
 634 #* DESCRIPTION : Main procedure. This executes all sub-commands for the  *
 635 #*               actual widget.                                          *
 636 #*                                                                       *
 637 #* SYNTAX : ::ibrowser::ibrowserWidgetProc $widget $command $args        *
 638 #*               This is a dummy proc, don't call it in your code.       *
 639 #*                                                                       *
 640 #* RETURN : Depends on each sub-command                                  *
 641 #*                                                                       *
 642 #* PARAMETERS :                                                          *
 643 #*      w       : string. Widget name.                                   *
 644 #*      command : string. Sub-command name.                              *
 645 #*      args    : list. Arguments for sub-command.                       *
 646 #*                                                                       *
 647 #******************************************************* END DESCRIPTION *
 648 proc ::ibrowser::ibrowserWidgetProc { w command args } {
 649
 650     # guess... ;-)
 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
 657
 658     # given command exists?
 659     set command [ ::ibrowser::canonizeIbrowser $w command $command ]
 660
 661     set result {}
 662
 663     # execute subcommands
 664     switch $command {
 665
 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 ] }
 675
 676     }
 677     return $result;
 678
 679 }
 680
 681 #* PROCEDURE DESCRIPTION *************************************************
 682 #*                                                                       *
 683 #* ::ibrowser::addImageIbrowser (procedure)                              *
 684 #*                                                                       *
 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.         *
 690 #*                                                                       *
 691 #* SYNTAX : set ret [ ::ibrowser::addImageIbrowser $w $args ]            *
 692 #*          <widget> add                                                 *
 693 #*                       ?-image <tkimage>?                              *
 694 #*                       ?-file <filename> -format <fileformat>?         *
 695 #*                       ?-tags <tags>?                                  *
 696 #*                       ?-title <title>?                                *
 697 #*                                                                       *
 698 #* RETURN : 0/1 Error/Success                                            *
 699 #*                                                                       *
 700 #* PARAMETERS :                                                          *
 701 #*      w    : string. Widget name.                                      *
 702 #*      args : list. Arguments for sub-command.                          *
 703 #*                                                                       *
 704 #******************************************************* END DESCRIPTION *
 705 proc ::ibrowser::addImageIbrowser { w args } {
 706
 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
 714
 715     set ret -1
 716     if { [ llength $args ] % 2 == 0 } {
 717
 718         # an associative array is easier...
 719         array set opt $args
 720
 721         # look at options...
 722         set inds [ array names opt ]
 723         foreach ind $inds {
 724
 725             if { $ind != "-image"  && \
 726                  $ind != "-file"   && \
 727                  $ind != "-format" && \
 728                  $ind != "-tags"   && \
 729                  $ind != "-title"     \
 730             } { error "unknown add option \"$ind\"" }
 731
 732         }
 733
 734         # set up title...
 735         if { [ lsearch -exact $inds "-title" ] != -1 } {
 736         set txt $opt(-title)
 737         } else { set txt "NO_TITLE" }
 738
 739         # extract real image...
 740         set img_erase 0
 741         if { [ lsearch -exact $inds "-image" ] != -1 } {
 742         set img $opt(-image)
 743         } elseif { [ lsearch -exact $inds "-file" ] != -1 && \
 744                    [ lsearch -exact $inds "-format" ] != -1  \
 745         } {
 746
 747             set img [ image create photo -file $opt(-file) -format $opt(-format) ]
 748             set img_erase 1
 749
 750         } else { error "no image to add" }
 751
 752         # get tags...
 753         if { [ lsearch -exact $inds "-tags" ] != -1 } {
 754         set tags $opt(-tags)
 755         } else { error "\"-tags\" options not found" }
 756
 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) \
 765         ]
 766         if { $rx == 0 || $ry == 0 } {
 767         $thumb copy $img
 768         } else { $thumb copy $img -subsample $rx $ry }
 769
 770         # add nImg to canvas...
 771         set pos [ llength $images ]
 772         set px  [ expr ( ( $pos % $nMaxX ) * ( $options(-gap) + $options(-thumbwidth) ) ) + \
 773                          $options(-gap)
 774         ]
 775         set py  [ expr ( ( $pos / $nMaxX ) * ( $options(-gap) + $options(-thumbheight) ) ) + \
 776                          $options(-gap)
 777         ]
 778
 779         set id [ $widgets(canvas) create image $px $py \
 780             -image $thumb \
 781             -anchor nw \
 782             -tags "image"
 783         ]
 784         $widgets(canvas) create text $px $py \
 785             -text $txt \
 786             -fill $options(-fontcolor) \
 787             -anchor nw \
 788             -tags "text_$id text"
 789
 790         # add image data...
 791         if { $options(-cache) == 0 } {
 792
 793             lappend images [ list $id {} $tags ]
 794             if { $img_erase == 1 } { image delete $img }
 795
 796         } else { lappend images [ list $id $img $tags ] }
 797         repos $w
 798
 799     } else { error "\"add\" command with incorrect number of arguments \"$args\"" }
 800
 801     return "1"
 802
 803 }
 804
 805 #* PROCEDURE DESCRIPTION *************************************************
 806 #*                                                                       *
 807 #* ::ibrowser::cgetIbrowser (procedure)                                  *
 808 #*                                                                       *
 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.         *
 813 #*                                                                       *
 814 #* SYNTAX : set ret [ ::ibrowser::cgetIbrowser $w $args ]                *
 815 #*          <widget> cget ?-<option>?                                    *
 816 #*                                                                       *
 817 #* RETURN : Option value.                                                *
 818 #*                                                                       *
 819 #* PARAMETERS :                                                          *
 820 #*      w    : string. Widget name.                                      *
 821 #*      args : list. Arguments for sub-command.                          *
 822 #*                                                                       *
 823 #******************************************************* END DESCRIPTION *
 824 proc ::ibrowser::cgetIbrowser { w args } {
 825
 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
 833
 834     set ret {}
 835     if { [ llength $args ] == 1 } {
 836
 837         set opt [ ::ibrowser::canonizeIbrowser $w option $args ]
 838         set ret $options($opt)
 839
 840     } else { error "\"cget\" command only accepts one argument" }
 841     return $ret
 842
 843 }
 844
 845 #* PROCEDURE DESCRIPTION *************************************************
 846 #*                                                                       *
 847 #* ::ibrowser::curSelectionIbrowser (procedure)                          *
 848 #*                                                                       *
 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.         *
 854 #*                                                                       *
 855 #* SYNTAX : set ret [ ::ibrowser::curSelectionIbrowser $w $args ]        *
 856 #*          <widget> curselection                                        *
 857 #*                                                                       *
 858 #* RETURN : Selected images.                                             *
 859 #*                                                                       *
 860 #* PARAMETERS :                                                          *
 861 #*      w    : string. Widget name.                                      *
 862 #*      args : list. Arguments for sub-command.                          *
 863 #*                                                                       *
 864 #******************************************************* END DESCRIPTION *
 865 proc ::ibrowser::curSelectionIbrowser { w args } {
 866
 867     # again, guess!
 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
 874
 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" ]
 880     if { $f_id != "" } {
 881         set f_id [ lindex [ $widgets(canvas) gettags $f_id ] 1 ]
 882     } else { set f_id [ llength $images ] }
 883     if { $l_id != "" } {
 884         set l_id [ lindex [ $widgets(canvas) gettags $l_id ] 1 ]
 885     } else { set l_id -1 }
 886     set f $f_id
 887     set l $l_id
 888     set i 0
 889     foreach img $images {
 890
 891         if { [ lindex $img 0 ] == $f } { set f $i }
 892         if { [ lindex $img 0 ] == $l } { set l $i }
 893         incr i
 894
 895     }
 896
 897     # f > l? avoid it!
 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 ]
 902
 903     # set return variable...
 904     set ret [ list ]
 905     for { set i $min } { $i <= $max && $i >= 0 } { incr i } {
 906
 907         lappend ret [ lindex $images $i ]
 908
 909     }
 910
 911     # end
 912     return $ret
 913
 914 }
 915
 916 #* PROCEDURE DESCRIPTION *************************************************
 917 #*                                                                       *
 918 #* ::ibrowser::deleteImageIbrowser (procedure)                           *
 919 #*                                                                       *
 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.         *
 924 #*                                                                       *
 925 #* SYNTAX : set ret [ ::ibrowser::deleteImageIbrowser $w $args ]         *
 926 #*          <widget> delete -tags <tags>                                 *
 927 #*                                                                       *
 928 #* RETURN : -NONE-                                                       *
 929 #*                                                                       *
 930 #* PARAMETERS :                                                          *
 931 #*      w    : string. Widget name.                                      *
 932 #*      args : list. Arguments for sub-command.                          *
 933 #*                                                                       *
 934 #******************************************************* END DESCRIPTION *
 935 proc ::ibrowser::deleteImageIbrowser { w args } {
 936
 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
 944
 945     if { [ llength $args ] % 2 == 0 } {
 946
 947         # an associative array is easier...
 948         array set opt $args
 949
 950         # look at options...
 951         set inds [ array names opt ]
 952         foreach ind $inds {
 953
 954             if { $ind != "-tags" } { error "unknown delete option \"$ind\"" }
 955
 956         }
 957
 958         # select images to delete
 959         set del [ list ]
 960         if { [ lsearch -exact $inds "-tags" ] != -1 } {
 961
 962             set tags $opt(-tags)
 963             foreach img $images {
 964
 965                 set itags [ lindex $img 2 ]
 966                 set c 0
 967                 foreach t $itags { if { [ lsearch -exact $tags $t ] != -1 } { incr c } }
 968                 if { $c == [ llength $tags ] } { lappend del $img }
 969
 970             }
 971
 972         } else { error "\"delete\" subcommand without \"-tags\" option" }
 973
 974         # real delete process
 975         $widgets(canvas) delete "frect"
 976         $widgets(canvas) delete "lrect"
 977         foreach d $del {
 978
 979             # delete from canvas...
 980             set ind [ lindex $d 0 ]
 981             $widgets(canvas) delete $ind
 982             $widgets(canvas) delete "text_$ind"
 983
 984             # from memory...
 985             if { [ lindex $d 1 ] != "" } { image delete [ lindex $d 1 ] }
 986
 987             # from list...
 988             set i [ lsearch -exact $images $d ]
 989             set images [ lreplace $images $i $i ]
 990
 991         }
 992
 993         # Re-arrange widget
 994         ::ibrowser::repos $w
 995
 996     } else { error "wrong number of arguments in \"delete\" command" }
 997
 998 }
 999
1000 #* PROCEDURE DESCRIPTION *************************************************
1001 #*                                                                       *
1002 #* ::ibrowser::findImageIbrowser (procedure)                             *
1003 #*                                                                       *
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.         *
1009 #*                                                                       *
1010 #* SYNTAX : set ret [ ::ibrowser::findImageIbrowser $w $args ]           *
1011 #*          <widget> find -tags <tags>                                   *
1012 #*                                                                       *
1013 #* RETURN : -NONE-                                                       *
1014 #*                                                                       *
1015 #* PARAMETERS :                                                          *
1016 #*      w    : string. Widget name.                                      *
1017 #*      args : list. Arguments for sub-command.                          *
1018 #*                                                                       *
1019 #******************************************************* END DESCRIPTION *
1020 proc ::ibrowser::findImageIbrowser { w args } {
1021
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
1029
1030     set ret {}
1031     set tags [ lindex $args 1 ]
1032     if { [ llength $tags ] > 0 } {
1033
1034         foreach img $images {
1035
1036             set itags [ lindex $img 2 ]
1037
1038             # if counter c, equals the number of given tags, then
1039             # actual image is of our interest
1040             set c 0
1041             foreach t $itags { if { [ lsearch -exact $tags $t ] != -1 } { incr c } }
1042             if { $c == [ llength $tags ] } { lappend ret $img }
1043
1044         }
1045
1046     }
1047     return $ret
1048
1049 }
1050
1051 #* PROCEDURE DESCRIPTION *************************************************
1052 #*                                                                       *
1053 #* ::ibrowser::selectImageIbrowser (procedure)                           *
1054 #*                                                                       *
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.         *
1061 #*                                                                       *
1062 #* SYNTAX : set ret [ ::ibrowser::selectImageIbrowser $w $args ]         *
1063 #*          <widget> select -tags <tags> ?-secondary?                    *
1064 #*                                                                       *
1065 #* RETURN : -NONE-                                                       *
1066 #*                                                                       *
1067 #* PARAMETERS :                                                          *
1068 #*      w    : string. Widget name.                                      *
1069 #*      args : list. Arguments for sub-command.                          *
1070 #*                                                                       *
1071 #******************************************************* END DESCRIPTION *
1072 proc ::ibrowser::selectImageIbrowser { w args } {
1073
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
1081
1082     # arguments verif...
1083     set ind -1
1084     set l [ llength $args ]
1085     if { $l == 2 || $l == 3 } {
1086
1087         set tind [ lsearch -exact $args "-tags" ]
1088         set prim [ expr ( [ lsearch -exact $args "-secondary" ] != -1 )? 0: 1 ]
1089         if { $tind != -1 } {
1090
1091             set tags [ lindex $args [ expr $tind + 1 ] ]
1092             if { $tags != "" } {
1093
1094                 foreach img $images {
1095
1096                     set itags [ lindex $img 2 ]
1097
1098                     # if counter c, equals the number of given tags, then
1099                     # actual image is of our interest
1100                     set c 0
1101                     foreach t $itags { if { [ lsearch -exact $tags $t ] != -1 } { incr c } }
1102                     if { $c == [ llength $tags ] } {
1103
1104                         set ind [ lindex $img 0 ]
1105                         break
1106
1107                     }
1108
1109                 }
1110                 if { $prim == 1 } { sFImage $w 0 0 $ind } else { sLImage $w 0 0 $ind }
1111
1112             }
1113
1114         }
1115
1116     } else { error "Wrong number of arguments for \"select\" subcommand." }
1117
1118 }
1119
1120 #* PROCEDURE DESCRIPTION *************************************************
1121 #*                                                                       *
1122 #* ::ibrowser::sFImage (procedure)                                       *
1123 #*                                                                       *
1124 #* DESCRIPTION : Event callback. Mouse left button action.               *
1125 #*               This is a dummy proc, don't call it in your code.       *
1126 #*                                                                       *
1127 #* SYNTAX : ::ibrowser::sFImage %W %x %y $i                              *
1128 #*                                                                       *
1129 #* RETURN : -NONE-                                                       *
1130 #*                                                                       *
1131 #* PARAMETERS :                                                          *
1132 #*      w : string. Widget name.                                         *
1133 #*      x : string. x-coordinate.                                        *
1134 #*      y : string. y-coordinate.                                        *
1135 #*      i : string. (optional) Image index to select.                    *
1136 #*                                                                       *
1137 #******************************************************* END DESCRIPTION *
1138 proc ::ibrowser::sFImage { w x y { i -1 } } {
1139
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
1147
1148     # is manual selection?
1149     if { $i == -1 } {
1150
1151         set ima [ $widgets(canvas) gettags current ]
1152         set i [ $widgets(canvas) find withtag current ]
1153
1154     } else { set ima [ $widgets(canvas) gettags $i ] }
1155
1156     $widgets(canvas) delete "frect"
1157
1158     # ok, select thumb
1159     if { [ string compare [ lindex $ima 0 ] "image" ] == 0 } {
1160
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) \
1170             -width 2 \
1171             -tags "frect $i rects"
1172
1173         set lastsel [ list -1 "" {} ]
1174         foreach img $images {
1175
1176             if { [ lindex $img 0 ] == $i } {
1177
1178                 set lastsel $img
1179                 break
1180
1181             }
1182
1183         }
1184
1185         # fire selection event
1186         event generate $widgets(this) <<AfterSelectImage>>
1187
1188     }
1189
1190 }
1191
1192 #* PROCEDURE DESCRIPTION *************************************************
1193 #*                                                                       *
1194 #* ::ibrowser::sLImage (procedure)                                       *
1195 #*                                                                       *
1196 #* DESCRIPTION : Event callback. Mouse right button action.              *
1197 #*               This is a dummy proc, don't call it in your code.       *
1198 #*                                                                       *
1199 #* SYNTAX : ::ibrowser::sLImage %W %x %y $i                              *
1200 #*                                                                       *
1201 #* RETURN : -NONE-                                                       *
1202 #*                                                                       *
1203 #* PARAMETERS :                                                          *
1204 #*      w : string. Widget name.                                         *
1205 #*      x : string. x-coordinate.                                        *
1206 #*      y : string. y-coordinate.                                        *
1207 #*      i : string. (optional) Image index to select.                    *
1208 #*                                                                       *
1209 #******************************************************* END DESCRIPTION *
1210 proc ::ibrowser::sLImage { w x y { i -1 } } {
1211
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
1219
1220     if { $options(-multisel) == 1 } {
1221
1222         # is manual selection?
1223         if { $i == -1 } {
1224
1225             set ima [ $widgets(canvas) gettags current ]
1226             set i [ $widgets(canvas) find withtag current ]
1227
1228         } else { set ima [ $widgets(canvas) gettags $i ] }
1229
1230         # ok, select thumb
1231         $widgets(canvas) delete "lrect"
1232
1233         if { [ string compare [ lindex $ima 0 ] "image" ] == 0 } {
1234
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) \
1244                 -width 2 \
1245                 -tags "lrect $i rects"
1246
1247             set lastsel [ list -1 "" {} ]
1248             foreach img $images {
1249
1250                 if { [ lindex $img 0 ] == $i } {
1251
1252                     set lastsel $img
1253                     break
1254
1255                 }
1256
1257             }
1258
1259             # fire selection event
1260             event generate $widgets(this) <<AfterSelectImage>>
1261
1262         }
1263
1264     }
1265
1266 }
1267
1268 #* PROCEDURE DESCRIPTION *************************************************
1269 #*                                                                       *
1270 #* ::ibrowser::repos (procedure)                                         *
1271 #*                                                                       *
1272 #* DESCRIPTION : Event callback. Repositionate images.                   *
1273 #*               This is a dummy proc, don't call it in your code.       *
1274 #*                                                                       *
1275 #* SYNTAX : ::ibrowser::repos %W                                         *
1276 #*                                                                       *
1277 #* RETURN : -NONE-                                                       *
1278 #*                                                                       *
1279 #* PARAMETERS :                                                          *
1280 #*      w : string. Widget name.                                         *
1281 #*                                                                       *
1282 #******************************************************* END DESCRIPTION *
1283 proc ::ibrowser::repos { w } {
1284
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
1292
1293     set itms [ $widgets(canvas) find withtag "image" ]
1294     set pos 0
1295     foreach itm $itms {
1296
1297         set px [ expr ( ( $pos % $nMaxX ) * ( $options(-gap) + $options(-thumbwidth) ) ) + \
1298                         $options(-gap) \
1299         ]
1300         set py [ expr ( ( $pos / $nMaxX ) * ( $options(-gap) + $options(-thumbheight) ) ) + \
1301                         $options(-gap) \
1302         ]
1303         $widgets(canvas) coords $itm $px $py
1304         incr pos
1305
1306     }
1307
1308     set itms [ $widgets(canvas) find withtag "text" ]
1309     set pos 0
1310     foreach itm $itms {
1311
1312         set px [ expr ( ( $pos % $nMaxX ) * ( $options(-gap) + $options(-thumbwidth) ) ) + \
1313                         $options(-gap) \
1314         ]
1315         set py [ expr ( ( $pos / $nMaxX ) * ( $options(-gap) + $options(-thumbheight) ) ) + \
1316                         $options(-gap) \
1317         ]
1318         $widgets(canvas) coords $itm $px $py
1319         incr pos
1320
1321     }
1322
1323     set rects [ $widgets(canvas) find withtag "rects" ]
1324     foreach r $rects {
1325
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
1335
1336     }
1337     ::ibrowser::configureSlider $w
1338
1339 }
1340
1341 #* PROCEDURE DESCRIPTION *************************************************
1342 #*                                                                       *
1343 #* ::ibrowser::resize (procedure)                                        *
1344 #*                                                                       *
1345 #* DESCRIPTION : Event callback. Resize widget.                          *
1346 #*               This is a dummy proc, don't call it in your code.       *
1347 #*                                                                       *
1348 #* SYNTAX : ::ibrowser::resize %W %w %h                                  *
1349 #*                                                                       *
1350 #* RETURN : -NONE-                                                       *
1351 #*                                                                       *
1352 #* PARAMETERS :                                                          *
1353 #*      w      : string. Widget name.                                    *
1354 #*      width  : string. Widget width.                                   *
1355 #*      height : string. Widget height.                                  *
1356 #*                                                                       *
1357 #******************************************************* END DESCRIPTION *
1358 proc ::ibrowser::resize { w width height } {
1359
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
1367
1368     if { $options(-width) != $width || $options(-height) != $height } {
1369
1370         set options(-width)  $width
1371         set options(-height) $height
1372         set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
1373                                                            $options(-thumbwidth) \
1374                                                          ) \
1375                                     ) \
1376                             ) \
1377         ]
1378         if { $nMaxX == 0 } {
1379
1380             set options(-width) [ expr $options(-thumbwidth) + $options(-gap) ]
1381             set nMaxX [ expr int( floor ( $options(-width) / ( $options(-gap) + \
1382                                                                $options(-thumbwidth) \
1383                                                              ) \
1384                                         ) \
1385                                 ) \
1386             ]
1387             $widgets(canvas) configure -width $options(-width)
1388
1389         }
1390         ::ibrowser::repos $w
1391
1392     }
1393
1394
1395 }
1396
1397 #* PROCEDURE DESCRIPTION *************************************************
1398 #*                                                                       *
1399 #* ::ibrowser::configureSlider (procedure)                               *
1400 #*                                                                       *
1401 #* DESCRIPTION : Puts or erases a slider, if necessary.                  *
1402 #*               This is a dummy proc, don't call it in your code.       *
1403 #*                                                                       *
1404 #* SYNTAX : ::ibrowser::configureSlider $widget                          *
1405 #*                                                                       *
1406 #* RETURN : -NONE-                                                       *
1407 #*                                                                       *
1408 #* PARAMETERS :                                                          *
1409 #*      w      : string. Widget name.                                    *
1410 #*                                                                       *
1411 #******************************************************* END DESCRIPTION *
1412 proc ::ibrowser::configureSlider { w } {
1413
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
1421
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)
1426
1427     $widgets(canvas) configure -scrollregion "0 0 $options(-width) $need"
1428     if { $need >= $rh && ! [ winfo exists $w.scroll ] } {
1429
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) \
1434             -row 0             \
1435             -column 0          \
1436             -rowspan 1         \
1437             -columnspan 1      \
1438             -sticky news
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
1442
1443     } elseif { $need < $rh && [ winfo exists $w.scroll ] } {
1444
1445         $widgets(canvas) configure -yscrollcommand ""
1446         destroy $w.scroll
1447         set widgets(scroll) ""
1448
1449     }
1450
1451 }
1452
1453 # EOF - ibrowser.tcl