Home | History | Annotate | Download | only in utils 
      1 #!/usr/bin/perl
      2 ## -----------------------------------------------------------------------
      3 ##
      4 ##   Copyright 2004-2008 H. Peter Anvin - All Rights Reserved
      5 ##
      6 ##   This program is free software; you can redistribute it and/or modify
      7 ##   it under the terms of the GNU General Public License as published by
      8 ##   the Free Software Foundation, Inc., 53 Temple Place Ste 330,
      9 ##   Boston MA 02111-1307, USA; either version 2 of the License, or
     10 ##   (at your option) any later version; incorporated herein by reference.
     11 ##
     12 ## -----------------------------------------------------------------------
     13 
     14 ##
     15 ## ppmtolss16
     16 ##
     17 ## Convert a PNM file with max 16 colors to a simple RLE-based format:
     18 ##
     19 ## uint32 0x1413f33d    ; magic (littleendian)
     20 ## uint16 xsize		; littleendian
     21 ## uint16 ysize		; littleendian
     22 ## 16 x uint8 r,g,b	; color map, in 6-bit format (each byte is 0..63)
     23 ##
     24 ## Then, a sequence of nybbles:
     25 ##
     26 ## N	... if N is != previous pixel, one pixel of color N
     27 ## ... otherwise run sequence follows ...
     28 ## M    ... if M > 0 then run length is M
     29 ## ... otherwise run sequence is encoded in two nybbles,
     30 ##     littleendian, +16
     31 ##
     32 ## The nybble sequences are on a per-row basis; runs may not extend
     33 ## across rows and odd-nybble rows are zero-padded.
     34 ##
     35 ## At the start of row, the "previous pixel" is assumed to be zero.
     36 ##
     37 ## Usage:
     38 ##
     39 ##	ppmtolss16 [#rrggbb=i ...] < input.ppm > output.rle
     40 ##
     41 ## Command line options of the form #rrggbb=i indicate that
     42 ## the color #rrggbb (hex) should be assigned index i (decimal)
     43 ##
     44 
     45 eval { use bytes; };
     46 eval { binmode STDIN; };
     47 eval { binmode STDOUT; };
     48 
     49 $magic = 0x1413f33d;
     50 
     51 # Get a token from the PPM header.  Ignore comments and leading
     52 # and trailing whitespace, as is required by the spec.
     53 # This routine eats exactly one character of trailing whitespace,
     54 # unless it is a comment (in which case it eats the comment up
     55 # to and including the end of line.)
     56 sub get_token() {
     57     my($token, $ch);
     58     my($ch);
     59 
     60     do {
     61 	$ch = getc(STDIN);
     62 	return undef if ( !defined($ch) ); # EOF
     63 	if ( $ch eq '#' ) {
     64 	    do {
     65 		$ch = getc(STDIN);
     66 		return undef if ( !defined($ch) );
     67 	    } while ( $ch ne "\n" );
     68 	}
     69     } while ( $ch =~ /^[ \t\n\v\f\r]$/ );
     70 
     71     $token = $ch;
     72     while ( 1 ) {
     73 	$ch = getc(STDIN);
     74 	last if ( $ch =~ /^[ \t\n\v\f\r\#]$/ );
     75 	$token .= $ch;
     76     }
     77     if ( $ch eq '#' ) {
     78 	do {
     79 	    $ch = getc(STDIN);
     80 	} while ( defined($ch) && $ch ne "\n" );
     81     }
     82     return $token;
     83 }
     84 
     85 # Get a token, and make sure it is numeric (and exists)
     86 sub get_numeric_token() {
     87     my($token) = get_token();
     88 
     89     if ( $token !~ /^[0-9]+$/ ) {
     90 	print STDERR "Format error on input\n";
     91 	exit 1;
     92     }
     93 
     94     return $token + 0;
     95 }
     96 
     97 # Must be called before each pixel row is read
     98 sub start_new_row() {
     99     $getrgb_leftover_bit_cnt = 0;
    100     $getrgb_leftover_bit_val = 0;
    101 }
    102 
    103 # Get a single RGB token depending on the PNM type
    104 sub getrgb($) {
    105     my($form) = @_;
    106     my($rgb,$r,$g,$b);
    107 
    108     if ( $form == 6 ) {
    109 	# Raw PPM, most common
    110 	return undef unless ( read(STDIN,$rgb,3) == 3 );
    111 	return unpack("CCC", $rgb);
    112     } elsif ( $form == 3 ) {
    113 	# Plain PPM
    114 	$r = get_numeric_token();
    115 	$g = get_numeric_token();
    116 	$b = get_numeric_token();
    117 	return ($r,$g,$b);
    118     } elsif  ( $form == 5 ) {
    119 	# Raw PGM
    120 	return undef unless ( read(STDIN,$rgb,1) == 1 );
    121 	$r = unpack("C", $rgb);
    122 	return ($r,$r,$r);
    123     } elsif ( $form == 2 ) {
    124 	# Plain PGM
    125 	$r = get_numeric_token();
    126 	return ($r,$r,$r);
    127     } elsif ( $form == 4 ) {
    128 	# Raw PBM
    129 	if ( !$getrgb_leftover_bit_cnt ) {
    130 	    return undef unless ( read(STDIN,$rgb,1) == 1 );
    131 	    $getrgb_leftover_bit_val = unpack("C", $rgb);
    132 	    $getrgb_leftover_bit_cnt = 8;
    133 	}
    134 	$r = ( $getrgb_leftover_bit_val & 0x80 ) ? 0x00 : 0xff;
    135 	$getrgb_leftover_bit_val <<= 1;
    136 	$getrgb_leftover_bit_cnt--;
    137 
    138 	return ($r,$r,$r);
    139     } elsif ( $form == 1 ) {
    140 	# Plain PBM
    141 	my($ch);
    142 
    143 	do {
    144 	    $ch = getc(STDIN);
    145 	    return undef if ( !defined($ch) );
    146 	    return (255,255,255) if ( $ch eq '0' ); # White
    147 	    return (0,0,0) if ( $ch eq '1'); # Black
    148 	    if ( $ch eq '#' ) {
    149 		do {
    150 		    $ch = getc(STDIN);
    151 		    return undef if ( !defined($ch) );
    152 		} while ( $ch ne "\n" );
    153 	    }
    154 	} while ( $ch =~ /^[ \t\n\v\f\r]$/ );
    155 	return undef;
    156     } else {
    157 	die "Internal error: unknown format: $form\n";
    158     }
    159 }
    160 
    161 sub rgbconvert($$$$) {
    162     my($r,$g,$b,$maxmult) = @_;
    163     my($rgb);
    164 
    165     $r = int($r*$maxmult);
    166     $g = int($g*$maxmult);
    167     $b = int($b*$maxmult);
    168     $rgb = pack("CCC", $r, $g, $b);
    169     return $rgb;
    170 }
    171 
    172 foreach $arg ( @ARGV ) {
    173     if ( $arg =~ /^\#([0-9a-f])([0-9a-f])([0-9a-f])=([0-9]+)$/i ) {
    174 	$r = hex($1) << 4;
    175 	$g = hex($2) << 4;
    176 	$b = hex($3) << 4;
    177 	$i = $4 + 0;
    178     } elsif ( $arg =~ /^\#([0-9a-f]{2})([0-9a-f]{2})([0-9a-f]{2})=([0-9]+)$/i ) {
    179 	$r = hex($1);
    180 	$g = hex($2);
    181 	$b = hex($3);
    182 	$i = $4 + 0;
    183     } elsif ( $arg =~ /^\#([0-9a-f]{3})([0-9a-f]{3})([0-9a-f]{3})=([0-9]+)$/i ) {
    184 	$r = hex($1) >> 4;
    185 	$g = hex($2) >> 4;
    186 	$b = hex($3) >> 4;
    187 	$i = $4 + 0;
    188     } elsif ( $arg =~ /^\#([0-9a-f]{4})([0-9a-f]{4})([0-9a-f]{4})=([0-9]+)$/i ) {
    189 	$r = hex($1) >> 8;
    190 	$g = hex($2) >> 8;
    191 	$b = hex($3) >> 8;
    192 	$i = $4 + 0;
    193     } else {
    194 	print STDERR "$0: Unknown argument: $arg\n";
    195 	next;
    196     }
    197 
    198     if ( $i > 15 ) {
    199 	print STDERR "$0: Color index out of range: $arg\n";
    200 	next;
    201     }
    202 
    203     $rgb = rgbconvert($r, $g, $b, 64/256);
    204 
    205     if ( defined($index_forced{$i}) ) {
    206 	print STDERR "$0: More than one color index $i\n";
    207 	exit(1);
    208     }
    209     $index_forced{$i} = $rgb;
    210     $force_index{$rgb} = $i;
    211 }
    212 
    213 $form = get_token();
    214 die "$0: stdin is not a PNM file" if ( $form !~ /^P([1-6])$/ );
    215 $form = $1+0;
    216 
    217 $xsize = get_numeric_token();
    218 $ysize = get_numeric_token();
    219 if ( $form == 1 || $form == 4 ) {
    220     $maxcol = 255;		# Internal convention
    221 } else {
    222     $maxcol = get_numeric_token();
    223 }
    224 $maxmult = 64/($maxcol+1);	# Equal buckets conversion
    225 
    226 @data = ();
    227 
    228 for ( $y = 0 ; $y < $ysize ; $y++ ) {
    229     start_new_row();
    230     for ( $x = 0 ; $x < $xsize ; $x++ ) {
    231 	die "$0: Premature EOF at ($x,$y) of ($xsize,$ysize)\n"
    232 	    if ( !scalar(@pnmrgb = getrgb($form)) );
    233 	# Convert to 6-bit representation
    234 	$rgb = rgbconvert($pnmrgb[0], $pnmrgb[1], $pnmrgb[2], $maxmult);
    235 	$color_count{$rgb}++;
    236 	push(@data, $rgb);
    237     }
    238 }
    239 
    240 # Sort list of colors according to freqency
    241 @colors = sort { $color_count{$b} <=> $color_count{$a} } keys(%color_count);
    242 
    243 # Now we have our pick of colors.  Sort according to intensity;
    244 # this is more or less an ugly hack to cover for the fact that
    245 # using PPM as input doesn't let the user set the color map,
    246 # which the user really needs to be able to do.
    247 
    248 sub by_intensity() {
    249     my($ra,$ga,$ba) = unpack("CCC", $a);
    250     my($rb,$gb,$bb) = unpack("CCC", $b);
    251 
    252     my($ia) = $ra*0.299 + $ga*0.587 + $ba*0.114;
    253     my($ib) = $rb*0.299 + $gb*0.587 + $bb*0.114;
    254 
    255     return ( $ia <=> $ib ) if ( $ia != $ib );
    256 
    257     # If same, sort based on RGB components,
    258     # with highest priority given to G, then R, then B.
    259 
    260     return ( $ga <=> $gb ) if ( $ga != $gb );
    261     return ( $ra <=> $rb ) if ( $ra != $rb );
    262     return ( $ba <=> $bb );
    263 }
    264 
    265 @icolors = sort by_intensity @colors;
    266 
    267 # Insert forced colors into "final" array
    268 @colors = (undef) x 16;
    269 foreach $rgb ( keys(%force_index) ) {
    270     $i = $force_index{$rgb};
    271     $colors[$i] = $rgb;
    272     $color_index{$rgb} = $i;
    273 }
    274 
    275 undef %force_index;
    276 
    277 # Insert remaining colors in the remaining slots,
    278 # in luminosity-sorted order
    279 $nix = 0;
    280 while ( scalar(@icolors) ) {
    281     # Advance to the next free slot
    282     $nix++ while ( defined($colors[$nix]) && $nix < 16 );
    283     last if ( $nix >= 16 );
    284     $rgb = shift @icolors;
    285     if ( !defined($color_index{$rgb}) ) {
    286 	$colors[$nix] = $rgb;
    287 	$color_index{$rgb} = $nix;
    288     }
    289 }
    290 
    291 while ( scalar(@icolors) ) {
    292     $rgb = shift @icolors;
    293     $lost++ if ( !defined($color_index{$rgb}) );
    294 }
    295 
    296 if ( $lost ) {
    297     printf STDERR
    298 	"$0: Warning: color palette truncated (%d colors ignored)\n", $lost;
    299 }
    300 
    301 undef @icolors;
    302 
    303 # Output header
    304 print pack("Vvv", $magic, $xsize, $ysize);
    305 
    306 # Output color map
    307 for ( $i = 0 ; $i < 16 ; $i++ ) {
    308     if ( defined($colors[$i]) ) {
    309 	print $colors[$i];
    310     } else {
    311 	# Padding for unused color entries
    312 	print pack("CCC", 63*$i/15, 63*$i/15, 63*$i/15);
    313     }
    314 }
    315 
    316 sub output_nybble($) {
    317     my($ny) = @_;
    318 
    319     if ( !defined($ny) ) {
    320 	if ( defined($nybble_tmp) ) {
    321 	    $ny = 0;		# Force the last byte out
    322 	} else {
    323 	    return;
    324 	}
    325     }
    326 
    327     $ny = $ny & 0x0F;
    328 
    329     if ( defined($nybble_tmp) ) {
    330 	$ny = ($ny << 4) | $nybble_tmp;
    331 	print chr($ny);
    332 	$bytes++;
    333 	undef $nybble_tmp;
    334     } else {
    335 	$nybble_tmp = $ny;
    336     }
    337 }
    338 
    339 sub output_run($$$) {
    340     my($last,$this,$run) = @_;
    341 
    342     if ( $this != $last ) {
    343 	output_nybble($this);
    344 	$run--;
    345     }
    346     while ( $run ) {
    347 	if ( $run >= 16 ) {
    348 	    output_nybble($this);
    349 	    output_nybble(0);
    350 	    if ( $run > 271 ) {
    351 		$erun = 255;
    352 		$run -= 271;
    353 	    } else {
    354 		$erun = $run-16;
    355 		$run = 0;
    356 	    }
    357 	    output_nybble($erun);
    358 	    output_nybble($erun >> 4);
    359 	} else {
    360 	    output_nybble($this);
    361 	    output_nybble($run);
    362 	    $run = 0;
    363 	}
    364     }
    365 }
    366 
    367 $bytes  = 0;
    368 undef $nybble_tmp;
    369 
    370 for ( $y = 0 ; $y < $ysize ; $y++ ) {
    371     $last = $prev = 0;
    372     $run = 0;
    373     for ( $x = 0 ; $x < $xsize ; $x++ ) {
    374 	$rgb = shift(@data);
    375 	$i   = $color_index{$rgb} + 0;
    376 	if ( $i == $last ) {
    377 	    $run++;
    378 	} else {
    379 	    output_run($prev, $last, $run);
    380 	    $prev = $last;
    381 	    $last = $i;
    382 	    $run  = 1;
    383 	}
    384     }
    385     # Output final datum for row; we're always at least one pixel behind
    386     output_run($prev, $last, $run);
    387     output_nybble(undef);	# Flush row
    388 }
    389 
    390 $pixels = $xsize * $ysize;
    391 $size = ($pixels+1)/2;
    392 printf STDERR "%d pixels, %d bytes, (%2.2f%% compression)\n",
    393     $pixels, $bytes, 100*($size-$bytes)/$size;
    394