source: trunk/gui/scripts/icons.tcl @ 4659

Last change on this file since 4659 was 3330, checked in by gah, 12 years ago

merge (by hand) with Rappture1.2 branch
File size: 14.4 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
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
10#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
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
16package require BLT
17
18namespace eval Rappture::icon {
19    variable iconpath [list [file join $RapptureGUI::library scripts images]]
20    variable icons
21}
22
23# ----------------------------------------------------------------------
24# USAGE: Rappture::icon::searchpath ?<dirname> <dirname>...?
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# ----------------------------------------------------------------------
31proc Rappture::icon::searchpath {args} {
32    variable iconpath
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# ----------------------------------------------------------------------
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# ----------------------------------------------------------------------
48proc Rappture::icon {name} {
49    variable ::Rappture::icon::iconpath
50    variable ::Rappture::icon::icons
51
52    #
53    # Already loaded? then return it directly
54    #
55    if {[info exists icons($name)]} {
56        return $icons($name)
57    }
58
59    #
60    # Search for the icon along the iconpath search path
61    #
62    set file ""
63    foreach dir $iconpath {
64        set path [file join $dir $name.*]
65        set file [lindex [glob -nocomplain $path] 0]
66        if {"" != $file} {
67            break
68        }
69    }
70
71    set imh ""
72    if {"" != $file} {
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        }
85    }
86    if {"" != $imh} {
87        set icons($name) $imh
88    }
89    return $imh
90}
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# ----------------------------------------------------------------------
98proc Rappture::icon::data {image {format "gif"}} {
99    if {[catch {$image data -format $format} result]} {
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        }
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# ----------------------------------------------------------------------
127proc Rappture::icon::gif_animate {delay args} {
128    if {[llength $args] < 1} {
129        error "must have at least one image for animation"
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} {
136        return ""  ;# can't query image data -- bail out!
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} {
172        gif_put_block final $first(im-0-colors)
173    }
174    gif_put_block final $first(im-0-data)
175
176    foreach imh [lrange $args 1 end] {
177        catch {unset gif}
178        gif_parse [data $imh gif] gif
179
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
187
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)
193
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)
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# ----------------------------------------------------------------------
217proc Rappture::icon::gif_parse {gifImageData arrayVar} {
218    upvar $arrayVar data
219    if {[string range $gifImageData 0 2] != "GIF"} {
220        error "not GIF data"
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} {
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            }
291   
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        }
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# ----------------------------------------------------------------------
324proc 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# ----------------------------------------------------------------------
341proc 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# ----------------------------------------------------------------------
358proc 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# ----------------------------------------------------------------------
372proc 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# ----------------------------------------------------------------------
384proc 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# ----------------------------------------------------------------------
394proc Rappture::icon::gif_put_block {bufferVar val} {
395    upvar $bufferVar buffer
396    append buffer $val
397}
Note: See TracBrowser for help on using the repository browser.