Color quantization: Difference between revisions

From Rosetta Code
Content added Content deleted
m (→‎{{header|Tcl}}: Was conversion of OCaml algorithm)
m (→‎{{header|Tcl}}: Faster, and more Tcl-ish, version that uses integer math)
Line 465: Line 465:
<lang tcl>package require Tcl 8.6
<lang tcl>package require Tcl 8.6
package require Tk
package require Tk
namespace path tcl::mathfunc


proc removeFrom {rem from} {
proc makeCluster {pixels} {
lsearch -inline -all -not -exact $from $rem
}
proc pixel {img x y} {
lassign [$img get $x $y] r g b
list [double $r] [double $g] [double $b]
}
proc color {rgb} {
lassign $rgb r g b
list [list [format "#%02x%02x%02x" [round $r] [round $g] [round $b]]]
}

proc makeCluster {pixelList} {
lassign { inf inf inf} rmin gmin bmin
lassign { inf inf inf} rmin gmin bmin
lassign {-inf -inf -inf} rmax gmax bmax
lassign {-inf -inf -inf} rmax gmax bmax
lassign { 0.0 0.0 0.0} rsum gsum bsum
lassign { 0 0 0} rsum gsum bsum
foreach p $pixelList {
foreach p $pixels {
lassign $p r g b
lassign $p r g b
set rmin [min $rmin $r]
if {$r<$rmin} {set rmin $r}
set gmin [min $gmin $g]
if {$g<$gmin} {set gmin $g}
set bmin [min $bmin $b]
if {$b<$bmin} {set bmin $b}
set rmax [max $rmax $r]
if {$r>$rmax} {set rmax $r}
set gmax [max $gmax $g]
if {$g>$gmax} {set gmax $g}
set bmax [max $bmax $b]
if {$b>$bmax} {set bmax $b}
set rsum [expr {$rsum+$r}]
set rsum [expr {$rsum + $r}]
set gsum [expr {$gsum+$g}]
set gsum [expr {$gsum + $g}]
set bsum [expr {$bsum+$b}]
set bsum [expr {$bsum + $b}]
}
}
set dr [expr {$rmax - $rmin}]
set dr [expr {$rmax - $rmin}]
Line 499: Line 486:
set db [expr {$bmax - $bmin}]
set db [expr {$bmax - $bmin}]
set vol [expr {$dr*$dg*$db}]
set vol [expr {$dr*$dg*$db}]
set n [llength $pixelList]
set n [llength $pixels]
set mean [list [expr {$rsum/$n}] [expr {$gsum/$n}] [expr {$bsum/$n}]]
list [expr {$vol*$n}] \
list $mean [expr {$vol*$n}] [list $dr $dg $db] $pixelList
[list [expr {$rsum/$n}] [expr {$gsum/$n}] [expr {$bsum/$n}]] \
[list $dr $dg $db] $pixels
}
}


proc subdivide {cluster} {
proc subdivide {cluster} {
lassign $cluster median nVolProd vol pixels
lassign $cluster score centroid volume pixels
lassign $median mr mg mb
lassign $centroid cr cg cb
lassign $vol vr vg vb
lassign $volume vr vg vb
set p1 [set p2 {}]
set p1 [set p2 {}]
foreach p $pixels {
foreach p $pixels {
lassign $p r g b
lassign $p r g b
if {$vr>$vg && $vr>$vb} {
if {$vr>$vg && $vr>$vb} {
if {$r<$mr} {lappend p1 $p} {lappend p2 $p}
if {$r<$cr} {lappend p1 $p} {lappend p2 $p}
} elseif {$vr<$vg && $vr>$vb} {
} elseif {$vr<$vg && $vr>$vb} {
if {$g<$mg} {lappend p1 $p} {lappend p2 $p}
if {$g<$cg} {lappend p1 $p} {lappend p2 $p}
} elseif {$vr>$vg && $vr<$vb} {
} elseif {$vr>$vg && $vr<$vb} {
if {$b<$mb} {lappend p1 $p} {lappend p2 $p}
if {$b<$cb} {lappend p1 $p} {lappend p2 $p}
} elseif {$vg>$vb} {
} elseif {$vg>$vb} {
if {$g<$mg} {lappend p1 $p} {lappend p2 $p}
if {$g<$cg} {lappend p1 $p} {lappend p2 $p}
} else {
} else {
if {$b<$mb} {lappend p1 $p} {lappend p2 $p}
if {$b<$cb} {lappend p1 $p} {lappend p2 $p}
}
}
}
}
Line 529: Line 517:
set width [image width $img]
set width [image width $img]
set height [image height $img]
set height [image height $img]
# Extract the pixels from the image
for {set x 0} {$x < $width} {incr x} {
for {set x 0} {$x < $width} {incr x} {
for {set y 0} {$y < $height} {incr y} {
for {set y 0} {$y < $height} {incr y} {
lappend lst [pixel $img $x $y]
lappend lst [$img get $x $y]
}
}
}
}
# Divide pixels into clusters
set clusters [list [makeCluster $lst]]
while {[llength $clusters] < $n} {
for {set cs [list [makeCluster $lst]]} {[llength $cs] < $n} {} {
set cs [lsort -decreasing -real -index 0 $cs]
set v -inf
set cs [concat [subdivide [lindex $cs 0]] [lrange $cs 1 end]]
foreach c $clusters {
if {[lindex $c 1] > $v} {
set v [lindex [set cl $c] 1]
}
}
set clusters [concat [subdivide $cl] [removeFrom $cl $clusters]]
}
}
# Produce map from pixel values to quantized values
foreach c $clusters {
foreach c $cs {
set mean [color [lindex $c 0]]
set centroid [format "#%02x%02x%02x" {*}[lindex $c 1]]
foreach p [lindex $c end] {
foreach p [lindex $c end] {
set map($p) $mean
set map($p) $centroid
}
}
}
}
# Remap the source image
set newimg [image create photo -width $width -height $height]
set newimg [image create photo -width $width -height $height]
for {set x 0} {$x < $width} {incr x} {
for {set x 0} {$x < $width} {incr x} {
for {set y 0} {$y < $height} {incr y} {
for {set y 0} {$y < $height} {incr y} {
$newimg put $map([pixel $img $x $y]) -to $x $y
$newimg put $map([$img get $x $y]) -to $x $y
}
}
}
}

Revision as of 13:55, 31 August 2011

Task
Color quantization
You are encouraged to solve this task according to the task description, using any language you may know.
Color quantization is a draft programming task. It is not yet considered ready to be promoted as a complete task, for reasons that should be found in its talk page.
full color
Example: Gimp 16 color

Color quantization is the process of reducing number of colors used in an image while trying to maintain the visual appearance of the original image. In general, it is a form of cluster analysis, if each RGB color value is considered as a coordinate triple in the 3D colorspace. There are some well know algorithms [1], each with its own advantages and drawbacks.

Task: Take an RGB color image and reduce its colors to some smaller number (< 256). For this task, use the frog as input and reduce colors to 16, and output the resulting colors. The chosen colors should be adaptive to the input image, meaning you should not use a fixed palette such as Web colors or Windows system palette. Dithering is not required.

Note: the funny color bar on top of the frog image is intentional.

C

C output

Using an octree to store colors. Here are only the relevant parts. For full C code see Color_quantization/C. It's different from the standard octree method in that:

  1. Each node can both be leaf node and have child nodes;
  2. Leaf nodes are not folded until all pixels are in. This removes the possibility of early pixels completely bias the tree. And child nodes are reduced one at a time instead of typical all or nothing approach.
  3. Node folding priorities are tracked by a binary heap instead of typical linked list.

The output image is better at preserving textures of the original than Gimp, though it obviously depends on the input image. This particular frog image has the color bar added at the top specifically to throw off some early truncation algorithms, which Gimp is suseptible to. <lang c>typedef struct oct_node_t oct_node_t, *oct_node; struct oct_node_t{ /* sum of all colors represented by this node. 64 bit in case of HUGE image */ uint64_t r, g, b; int count, heap_idx; oct_node kids[8], parent; unsigned char n_kids, kid_idx, flags, depth; };

/* cmp function that decides the ordering in the heap. This is how we determine

  which octree node to fold next, the heart of the algorithm. */

inline int cmp_node(oct_node a, oct_node b) { if (a->n_kids < b->n_kids) return -1; if (a->n_kids > b->n_kids) return 1;

int ac = a->count * (1 + a->kid_idx) >> a->depth; int bc = b->count * (1 + b->kid_idx) >> b->depth; return ac < bc ? -1 : ac > bc; }

/* adding a color triple to octree */ oct_node node_insert(oct_node root, unsigned char *pix) {

  1. define OCT_DEPTH 8

/* 8: number of significant bits used for tree. It's probably good enough for most images to use a value of 5. This affects how many nodes eventually end up in the tree and heap, thus smaller values helps with both speed and memory. */

unsigned char i, bit, depth = 0; for (bit = 1 << 7; ++depth < OCT_DEPTH; bit >>= 1) { i = !!(pix[1] & bit) * 4 + !!(pix[0] & bit) * 2 + !!(pix[2] & bit); if (!root->kids[i]) root->kids[i] = node_new(i, depth, root);

root = root->kids[i]; }

root->r += pix[0]; root->g += pix[1]; root->b += pix[2]; root->count++; return root; }

/* remove a node in octree and add its count and colors to parent node. */ oct_node node_fold(oct_node p) { if (p->n_kids) abort(); oct_node q = p->parent; q->count += p->count;

q->r += p->r; q->g += p->g; q->b += p->b; q->n_kids --; q->kids[p->kid_idx] = 0; return q; }

/* traverse the octree just like construction, but this time we replace the pixel

  color with color stored in the tree node */

void color_replace(oct_node root, unsigned char *pix) { unsigned char i, bit;

for (bit = 1 << 7; bit; bit >>= 1) { i = !!(pix[1] & bit) * 4 + !!(pix[0] & bit) * 2 + !!(pix[2] & bit); if (!root->kids[i]) break; root = root->kids[i]; }

pix[0] = root->r; pix[1] = root->g; pix[2] = root->b; }

/* Building an octree and keep leaf nodes in a bin heap. Afterwards remove first node

  in heap and fold it into its parent node (which may now be added to heap), until heap
  contains required number of colors. */

void color_quant(image im, int n_colors) { int i; unsigned char *pix = im->pix; node_heap heap = { 0, 0, 0 };

oct_node root = node_new(0, 0, 0), got; for (i = 0; i < im->w * im->h; i++, pix += 3) heap_add(&heap, node_insert(root, pix));

while (heap.n > n_colors + 1) heap_add(&heap, node_fold(pop_heap(&heap)));

double c; for (i = 1; i < heap.n; i++) { got = heap.buf[i]; c = got->count; got->r = got->r / c + .5; got->g = got->g / c + .5; got->b = got->b / c + .5; printf("%2d | %3llu %3llu %3llu (%d pixels)\n", i, got->r, got->g, got->b, got->count); }

for (i = 0, pix = im->pix; i < im->w * im->h; i++, pix += 3) color_replace(root, pix);

node_free(); free(heap.buf); }</lang>

D

Translation of: OCaml

<lang d>import core.stdc.stdio, std.stdio, std.ascii, std.algorithm,

      std.typecons, std.math, std.traits, std.range, std.conv;

alias Tuple!(float,"r", float,"g", float,"b") Col; alias Tuple!(ubyte,ubyte,ubyte) Ubyte3; alias Tuple!(Col, float, Col, Col[]) Cluster; enum Axis { R, G, B } int round(float x) { return cast(int)floor(x + 0.5); }

auto rem_from(T, R)(T rem, R from) {

   return array(filter!((T item){ return rem != item; })(from));

}

Ubyte3 ubyte_rgb(Col c) {

   return tuple(cast(ubyte)round(c.r), cast(ubyte)round(c.g), cast(ubyte)round(c.b));

}

Col rgb_mean(R)(R px_list) if (is(ForeachType!R == Col)) {

   int n = walkLength(px_list);
   static Col rgb_add(Col c1, Col c2) { return Col(c1.r + c2.r, c1.g + c2.g, c1.b + c2.b); }
   Col tot = reduce!rgb_add(Col(0,0,0), px_list);
   return Col(tot.r / n, tot.g / n, tot.b / n);

}

Tuple!(Col, Col) extrems(R)(R lst) if (is(ForeachType!R == Col)) {

   auto min_rgb = Col(float.infinity, float.infinity, float.infinity);
   auto max_rgb = Col(-float.infinity, -float.infinity, -float.infinity);
   static Col f1(Col c1, Col c2){ return Col(min(c1.r, c2.r), min(c1.g, c2.g), min(c1.b, c2.b)); }
   Col mi = reduce!f1(min_rgb, lst);
   static Col f2(Col c1, Col c2){ return Col(max(c1.r, c2.r), max(c1.g, c2.g), max(c1.b, c2.b)); }
   Col ma = reduce!f2(max_rgb, lst);
   return tuple(mi, ma);

}

Tuple!(float, Col) volume_and_dims(R)(R lst) if (is(ForeachType!R == Col)) {

   Tuple!(Col, Col) e = extrems(lst);
   Col r = Col(e[1].r - e[0].r, e[1].g - e[0].g, e[1].b - e[0].b);
   return tuple(r[0] * r[1] * r[2], r);

}

Cluster make_cluster(Col[] pixel_list) {

   Tuple!(float, Col) vol_dims = volume_and_dims(pixel_list);
   int len = pixel_list.length;
   return Cluster(rgb_mean(pixel_list), len * vol_dims[0], vol_dims[1], pixel_list);

}

int fcmp(float a, float b) {

   if (a > b) return 1;
   else if (a < b) return -1;
   else return 0;

}

Axis largest_axis(Col c) {

   int r1 = fcmp(c.r, c.g);
   int r2 = fcmp(c.r, c.b);
   if (r1 == 1 && r2 == 1) return Axis.R;
   if (r1 == -1 && r2 == 1) return Axis.G;
   if (r1 == 1 && r2 == -1) return Axis.B;
   if (fcmp(c.g, c.b) == 1) return Axis.G;
   else return Axis.B;

}

Tuple!(Cluster, Cluster) subdivide(Col c, float n_vol_prod, Col vol, Col[] pixels) {

   bool delegate(Col c) part_func;
   final switch (largest_axis(vol)) {
       case Axis.R: part_func = (Col c1){ return c1.r < c.r; }; break;
       case Axis.G: part_func = (Col c1){ return c1.g < c.g; }; break;
       case Axis.B: part_func = (Col c1){ return c1.b < c.b; }; break;
   }
   Col[] px2 = partition!part_func(pixels);
   Col[] px1 = pixels[0 .. $-px2.length];
   return tuple(make_cluster(px1), make_cluster(px2));

}

class Image {

   int w, h;
   ubyte[] pix;
   void allocate(int nr, int nc) {
       w = nc;
       h = nr;
       this.pix.length = 3 * this.w * this.h;
   }
   void loadPPM6(string fileName) {
       static int read_num(FILE* f) {
           int n;
           while (!fscanf(f, "%d ", &n)) {
               if ((n = fgetc(f)) == '#') {
                   while ((n = fgetc(f)) != '\n')
                       if (n == EOF)
                           return 0;
               } else
                   return 0;
           }
           return n;
       }
       auto fin = fopen((fileName ~ '\0').ptr, "rb");
       if (!fin)
           goto bail;
       if (fgetc(fin) != 'P' || fgetc(fin) != '6' || !isWhite(fgetc(fin)))
           goto bail;
       int nc = read_num(fin);
       int nr = read_num(fin);
       int maxval = read_num(fin);
       if (nc <= 0 || nr <= 0 || maxval <= 0)
           goto bail;
       allocate(nr, nc);
       auto count = fread(this.pix.ptr, 1, 3 * nc * nr, fin);
       if (count != 3 * nc * nr)
           writeln("Wrong number of items read.");
     bail:
       if (fin)
           fclose(fin);
   }
   void savePPM6(string fileName) {
       if (this.w <= 0 || this.h <= 0 || pix.length != (3 * this.w * this.h))
           throw new Exception("Not correct image.");
       auto fout = fopen((fileName ~ '\0').ptr, "wb");
       if (fout == null)
           throw new Exception("File can't be opened.");
       fprintf(fout, "P6\n%d %d\n255\n", this.w, this.h);
       auto count = fwrite(this.pix.ptr, 1, 3 * this.w * this.h, fout);
       if (count != 3 * this.w * this.h)
           writeln("Wrong number of items written.");
       fclose(fout);
   }

}

Image color_quant(Image img, int n) {

   const int width = img.w;
   const int height = img.h;
   auto cols = new Col[width * height];
   foreach (i, ref c; cols)
       c = Col(img.pix[i * 3 + 0], img.pix[i * 3 + 1], img.pix[i * 3 + 2]);
   Cluster[] clusters = [make_cluster(cols)];
   Cluster selectCluster(Cluster cl1, Cluster cl2) {
       return cl1[1] > cl2[1] ? cl1 : cl2;
   }
   Col dumb = Col(0.0, 0.0, 0.0);
   Cluster unused = Cluster(dumb, -float.infinity, dumb, (Col[]).init);
   while (clusters.length < n) {
       Cluster cl = reduce!selectCluster(unused, clusters);
       Tuple!(Cluster, Cluster) cls = subdivide(cl.tupleof);
       clusters = [cls.tupleof] ~ rem_from(cl, clusters);
   }
   Ubyte3[Ubyte3] pixMap;
   foreach (cluster; clusters) {
       Ubyte3 ubyte_mean = ubyte_rgb(cluster[0]);
       foreach (col; cluster[3])
           pixMap[ubyte_rgb(col)] = ubyte_mean;
   }
   Image result = new Image;
   result.allocate(height, width);
   foreach (i; 0 .. height * width) {
       Ubyte3 c = pixMap[Ubyte3(img.pix[i * 3 + 0], img.pix[i * 3 + 1], img.pix[i * 3 + 2])];
       result.pix[i * 3 + 0] = c[0];
       result.pix[i * 3 + 1] = c[1];
       result.pix[i * 3 + 2] = c[2];
   }
   return result;

}

void main(string[] args) {

   string fileName = args[1];
   int ncols = to!int(args[2]);
   Image im = new Image;
   im.loadPPM6(fileName);
   Image imq = color_quant(im, ncols);
   imq.savePPM6("out.ppm");

}</lang>

OCaml

Here we use a simplified method inspired from this paper: www.leptonica.com/papers/mediancut.pdf

<lang ocaml>let rem_from rem from =

 List.filter ((<>) rem) from

let float_rgb (r,g,b) = (* prevents int overflow *)

 (float r, float g, float b)

let round x =

 int_of_float (floor (x +. 0.5))

let int_rgb (r,g,b) =

 (round r, round g, round b)

let rgb_add (r1,g1,b1) (r2,g2,b2) =

 (r1 +. r2,
  g1 +. g2,
  b1 +. b2)

let rgb_mean px_list =

 let n = float (List.length px_list) in
 let r, g, b = List.fold_left rgb_add (0.0, 0.0, 0.0) px_list in
 (r /. n, g /. n, b /. n)

let extrems lst =

 let min_rgb = (infinity, infinity, infinity)
 and max_rgb = (neg_infinity, neg_infinity, neg_infinity) in
 List.fold_left (fun ((sr,sg,sb), (mr,mg,mb)) (r,g,b) ->
   ((min sr r), (min sg g), (min sb b)),
   ((max mr r), (max mg g), (max mb b))
 ) (min_rgb, max_rgb) lst

let volume_and_dims lst =

 let (sr,sg,sb), (br,bg,bb) = extrems lst in
 let dr, dg, db = (br -. sr), (bg -. sg), (bb -. sb) in
 (dr *. dg *. db),
 (dr, dg, db)

let make_cluster pixel_list =

 let vol, dims = volume_and_dims pixel_list in
 let len = float (List.length pixel_list) in
 (rgb_mean pixel_list, len *. vol, dims, pixel_list)

type axis = R | G | B let largest_axis (r,g,b) =

 match compare r g, compare r b with
 | 1, 1 -> R
 | -1, 1 -> G
 | 1, -1 -> B
 | _ ->
     match compare g b with
     | 1 -> G
     | _ -> B

let subdivide ((mr,mg,mb), n_vol_prod, vol, pixels) =

 let part_func =
   match largest_axis vol with
   | R -> (fun (r,_,_) -> r < mr)
   | G -> (fun (_,g,_) -> g < mg)
   | B -> (fun (_,_,b) -> b < mb)
 in
 let px1, px2 = List.partition part_func pixels in
 (make_cluster px1, make_cluster px2)

let color_quant img n =

 let width, height = get_dims img in
 let clusters =
   let lst = ref [] in
   for x = 0 to pred width do
     for y = 0 to pred height do
       let rgb = float_rgb (get_pixel_unsafe img x y) in
       lst := rgb :: !lst
     done;
   done;
   ref [make_cluster !lst]
 in
 while (List.length !clusters) < n do
   let dumb = (0.0,0.0,0.0) in
   let unused = (dumb, neg_infinity, dumb, []) in
   let select ((_,v1,_,_) as c1) ((_,v2,_,_) as c2) =
     if v1 > v2 then c1 else c2
   in
   let cl = List.fold_left (fun c1 c2 -> select c1 c2) unused !clusters in
   let cl1, cl2 = subdivide cl in
   clusters := cl1 :: cl2 :: (rem_from cl !clusters)
 done;
 let module PxMap = Map.Make
   (struct type t = float * float * float let compare = compare end) in
 let m =
   List.fold_left (fun m (mean, _, _, pixel_list) ->
     let int_mean = int_rgb mean in
     List.fold_left (fun m px -> PxMap.add px int_mean m) m pixel_list
   ) PxMap.empty !clusters
 in
 let res = new_img ~width ~height in
 for y = 0 to pred height do
   for x = 0 to pred width do
     let rgb = float_rgb (get_pixel_unsafe img x y) in
     let mean_rgb = PxMap.find rgb m in
     put_pixel_unsafe res mean_rgb x y;
   done;
 done;
 (res)</lang>

J

Here, we use a simplistic averaging technique to build an initial set of colors and then use k-means clustering to refine them.

<lang j>kmcL=:4 :0

 C=. /:~ 256 #.inv ,y  NB. colors
 G=. x (i.@] <.@* %) #C  NB. groups (initial)
 Q=. _  NB. quantized list of colors (initial
 whilst.-. Q-:&<.&(x&*)Q0 do.
   Q0=. Q
   Q=. /:~C (+/ % #)/.~ G
   G=. (i. <./)"1 C +/&.:*: .- |:Q
 end.Q

)</lang>

The left argument is the number of colors desired.

The right argument is the image, with pixels represented as bmp color integers (base 256 numbers).

The result is the colors represented as pixel triples (blue, green, red). They are shown here as fractional numbers, but they should be either rounded to the nearest integer in the range 0..255 (and possibly converted back to bmp integer form) or scaled so they are floating point triples in the range 0..1.

<lang j> 16 kmcL img 7.52532 22.3347 0.650468 8.20129 54.4678 0.0326828 33.1132 69.8148 0.622265 54.2232 125.682 2.67713 56.7064 99.5008 3.04013 61.2135 136.42 4.2015 68.1246 140.576 6.37512 74.6006 143.606 7.57854 78.9101 150.792 10.2563 89.5873 148.621 14.6202 98.9523 154.005 25.7583 114.957 159.697 47.6423 145.816 178.136 33.8845 164.969 199.742 67.0467 179.849 207.594 109.973 209.229 221.18 204.513</lang>

Tcl

Translation of: OCaml
Library: Tk

<lang tcl>package require Tcl 8.6 package require Tk

proc makeCluster {pixels} {

   lassign { inf  inf  inf} rmin gmin bmin
   lassign {-inf -inf -inf} rmax gmax bmax
   lassign {   0    0    0} rsum gsum bsum
   foreach p $pixels {

lassign $p r g b if {$r<$rmin} {set rmin $r} if {$g<$gmin} {set gmin $g} if {$b<$bmin} {set bmin $b} if {$r>$rmax} {set rmax $r} if {$g>$gmax} {set gmax $g} if {$b>$bmax} {set bmax $b} set rsum [expr {$rsum + $r}] set gsum [expr {$gsum + $g}] set bsum [expr {$bsum + $b}]

   }
   set dr [expr {$rmax - $rmin}]
   set dg [expr {$gmax - $gmin}]
   set db [expr {$bmax - $bmin}]
   set vol [expr {$dr*$dg*$db}]
   set n [llength $pixels]
   list [expr {$vol*$n}] \

[list [expr {$rsum/$n}] [expr {$gsum/$n}] [expr {$bsum/$n}]] \ [list $dr $dg $db] $pixels }

proc subdivide {cluster} {

   lassign $cluster score centroid volume pixels
   lassign $centroid cr cg cb
   lassign $volume vr vg vb
   set p1 [set p2 {}]
   foreach p $pixels {

lassign $p r g b if {$vr>$vg && $vr>$vb} { if {$r<$cr} {lappend p1 $p} {lappend p2 $p} } elseif {$vr<$vg && $vr>$vb} { if {$g<$cg} {lappend p1 $p} {lappend p2 $p} } elseif {$vr>$vg && $vr<$vb} { if {$b<$cb} {lappend p1 $p} {lappend p2 $p} } elseif {$vg>$vb} { if {$g<$cg} {lappend p1 $p} {lappend p2 $p} } else { if {$b<$cb} {lappend p1 $p} {lappend p2 $p} }

   }
   list [makeCluster $p1] [makeCluster $p2]

}

proc colorQuant {img n} {

   set width  [image width  $img]
   set height [image height $img]
   # Extract the pixels from the image
   for {set x 0} {$x < $width} {incr x} {

for {set y 0} {$y < $height} {incr y} { lappend lst [$img get $x $y] }

   }
   # Divide pixels into clusters
   for {set cs [list [makeCluster $lst]]} {[llength $cs] < $n} {} {

set cs [lsort -decreasing -real -index 0 $cs] set cs [concat [subdivide [lindex $cs 0]] [lrange $cs 1 end]]

   }
   # Produce map from pixel values to quantized values
   foreach c $cs {

set centroid [format "#%02x%02x%02x" {*}[lindex $c 1]] foreach p [lindex $c end] { set map($p) $centroid }

   }
   # Remap the source image
   set newimg [image create photo -width $width -height $height]
   for {set x 0} {$x < $width} {incr x} {

for {set y 0} {$y < $height} {incr y} { $newimg put $map([$img get $x $y]) -to $x $y }

   }
   return $newimg

}</lang> Demonstration code: <lang tcl>set src [image create photo -file quantum_frog.png] set dst [colorQuant $src 16]

  1. Save as GIF now that quantization is done, then exit explicitly (no GUI desired)

$dst write quantum_frog_compressed.gif exit</lang>