# resize.tcl - Resize images.
# Writted by Rejjin 
# xmpp: 	<rejjin@jabber.ru>
# e-mail:	<webrenji@gmail.com>

namespace eval ::resize {
	package provide resize 0.1	
	namespace export resize
	
	proc resize {src newx newy} {
		 set mx [image width $src]
		 set my [image height $src]
		 
		set dest [image create photo]
	   
		 $dest configure -width $newx -height $newy

		 if { $newx % $mx == 0 && $newy % $my == 0} {
			 set ix [expr {$newx / $mx}]
			 set iy [expr {$newy / $my}]
			 $dest copy $src -zoom $ix $iy
			 return $dest
		 }

		 set ny 0; set ytot $my
		 for {set y 0} {$y < $my} {incr y} {
			 foreach {pr pg pb} [$src get 0 $y] {break}
			 
			 set row {}; set thisrow {}
			 set nx 0; set xtot $mx
			 
			 for {set x 1} {$x < $mx} {incr x} {
				 while { $xtot <= $newx } {
					 lappend row [format "#%02x%02x%02x" $pr $pg $pb]
					 lappend thisrow $pr $pg $pb
					 incr xtot $mx; incr nx
					 update idletasks
				 }

				 foreach {r g b} [$src get $x $y] {break}

				 set xtot [expr {$xtot - $newx}]; set rn $xtot; set rp [expr {$mx - $xtot}]
				 set xr 0; set xg 0; set xb 0

				 while { $xtot > $newx } {
					 incr xr $r; incr xg $g; incr xb $b
					 set xtot [expr {$xtot - $newx}]; incr x
					 foreach {r g b} [$src get $x $y] {break}
					 update idletasks
				 }

				 set tr [expr {int( ($rn*$r + $xr + $rp*$pr) / $mx)}]
				 set tg [expr {int( ($rn*$g + $xg + $rp*$pg) / $mx)}]
				 set tb [expr {int( ($rn*$b + $xb + $rp*$pb) / $mx)}]

				 if {$tr > 255} {set tr 255}
				 if {$tg > 255} {set tg 255}
				 if {$tb > 255} {set tb 255}

				 lappend row [format "#%02x%02x%02x" $tr $tg $tb]
				 lappend thisrow $tr $tg $tb
				 incr xtot $mx; incr nx
				 set pr $r; set pg $g; set pb $b
				 update idletasks
			 }

			 while { $nx < $newx } {
				 lappend row [format "#%02x%02x%02x" $r $g $b]
				 lappend thisrow $r $g $b
				 incr nx
			 }

			 if {[info exists prevrow]} {
				 set nrow {}
				 
				 while { $ytot <= $newy } {
					 $dest put -to 0 $ny [list $prow]
					 incr ytot $my; incr ny
					 update idletasks
				 }

				 set ytot [expr {$ytot - $newy}]
				 set rn $ytot; set rp [expr {$my - $rn}]

				 while { $ytot > $newy } {
					 set ytot [expr {$ytot - $newy}]
					 incr y
					 continue
				 }


				 foreach {pr pg pb} $prevrow {r g b} $thisrow {
					 set tr [expr {int( ($rn*$r + $rp*$pr) / $my)}]
					 set tg [expr {int( ($rn*$g + $rp*$pg) / $my)}]
					 set tb [expr {int( ($rn*$b + $rp*$pb) / $my)}]
					 lappend nrow [format "#%02x%02x%02x" $tr $tg $tb]
				 }

				 $dest put -to 0 $ny [list $nrow]
				 incr ytot $my; incr ny
			 }

			 set prevrow $thisrow
			 set prow $row
			 update idletasks
		 }

		      while { $ny < $newy } {
         $dest put -to 0 $ny [list $row]
         incr ny
     }
     update idletasks

     # Saving transparency information
	for {set i 0} {$i < $newx} {incr i} {
		for {set j 0} {$j < $newy} {incr j} {
			set ox [expr {round(($mx)*1.0/$newx*$i+0.5)}]
			set oy [expr {round(($my)*1.0/$newy*$j+0.5)}]
			if {[catch {set tr [$src transparency get $ox $oy ]}]} {
			set tr 1
			}
			incr ox -1; incr oy -1
			if {[catch {set tr0 [$src transparency get $ox $oy]}]} {
			set tr 1
			} else {
			set tr [expr {$tr || $tr0}]
			}
			catch {$dest transparency set $i $j $tr}
		}
     }

     return $dest
	}
}

# (c) wiki.tcl.tk