




The proc
# Please, download the images file before running the script: # http://perso.wanadoo.fr/maurice.ulis/tcl/flower1.gifSteve Lidie:I just finished converting the above to Perl/Tk. For images of different sizes, or when experimenting with $dx and $dy, I needed a catch statement around this code:# http://perso.wanadoo.fr/maurice.ulis/tcl/flower2.gif
# parameters of 1st image set file1 flower1.gif # parameters of 2nd image set file2 flower2.gif set dx 0 ;# x displacement set dy 0 ;# y displacement set alpha 0.25 ;# opacity if {$alpha < 0.0 || $alpha > 1.0} \ { error "alpha should be between 0.0 and 1.0" } # package package require Tk # merge proc proc merge {img1 img2 dx dy alpha} \ { # compute alpha factors set a2 $alpha set a1 [expr {1.0 - $a2}] # get images sizes set width1 [image width $img1] set height1 [image height $img1] set width2 [image width $img2] set height2 [image height $img2] # merge the pixels set x1 $dx set x2 0 for {set i 0} {$i < $width1} {incr i} \ { if {$i > $width2} { break } set y1 $dy set y2 0 for {set j 0} {$j < $height1} {incr j} \ { if {$j > $height2} { break } # skip if pixel is transparent if {![$img2 transparency get $x2 $y2]} \ { # merge each color component foreach {R G B} [$img1 get $x1 $y1] break foreach {_R _G _B} [$img2 get $x2 $y2] break foreach c {R G B} \ { set c2 [set _$c] set c1 [set $c] set $c [expr {round($c1 * $a1 + $c2 * $a2)}] } # update the image set color [format #%02x%02x%02x $R $G $B] $img1 put $color -to $x1 $y1 } incr y1 incr y2 } incr x1 incr x2 } } # create images image create photo _img1_ -file $file1 image create photo _img2_ -file $file2 # merge images merge _img1_ _img2_ $dx $dy $alpha # display result pack [canvas .c] .c create image 0 0 -anchor nw -image _img1_
if {![$img2 transparency get $x2 $y2]} \ { # merge each color component....
}
GENERALIZED PROC

- Rr = R1 * alpha + R2 * (1 - alpha)
- Gr = G1 * alpha + G2 * (1 - alpha)
- Br = B1 * alpha + B2 * (1 - alpha)
- 0 <= alpha <= 1 (merging factor -- "amount" the first image takes over the second image)
The new proc
# merge images with transparency # parms: # list of {image ?alpha-factor ?x y??} # with: # image: image ref # alpha-factor: relative opacity (0.0 to 1.0) # x y: x & y-offsets proc merge {args} \ { # create image set newimg [image create photo] # compute size & lists set count [llength $args] set width 0 set height 0 foreach item $args \ { foreach {image alpha xi yi} $item break if {$alpha == ""} { set alpha 1.0 } if {$xi == ""} { set xi 0 } if {$yi == ""} { set yi 0 } set w [image width $image] set h [image height $image] set xm [expr {$w + $xi}] set ym [expr {$h + $yi}] if {$w + $xi > $width} { set width $w; incr width $xi } if {$h + $yi > $height} { set height $h; incr height $yi } lappend images $image lappend alphas $alpha lappend xis $xi ;# x min lappend yis $yi ;# y min lappend xms $xm ;# x max lappend yms $ym ;# y max } # compute image set data {} for {set y 0} {$y < $height} {incr y} \ { set row {} for {set x 0} {$x < $width} {incr x} \ { set Xs {} set Ys {} # compute alpha channel (opacity coef) set cnt 0 set aa 0.0 set a {} for {set n 0} {$n < $count} {incr n} \ { set image [lindex $images $n] set alpha [lindex $alphas $n] set xi [lindex $xis $n] set yi [lindex $yis $n] set xm [lindex $xms $n] set ym [lindex $yms $n] set X $x; incr X -$xi; lappend Xs $X set Y $y; incr Y -$yi; lappend Ys $Y if {$x < $xi || $x >= $xm || $y < $yi || $y >= $ym} { set t 1 } \ else { set t [$image transparency get $X $Y] } if {$t} \ { # fully transparent pixel lappend a 0.0 set aa [expr {$aa + $alpha}] } \ else \ { lappend a $alpha incr cnt } } # compute pixels set r 0.0 set g 0.0 set b 0.0 for {set n 0} {$n < $count} {incr n} \ { set image [lindex $images $n] set alpha [lindex $a $n] if {$alpha > 0.0} \ { set alpha [expr {$alpha + $aa / $cnt}] set X [lindex $Xs $n] set Y [lindex $Ys $n] foreach {rr gg bb} [$image get $X $Y] break foreach cc {r g b} \ { set $cc [expr [set $cc] + [set $cc$cc] * $alpha] } } } set pixel [format #%02x%02x%02x [expr {int($r)}] [expr {int($g)}] [expr {int($b)}]] lappend row $pixel } lappend data $row } $newimg put $data return $newimg }
Demo
# build a background image proc background {width height} \ { set a [expr {$width / 2}] set b [expr {$height / 2}] set a1 [expr {1.0 / $a}] set b1 [expr {1.0 / $b}] set image [image create photo] set data {} for {set x -$a} {$x <= $a} {incr x} \ { set row {} for {set y -$b} {$y <= $b} {incr y} \ { if {$x * $y > 0} { set color #ffffff } else { set color #000000 } lappend row $color } lappend data $row } $image put $data return $image } # build a jewel image proc jewel {width height color} \ { set image [image create photo] foreach {r g b} [winfo rgb . $color] break foreach c {r g b} { set $c [expr [set $c] / 256] } set a [expr {$width / 2}] set a2 [expr {1.0 / ($a * $a)}] set b [expr {$height / 2}] set b2 [expr {1.0 / ($b * $b)}] for {set x -$a} {$x <= $a} {incr x} \ { set column {} set x2 [expr {$x * $x * $a2}] for {set y -$b} {$y <= $b} {incr y} \ { set v [expr {$x2 + $y * $y * $b2}] if {$v <= 1.0} \ { if {$column == ""} { set my $y } set cr [expr {int($r * (1.0 - $v))}] set cg [expr {int($g * (1.0 - $v))}] set cb [expr {int($b * (1.0 - $v))}] lappend column [format #%02x%02x%02x $cr $cg $cb] } \ elseif {$column != ""} { break } } $image put $column -to [expr {$x + $a}] [expr {$my + $b}] } return $image } # ========== # little demo # ========== # parameters set width 200 set height 200 set background [background $width $height] set jewel [jewel 150 100 gold] set image [merge [list $background 0.05] [list $jewel 0.95 25 50]] wm title . "Transparency" canvas .c -bd 0 -highlightt 0 -insertwidth 0 \ -width $width -height $height .c create image 0 0 -anchor nw -image $image pack .c