Version 4 of Blurring

Updated 2003-12-07 14:24:57

ulis, 2003-09-29. Updated 2003-09-30.

Deprecated, 2003-12-07. See Blurring an image (faster proc).

---

---

Please, dowload the file before running the script:

  http://perso.wanadoo.fr/maurice.ulis/tcl/flower1.gif

---

  # blur package
  namespace eval ::blur \
  {
    namespace export blur
    # blur image proc
    proc blur {image {blur 0.1}} \
    {
      variable {}
      # get coef
      if {$blur < 0.0 || $blur > 1.0} \
      { error "blur should be between 0.0 and 1.0" }
      set neighbur [expr {int($blur * 4.0)}]
      # get image size
      set height [image height $image]
      set width [image width $image]
      # get pixels
      set (data) [$image data]
      set data {}
      for {set y 0} {$y < $height} {incr y} \
      {
        set row {}
        for {set x 0} {$x < $width} {incr x} \
        {
          # blur pixel
          set pixel [pixel $x $y $width $height $blur $neighbur]
          lappend row [eval format #%02x%02x%02x $pixel]
        }
        lappend data $row
      }
      unset (data)
      set image [image create photo]
      $image put $data
      return $image
    }
    # blur pixel proc
    proc pixel {x y maxx maxy blur neighbur} \
    {
      variable {}
      # get pixel & neighbour
      if {$neighbur == 0} { set rgb0 [rgb $x $y] } \
      else { set rgb0 [pixel $x $y $maxx $maxy $blur [expr {$neighbur - 1}]] }
      set rgb [list 0 0 0]
      set list1 [list 0]
      incr neighbur
      for {set i 1} {$i <= $neighbur} {incr i} \
      { lappend list1 $i -$i }
      set list1 [lrange $list1 0 end-1]
      set list2 [list $neighbur -$neighbur]
      set n 0
      foreach i $list1 \
      {
        foreach j $list2 \
        {
          set x1 [expr {$x + $i}]
          set y1 [expr {$y + $j}]
          if {$x1 < 0 || $x1 >= $maxx || $y1 < 0 || $y1 >= $maxy} { continue }
          ladd rgb [rgb $x1 $y1]
          incr n
        }
      }
      foreach j $list1 \
      {
        foreach i $list2 \
        {
          set x1 [expr {$x + $i}]
          set y1 [expr {$y + $j}]
          if {$x1 < 0 || $x1 >= $maxx || $y1 < 0 || $y1 >= $maxy} { continue }
          ladd rgb [rgb $x1 $y1]
          incr n
        }
      }
      lmultiply rgb $blur
      ldivide rgb $n
      lmultiply rgb0 [expr {1.0 - $blur}]
      ladd rgb $rgb0
      lround rgb
      return $rgb
    }
    # add components
    proc ladd {rgb1_name rgb2} \
    {
      upvar $rgb1_name rgb1
      foreach i {0 1 2} \
      { lset rgb1 $i [expr [lindex $rgb1 $i] + [lindex $rgb2 $i]] }
    }
    # multiply components
    proc lmultiply {rgb_name factor} \
    {
      upvar $rgb_name rgb
      foreach i {0 1 2} \
      { lset rgb $i [expr [lindex $rgb $i] * $factor] }
    }
    # divide components
    proc ldivide {rgb_name factor} \
    {
      upvar $rgb_name rgb
      foreach i {0 1 2} \
      { lset rgb $i [expr [lindex $rgb $i] / $factor] }
    }
    # round components
    proc lround {rgb_name} \
    {
      upvar $rgb_name rgb
      foreach i {0 1 2} \
      { lset rgb $i [expr round([lindex $rgb $i])] }
    }
    # get a rgb list
    proc rgb {x y} \
    {
      variable {}
      set pixel [lindex [lindex $(data) $y] $x]
      scan $pixel #%2x%2x%2x r g b
      return [list $r $g $b]
    }
  }

  # =============
  #   demo
  # =============

  set blur1 0.2
  set blur2 0.4
  wm title . "blur $blur1 - $blur2"
  package require Tk
  namespace import ::blur::blur
  image create photo _img_ -file flower1.gif
  set width [image width _img_]
  set height [image height _img_]
  set width2 [expr {$width * 2}]
  pack [canvas .c -height $height -width $width2]
  .c create image 0 0 -anchor nw -image [blur _img_ $blur1]
  .c create image $width 0 -anchor nw -image [blur _img_ $blur2]

---

FW: See also TkPhotoLab, which is a generalized version that also supports custom image manipulation based on a similar algorithm.

---

Category Example

Category Graphics

Category Image processing