Une image monochrome

 

ulis, 25-01-2005. Voici un petit script pour transformer une image en couleurs (ou en niveaux de gris) en une image qui ne contient que des points blancs et des points noirs.


Pourquoi

Pour répondre à une demande de Miko. Qui voulait autre chose...


Comment

Il s'agit de l'algorithme de diffusion d'erreur de Floyd-Steinberg :

  +---+---+---+
  |   |   |   |
  +---+---+---+
  |   | x | 7 |
  +---+---+---+
  | 1 | 5 | 3 |
  +---+---+---+

  Xm = Rx + (Xr + Xg + Xb) / 3        # teinte moyenne
  Xrgb = (Xm > 128 ? 255 : 0)         # nouvelle couleur : blanc ou noir
  Xe = (Xm > 128 ? Xm - 255 : Xm - 0) # erreur sur la couleur
  R7 = R7 + 7 * Xe / 16               # diffusion aux points voisins
  R1 = R1 + 1 * Xe / 16
  R5 = R5 + 5 * Xe / 16
  R3 = R3 + 3 * Xe / 16

Le script

  proc f-s {img omg} \
  {
    # Floyd-Steinberg dithering
    set idata [$img data]
    set maxrow [llength $idata]
    set maxcol [llength [lindex $idata 0]]
    # compute new image
      # init error propagation
    for {set i 0} {$i < $maxrow + 1} {incr i} \
    { for {set j -1} {$j < $maxcol + 1} {incr j} { set er($i,$j) 0 } }
    for {set nrow 0} {$nrow < $maxrow} {incr nrow} \
    {
      set irow [lindex $idata $nrow]
      set orow {}
      for {set ncol 0} {$ncol < $maxcol} {incr ncol} \
      {
        set nrow1 [expr {$nrow + 1}]
        set ncol1 [expr {$ncol + 1}]
        set ncol2 [expr {$ncol - 1}]
        set ipix [lindex $irow $ncol]
        # get old rgb
        set r 0x[string range $ipix 1 2]
        set g 0x[string range $ipix 3 4]
        set b 0x[string range $ipix 5 6]
        # compute new rgb
        set c [expr {round(($r + $g + $b) / 3.0)}]
        set c [expr {$c + $er($nrow,$ncol)}]
        set opix [expr {$c > 128 ? "#fff": "#000"}]
        # compute error
        set r [expr {($c > 128 ? $c - 255: $c) / 16.0}]
        # propagate error
        set or $er($nrow,$ncol1)
        set er($nrow,$ncol1) [expr {$or + 7 * $r}]
        set or $er($nrow1,$ncol1)
        set er($nrow1,$ncol1) [expr {$or + 3 * $r}]
        set or $er($nrow1,$ncol)
        set er($nrow1,$ncol) [expr {$or + 5 * $r}]
        set or $er($nrow1,$ncol2)
        set er($nrow1,$ncol2) [expr {$or + 1 * $r}]
        lappend orow $opix
      }
      lappend odata $orow
    }
    $omg put $odata
  }

Le test

  package require Tk
  package require Img

  # lena2.png : http://www.images.com/lena2.png
  image create photo img -file lena2.png
  image create photo omg
  f-s img omg
  set width [image width img]
  set height [image height img]
  canvas .c -bd 0 -highlightt 0 \
    -width [expr {$width * 2}] -height $height
  .c create image 0 0 -anchor nw -image img
  .c create image $width 0 -anchor nw -image omg
  pack .c

Voir aussi


Discussion

ulis : on peut remplacer le noir et blanc par du bistre pour faire plus joli ;^)

Kroc : Je ne sais pas si tu as fait exprès, mais le résultat n'est pas du noir et blanc (tes points blancs retournent "240 240 240" au lieu de "255 255 255"). Pour faire une vraie image noir et blanc il faut faire cette petite modification :

        set opix [expr {$c > 128 ? "#ffffff": "#000000"}]

DKF, la même chose, deux fois plus rapide, mais seulement pour Tk 8.4 ou plus...

 proc fs2 {src dst} {
    set data [$src data]
    set rows [image height $src]
    set cols [image width $src]

    # Construct error and output data stores
    set errow {}
    set datarow {}
    set zero [expr 0.0]
    for {set i 0} {$i<$cols} {incr i} {
       lappend datarow {}
       lappend errow $zero
    }
    lappend errow $zero
    set er {}
    set odata {}
    for {set i 0} {$i<$rows} {incr i} {
       lappend odata $datarow
       lappend er $errow
    }
    lappend er $errow
    unset errow zero

    for {set y 0} {$y < $rows} {incr y} {
       for {set x 0} {$x < $cols} {incr x} {
          # get old rgb
          scan [lindex $data $y $x] "#%2x%2x%2x" r g b
          # compute new rgb and error (in $r)
          if {[set c [expr {
             round(($r + $g + $b) / 3.0) + [lindex $er $y $x]
          }]] >= 128} then {
             lset odata $y $x "#ffffff"
             set r [expr {($c - 255) / 16.0}]
          } else {
             lset odata $y $x "#000"
             set r [expr {$c / 16.0}]
          }
          # propagate error
          set y1 [expr {$y + 1}]
          set x1 [expr {$x + 1}]
          lset er $y $x1 [expr {[lindex $er $y $x1] + 7 * $r}]
          lset er $y1 $x1 [expr {[lindex $er $y1 $x1] + 3 * $r}]
          lset er $y1 $x [expr {[lindex $er $y1 $x] + 5 * $r}]
          if {$x} {
             set x2 [expr {$x - 1}]
             lset er $y1 $x2 [expr {[lindex $er $y1 $x2] + $r}]
          }
       }
    }

    $dst put $odata
 }

Catégorie Exemple | Catégorie Traitement d'image