[3330] | 1 | # -*- mode: tcl; indent-tabs-mode: nil -*- |
---|
[413] | 2 | # ---------------------------------------------------------------------- |
---|
| 3 | # COMPONENT: icons - utility for loading icons from a library |
---|
| 4 | # |
---|
| 5 | # This utility makes it easy to load GIF and XBM files installed |
---|
| 6 | # in a library in the final installation. It is used throughout |
---|
| 7 | # the Rappture GUI, whenever an icon is needed. |
---|
| 8 | # ====================================================================== |
---|
| 9 | # AUTHOR: Michael McLennan, Purdue University |
---|
[3177] | 10 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
---|
[413] | 11 | # |
---|
| 12 | # See the file "license.terms" for information on usage and |
---|
| 13 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
---|
| 14 | # ====================================================================== |
---|
| 15 | |
---|
[1929] | 16 | package require BLT |
---|
| 17 | |
---|
[433] | 18 | namespace eval Rappture::icon { |
---|
[1856] | 19 | variable iconpath [list [file join $RapptureGUI::library scripts images]] |
---|
[433] | 20 | variable icons |
---|
[413] | 21 | } |
---|
| 22 | |
---|
| 23 | # ---------------------------------------------------------------------- |
---|
[2751] | 24 | # USAGE: Rappture::icon::searchpath ?<dirname> <dirname>...? |
---|
[2750] | 25 | # |
---|
| 26 | # Adds one or more directories onto the icon path searched when |
---|
| 27 | # locating icons in Rappture::icon. You can do the same thing by |
---|
| 28 | # lappend'ing onto the "iconpath" variable, but this call avoids |
---|
| 29 | # duplicates and makes it easier |
---|
| 30 | # ---------------------------------------------------------------------- |
---|
[2751] | 31 | proc Rappture::icon::searchpath {args} { |
---|
| 32 | variable iconpath |
---|
[2750] | 33 | foreach dir $args { |
---|
| 34 | if {[file isdirectory $dir]} { |
---|
| 35 | if {[lsearch $iconpath $dir] < 0} { |
---|
| 36 | lappend iconpath $dir |
---|
| 37 | } |
---|
| 38 | } |
---|
| 39 | } |
---|
| 40 | } |
---|
| 41 | |
---|
| 42 | # ---------------------------------------------------------------------- |
---|
[413] | 43 | # USAGE: Rappture::icon <name> |
---|
| 44 | # |
---|
| 45 | # Searches for an icon called <name> on all of the directories in |
---|
| 46 | # the search path set up by RapptureGUI::iconpath. |
---|
| 47 | # ---------------------------------------------------------------------- |
---|
| 48 | proc Rappture::icon {name} { |
---|
[433] | 49 | variable ::Rappture::icon::iconpath |
---|
| 50 | variable ::Rappture::icon::icons |
---|
[413] | 51 | |
---|
| 52 | # |
---|
| 53 | # Already loaded? then return it directly |
---|
| 54 | # |
---|
| 55 | if {[info exists icons($name)]} { |
---|
[1694] | 56 | return $icons($name) |
---|
[413] | 57 | } |
---|
| 58 | |
---|
| 59 | # |
---|
| 60 | # Search for the icon along the iconpath search path |
---|
| 61 | # |
---|
| 62 | set file "" |
---|
| 63 | foreach dir $iconpath { |
---|
[1694] | 64 | set path [file join $dir $name.*] |
---|
| 65 | set file [lindex [glob -nocomplain $path] 0] |
---|
| 66 | if {"" != $file} { |
---|
| 67 | break |
---|
| 68 | } |
---|
[413] | 69 | } |
---|
| 70 | |
---|
| 71 | set imh "" |
---|
| 72 | if {"" != $file} { |
---|
[1694] | 73 | switch -- [file extension $file] { |
---|
| 74 | .gif - .jpg - .png { |
---|
| 75 | set imh [image create photo -file $file] |
---|
| 76 | } |
---|
| 77 | .xbm { |
---|
| 78 | set fid [open $file r] |
---|
| 79 | set data [read $fid] |
---|
| 80 | close $fid |
---|
| 81 | set imh bitmap-$name |
---|
| 82 | blt::bitmap define $imh $data |
---|
| 83 | } |
---|
| 84 | } |
---|
[413] | 85 | } |
---|
| 86 | if {"" != $imh} { |
---|
[1694] | 87 | set icons($name) $imh |
---|
[413] | 88 | } |
---|
| 89 | return $imh |
---|
| 90 | } |
---|
[433] | 91 | |
---|
| 92 | # ---------------------------------------------------------------------- |
---|
| 93 | # USAGE: Rappture::icon::data <image> ?<format>? |
---|
| 94 | # |
---|
| 95 | # Returns the bytes the represent an <image> in the requested |
---|
| 96 | # <format>, which can get "gif" or "jpeg". |
---|
| 97 | # ---------------------------------------------------------------------- |
---|
| 98 | proc Rappture::icon::data {image {format "gif"}} { |
---|
| 99 | if {[catch {$image data -format $format} result]} { |
---|
[1694] | 100 | if {"too many colors" == $result && "" != [auto_execok djpeg]} { |
---|
| 101 | # |
---|
| 102 | # HACK ALERT! We should use "blt::winop quantize" to |
---|
| 103 | # reduce the number of colors for GIF format. But |
---|
| 104 | # it has a bug right now, so we work around it like this. |
---|
| 105 | # |
---|
| 106 | set tmpfile /tmp/image[pid].dat |
---|
| 107 | $image write $tmpfile -format "jpeg -quality 100" |
---|
| 108 | set fid [open "| djpeg -gif -quantize 250 $tmpfile" r] |
---|
| 109 | fconfigure $fid -encoding binary -translation binary |
---|
| 110 | set result [read $fid] |
---|
| 111 | close $fid |
---|
| 112 | file delete -force $tmpfile |
---|
| 113 | } else { |
---|
| 114 | set result "" |
---|
| 115 | } |
---|
[433] | 116 | } |
---|
| 117 | return $result |
---|
| 118 | } |
---|
| 119 | |
---|
| 120 | # ---------------------------------------------------------------------- |
---|
| 121 | # USAGE: Rappture::icon::gif_animate <delay> ?<image> <image>...? |
---|
| 122 | # |
---|
| 123 | # Takes a series if <images> and composited them into a single, |
---|
| 124 | # animated GIF image, with the <delay> in milliseconds between |
---|
| 125 | # frames. Returns binary data in GIF89a format. |
---|
| 126 | # ---------------------------------------------------------------------- |
---|
| 127 | proc Rappture::icon::gif_animate {delay args} { |
---|
| 128 | if {[llength $args] < 1} { |
---|
[1694] | 129 | error "must have at least one image for animation" |
---|
[433] | 130 | } |
---|
| 131 | set delay [expr {round($delay*0.01)}] ;# convert to 1/100s of second |
---|
| 132 | |
---|
| 133 | set imh [lindex $args 0] |
---|
| 134 | set bytes [data $imh gif] |
---|
| 135 | if {[string length $bytes] == 0} { |
---|
[1694] | 136 | return "" ;# can't query image data -- bail out! |
---|
[433] | 137 | } |
---|
| 138 | gif_parse $bytes first |
---|
| 139 | |
---|
| 140 | set final "GIF89a" |
---|
| 141 | gif_put_short final $first(screen-w) |
---|
| 142 | gif_put_short final $first(screen-h) |
---|
| 143 | gif_put_byte final $first(screen-packed) |
---|
| 144 | gif_put_byte final $first(screen-bg) |
---|
| 145 | gif_put_byte final $first(screen-aspect) |
---|
| 146 | gif_put_block final $first(colors) |
---|
| 147 | |
---|
| 148 | gif_put_byte final 0x21 ;# looping block |
---|
| 149 | gif_put_byte final 0xFF |
---|
| 150 | gif_put_byte final 11 |
---|
| 151 | gif_put_block final "NETSCAPE2.0" |
---|
| 152 | gif_put_byte final 3 ;# 3 bytes in this block |
---|
| 153 | gif_put_byte final 1 ;# turn looping on |
---|
| 154 | gif_put_short final 0 ;# number of loops (forever) |
---|
| 155 | gif_put_byte final 0 ;# block terminator |
---|
| 156 | |
---|
| 157 | gif_put_byte final 0x21 ;# graphic control block |
---|
| 158 | gif_put_byte final 0xF9 |
---|
| 159 | gif_put_byte final 4 ;# 4 bytes in this block |
---|
| 160 | gif_put_byte final 0 ;# packed bits |
---|
| 161 | gif_put_short final [expr {5*$delay}] ;# delay time *0.01s |
---|
| 162 | gif_put_byte final 0 ;# transparency index |
---|
| 163 | gif_put_byte final 0 ;# block terminator |
---|
| 164 | |
---|
| 165 | gif_put_byte final 0x2C ;# image block |
---|
| 166 | gif_put_short final $first(im-0-left) |
---|
| 167 | gif_put_short final $first(im-0-top) |
---|
| 168 | gif_put_short final $first(im-0-wd) |
---|
| 169 | gif_put_short final $first(im-0-ht) |
---|
| 170 | gif_put_byte final $first(im-0-packed) |
---|
| 171 | if {($first(im-0-packed) & 0x80) != 0} { |
---|
[1694] | 172 | gif_put_block final $first(im-0-colors) |
---|
[433] | 173 | } |
---|
| 174 | gif_put_block final $first(im-0-data) |
---|
| 175 | |
---|
| 176 | foreach imh [lrange $args 1 end] { |
---|
[1694] | 177 | catch {unset gif} |
---|
| 178 | gif_parse [data $imh gif] gif |
---|
[433] | 179 | |
---|
[1694] | 180 | gif_put_byte final 0x21 ;# graphic control block |
---|
| 181 | gif_put_byte final 0xF9 |
---|
| 182 | gif_put_byte final 4 ;# 4 bytes in this block |
---|
| 183 | gif_put_byte final 0 ;# packed bits |
---|
| 184 | gif_put_short final $delay ;# delay time *0.01s |
---|
| 185 | gif_put_byte final 0 ;# transparency index |
---|
| 186 | gif_put_byte final 0 ;# block terminator |
---|
[433] | 187 | |
---|
[1694] | 188 | gif_put_byte final 0x2C ;# image block |
---|
| 189 | gif_put_short final $gif(im-0-left) |
---|
| 190 | gif_put_short final $gif(im-0-top) |
---|
| 191 | gif_put_short final $gif(im-0-wd) |
---|
| 192 | gif_put_short final $gif(im-0-ht) |
---|
[433] | 193 | |
---|
[1694] | 194 | if {[string length $gif(im-0-colors)] > 0} { |
---|
| 195 | gif_put_byte final $gif(im-0-packed) |
---|
| 196 | gif_put_block final $gif(im-0-colors) |
---|
| 197 | } else { |
---|
| 198 | set packed [expr {($gif(im-0-packed) & 0xF8) |
---|
| 199 | | ($gif(screen-packed) & 0x87)}] |
---|
| 200 | gif_put_byte final $packed |
---|
| 201 | gif_put_block final $gif(colors) |
---|
| 202 | } |
---|
| 203 | gif_put_block final $gif(im-0-data) |
---|
[433] | 204 | } |
---|
| 205 | |
---|
| 206 | gif_put_byte final 0x3B ;# terminate GIF |
---|
| 207 | |
---|
| 208 | return $final |
---|
| 209 | } |
---|
| 210 | |
---|
| 211 | # ---------------------------------------------------------------------- |
---|
| 212 | # USAGE: Rappture::icon::gif_parse <gifImageData> <array> |
---|
| 213 | # |
---|
| 214 | # Takes the data from a GIF image, parses it into various components, |
---|
| 215 | # and returns the information in the <array> in the calling scope. |
---|
| 216 | # ---------------------------------------------------------------------- |
---|
| 217 | proc Rappture::icon::gif_parse {gifImageData arrayVar} { |
---|
| 218 | upvar $arrayVar data |
---|
| 219 | if {[string range $gifImageData 0 2] != "GIF"} { |
---|
[1694] | 220 | error "not GIF data" |
---|
[433] | 221 | } |
---|
| 222 | set data(version) [string range $gifImageData 0 5] |
---|
| 223 | set pos 6 |
---|
| 224 | |
---|
| 225 | set data(screen-w) [gif_get_short $gifImageData pos] |
---|
| 226 | set data(screen-h) [gif_get_short $gifImageData pos] |
---|
| 227 | set data(screen-packed) [gif_get_byte $gifImageData pos] |
---|
| 228 | set data(screen-bg) [gif_get_byte $gifImageData pos] |
---|
| 229 | set data(screen-aspect) [gif_get_byte $gifImageData pos] |
---|
| 230 | |
---|
| 231 | set ctsize [expr {3*(1 << ($data(screen-packed) & 0x07)+1)}] |
---|
| 232 | set data(colors) [gif_get_block $gifImageData pos $ctsize] |
---|
| 233 | |
---|
| 234 | set n 0 |
---|
| 235 | while {1} { |
---|
[1694] | 236 | set ctrl [gif_get_byte $gifImageData pos] |
---|
| 237 | switch -- [format "0x%02X" $ctrl] { |
---|
| 238 | 0x21 { |
---|
| 239 | set ext [gif_get_byte $gifImageData pos] |
---|
| 240 | switch -- [format "0x%02X" $ext] { |
---|
| 241 | 0xF9 { |
---|
| 242 | # graphic control |
---|
| 243 | set bsize [gif_get_byte $gifImageData pos] |
---|
| 244 | set data(gc-$n-packed) [gif_get_byte $gifImageData pos] |
---|
| 245 | set data(gc-$n-delay) [gif_get_short $gifImageData pos] |
---|
| 246 | set data(gc-$n-transp) [gif_get_byte $gifImageData pos] |
---|
| 247 | set bterm [gif_get_byte $gifImageData pos] |
---|
| 248 | if {$bterm != 0} { error "bad magic $bterm" } |
---|
| 249 | } |
---|
| 250 | 0xFE { |
---|
| 251 | # comment extension -- skip and ignore |
---|
| 252 | while {1} { |
---|
| 253 | set count [gif_get_byte $gifImageData pos] |
---|
| 254 | if {$count == 0} { |
---|
| 255 | break |
---|
| 256 | } |
---|
| 257 | incr pos $count |
---|
| 258 | } |
---|
| 259 | } |
---|
| 260 | 0xFF { |
---|
| 261 | set bsize [gif_get_byte $gifImageData pos] |
---|
| 262 | set data(app-name) [gif_get_block $gifImageData pos $bsize] |
---|
| 263 | set data(app-bytes) "" |
---|
| 264 | while {1} { |
---|
| 265 | set count [gif_get_byte $gifImageData pos] |
---|
| 266 | gif_put_byte data(app-bytes) $count |
---|
| 267 | if {$count == 0} { |
---|
| 268 | break |
---|
| 269 | } |
---|
| 270 | gif_put_block data(app-bytes) \ |
---|
| 271 | [gif_get_block $gifImageData pos $count] |
---|
| 272 | } |
---|
| 273 | } |
---|
| 274 | default { |
---|
| 275 | error [format "unknown extension code 0x%02X" $ext] |
---|
| 276 | } |
---|
| 277 | } |
---|
| 278 | } |
---|
| 279 | 0x2C { |
---|
| 280 | # image data |
---|
| 281 | set data(im-$n-left) [gif_get_short $gifImageData pos] |
---|
| 282 | set data(im-$n-top) [gif_get_short $gifImageData pos] |
---|
| 283 | set data(im-$n-wd) [gif_get_short $gifImageData pos] |
---|
| 284 | set data(im-$n-ht) [gif_get_short $gifImageData pos] |
---|
| 285 | set data(im-$n-packed) [gif_get_byte $gifImageData pos] |
---|
| 286 | set data(im-$n-colors) "" |
---|
| 287 | if {($data(im-$n-packed) & 0x80) != 0} { |
---|
| 288 | set ctsize [expr {3*(1 << ($data(im-$n-packed) & 0x07)+1)}] |
---|
| 289 | set data(im-$n-colors) [gif_get_block $gifImageData pos $ctsize] |
---|
| 290 | } |
---|
[433] | 291 | |
---|
[1694] | 292 | set data(im-$n-data) "" |
---|
| 293 | gif_put_byte data(im-$n-data) \ |
---|
| 294 | [gif_get_byte $gifImageData pos] ;# lwz min code size |
---|
| 295 | while {1} { |
---|
| 296 | set count [gif_get_byte $gifImageData pos] |
---|
| 297 | gif_put_byte data(im-$n-data) $count |
---|
| 298 | if {$count == 0} { |
---|
| 299 | break |
---|
| 300 | } |
---|
| 301 | gif_put_block data(im-$n-data) \ |
---|
| 302 | [gif_get_block $gifImageData pos $count] |
---|
| 303 | } |
---|
| 304 | incr n |
---|
| 305 | } |
---|
| 306 | 0x3B { |
---|
| 307 | # end of image data |
---|
| 308 | break |
---|
| 309 | } |
---|
| 310 | default { |
---|
| 311 | error [format "unexpected control byte 0x%02X" $ctrl] |
---|
| 312 | } |
---|
| 313 | } |
---|
[433] | 314 | } |
---|
| 315 | } |
---|
| 316 | |
---|
| 317 | # ---------------------------------------------------------------------- |
---|
| 318 | # USAGE: Rappture::icon::gif_get_byte <buffer> <posVar> |
---|
| 319 | # |
---|
| 320 | # Extracts one byte of information from the <buffer> at the index |
---|
| 321 | # specified by <posVar> in the calling scope. Increments <posVar> |
---|
| 322 | # to move past the byte and returns the byte of information. |
---|
| 323 | # ---------------------------------------------------------------------- |
---|
| 324 | proc Rappture::icon::gif_get_byte {buffer posVar} { |
---|
| 325 | upvar $posVar pos |
---|
| 326 | set byte [string range $buffer $pos $pos] |
---|
| 327 | incr pos 1 |
---|
| 328 | |
---|
| 329 | binary scan $byte c rval |
---|
| 330 | if {$rval < 0} {incr rval 256} |
---|
| 331 | return $rval |
---|
| 332 | } |
---|
| 333 | |
---|
| 334 | # ---------------------------------------------------------------------- |
---|
| 335 | # USAGE: Rappture::icon::gif_get_short <buffer> <posVar> |
---|
| 336 | # |
---|
| 337 | # Extracts one short int of information from the <buffer> at the index |
---|
| 338 | # specified by <posVar> in the calling scope. Increments <posVar> |
---|
| 339 | # to move past the int and returns the information. |
---|
| 340 | # ---------------------------------------------------------------------- |
---|
| 341 | proc Rappture::icon::gif_get_short {buffer posVar} { |
---|
| 342 | upvar $posVar pos |
---|
| 343 | set bytes [string range $buffer $pos [expr {$pos+1}]] |
---|
| 344 | incr pos 2 |
---|
| 345 | |
---|
| 346 | binary scan $bytes s rval |
---|
| 347 | if {$rval < 0} {incr rval 65536} |
---|
| 348 | return $rval |
---|
| 349 | } |
---|
| 350 | |
---|
| 351 | # ---------------------------------------------------------------------- |
---|
| 352 | # USAGE: Rappture::icon::gif_get_block <buffer> <posVar> <size> |
---|
| 353 | # |
---|
| 354 | # Extracts <size> bytes of information from the <buffer> at the index |
---|
| 355 | # specified by <posVar> in the calling scope. Increments <posVar> |
---|
| 356 | # to move past the byte and returns the byte of information. |
---|
| 357 | # ---------------------------------------------------------------------- |
---|
| 358 | proc Rappture::icon::gif_get_block {buffer posVar size} { |
---|
| 359 | upvar $posVar pos |
---|
| 360 | set bytes [string range $buffer $pos [expr {$pos+$size-1}]] |
---|
| 361 | incr pos $size |
---|
| 362 | return $bytes |
---|
| 363 | } |
---|
| 364 | |
---|
| 365 | # ---------------------------------------------------------------------- |
---|
| 366 | # USAGE: Rappture::icon::gif_put_byte <buffer> <charVal> |
---|
| 367 | # |
---|
| 368 | # Appends one byte of information onto the <buffer> in the calling |
---|
| 369 | # scope. The <charVal> is an integer in the range 0-255. It is |
---|
| 370 | # formated as a single byte and appended onto the buffer. |
---|
| 371 | # ---------------------------------------------------------------------- |
---|
| 372 | proc Rappture::icon::gif_put_byte {bufferVar char} { |
---|
| 373 | upvar $bufferVar buffer |
---|
| 374 | append buffer [binary format c $char] |
---|
| 375 | } |
---|
| 376 | |
---|
| 377 | # ---------------------------------------------------------------------- |
---|
| 378 | # USAGE: Rappture::icon::gif_put_short <buffer> <shortVal> |
---|
| 379 | # |
---|
| 380 | # Appends one byte of information onto the <buffer> in the calling |
---|
| 381 | # scope. The <shortVal> is an integer in the range 0-65535. It is |
---|
| 382 | # formated as a 2-byte short integer and appended onto the buffer. |
---|
| 383 | # ---------------------------------------------------------------------- |
---|
| 384 | proc Rappture::icon::gif_put_short {bufferVar short} { |
---|
| 385 | upvar $bufferVar buffer |
---|
| 386 | append buffer [binary format s $short] |
---|
| 387 | } |
---|
| 388 | |
---|
| 389 | # ---------------------------------------------------------------------- |
---|
| 390 | # USAGE: Rappture::icon::gif_put_block <buffer> <val> |
---|
| 391 | # |
---|
| 392 | # Appends a string <val> onto the <buffer> in the calling scope. |
---|
| 393 | # ---------------------------------------------------------------------- |
---|
| 394 | proc Rappture::icon::gif_put_block {bufferVar val} { |
---|
| 395 | upvar $bufferVar buffer |
---|
| 396 | append buffer $val |
---|
| 397 | } |
---|