The proc
# Please, download the images file before running the script: # http://perso.wanadoo.fr/maurice.ulis/tcl/flower1.gif # 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_Steve 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:
if {![$img2 transparency get $x2 $y2]} \ { # merge each color component....
}
GENERALIZED PROCHow to emulate transparency?Given two tranparent images, the merged image has for each point a mixt of the colors of the merging images corresponding points. The more the merging image is transparent, the less the resulting color depends on. The more the merging image is opaque, the more the resulting color depends on.Decomposing the color into RGB components, the resulting components are:
- 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