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

Last change on this file since 2790 was 2751, checked in by mmc, 12 years ago

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