1# ----------------------------------------------------------------------------
2#  xpm2image.tcl
3#  Slightly modified xpm-to-image command
4#  $Id: xpm2image.tcl,v 1.5 2004/09/09 22:17:03 hobbs Exp $
5# ------------------------------------------------------------------------------
6#
7#  Copyright 1996 by Roger E. Critchlow Jr., San Francisco, California
8#  All rights reserved, fair use permitted, caveat emptor.
9#  rec@elf.org
10#
11# ----------------------------------------------------------------------------
12
13proc xpm-to-image { file } {
14    set f [open $file]
15    set string [read $f]
16    close $f
17
18    #
19    # parse the strings in the xpm data
20    #
21    set xpm {}
22    foreach line [split $string "\n"] {
23        if {[regexp {^"([^\"]*)"} $line all meat]} {
24            if {[string first XPMEXT $meat] == 0} {
25                break
26            }
27            lappend xpm $meat
28        }
29    }
30    #
31    # extract the sizes in the xpm data
32    #
33    set sizes  [lindex $xpm 0]
34    set nsizes [llength $sizes]
35    if { $nsizes == 4 || $nsizes == 6 || $nsizes == 7 } {
36        set data(width)   [lindex $sizes 0]
37        set data(height)  [lindex $sizes 1]
38        set data(ncolors) [lindex $sizes 2]
39        set data(chars_per_pixel) [lindex $sizes 3]
40        set data(x_hotspot) 0
41        set data(y_hotspot) 0
42        if {[llength $sizes] >= 6} {
43            set data(x_hotspot) [lindex $sizes 4]
44            set data(y_hotspot) [lindex $sizes 5]
45        }
46    } else {
47	    error "size line {$sizes} in $file did not compute"
48    }
49
50    #
51    # extract the color definitions in the xpm data
52    #
53    foreach line [lrange $xpm 1 $data(ncolors)] {
54        set colors [split $line \t]
55        set cname  [lindex $colors 0]
56        lappend data(cnames) $cname
57        if { [string length $cname] != $data(chars_per_pixel) } {
58            error "color definition {$line} in file $file has a bad size color name"
59        }
60        foreach record [lrange $colors 1 end] {
61            set key [lindex $record 0]
62            set color [string tolower [join [lrange $record 1 end] { }]]
63            set data(color-$key-$cname) $color
64            if { [string equal -nocase $color "none"] } {
65                set data(transparent) $cname
66            }
67        }
68        foreach key {c g g4 m} {
69            if {[info exists data(color-$key-$cname)]} {
70                set color $data(color-$key-$cname)
71                set data(color-$cname) $color
72                set data(cname-$color) $cname
73                lappend data(colors) $color
74                break
75            }
76        }
77        if { ![info exists data(color-$cname)] } {
78            error "color definition {$line} in $file failed to define a color"
79        }
80    }
81
82    #
83    # extract the image data in the xpm data
84    #
85    set image [image create photo -width $data(width) -height $data(height)]
86    set y 0
87    foreach line [lrange $xpm [expr {1+$data(ncolors)}] [expr {1+$data(ncolors)+$data(height)}]] {
88        set x 0
89        set pixels {}
90        while { [string length $line] > 0 } {
91            set pixel [string range $line 0 [expr {$data(chars_per_pixel)-1}]]
92            set c $data(color-$pixel)
93            if { [string equal $c none] } {
94                if { [string length $pixels] } {
95                    $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
96                    set pixels {}
97                }
98            } else {
99                lappend pixels $c
100            }
101            set line [string range $line $data(chars_per_pixel) end]
102            incr x
103        }
104        if { [llength $pixels] } {
105            $image put [list $pixels] -to [expr {$x-[llength $pixels]}] $y
106        }
107        incr y
108    }
109
110    #
111    # return the image
112    #
113    return $image
114}
115
116