#!/usr/bin/perl -w
use strict;

## Written by: Matthew Diephouse
## Copyright 2001.  This may be modified and distributed
## on the same terms as Perl.
##
## Not that anyone would really want to do anything with this,
## It's pretty elementary stuff I think, not for me though
## oh yeah, it's quite sloppy too.

my ($filename, $red, $green, $blue, $save) = @ARGV; #assign file and t
+he rbg color to be matched
$save ||= $filename;
my $hex = rgb2hex($red, $green, $blue);

my %im; #image -> hash containing data for all the images

# loads an image
## invoke using load("HANDLE", "filename.ppm");
sub load {
    my $hd = shift; # handle
    $im{$hd}->{file} = shift;
    my $line;
    open FILE, $im{$hd}->{file} or die "Cannot open $im{$hd}->{file}!"
+;
    $im{$hd}->{header} = <FILE>;
    chomp $im{$hd}->{header};
    do { $line = <FILE> } while ($line =~ /^#/);
    ($im{$hd}->{width}, $im{$hd}->{height}) = split /\D+/, $line, 2;
    chomp $im{$hd}->{height};
    die "Can't work with this type of PPM" if ($line = <FILE>) ne "255
+\n";
    if ($im{$hd}->{header} eq "P6") {
        die "not dealing with binary ppm's yet, sorry";
    } elsif ($im{$hd}->{header} eq "P3") {
        my ($x, $y) = (0, 0);
        $line = <FILE>;
        while ($line) {
            $line =~ s/^(\d+) (\d+) (\d+) //;
            $line = <FILE> if $line eq "\n";
            $im{$hd}->{pixels}[$x][$y] = sprintf("#%02x%02x%02x", $1, 
+$2, $3);
            if ($x < $im{$hd}->{width}-1) { # if x < the width - 1 (x 
+starts 0)
                $x++; 
            } else { # need to start another row
                $x = 0;
                $y++;
            }
        }
    } else {
        die "Only P3 and P6 headers. (Are there any other kinds?)";
    }
    close FILE;
}

# shuts an image;
## invoke using shut("HANDLE"[, "save_as_filename.ppm"]);
sub shut {
    my $hd = shift;
    my $file = shift;
    $file ||= $im{$hd}->{file};
    my $count = 1;
    open FILE, ">$file";
    print FILE $im{$hd}->{header}, "\n";
    print FILE "# edited by PPM.pm\n";
    print FILE "# $im{$hd}->{comments}\n" if $im{$hd}->{comments};
    print FILE "$im{$hd}->{width} $im{$hd}->{height}\n";
    print FILE "255\n";
    if ($im{$hd}->{header} eq "P6") {
        die "if I can't open a binary ppm it should be assumed I can't
+ close one yet either.";
    } else {
        my ($x, $y) = (0, 0);
        while (1) {
            if ($count == 7) {
                print FILE "\n";
                $count = 1;
            } else {
                $count++;
            }
            my @rgb = hex2rgb(pixel($hd, $x, $y));
            print FILE join(" ", @rgb), " ";
            if ($x < $im{$hd}->{width}-1) { # if x < the width - 1 (x 
+starts 0)
                $x++; 
            } else { # need to start another row
                $x = 0;
                $y++;
                last if $y == $im{$hd}->{height};
            }
        }
    }
    close FILE;
}

# get attributes of the image
## invoke using: get("HANDLE", "width");
sub get {
    my $hd = shift;
    my $attribute = lc shift;
    die "There is now attribute $attribute for $hd" if !$im{$hd}->{$at
+tribute};
    return $im{$hd}->{$attribute};
}

# set attributes of the image
## invoke using: set("HANDLE", "width", 300);
sub set {
    my $hd = shift;
    my $attribute = lc shift;
    my $value = shift;
    return $im{$hd}->{$attribute} = $value;
}

# get the hex value of pixel
## invoke using: pixel("HANDLE", $x, $y);
sub pixel {
    my $hd = shift;
    my $x = shift;
    my $y = shift;
    die "There is no pixel ($x, $y) in image $hd. Remember, values sta
+rt at (0, 0)" if $x >= $im{$hd}->{width} || $y >= $im{$hd}->{height};
    return $im{$hd}->{pixels}[$x][$y];
}

# paint a pixel a hex color
## invoke using: paint("HANDLE", $x, $y, $hex);
sub paint {
    my $hd = shift;
    my $x = shift;
    my $y = shift;
    my $color = shift;
    die "There is no pixel ($x, $y) in image $hd. Remember, values sta
+rt at (0, 0)" if $x >= $im{$hd}->{width} || $y >= $im{$hd}->{width};
    return $im{$hd}->{pixels}[$x][$y] = $color;
}

# convert hex 2 rgb returns a list
## invoke using: hex2rgb($hex);
sub hex2rgb {
    $_ = shift @_;
    substr($_, 0, 1, "");
    return hex(substr($_, 0, 2, "")), hex(substr($_, 0, 2, "")), hex(s
+ubstr($_, 0, 2, ""));
}

# convert rgb 2 hex
## invoke using: rgb2hex($r, $g, $b);
sub rgb2hex {
    return sprintf("#%02x%02x%02x", @_);
}

load("IMAGE", $filename);
my $width = get("IMAGE", 'Width');
my $height = get("IMAGE", 'Height');
my @image;
my @replace;
my %correct;

sub check8hood { # check how many pixels surrounding the current one a
+re correct
    my ($x, $y) = @_;
    my $correct = 0;
    my @coords = ([$x-1, $y-1], [$x, $y-1], [$x+1, $y-1], # assign the
+ coordinates
                    [$x-1, $y],                    [$x+1, $y],   # for
+ the 8 neighborhood
                    [$x-1, $y+1], [$x, $y+1], [$x+1, $y+1]);
    for (@coords) {
        ($x, $y) = @$_;
        next if $x < 0 || $y < 0; # skip if doesn't exist
        next if $x > $width-1 || $y > $height-1;
        $correct++ unless pixel("IMAGE", $x, $y) eq $hex;
    }
    return $correct;
}

sub get8hoodrgb { # get the average rgb value of the surrounding corre
+ct pixels
    my ($x, $y) = @_;
    my ($r, $g, $b, $count, @update);
    my @coords = ([$x-1, $y-1], [$x, $y-1], [$x+1, $y-1], # assign the
+ coordinates
                      [$x-1, $y],               [$x+1, $y],   # for th
+e 8 neighborhood
                    [$x-1, $y+1], [$x, $y+1], [$x+1, $y+1]);
    for (@coords) {
        ($x, $y) = @$_;
        next if $x < 0 || $y < 0; # skip if doesn't exist
        next if $x > $width-1 || $y > $height-1;
        if (pixel("IMAGE", $x, $y) eq $hex) {
            push @update, [$x, $y];
            next;
        }
        my ($s, $h, $c) = hex2rgb(pixel("IMAGE", $x, $y));
        $r += $s;
        $g += $h;
        $b += $c;
        $count++;
    }
    if ($count) {
        $r = int($r/$count);
        $g = int($g/$count);
        $b = int($b/$count);
        return $r, $g, $b, @update;
    }
}

sub update { # update pixels to show new numbers of the surrounding co
+rrect pixels
    my ($x, $y) = @_;
    $correct{$x}{$y}++;
}

sub best { # best first search
    my $best;
    my $value = 0;
    my $location = 0;
    my $i = 0;
    for (@replace) {
        my ($x, $y) = @$_;
        my $correct = $correct{$x}{$y};
        if ($correct > $value) {
            $best = [$x, $y];
            $value = $correct;
            $location = $i;
        }
        $i++;
    }
    return @$best, $location;
}

foreach my $x (0..$width-1) { # determine the pixels to be finished
    foreach my $y (0..$height-1) {
        if (pixel("IMAGE", $x, $y) eq $hex) {
            push @replace, [$x, $y];
            $correct{$x}{$y} = check8hood($x,$y);
        }
    }
}

while (@replace) { # main routine right here
    my ($x, $y, $i) = best;
    my ($r, $g, $b, @update) = get8hoodrgb($x,$y);
    paint("IMAGE", $x, $y, rgb2hex($r, $g, $b));
    splice @replace, $i, 1;
    for (@update) {
        update(@$_);
    }
}

shut("IMAGE", $save);

[download]

In reply to FixImage by elusion

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.