Conversion d'image TrueColor en mode 4 couleurs

#/bin/perl
# Reduction d'image true color à 4 couleurs spécialement adaptées
# au format BM4 Thomson.
#
# Usage: perl convBM4.pl [-h] [<option>] [<fichiers>]
#
# -h affiche l'aide. Si aucun fichier n'est présent, ils seront
# lus depuis l'entrée standard.
#
# (c) Samuel DEVULDER, Mars 2014
#

#use Graphics::Magick;
use Image::Magick;

$SIG{'INT'} = 'DEFAULT';
$SIG{'CHLD'} = 'IGNORE';

# suppression du buffer pour l'affichage en sortie
#$| = 1;

# vars globales
$glb_width  = 320;
$glb_height = 200;
$glb_resize = 0;  # resize toujours ?
$glb_gamma  = 2.2;
$glb_outdir = "rgb";
$glb_num    = 8;
$glb_black  = 0;
$glb_blur   = 1;
$glb_ext    = "gif";
$glb_overw  = 0;
$glb_satur  = 130;
$glb_dither = undef;
@glb_pal    = (0x000000, 0x0000FF, 0x00FF00, 0x00FFFF,
               0xFF0000, 0xFF00FF, 0xFFFF00, 0xFFFFFF,
           0x777777, 0x3333AA, 0x33AA33, 0x33AAAA,
           0xAA3333, 0xAA33AA, 0xEEEE77, 0x0077BB);
@glb_files  =();

# parsing des arguments
&parse_args(@ARGV);

# si aucun fichier, alors on les prends depuis l'entrée standard
if(!@glb_files) {
    print "No file found, reading from STDIN...";
    while(<STDIN>) {
        chomp;
        y%\\%/%;
        s%^([\S]):%/cygdrive/$1%;
        push(@glb_files, $_);
    }
    print "done\n";
}

# creation dossier de sortie
mkdir($glb_outdir) || die "$glb_outdir: $!" unless -d $glb_outdir;

# generation de toutes les combinaisons de couleurs
@glb_pals = &generate_pals($glb_num);

# traitement
$pause_durat = 10;    # duree des pauses
$pause_delay = int(100*$pause_durat/10);  # une pause de 10% du temps
$next_pause  = time + $pause_delay;
for my $i (0..$#glb_files) {
    my $file = $glb_files[$i];
    print 1+$i,"/",1+$#glb_files," ",$file,"\n";

    my $out = $file;
    $out =~ s/.*[\\\/]//;
    $out =~ s/[\.][^\.]*//;
    $out = "$glb_outdir/$out.$glb_ext";
    next if !$glb_overw && -f $out;

    my $conv = &convert($file);
    next unless $conv;

    $conv->Write($out);
    undef $conv;

    # on laisse du temps au processeur pour se refroidir
    my($t) = time;
    if($t > $next_pause) {
        $next_pause = $t + $pause_delay;
        sleep($pause_durat);
    }
}

exit 0;

sub convert_ordered {
    my($file) = @_;

    my $src = &read_image($file); return unless $src;
    my $blr = $src->Clone();
    $blr->Blur(size=>$glb_blur);

    $src->OrderedDither($glb_dither);

    my ($best, $best_err) = (0, 1e38);
    &perc(-1);
    for my $ip (0..$#glb_pals) {
        &perc((1+$ip)/(1+$#glb_pals));

        # construction palette
        my $map = Image::Magick->new(size=>"4x1");
        $map->ReadImage('canvas:white');
        my @pal = ($glb_pals[$ip]>>12, ($glb_pals[$ip]>>8)&15, ($glb_pals[$ip]>>4)&15, $glb_pals[$ip]&15);
        for my $j (0..3) {
            my($t) = $glb_pal[$pal[$j]];
            my(@px) = (($t>>16)&255, ($t>>8)&255, ($t>>0)&255);
            $map->SetPixel(x=>$j,y=>0,color=>\@px);
        }
        $map->Gamma(gamma=>1/$glb_gamma);

        # dithering avec la palette courante
        my $img = $src->Clone();
        $img->Remap(image=>$map, 'dither-method'=>'none');
        undef $map;

        # floutage
        $map = $img->Clone();
        $map->Blur(sigma=>$glb_blur);

        # calcul d'erreur
        my $diff = $map->Compare(image=>$blr, metric=>"rmse");
        my($err) = $diff->Get('error');
        undef $diff; undef $map;

        # meilleur?
        if($err < $best_err) {
            $best_err = $err;
            $best = $img->Clone();
        }

        # nettoyage
        undef $img;
    }
    undef $src;
    undef $blr;

    # retour au gamma PC
    $best->Gamma(gamma=>$glb_gamma) if $best;

    &perc(2);

    return $best;
}


sub convert {
    my($file) = @_;

    return &convert_ordered($file) if $glb_dither;

    my $src = &read_image($file); return unless $src;
    my $blr = $src->Clone();
    $blr->Blur(size=>$glb_blur);

    my ($best, $best_err) = (0, 1e38);
    &perc(-1);
    for my $ip (0..$#glb_pals) {
        &perc((1+$ip)/(1+$#glb_pals));

        # construction palette
        my $map = Image::Magick->new(size=>"4x1");
        $map->ReadImage('canvas:white');
        my @pal = ($glb_pals[$ip]>>12, ($glb_pals[$ip]>>8)&15, ($glb_pals[$ip]>>4)&15, $glb_pals[$ip]&15);
        for my $j (0..3) {
            my($t) = $glb_pal[$pal[$j]];
            my(@px) = (($t>>16)&255, ($t>>8)&255, ($t>>0)&255);
            $map->SetPixel(x=>$j,y=>0,color=>\@px);
        }
        $map->Gamma(gamma=>1/$glb_gamma);

        # dithering avec la palette courante
        my $img = $src->Clone();
        $img->Remap(image=>$map, 'dither-method'=>'Floyd-Steinberg');
        undef $map;

        # floutage
        $map = $img->Clone();
        $map->Blur(sigma=>$glb_blur);

        # calcul d'erreur
        my $diff = $map->Compare(image=>$blr, metric=>"rmse");
        my($err) = $diff->Get('error');
        undef $diff; undef $map;

        # meilleur?
        if($err < $best_err) {
            $best_err = $err;
            $best = $img->Clone();
        }

        # nettoyage
        undef $img;
    }
    undef $src;
    undef $blr;

    # retour au gamma PC
    $best->Gamma(gamma=>$glb_gamma) if $best;

    &perc(2);

    return $best;
}

# lit une image
sub read_image {
    my($file) = @_;

    return 0 if $file=~ /\.txt/i;

    my $img = Image::Magick->new();
    if($img->Read($file)) {undef $img; return 0;}

    if($#{$img}>=0) {
        my($z) = $img->[0]->Clone();
        for(my($i,$l) = (1,$#{$img}); $i<=$l; ++$i) {
            my($d) = $img->[$i]->Get("delay");
            $z->Composite(image=>$img->[$i], compose=>"Over",
                      x=>$img->[$i]->Get("page.x"),
                          y=>$img->[$i]->Get("page.y"));
            $img->[$i] = $z->Clone();
            $img->[$i]->Set(delay=>$d);
        }
        #$img->Write("toto.png");
    }

    # conversion en gamma uniforme
    $img->Set(depth=>16);
    $img->Gamma(gamma=>1/$glb_gamma);

    $img->Enhance();
    $img->Normalize(); #"0.1%,0.1%"); #
    $img->Modulate(saturation=>$glb_satur);
    $img->SigmoidalContrast(contrast=>2);

    my $width  = $img->Get('width');
    my $height = $img->Get('height');

    # resize ?
    $img->AdaptiveResize(geometry=>"${glb_width}x${glb_height}", filter=>"lanczos", blur=>1)
        if($glb_resize || $width>$glb_width || $height>$glb_height);

    # on centre l'image autour d'un cadre noir
    $img->Border(width=>$glb_width,height=>$glb_height,color=>"black");
    $img->Set(gravity=>"Center");
    $img->Crop(geometry=>"${glb_width}x${glb_height}!");
    $img->Set(page=>"${glb_width}x${glb_height}+0+0");
    $img->Resize(geometry=>"${glb_width}x${glb_height}!");

    #for(my $i=$#{$img}; --$i>=0;) {
    #   my(@px) = ($i&1?0:255, $i&2?0:255, $i&4?0:255);
    #   $img->[$i]->SetPixel(x=>0,y=>0,color=>\@px);
    #}

    return $img;
}

# genere toutes les combinaisons de palette
sub generate_pals {
    my($max) = @_;
    my @pals = ();

    my $max2 = --$max;
    $max2 = 7 if $max2>7;
    for my $a (0..($glb_black?$max2:0)) {
        for my $b ($a+1..$max2) {
            for my $c ($b+1..$max2) {
                for my $d ($c+1..$max) {
                    push(@pals, ($a<<12)|($b<<8)|($c<<4)|$d);
                }
            }
        }
    }

    print 1+$#pals, " possible palettes\n";

    return @pals;
}

# affiche une barre de progression
sub perc {
    my($perc) = @_;

    if($perc>0) {
        my($z) = int($perc*100);
        return if $z == $glb_perc_last;
        $glb_perc_last = $z;
    }

    my($t) = time;
    if($perc<=0) {
        $glb_perc_time = $t;
    } elsif($perc>=1) {
        $|=1;
            print " " x length($glb_perc_txt), "\b" x length($glb_perc_txt);
        $|=0;
        undef $glb_perc_last;
        undef $glb_perc_time;
        undef $glb_perc_txt;
    } elsif($t>$glb_perc_time+15) {
        my($old) = length($glb_perc_txt);
        $glb_perc_txt = sprintf("%3d%% (%ds rem)", $perc*100, int(($t-$glb_perc_time)*(1/$perc-1)));
        my($end) = " " x ($old-length($glb_perc_txt));
        $|=1;
        print $glb_perc_txt, $end, "\b" x (length($glb_perc_txt) + length($end));
        $|=0;
    }
}

# affiche l'usage
sub usage {
    print "Usage:\n";
    print "   perl ",__FILE__;
    print " [-o <outdir>] [-W <width>] [-H <height>] [-g <gamma>]";
    print "\n\t"," " x length(__FILE__);
    print " [-n <num cols>] [-blur <size>] [-resize] [-black]";
    print "\n\t"," " x length(__FILE__);
    print " [-overwrite] [-ext <bmp|png|...>] [-sat <saturation>]";
    print "\n\t"," " x length(__FILE__);
    print " [-dither <mode>] <file 1> <file 2> ...";
    print "\n";
    exit 0;
}

# lit la ligne de commande
sub parse_args {
    my(@ARGS) = @_;

    my $prev = "";
    foreach my $curr (@ARGS) {
        push(@glb_files, $curr) if -f $curr;
        &usage              if $curr eq "-h" || $curr eq "?";
        $glb_resize = 1     if $curr eq "-resize";
        $glb_black  = 1     if $curr eq "-black";
        $glb_overw  = 1     if $curr eq "-overwrite";
        @glb_pal    = eval("($curr)")
                            if $prev eq "-p";
        $glb_dither = $curr if $prev eq "-dither";
        $glb_outdir = $curr if $prev eq "-o";
        $glb_width  = $curr if $prev eq "-W";
        $glb_height = $curr if $prev eq "-H";
        $glb_gamma  = $curr if $prev eq "-g";
        $glb_num    = $curr if $prev eq "-n";
        $glb_satur  = $curr if $prev eq "-sat";
        $glb_blur   = $curr if $prev eq "-blur";
        $glb_ext    = $curr if $prev eq "-ext";
        $prev = $curr;
    }

    $glb_dither = undef if $glb_dither eq "fs";

    print "Out directory : ",$glb_outdir,"\n";
    print "Out extension : ",$glb_ext,"\n";
    print "Width         : ",$glb_width,"\n";
    print "Height        : ",$glb_height,"\n";
    print "Gamma         : ",$glb_gamma,"\n";
    print "Palette size  : ",$glb_num,"\n";
    print "Resize        : ",$glb_resize?"yes":"no","\n";
    print "Force black   : ",$glb_black?"no":"yes","\n";
    print "Blur size     : ",$glb_blur,"\n";
    print "Saturation    : ",$glb_satur,"\n";
    print "Dither        : ",$glb_dither,"\n" if $glb_dither;
}