generate.pl (11838B)
1 =pod 2 Copyright (c) 2007 Philip Taylor 3 4 Permission is hereby granted, free of charge, to any person obtaining a copy 5 of this software and associated documentation files (the "Software"), to deal 6 in the Software without restriction, including without limitation the rights 7 to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 8 copies of the Software, and to permit persons to whom the Software is 9 furnished to do so, subject to the following conditions: 10 11 The above copyright notice and this permission notice shall be included in 12 all copies or substantial portions of the Software. 13 14 THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15 IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16 FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 17 AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 18 LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 19 OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 20 THE SOFTWARE. 21 =cut 22 23 use strict; 24 use warnings; 25 26 use Compress::Zlib(); 27 use Cairo; 28 use PDL qw(float byte); 29 30 sub chunk { 31 my ($name, $data) = @_; 32 (pack 'N', length $data) . $name . $data . (pack 'N', Compress::Zlib::crc32($name . $data)); 33 } 34 35 sub IHDR { 36 my ($img) = @_; 37 return chunk 'IHDR', pack 'NNCCCCC', 38 $img->{width}, $img->{height}, 39 $img->{bit_depth}, $img->{color_type}, 40 $img->{compression_method}, $img->{filter_method}, $img->{interlace_method}; 41 } 42 43 sub gAMA { 44 my ($img) = @_; 45 return chunk 'gAMA', pack 'N', $img->{gamma}; 46 } 47 48 sub sRGB { 49 my ($img) = @_; 50 return chunk 'sRGB', pack 'C', $img->{rendering_intent}; 51 } 52 53 sub PLTE { 54 my ($img) = @_; 55 return chunk 'PLTE', pack 'C*', @{$img->{colours}}; 56 } 57 58 sub tRNS { 59 my ($img) = @_; 60 return chunk 'tRNS', pack 'C*', @{$img->{values}}; 61 } 62 63 sub IDAT { 64 my ($img) = @_; 65 return chunk 'IDAT', xdat_data($img); 66 } 67 68 sub IDAT_split { 69 my ($img, $blocksize) = @_; 70 my $c = xdat_data($img); 71 my @out; 72 while (length $c) { 73 push @out, chunk 'IDAT', substr $c, 0, $blocksize, ''; 74 } 75 return @out; 76 } 77 78 sub IEND { 79 my ($img) = @_; 80 return chunk 'IEND', ''; 81 } 82 83 sub acTL { 84 my ($img) = @_; 85 return chunk 'acTL', pack 'NN', $img->{num_frames}, $img->{num_plays}; 86 } 87 88 sub fcTL { 89 my ($img) = @_; 90 return chunk 'fcTL', pack 'NNNNNnnCC', 91 $img->{sequence_number}, 92 $img->{width}, $img->{height}, 93 $img->{x_offset}, $img->{y_offset}, 94 $img->{delay_num}, $img->{delay_den}, 95 $img->{dispose_op}, $img->{blend_op}; 96 } 97 98 sub fdAT { 99 my ($img) = @_; 100 return chunk 'fdAT', (pack 'N', $img->{sequence_number}) . xdat_data($img); 101 } 102 103 sub xdat_data { 104 my ($img) = @_; 105 return compress(filter($img->{image_data}, $img->{width}, $img->{height}, $img->{depth})); 106 } 107 108 use constant DISPOSE_NONE => 0; 109 use constant DISPOSE_BACKGROUND => 1; 110 use constant DISPOSE_PREVIOUS => 2; 111 use constant BLEND_SOURCE => 0; 112 use constant BLEND_OVER => 1; 113 114 sub filter { 115 my ($imagedata, $width, $height, $depth) = @_; 116 my $out = ''; 117 for my $scanline (0..$height-1) { 118 $out .= pack 'C', 0; 119 $out .= substr($imagedata, $scanline*$width*$depth/8, $width*$depth/8); 120 } 121 return $out; 122 } 123 124 sub compress { 125 my ($filtered) = @_; 126 return Compress::Zlib::compress($filtered); 127 } 128 129 130 sub fix_bitmap { 131 my ($d) = @_; 132 # Flip BGRA->RGBA, and undo premultiplication 133 134 my $pdl = float unpack 'C*', $d; 135 my $pdl2 = byte $pdl; 136 my $a = 255 / $pdl->mslice([3, -1, 4]); 137 $pdl2->mslice([0, -1, 4]) .= $pdl->mslice([2, -1, 4])*$a; 138 $pdl2->mslice([1, -1, 4]) .= $pdl->mslice([1, -1, 4])*$a; 139 $pdl2->mslice([2, -1, 4]) .= $pdl->mslice([0, -1, 4])*$a; 140 return ${(byte $pdl2)->get_dataref}; 141 =pod 142 my @d = unpack 'C*', $d; 143 my $a; 144 for (map $_*4, 0..$#d/4) { 145 if ($a = $d[$_+3]) { 146 $a = 255 / $a; 147 @d[$_, $_+1, $_+2] = ($d[$_+2]*$a, $d[$_+1]*$a, $d[$_]*$a); 148 } # else alpha=0 hence r=g=b=0, so nothing to do 149 } 150 return pack 'C*', @d; 151 =cut 152 } 153 154 sub create_surface { 155 my ($w, $h, $type, @data) = @_; 156 my $surface = Cairo::ImageSurface->create('argb32', $w, $h); 157 my $cr = Cairo::Context->create($surface); 158 159 if ($type eq 'red') { 160 ($type, @data) = ('solid', 1, 0, 0, 1); 161 } elsif ($type eq 'green') { 162 ($type, @data) = ('solid', 0, 1, 0, 1); 163 } elsif ($type eq 'blue') { 164 ($type, @data) = ('solid', 0, 0, 1, 1); 165 } elsif ($type eq 'cyan') { 166 ($type, @data) = ('solid', 0, 1, 1, 1); 167 } elsif ($type eq 'magenta') { 168 ($type, @data) = ('solid', 1, 0, 1, 1); 169 } elsif ($type eq 'yellow') { 170 ($type, @data) = ('solid', 1, 1, 0, 1); 171 } elsif ($type eq 'transparent') { 172 ($type, @data) = ('solid', 0, 0, 0, 0); 173 } 174 175 if ($type eq 'solid') { 176 $cr->rectangle(0, 0, $w, $h); 177 $cr->set_source_rgba(@data); 178 $cr->fill; 179 } elsif ($type eq 'doublerect') { 180 $cr->rectangle(0, 0, $w, $h); 181 $cr->set_source_rgba(@data[0..3]); 182 $cr->fill; 183 $cr->rectangle(int($w/4), int($h/4), int($w/2), int($h/2)); 184 $cr->set_source_rgba(@data[4..7]); 185 $cr->fill; 186 } else { 187 die "Invalid create_surface type '$type'"; 188 } 189 return { width => $w, height => $h, depth => 32, data => fix_bitmap($surface->get_data) }; 190 } 191 192 sub create_raw_surface { 193 my ($w, $h, $d, $data) = @_; 194 return { width => $w, height => $h, depth => $d, data => $data }; 195 } 196 197 sub find_errors { 198 my (@img) = @_; 199 my @chunks; 200 { 201 my @img2 = @img; 202 push @chunks, [ splice @img2, 0, 2 ] while @img2; 203 } 204 205 my $chunknames = join '', map "<$_->[0]>", @chunks; 206 207 my @errors; 208 209 my $has_actl = ($chunknames =~ /<acTL>/); 210 211 if ($has_actl) { 212 # acTL must be before IDAT 213 if ($chunknames =~ /<IDAT>.*<acTL>/) { 214 push @errors, "acTL after IDAT"; 215 } 216 217 # Must have only one acTL (TODO: in spec?) 218 if ($chunknames =~ /<acTL>.*<acTL>/) { 219 push @errors, "More than one acTL"; 220 } 221 222 my $num_frames = {@img}->{acTL}[0]; 223 224 # num_frames > 0 225 if ($num_frames <= 0) { 226 push @errors, "num_frames <= 0"; 227 } 228 229 # num_frames = count(fcTL) 230 my $num_fctls = grep $_->[0] eq 'fcTL', @chunks; 231 if ($num_frames != $num_fctls) { 232 push @errors, "num_frames ($num_frames) != number of fcTLs ($num_fctls)"; 233 } 234 } 235 236 # Check sequence numbers (start from 0, no duplicates or gaps) 237 my @seqnos; 238 for (grep { $_->[0] =~ /^(fcTL|fdAT|fdAT_split)$/ } @chunks) { 239 push @seqnos, $_->[1][0]; 240 } 241 if (@seqnos and (join ',', @seqnos) ne (join ',', 0..$#seqnos)) { 242 push @errors, "Incorrect sequence numbers"; 243 } 244 245 return @errors; 246 } 247 248 sub create_image { 249 my ($filename, @img) = @_; 250 my @chunks; 251 while (@img) { 252 my ($chunk, $data) = splice @img, 0, 2; 253 if ($chunk eq 'IHDR') { 254 push @chunks, IHDR { 255 width => $data->[0], 256 height => $data->[1], 257 bit_depth => defined $data->[2] ? $data->[2] : 8, 258 color_type => defined $data->[3] ? $data->[3] : 6, 259 compression_method => 0, 260 filter_method => 0, 261 interlace_method => 0, 262 }; 263 } elsif ($chunk eq 'IEND') { 264 push @chunks, IEND { } 265 } elsif ($chunk eq 'gAMA') { 266 push @chunks, gAMA { 267 gamma => int(100_000*$data->[0]), 268 }; 269 } elsif ($chunk eq 'sRGB') { 270 push @chunks, sRGB { 271 rendering_intent => $data->[0], 272 }; 273 } elsif ($chunk eq 'PLTE') { 274 push @chunks, PLTE { 275 colours => $data, 276 }; 277 } elsif ($chunk eq 'tRNS') { 278 push @chunks, tRNS { 279 values => $data, 280 }; 281 } elsif ($chunk eq 'acTL') { 282 push @chunks, acTL { 283 num_frames => $data->[0], 284 num_plays => $data->[1], 285 }; 286 } elsif ($chunk eq 'fcTL') { 287 push @chunks, fcTL { 288 sequence_number => $data->[0], 289 width => $data->[1], 290 height => $data->[2], 291 x_offset => $data->[3], 292 y_offset => $data->[4], 293 delay_num => $data->[5], 294 delay_den => $data->[6], 295 dispose_op => $data->[7], 296 blend_op => $data->[8], 297 }; 298 } elsif ($chunk eq 'IDAT') { 299 push @chunks, IDAT { 300 depth => $data->[0]{depth}, 301 width => $data->[0]{width}, 302 height => $data->[0]{height}, 303 image_data => $data->[0]{data}, 304 } 305 } elsif ($chunk eq 'IDAT_split') { 306 my $c = xdat_data { 307 depth => $data->[2]{depth}, 308 width => $data->[2]{width}, 309 height => $data->[2]{height}, 310 image_data => $data->[2]{data}, 311 }; 312 if ($data->[1] == -1) { 313 $c = substr $c, $data->[0]; 314 } else { 315 $c = substr $c, $data->[0], $data->[1] - $data->[0]; 316 } 317 push @chunks, chunk 'IDAT', $c; 318 } elsif ($chunk eq 'fdAT') { 319 push @chunks, fdAT { 320 sequence_number => $data->[0], 321 depth => $data->[1]{depth}, 322 width => $data->[1]{width}, 323 height => $data->[1]{height}, 324 image_data => $data->[1]{data}, 325 } 326 } elsif ($chunk eq 'fdAT_split') { 327 my $c = xdat_data { 328 depth => $data->[3]{depth}, 329 width => $data->[3]{width}, 330 height => $data->[3]{height}, 331 image_data => $data->[3]{data}, 332 }; 333 if ($data->[2] == -1) { 334 $c = substr $c, $data->[1]; 335 } else { 336 $c = substr $c, $data->[1], $data->[2] - $data->[1]; 337 } 338 push @chunks, chunk 'fdAT', (pack 'N', $data->[0]) . $c; 339 } else { 340 die "Invalid create_image chunk '$chunk'"; 341 } 342 } 343 open my $fh, '>', "images/$filename.png" or die $!; 344 binmode $fh; 345 print $fh "\211PNG\r\n\032\n", @chunks; 346 } 347 348 use constant W => 128; 349 use constant H => 64; 350 351 sub escape_html { 352 my ($t) = @_; 353 $t =~ s/&/&/g; 354 $t =~ s/</</g; 355 return $t; 356 } 357 358 my $img_id = '000'; 359 sub handle_html_png { 360 my ($code) = @_; 361 my $name = $img_id++; 362 my @img = eval '(' . $code . ')'; 363 die $@ if $@; 364 create_image($name, @img); 365 my $data = $code; 366 $data =~ s/^\s*(.*?)\s*$/$1/sg; 367 $data =~ s/([^a-zA-Z0-9])/sprintf('%%%02X', ord $1)/eg; 368 my $errors = (join '; ', map escape_html($_), find_errors(@img)) || 'None'; 369 return qq{<p>} 370 #. qq{<object data="$name.png" class="testimage"><strong>Did not load image.</strong></object>} # IE doesn't like this 371 . qq{<img src="$name.png" alt="Did not load image" class="testimage">\n} 372 . qq{<p><a href="data:text/plain,$data">(source)</a>\n} 373 #. qq{<p>Expected errors: $errors\n} 374 ; 375 } 376 # TODO: regexping HTML is nasty - should use a better input data format instead 377 sub handle_html_case { 378 my ($title) = @_; 379 my $id = lc $title; 380 $id =~ s/[^a-z0-9]+/-/g; 381 $id =~ s/^-*(.*?)-*$/$1/g; 382 return qq{<div class="case" id="$id">\n<p><a href="#$id">#</a> $title\n}; 383 } 384 385 open my $in, 'source.html' or die $!; 386 my $html = do { local $/; <$in> }; 387 $html =~ s/<png>(.*?)<\/png>/handle_html_png($1)/seg; 388 $html =~ s/<div class="case">\n<p>(.*?)\n/handle_html_case($1)/eg; 389 open my $out, '>', 'images/tests.html' or die $!; 390 print $out $html;