| 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; |
|---|
