home *** CD-ROM | disk | FTP | other *** search
/ PC World 2000 December / PCWorld_2000-12_cd.bin / Komunikace / Comanche / BWidget-1.2 / xpm2image.tcl < prev   
Text File  |  2000-11-02  |  4KB  |  116 lines
  1. # ------------------------------------------------------------------------------
  2. #  xpm2image.tcl
  3. #  Slightly modified xpm-to-image command
  4. #  $Id: xpm2image.tcl,v 1.1.1.1 1996/02/22 06:05:56 daniel 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.  
  13. proc 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 compare $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 compare $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.