#!/usr/bin/perl -wT # Bitsticker 1.0.2 # 23 February 2007 # Jim DeVona # http://anoved.net/bitsticker.html # # This script converts bitmap images to an array of LDraw quadrilaterals # corresponding to the image pixels. The output is intended to be generally # compliant with the LDraw "sticker" specification, but as this script is # intended primarily as a toy rather than a legitimate part authoring tool, # strict conformance is not guaranteed. # # More information may be found in the comments and the associated HTML form. # This script requires the GD Perl module and therefore its prerequisite libgd. # These are available at http://search.cpan.org/dist/GD/ and http://libgd.org/ # if they are not already installed on your server or computer. Also required # is the Archive::Zip module and its various prerequisites, which are easier to # install with the CPAN program. Some parts of this script are derived from # libgd's gd.c and examples in O'Reilly's "CGI Programming with Perl" 2nd ed. # # Version History: # # - 1.0 initial # - 1.0.1 (2/3/2007) added "unofficial part" and "bfc certify cw" headers per # suggestion at http://news.lugnet.com/cad/?n=14395 for BFC compatibility # - 1.0.2 (6/3/2007) generate filename differently to try to avoid long path- # like filenames in browsers like IE. Noted problem unzipping with Stuffit. # # Issues: # # - Our hexadecimal "true color" format may need to be reconciled with others. # (http://news.lugnet.com/cad/?n=14172 vs http://ldlite.sourceforge.net?) # - Only transfer size is optimized (zipping); performance and memory usage # have not been addressed at all. Our Perl color substitution subroutine is # markedly slower than the compiled GD colorClosest functions used initially. # # Wish List: # # - Additional alternative color substitution algorithms (HSV, HWB as GD, etc.) # - Accelerate color substitution by reverting to GD colorClosest routines and # mapping GD palette indices to LDraw color codes; limited to 256 colors. # (256 color limit may not really be a problem; LDraw codes go up to 511, but # I've yet to see an ldconfig.ldr with that many codes actually assigned.) # - Extend script to support command line use without modification; image size # restrictions need not be applied in that context. # - Support transparency for head-up display or stained glass window effects. # Do something useful with special material colors from ldconfig.ldr. # - Verifiable compliance with LDraw sticker and OMR header specifications # (http://www.ldraw.org/article/339 and http://www.ldraw.org/article/48). # - Variable quadrilateral size for more efficient coverage. # - Complementary LDraw-sticker-to-bitmap script. # # License: # # You can do whatever you want to do with this script. # Improvements are encouraged. # No support is promised. # use strict; use CGI; use CGI::Carp 'fatalsToBrowser'; #use lib '/home/anoved/modules'; # GD #use lib '/home/anoved/modules/lib/perl5/site_perl/5.8.5'; # CPAN use lib '/Library/Perl/5.8.6/darwin-thread-multi-2level'; use GD; use Archive::Zip qw( :CONSTANTS ); # Configuration and image size restrictions use constant MAX_KB_UPLOAD => 200; use constant MAX_IMG_WIDTH => 200; use constant MAX_IMG_HEIGHT => 200; use constant DEFAULT_COLOR => 7; use constant LDCONFIG_FILE => '/home/anoved/anoved.net/files/bitsticker/ldconfig.ldr'; use constant BITSTICKER_HOME => '../bitsticker.html'; # Allow but restrict uploads $CGI::DISABLE_UPLOADS = 0; $CGI::POST_MAX = 1024 * MAX_KB_UPLOAD; # Parse CGI request my $q = new CGI; if ($q->cgi_error) { bs_error($q, $q->cgi_error . ' (maximum upload size is ' . MAX_KB_UPLOAD . ' kilobytes)'); } # Preliminary parameter-present check if ( (not defined $q->param('bitmap')) || (not defined $q->param('ldx')) || (not defined $q->param('ldy')) || (not defined $q->param('fit')) || (not defined $q->param('color')) || (not defined $q->param('backing'))) { bs_error($q, 'Incomplete parameters'); } # Load and validate dimensions as numbers greater than zero # !doesn't currently catch strings that start with digits other than 0! my ($ldx, $ldy); $ldx = $q->param('ldx'); $ldy = $q->param('ldy'); if ($ldx <= 0 || (($ldx == 0) && ($ldx ne '0'))) { bs_error($q, 'Invalid X dimension: ' . $q->param('ldx') . ' (please enter a number greater than 0)'); } if ($ldy <= 0 || (($ldy == 0) && ($ldy ne '0'))) { bs_error($q, 'Invalid Y dimension: ' . $q->param('ldy') . ' (please enter a number greater than 0)'); } # Load and validate color mode my %cp; my $colorscheme; if ($q->param('color') eq 'actual') { $colorscheme = 0; } else { # require supplemental color parameters if (not defined $q->param('colsrc')) { bs_error($q, 'Undefined color substitution palette.'); } # select substitution method (only one now, but others desired...) if ($q->param('color') eq 'ldrawrgb') { $colorscheme = 1; } else { bs_error($q, 'Invalid color scheme: ' . $q->param('color') . ' (should be actual or ldrawrgb)'); } # create and populate color substitution palette if ($q->param('colsrc') eq 'ldraw') { %cp = bs_palette(); } elsif ($q->param('colsrc') eq 'stdldconfig') { my $fp; open $fp, LDCONFIG_FILE or bs_error($q, 'Could not open ' . LDCONFIG_FILE); %cp = bs_palette($fp); close $fp; } elsif ($q->param('colsrc') eq 'customldcfg') { if (not defined $q->param('colordef')) { bs_error($q, 'Undefined color definition file.'); } %cp = bs_palette($q->param('colordef')); } else { bs_error($q, 'Invalid color substitution palette: ' . $q->param('colsrc') . ' (should be ldraw, stdldconfig, or customldcfg)'); } if (%cp == ()) { bs_error($q, 'An error occured while loading the color substitution palette.'); } } # Load and validate backing color as an integer between 0 and 511 inclusive # (LDraw color code) or as an unofficial hexadecimal color specification. my $backcolor = $q->param('backing'); if ((($backcolor < 0) || ($backcolor > 511) || (($backcolor == 0) && ($backcolor ne '0')) || ($backcolor != int($backcolor))) && ($backcolor !~ m/^0x02[0-9A-Fa-f]{6}$/)) { bs_error($q, 'Invalid paper color: ' . $q->param('backing') . ' (please enter an LDraw color code from 0 to 511 or a hexadecimal color specification in the format 0x02RRGGBB)'); } # Load and validate uploaded image #my $fh = $q->upload($q->param('bitmap')); # doesn't work #local *F = $q->upload('bitmap'); my $fh = $q->upload('bitmap') or bs_error($q, "Cannot access uploaded image."); binmode $fh; #my $fh = $q->param('bitmap'); my $img = new GD::Image($fh); if (not defined $img) { bs_error($q, 'Invalid image or unsupported format: ' . $q->param('bitmap') . ' (supported image formats include JPG, PNG, and XPM)'); } my ($imgw, $imgh) = $img->getBounds(); if ($imgw > MAX_IMG_WIDTH) { bs_error($q, 'Image too wide: ' . $imgw . ' (maximum width is ' . MAX_IMG_WIDTH . ')'); } if ($imgh > MAX_IMG_HEIGHT) { bs_error($q, 'Image too tall: ' . $imgh . ' (maximum height is ' . MAX_IMG_HEIGHT . ')'); } # we could either test for transparent color code in loop # or cheat and make a false duplicate color entry for a color identical to # the transparent color and assign it $backcolor instead #my $transparent; #if (-1 != $img->transparent()) { # #} # Load, validate, and configure scaling parameters my ($pixelw, $pixelh); my ($stickw, $stickh); if ($q->param('fit') eq 'pixel') { $pixelw = $ldx; $pixelh = $ldy; $stickw = $pixelw * $imgw; $stickh = $pixelh * $imgh; } elsif ($q->param('fit') eq 'stretch') { $stickw = $ldx; $stickh = $ldy; $pixelw = $stickw / $imgw; $pixelh = $stickh / $imgh; } elsif ($q->param('fit') eq 'scale') { $pixelw = $ldx / $imgw; $pixelh = $ldy / $imgh; if ($pixelw * $imgh <= $ldy) { $pixelh = $pixelw; } else { $pixelw = $pixelh; } $stickw = $pixelw * $imgw; $stickh = $pixelh * $imgh; } else { bs_error($q, 'Invalid fit type: ' . $q->param('fit') . ' (should be pixel, stretch, or scale)'); } # Starting coordinates center sticker on origin. my ($startx, $starty); $startx = $stickw / -2.0; $starty = $stickh / -2.0; # start with the uploaded name. probably a flaky way to get a reasonable filename my $stickername = $q->param('bitmap'); $stickername =~ s/[ _]//g; # strip spaces and real underscores $stickername =~ s/[\/\\:]/_/g; # replace anything that might be a path separator with an underscore $stickername =~ s/\.[^.]+$//; # remove file extension $stickername =~ s/[^\w]//g; # strip out anything that's not a-z0-9_ if ($stickername =~ m/_([^_]+)$/) { # any underscores that remain in stickername were actually directory separators # so consider everything after the last separator the actual filename (thanks, IE) $stickername = $1; } $stickername .= '.ldr'; # initialize file contents my $content = "0 Sticker $stickername\n"; $content .= "0 UNOFFICIAL PART\n"; $content .= "0 BFC CERTIFY CW\n"; my ($row, $col); my ($r, $g, $b); my $colorcode; my ($xmin, $xmax, $ymin, $ymax); # Print a quad for every pixel for ($row = 0; $row < $imgh; $row++) { for ($col = 0; $col < $imgw; $col++) { # retrieve the components of this pixel's color ($r, $g, $b) = $img->rgb($img->getPixel($col, $row)); # Select LDraw color code or hex specification for this RGB value if (!$colorscheme) { $colorcode = sprintf '0x02%02X%02X%02X', $r, $g, $b; } elsif ($colorscheme == 1) { $colorcode = bs_matchRGB(\%cp, $r, $g, $b); } # Place this pixel's quadrilateral! # (The -1 coefficients for ymin and ymax's increment account for the # fact that we're actually plotting the image Y plane along the LDraw # Z plane, where we want to plot +Y points in the -Z direction. Swap # sign here and for backing box to invert this behavior, ie, if you # want to map Y coordinates to the actual Y plane. To complete that # change also swap all the y coordinates with their neighboring -0.25.) $xmin = $startx + ($col * $pixelw); $xmax = $xmin + $pixelw; $ymin = -1 * ($starty + ($row * $pixelh)); $ymax = $ymin - $pixelh; $content .= sprintf "4 %s %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f\n", $colorcode, $xmin, -0.25, $ymin, $xmax, -0.25, $ymin, $xmax, -0.25, $ymax, $xmin, -0.25, $ymax; } } # Box up the rest of the sticker $xmin = $startx; $xmax = $xmin + $stickw; $ymin = -$starty; $ymax = $ymin - $stickh; # back $content .= sprintf "4 %s %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f\n", $backcolor, $xmin, 0, $ymin, $xmin, 0, $ymax, $xmax, 0, $ymax, $xmax, 0, $ymin; # top $content .= sprintf "4 %s %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f\n", $backcolor, $xmin, 0, $ymin, $xmax, 0, $ymin, $xmax, -0.25, $ymin, $xmin, -0.25, $ymin; # right $content .= sprintf "4 %s %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f\n", $backcolor, $xmax, 0, $ymin, $xmax, 0, $ymax, $xmax, -0.25, $ymax, $xmax, -0.25, $ymin; # bottom $content .= sprintf "4 %s %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f\n", $backcolor, $xmax, 0, $ymax, $xmin, 0, $ymax, $xmin, -0.25, $ymax, $xmax, -0.25, $ymax; # left $content .= sprintf "4 %s %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f %.6f\n", $backcolor, $xmin, 0, $ymax, $xmin, 0, $ymin, $xmin, -0.25, $ymin, $xmin, -0.25, $ymax; # for debugging, just print $q->header('text/plain') and print $content; otherwise: # zip the content my $zip = new Archive::Zip; my $member = $zip->addString(\$content, $stickername); $member->desiredCompressionMethod(COMPRESSION_DEFLATED); $member->desiredCompressionLevel(COMPRESSION_LEVEL_BEST_COMPRESSION); # print the zip file # -content_length=>$member->compressedSize() in header would let download client # know how much to expect, but unfortunately it is not set for from-string zips # until after writing. if we were printing unzipped, we could give the length # of $content as the content-length. print $q->header(-type => 'application/x-zip', -attachment => "$stickername.zip"); $zip->writeToFileHandle(\*STDOUT, 0); exit; # # bs_error # # Display a minimal HTML error page and exits the script. # # Parameters: # q, a CGI object # msg, error text to announce # # Return: # none # sub bs_error { my ($q, $msg) = @_; print $q->header('text/html'), $q->start_html('Bitsticker Error'), $q->h1('Bitsticker Error:'), $q->h2($msg), $q->p('Please return to ' . $q->a({-href=>BITSTICKER_HOME},'Bitsticker') . ' and verify your input.'), $q->end_html; exit; } # # bs_palette # # Populate color substitution palette. # # Parameters: # fh, file handle to read color definitions from # # Return: # () on error # associative array of colors keyed by code # sub bs_palette { my $fh = shift; my %p; if (not defined $fh) { $p{'0'} = [33,33,33]; # black $p{'1'} = [0,51,178]; # blue $p{'2'} = [0,140,20]; # green $p{'3'} = [0,153,159]; # teal $p{'4'} = [196,0,38]; # red $p{'5'} = [233,102,149]; # dark pink $p{'6'} = [92,32,0]; # brown $p{'7'} = [193,194,193]; # gray $p{'8'} = [99,95,82]; # dark gray $p{'9'} = [107,171,220]; # light blue $p{'10'} = [107,238,144]; # bright green $p{'11'} = [51,166,167]; # turquiose $p{'12'} = [255,133,122]; # light red $p{'13'} = [249,164,198]; # pink $p{'14'} = [255,220,0]; # yellow $p{'15'} = [255,255,255]; # white return %p; } my ($code, $color); my ($r, $g, $b); # look at each line in the file while (<$fh>) { # look for plain color definitions (ignore special material types) if (m{ ^\s* # line may start with whitespace 0 # 0 linetype \s+ !COLOU?R # COLOR or COLOUR meta command \s+ \w+ # color name \s+ CODE # color code marker \s+ (\d+) # get color code \s+ VALUE # color value marker \s+ \#([A-Fa-f0-9]{6}) # get color value \s+ EDGE # edge color marker \s+ (?:\d+|\#[A-Fa-f0-9]{6}) # edge color value \s*$ # line end - don't match special materials }x) { $code = $1; $color = $2; # store this color if the code has not been assigned already if (not defined $p{$code}) { $r = hex(substr($color, 0, 2)); $g = hex(substr($color, 2, 2)); $b = hex(substr($color, 4, 2)); $p{$code} = [$r, $g, $b]; } } } return %p; } # # bs_matchRGB # # Identify the most similar color in the palette to a specified color based # on Cartesian distance between RGB colorspace points. Derived from libgd's # gdImageColorClosestAlpha function (in gd.c). # # Parameters: # p, reference to color palette # r, red value # g, green value # b, blue value # # Return: # # sub bs_matchRGB { my $p = shift; my $r = shift; my $g = shift; my $b = shift; my $key; my ($dr, $dg, $db); my $dist; my $code = DEFAULT_COLOR; # max potential difference from 0,0,0 black to 255,255,255 white is # sqrt(195075), or ~442, so start with a mindist greater than the max # this simplifies the comparison logic so we don't have to test for a first # case that occurs only once. Maximum RGB color values of 255 are assumed. my $mindist = 195076; foreach $key (keys %{$p}) { # difference between palette and pixel color values $dr = @{$$p{$key}}[0] - $r; $dg = @{$$p{$key}}[1] - $g; $db = @{$$p{$key}}[2] - $b; # no need to sqrt since comparing the squares yields the same results $dist = ($dr * $dr) + ($dg * $dg) + ($db * $db); # is this the closest color yet? if ($dist < $mindist) { $mindist = $dist; $code = $key; } } return $code; }