#!/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 {
        P5 {
             binary scan $data c* grey
             foreach byte $grey { lappend pixl $byte $byte $byte }
             set data [binary format c* $pixl]

             return [list $w $h [lreverse [::ico::getIconAsColorList $w $h 24 {} $data $and]]]
        }


        P6 { return [list $w $h [lreverse [::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]
    }
}