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

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