[jbr] - 2012-01-07 Here is a tcl only icon maker specifically created to convert a PPM file into the required icon set for a Windows starpack branded executable. Icons are scaled using bi-linear interpolation implemented in tcl. Its not fast but icons are small. This script does not call any external executables (fex. from ImageMagick). The script does requires the ico package from tklib, but does not use any Tk features and can be run with tclkitsh.exe. Operation : A PPM file is read in and scaled to each of the icon sizes and pixel depths found in the tclkit.exe. The tclkit.ico file is written as the output for use with [sdx] wrap. Usage : ./icomaker.tcl tclkit8.6.exe icon.ppm tclkit.ico ====== #!/usr/bin/env tclkitsh # lappend auto_path /home/john/lib/tklib-0.5/modules package require ico proc ::tcl::mathfunc::clip { value min max } { if { $value < $min } { return $min } if { $value > $max } { return $max } return $value } proc ppm-read { file } { set f [open $file rb] lassign [gets $f] magic lassign [gets $f] w h lassign [gets $f] max set data [read $f] close $f set and [string repeat 0 [expr { $h*$w }]] switch $magic { P6 { return [list $w $h [::ico::getIconAsColorList $w $h 24 {} $data $and]] } default { error "$file is not likely NetPBM" } } } proc colorpolate { c0 c2 frac } { scan $c0 "#%2x%2x%2x" r0 g0 b0 scan $c2 "#%2x%2x%2x" r2 g2 b2 set r1 [expr { int($r0*(1-$frac) + $r2*$frac) }] set g1 [expr { int($g0*(1-$frac) + $g2*$frac) }] set b1 [expr { int($b0*(1-$frac) + $b2*$frac) }] format "#%02x%02x%02x" $r1 $g1 $b1 } proc idx { data x y } { lindex [lindex $data $y] $x } proc imagescale { w h nw nh old } { for {set x 0} {$x < $nw} {incr x} { lappend row {} } for {set y 0} {$y < $nh} {incr y} { lappend new $row } for { set y 0 } { $y < $nw } { incr y } { for { set x 0 } { $x < $nw } { incr x } { set ix1 [expr ($x * ($w-1)/($nw-1.0))] set ix0 [expr clip(int($ix1) , 0, $w-1)] set ix2 [expr clip(int($ix1)+1, 0, $w-1)] set iy1 [expr ($y * ($h-1)/($nh-1.0))] set iy0 [expr clip(int($iy1) , 0, $h-1)] set iy2 [expr clip(int($iy1)+1, 0, $h-1)] set px0 [colorpolate [idx $old $ix0 $iy0] [idx $old $ix2 $iy0] [expr { $ix1 - int($ix1) }]] set px2 [colorpolate [idx $old $ix0 $iy2] [idx $old $ix2 $iy2] [expr { $ix1 - int($ix1) }]] lset new $y $x [colorpolate $px0 $px2 [expr { $iy1 - int($iy1) }]] } } set new } set exe [lindex $argv 0] set img [lindex $argv 1] set ico [lindex $argv 2] lassign [ppm-read $img] w h old set pos -1 foreach I [::ico::icons $exe] { foreach { n nw nh bpp } [join [::ico::iconMembers $exe $I]] { ::ico::writeIcon $ico [incr pos] $bpp [imagescale $w $h $nw $nh $old] } } ====== <> Graphics