Merging images with transparency
ulis, 2003-09-28.
Generalized 2003-11-21 (see below).
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_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 PROC
How 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)
This can be generalized to n images.
What if a merging image contains fully transparent points (as Tk images have)?
At these points the merging factor is 0.0 (the color of the point is not used for the merged color) and to maintains (4), at this point the merging factor of the image must be divided between the other merging images.
What if a merging image is smaller than the resulting image?
The smaller image is extended by fully transparent points.
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