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. [L1 ]
Here some code that implements 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 palette 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 "https://wiki.tcl-lang.org/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
set done 0
if {$argc > 0} {
DoOpen [lindex $argv 0]
set done 1
return
}
foreach img [list lena.gif $teapotImg] {
if {[file exists $img]} {
DoOpen $img
set done 1
return
}
}
if {! $done} {
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