[Keith Vetter] 2006-07-22 : is a technique used in 
computer graphics to create the illusion of color 
depth in images with a limited color palette (color 
quantization). In a dithered image, colors not 
available in the palette are approximated by a 
diffusion of colored pixels from within the 
available palette. [http://en.wikipedia.org/wiki/Dither]

Here some code that implemenents some dithering 
algorithms, along with the requisite demo code.
The code here is only for gray-scaled images
but could easily be extended to color images. 
Also, another improvement would be to use
an optimized paletter before dithering
(see [Reduce Colour Depth - Median Cut]).

This was a really fun project. To save space
in the wiki, I didn't include a sample image
in the demo. Instead, I tried linking to 
tcl demo images and images from the web
(I included some famous image processing images
such as Lena).

For fun, try out some of the various web images I 
included links for and see a) how many colors are
needed by the various algorithms to look good, and
b) how badly some algorithms are with certain images
at different color depths.

For example, try the tcl demo code image of the teapot
at just 2 colors and then 3 colors.

----

 ##+##########################################################################
 #
 # dither.tcl -- Plays with various types of dithering
 # by Keith Vetter, May 2006
 #
 # image source: http://sipi.usc.edu/database/database.cgi?volume=misc
 # dithering overview: http://www.visgraf.impa.br/Courses/ip00/proj/Dithering1/algoritmos_desenvolvidos.htm
 #
 
 package require Tk
 package require http
 package require Img
 if {! [catch {package require tile 0.7.2}]} {   ;# Use tile if present
    namespace import -force ::ttk::button
 }

 set S(title) "Dithering"
 set S(numShades) 2
 set S(status) blank
 
 set lenaURL http://www.visgraf.impa.br/Courses/ip00/proj/Dithering1/image/lena.gif
 set teapotImg [file join $tk_library demos images teapot.ppm]
 
 set images {}
 lappend images [list Lena $lenaURL]
 lappend images [list "Lena (full size)" http://sipi.usc.edu/services/database/misc/4.2.04.tiff]
 lappend images [list "Mandrill" http://sipi.usc.edu/services/database/misc/4.2.03.tiff]
 lappend images [list "Sailboat on lake" http://sipi.usc.edu/services/database/misc/4.2.06.tiff]
 lappend images [list "Elaine" http://sipi.usc.edu/services/database/misc/elaine.512.tiff]
 lappend images [list "Gray Scale" http://www.sput.nl/images/grey2.gif]
 lappend images [list "Gray Scale 2" http://support.sas.com/techsup/technote/ts688/gray.gif]
 
 lappend images {- -}
 lappend images [list Teapot $teapotImg]
 lappend images [list Earth [file join $tk_library demos images earth.gif]]
 lappend images [list "Active Tcl Splash" [file join $tk_library images activetclsplash.gif]]
 lappend images [list "Bliss Wallpaper" [file join $env(windir) Web/Wallpaper/Bliss.bmp]]
 
 proc Floyd-Steinberg {numShades srcImg dstImg} {
    set iw [image width $srcImg]
    set ih [image height $srcImg]
    set factor [expr {($numShades - 1) / 255.0}];# For computing output color
 
    # Error matrix, be lazy and over allocate
    for {set x -1} {$x <= $iw} {incr x} {       ;# NB. extend beyond boundary
        for {set y -1} {$y <= $ih} {incr y} {
            set cerror($x,$y) 0
        }
    }
    for {set y 0} {$y < $ih} {incr y} {
        set y2 [expr {$y + 1}]
        set data [$srcImg data -from 0 $y $iw $y2] ;# Read whole row of image
 
        set FSData {}
        set direction [expr {($y & 1) ? -1 : 1}];# Serpentine scan-line access
        for {set idx 0} {$idx < $iw} {incr idx} {
            set x [expr {$direction ? $idx : $iw-1-$idx}]
            set x2 [expr {$x + $direction}]
            set x0 [expr {$x - $direction}]
            
            set pxl "0x[string range [lindex $data 0 $x] 1 2]" ;# Pixel color
            set src [expr {$pxl + $cerror($x,$y)}] ;# With error added in
            set dst [expr {round(floor($src * $factor + .5) / $factor)}]
            set dst [expr {$dst < 0 ? 0 : $dst > 255 ? 255 : $dst}]
            
            lappend FSData [format "\#%02X%02X%02X" $dst $dst $dst]
 
            set err [expr {$src - $dst}]
            set cerror($x2,$y) [expr {$cerror($x2,$y) + $err*7/16.0}]
            set cerror($x2,$y2) [expr {$cerror($x2,$y2) + $err*1/16.0}]
            set cerror($x,$y2) [expr {$cerror($x,$y2) + $err*5/16.0}]
            set cerror($x0,$y2) [expr {$cerror($x0,$y2) + $err*3/16.0}]
        }
        $dstImg put [list $FSData] -to 0 $y $iw $y2
        update
    }
 }
 proc AverageDither {numShades srcImg dstImg} {
    set iw [image width $srcImg]
    set ih [image height $srcImg]
    set factor [expr {($numShades - 1) / 255.0}];# For computing output color
 
    for {set y 0} {$y < $ih} {incr y} {
        set y2 [expr {$y + 1}]
        set data [$srcImg data -from 0 $y $iw $y2]
 
        set ddata {}
        for {set x 0} {$x < $iw} {incr x} {
            set pxl "0x[string range [lindex $data 0 $x] 1 2]" ;# Pixel color
            set dst [expr {round(floor($pxl * $factor + .5) / $factor)}]
            set dst [expr {$dst < 0 ? 0 : $dst > 255 ? 255 : $dst}]
            lappend ddata [format "\#%02X%02X%02X" $dst $dst $dst]
        }
        $dstImg put [list $ddata] -to 0 $y $iw $y2
        update
    }
 }
 proc OrderedDither {numShades srcImg dstImg} {
    set iw [image width $srcImg]
    set ih [image height $srcImg]
 
    set omatrix {
        {1  9  3 11}
        {13  5 15  7}
        {4 12  2 10}
        {16  8 14  6}}
 
    # We're scanning row by row instead of 4x4 chunks because
    # speed is not important here and this way has no corner cases
    for {set y 0} {$y < $ih} {incr y} {
        set mrow [expr {$y % 4}]                ;# Row in ordering matrix
        set y2 [expr {$y + 1}]
        set data [$srcImg data -from 0 $y $iw $y2]
 
        set ddata {}
        for {set x 0} {$x < $iw} {incr x} {
            set pxl "0x[string range [lindex $data 0 $x] 1 2]" ;# Pixel color
            set pxl [expr {round ($pxl * 16 / 255.0)}]
            set threshold [lindex $omatrix $mrow [expr {$x % 4}]]
            set dst [expr {$pxl < $threshold ? 0 : 255}]
            lappend ddata [format "\#%02X%02X%02X" $dst $dst $dst]
        }
        $dstImg put [list $ddata] -to 0 $y $iw $y2
        update
    }
 }
 proc RandomDither {numShades srcImg dstImg} {
    set iw [image width $srcImg]
    set ih [image height $srcImg]
 
    for {set y 0} {$y < $ih} {incr y} {
        set y2 [expr {$y + 1}]
        set data [$srcImg data -from 0 $y $iw $y2]
 
        set ddata {}
        for {set x 0} {$x < $iw} {incr x} {
            set pxl "0x[string range [lindex $data 0 $x] 1 2]" ;# Pixel color
            set dst [expr {$pxl > (rand()*255) ? 255 : 0}]
            lappend ddata [format "\#%02X%02X%02X" $dst $dst $dst]
        }
        $dstImg put [list $ddata] -to 0 $y $iw $y2
        update
    }
 }
 
 # DEMO CODE
 proc DoDisplay {} {
    if {! [winfo exists .c]} {
        wm title . $::S(title)
        wm protocol . WM_DELETE_WINDOW exit
        wm geom . +10+10
        bind all <Key-F2> {console show}
 
        canvas .c -xscrollcommand {.sb set} -bd 0 -highlightthickness 0
        scrollbar .sb -orient horizontal -command {.c xview}
        pack .c -side top -fill both -expand 1
        pack .sb -side bottom -fill x
        DoMenus
    }
    MakeFrame .f1 src Original 2
    MakeFrame .f2 avg "Average Dither" 1
    MakeFrame .f3 fs "Floyd-Steinberg" 1
    MakeFrame .f4 rnd "Random Dither" 1
    MakeFrame .f5 ord "Ordered Dither"
    update idletasks
    set x 0
    set h 0
    foreach child {.f1 .f2 .f3 .f4 .f5} {
        .c create window $x 0 -tag $child -window $child -anchor nw
        incr x [winfo reqwidth $child]
        if {[winfo reqheight $child] > $h} {set h [winfo reqheight $child]}
    }
    set maxWidth [expr {[winfo screenwidth .] - 50}]
    set width [expr {$x > $maxWidth ? $maxWidth : $x}]
    .c config -width $width -height $h -scrollregion [list 0 0 $x $h]
 
    set ::S(colors,src) "[CountColors ::img::src] colors"
 }
 proc DoMenus {} {
    menu .m
    . configure -menu .m
    .m add cascade -menu .m.file -label File -underline 0
    menu .m.file -tearoff 0
    .m.file add command -label "Open File" -under 5 -command DoOpen
    .m.file add command -label "Open Web" -under 5 -command OpenWeb -state disabled
    .m.file add separator
    .m.file add command -label "Exit" -under 0 -command exit
 
    .m add cascade -menu .m.imgs -label Images -underline 0
    menu .m.imgs -tearoff 0
 
    .m add cascade -menu .m.help -label Help -underline 0
    menu .m.help -tearoff 0
    .m.help add command -label "About" -underline 0 -command Help
 
    foreach item $::images {
        foreach {title uri} $item break
        if {$title eq "-"} {
            .m.imgs add separator
            continue
        }
        if {! [string match "http:*" [string tolower $uri]]} {
            if {! [file exists $uri]} continue
            .m.imgs add command -label $title -command [list DoOpen $uri]
        } else {
            .m.imgs add command -label $title -command [list DoOpen $uri] \
                -accelerator "(web)"
        }
    }
 }
 
 
 proc DIE {emsg} {
    tk_messageBox -message $emsg -icon error -title $::S(title)
    exit
 }
 proc WARN {emsg} {
    tk_messageBox -message $emsg -icon error -title $::S(title)
 }
 proc CountColors {img} {
    set iw [image width  $img]
    set ih [image height $img]
    array unset C
 
    for {set y 0} {$y < $ih} {incr y} {
        set y2 [expr {$y + 1}]
        set data [$img data -from 0 $y $iw $y2]
        foreach datum [lindex $data 0] {
            set C($datum) 1
        }
    }
    set cnt [llength [array names C]]
    return $cnt
 }
 proc MakeFrame {w who title {btn 0}} {
    destroy $w
    frame $w
    label $w.title -text $title -font {Times 24 bold}
    label $w.image -image ::img::$who -relief ridge
    label $w.clrs -textvariable ::S(colors,$who) -font {Times 12 bold}
    set ::S(colors,$who) "? colors"
    if {$btn == 1} {
        button $w.btn -text Go -command [list Demo $who] -state disabled
        lappend ::S(btns) $w.btn
    } elseif {$btn == 2} {
        scale $w.shades -variable S(numShades) -from 2 -to 256 \
            -label "\# Shades" -orient h -relief ridge
    }
    foreach child [winfo child $w] { grid $child -sticky n }
    grid rowconfigure $w 100 -weight 1
    return $w
 }
 proc Demo {who} {
    global S
 
    ButtonState disabled
    if {$who eq "avg"} {
        ::img::avg blank
        ::img::avg put \#00FFFF -to 0 0 $::iw $::ih
        set S(colors,avg) "$S(numShades) colors"
        AverageDither $S(numShades) ::img::src ::img::avg
    } elseif {$who eq "rnd"} {
        ::img::rnd blank
        ::img::rnd put \#FFFF00 -to 0 0 $::iw $::ih
        set S(colors,rnd) "2 colors"
        RandomDither $S(numShades) ::img::src ::img::rnd
    } elseif {$who eq "ord"} {
        ::img::ord blank
        ::img::ord put \#FF8080 -to 0 0 $::iw $::ih
        set S(colors,ord) "2 colors"
        OrderedDither $S(numShades) ::img::src ::img::ord
    } else {
        ::img::fs blank
        ::img::fs put \#FF00FF -to 0 0 $::iw $::ih
        set S(colors,fs) "$S(numShades) colors"
        Floyd-Steinberg $S(numShades) ::img::src ::img::fs
    }
    ButtonState normal
 }
 proc ButtonState {how} {
    foreach w $::S(btns) { $w config -state $how}
 }
 
 proc DoOpen {{fname ""}} {
    if {$fname eq ""} {
        set fname [tk_getOpenFile]
    }
    if {$fname eq ""} return
    set n [OpenURI ::img::org $fname]
    if {! $n} {
        ButtonState disabled
    } else {
        MakeImages
        DoDisplay
        Demo avg
        Demo fs
        Demo rnd
        Demo ord
    }
 }
 
 proc OpenURI {img fname} {
    catch {image delete $img}
    image create photo $img
    ButtonState disabled
    
    if {[file exists $fname]} {
        $img config -file $fname
        ButtonState normal
        return 1
    }
    if {! [string match "http:*" [string tolower $fname]]} {
        WARN "Can't find '$fname'"
        return 0
    }
    destroy .http
    toplevel .http
    wm transient .http .
    wm title .http "Download"
    label .http.t -text "Web Download Progress" -font {Times 12 bold}
    label .http.l -textvariable S(msg)
    
    pack .http.t .http.l -side top -expand 1
    set wh [winfo reqheight .http]     ; set ww [winfo reqwidth .http]
    set sw [winfo width .]             ; set sh [winfo height .]
    set sy [winfo y .]                 ; set sx [winfo x .]
    set x [expr {$sx + ($sw - $ww)/2}] ; set y [expr {$sy + ($sh - $wh)/2}]
    if {$x < 0} { set x 0 }            ; if {$y < 0} {set y 0}
    wm geometry .http +$x+$y
    
    set token [::http::geturl $fname -progress HttpProgress]
    ::http::wait $token
    destroy .http
    if {[::http::ncode $token] != 200} {
        ::http::cleanup $token
        WARN "Error downloading url"
        return 0
    }
 
    $img config -data [::http::data $token]
    ButtonState normal
    ::http::cleanup $token
    return 1
 }
 proc HttpProgress {token total current} {
    set ::S(msg) "[comma $current]/[comma $total]"
    set data [::http::data $token]
    catch {::img::src config -data $data}
    update
 }
 proc comma { num } {
    while {[regsub {^([-+]?[0-9]+)([0-9][0-9][0-9])} $num {\1,\2} num]} {}
    return $num
 }
 
 proc MakeImages {} {
    global iw ih
 
    set iw [image width ::img::org]
    set ih [image height ::img::org]
    
    if {$iw == 0} {set iw 300; set ih 420 }
    image create photo ::img::src -width $iw -height $ih
    ::img::src put [::img::org data -grayscale]
    
    image create photo ::img::avg -width $iw -height $ih
    ::img::avg put cyan -to 0 0 $iw $ih
    image create photo ::img::fs -width $iw -height $ih
    ::img::fs put magenta -to 0 0 $iw $ih
    image create photo ::img::rnd -width $iw -height $ih
    ::img::rnd put yellow -to 0 0 $iw $ih
    image create photo ::img::ord -width $iw -height $ih
    ::img::ord put \#FF8080 -to 0 0 $iw $ih
 }
 proc Help {} {
    catch {destroy .help}
    toplevel .help
    wm transient .help .
    wm title .help "Dither Help"
    if {[regexp {(\+[0-9]+)(\+[0-9]+)$} [wm geom .] => wx wy]} {
        wm geom .help "+[expr {$wx+35}]+[expr {$wy+35}]"
    }
    set w .help.t
    scrollbar .help.sb -orient vertical -command [list $w yview]
    text $w -wrap word -width 70 -height 30 -pady 10 -yscroll {.help.sb set}
    button .help.quit -text Dismiss -command {catch {destroy .help}}
    pack .help.quit -side bottom
    pack $w -side left -fill both -expand 1
    pack .help.sb -side right -fill y
 
    set margin [font measure [$w cget -font] " o "]
    set margin2 [font measure [$w cget -font] " o - "]
    $w tag config header -justify center -font bold -foreground red
    $w tag config header2  -justify center -font bold
    $w tag config bullet -lmargin2 $margin -fon "[$w cget -font] bold"
    $w tag config n -lmargin1 $margin2 -lmargin2 $margin2
 
    $w insert end "Dither" header "\nby Keith Vetter\nJuly 2006\n\n" header2
 
    $w insert end "Here are some common dithering algorithms for gray scaled "
    $w insert end "images. They can easily be extended to color images. "
    $w insert end "Also of interest--but not done here--is to first "
    $w insert end "optimize the palette before dithering. See "
    $w insert end "http://wiki.tcl.tk/11234 for such an algorithm\n\n"
    
    $w insert end " o Average dither\n" bullet
    $w insert end "One of the simplest dithering techniques, based on " n
    $w insert end "selecting an average tone and choosing pixel colors " n
    $w insert end "based on how close they are to the average.\n\n" n
 
    $w insert end " o Floyd-Steinberg dither\n" bullet
    $w insert end "A dithering algorithm by Robert Floyd and " n
    $w insert end "Louis Steinberg (1976). The algorithm achieves " n
    $w insert end "dithering by diffusing the quantization error of " n
    $w insert end "a pixel to its neighboring pixels.\n\n" n
 
    $w insert end " o Random dithering\n" bullet
    $w insert end "For each value in the image, simply generate a random " n
    $w insert end "number 1..256; if it is greater than the image value " n
    $w insert end "at that point, plot the point white, otherwise plot " n
    $w insert end "it black.  This generates a picture with a lot of " n
    $w insert end "\x22white noise\x22, which looks like TV picture " n
    $w insert end "\snow. This algorithm can be used to remove " n
    $w insert end "\"artifacts\" which are phenomena produced by digital " n
    $w insert end "signal processing.\n\n" n
 
    $w insert end " o Ordered dither\n" bullet
    $w insert end "A fast algorithm which produces a cross-hatch dithering " n
    $w insert end "pattern similar to the halftones used by print newspapers." n
    $w insert end " It tiles a 4x4 threshold matrix on top of the image. If " n
    $w insert end "the value of a pixel (scaled to 0-16 range) is less than " n
    $w insert end "the number in the corresponding cell in the matrix, draw " n
    $w insert end "it black, otherwise draw it white.\n\n" n
    $w config -state disabled
 }
 
 image create photo ::img::org
 MakeImages
 DoDisplay
 if {$tcl_interactive} return
 
 if {$argc > 0} {
    DoOpen [lindex $argv 0]
    return
 }
 foreach img [list lena.gif $teapotImg] {
    if {[file exists $img]} {
        DoOpen $img
        return
    }
 }
 
 set msg "Cannot find standard image for demo.\n\n"
 append msg "Download from the net?"
 set val [tk_messageBox -message $msg -icon info -title $S(title) -type yesno]
 if {$val eq "yes"} {
    DoOpen $lenaURL
 }
 
 return

----

[Category Graphics] |
[Category Image Processing] |
[Category Algorithm]