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_

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 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

Category Graphics

Category Image Processing

Category Example