use strict; use File::Basename; use FileHandle; use Image::Magick; #===== Copyright 2008, Webpraxis Consulting Ltd. - ALL RIGHTS RESERVED - Email: webpraxis@gmail.com ============================ # img2mosaic.pl: Mosaic image filter with assembly instructions. #=============================================================================================================================== # Usage : perl img2mosaic.pl ImageFile ColorChartFile TileWidth TileHeight Verbose # Arguments : ImageFile = path of image file to be filtered. # ColorChartFile = path of text file containing the hash declarations for the color chart. # TileWidth = width of a tile in pixels # TileHeight = height of a tile in pixels # Verbose = boolean flag for verbose output # Input Files : See arguments. # Output Files : Mosaic GIF file in the form "basename_wxh_px_tiles.gif" where "basename" denotes the basename of the # source image file, "w" the tile width and "h" the tile height. # Mosaic text assembly instructions in the form "basename_wxh_px_tiles.txt". # Temporary Files : None. # Remarks : Requires PerlMagick. Used module from ImageMagick 6.3.7. # History : v1.0.0 - January 24, 2008 - Original release. # v1.0.1 - February 11, 2008 - Scaling of mosaic image now done with force # v1.0.2 - February 17, 2008 - Added call to "fileparse_set_fstype" to force Unix syntax #=============================================================================================================================== # 0) INITIALIZE: system( 'cls' ) if $^O =~ /^MSWin/; #clear screen if running Windows print "$0\n", '=' x length($0), "\n\n"; #display program name my $SourceFile = shift || die 'ERROR: No image file specified'; #get path of source image file my $ChartFile = shift || die 'ERROR: No color-chart file specified'; #get path of color-chart file my $TileWidth = shift || die 'ERROR: No tile width specified'; #get pixel width of a tile my $TileHeight = shift || die 'ERROR: No tile height specified'; #get pixel height of a tile my $Verbose = shift; #get boolean flag for verbose mode die 'ERROR: Cannot locate image file' unless -e $SourceFile; die 'ERROR: Cannot locate color-chart file' unless -e $ChartFile; fileparse_set_fstype(''); my ( $basename, #extract basename & $path #extract path ) = fileparse( $SourceFile, '\..*' ); # of source image file my $MosaicFile = "$path${basename}_${TileWidth}x${TileHeight}_px_tiles.gif"; #compose filename of mosaic image my $ReportFile = "$path${basename}_${TileWidth}x${TileHeight}_px_tiles.txt"; #compose filename of report local *REPORT; #define filehandle for the report my %ColorChart; #hash of tile id codes => rgb color values push @ARGV, $ChartFile; #set up reading of color chart eval '%ColorChart = (' . join( '', <> ) . ')'; #load chart into hash my %TileRGB; #hash of arrays for each color channel value my %TileColor; #hash of rgb fill attributes my %TileId; #hash of tile id codes { #start naked block my $key; # chart hash key my $value; # chart hash value my @rgb; # array of rgb channel colors while( ( $key, $value ) = each %ColorChart ) { # repeat for each chart entry @rgb = split / /, $value; # extract hex channel colors push @{ $TileRGB{ $key } }, hex for @rgb; # create RGB array of decimal values $TileColor{ $key } = '#' . join '', @rgb; # create rgb fill attribute $TileId{ $key } = ( split /-/, $key )[0]; # extract tile id code } # until all chart entries processed } #end naked block undef %ColorChart; #discard the color chart my %TileCounts; #hash for tile totals per type my $Blueprint; #mosaic assembly instructions #------------------------------------------------------------------------------------------------------------------------------- # 1) SETUP MOSAIC IMAGE: my $source = Image::Magick->new; #instantiate an image object for the source my ( $SourceWidth, #get width & $SourceHeight #get height ) = ( $source->Ping( $SourceFile ) )[0,1]; #of source undef $source; #destroy the image object for the source my $No_Tile_Cols = $SourceWidth / $TileWidth; #compute raw number of tile columns $No_Tile_Cols = int( ++$No_Tile_Cols ) #adjust to an integral number unless $No_Tile_Cols == int( $No_Tile_Cols ); # if necessary my $No_Tile_Rows = $SourceHeight / $TileHeight; #compute raw number of tile rows $No_Tile_Rows = int( ++$No_Tile_Rows ) #adjust to an integral number unless $No_Tile_Rows == int( $No_Tile_Rows ); # if necessary my $MosaicWidth = $No_Tile_Cols * $TileWidth; #compute pixel width of mosaic image my $MosaicHeight = $No_Tile_Rows * $TileHeight; #compute pixel height of mosaic image my $Mosaic = Image::Magick->new( magick=>"GIF" ); #instantiate an image object for the mosaic $Mosaic->Read( $SourceFile ); #init mosaic with source image file $Mosaic->Quantize( colors=>scalar keys %TileColor, colorspace=>'RGB' ); #insure correct colorspace $Mosaic->Scale( geometry=>"${MosaicWidth}x${MosaicHeight}!" ); #scale mosaic image print "Source Image: $SourceFile\n", #echo initialization results " Width: $SourceWidth px\n", " Height: $SourceHeight px\n", "Mosaic Image: $MosaicFile\n", " Width: $MosaicWidth px\n", " Height: $MosaicHeight px\n", "Report File: $ReportFile\n\n", "Mosaic Details: ", $No_Tile_Cols * $No_Tile_Rows, " tiles\n", " No. of rows: $No_Tile_Rows\n", " No. of cols: $No_Tile_Cols\n", " Tile width: $TileWidth px\n", " Tile height: $TileHeight px\n\n"; print( "Pause. Press the ENTER key to continue..." ), if $Verbose; #------------------------------------------------------------------------------------------------------------------------------- # 2) CREATE MOSAIC IMAGE: { #start naked block my $best_tile; # name of best matching tile my $colNo; # tile column number my $rowNo; # tile row number my $geometry; # geometry of a tile: width, height & x,y offsets my $x_top_left; # x-coordinate of a tile's top-left corner my $y_top_left; # y-coordinate of a tile's top-left corner my $x_bottom_right; # x-coordinate of a tile's bottom-right corner my $y_bottom_right; # y-coordinate of a tile's bottom-right corner print "Creating mosaic image...\n"; for ( $y_top_left = $MosaicHeight - $TileHeight; # for each tile row: start at bottom and work up $y_top_left >= 0; $y_top_left -= $TileHeight ) { ++$rowNo; # update tile row number $colNo = 0; # reset tile column number $y_bottom_right = $y_top_left + $TileHeight - 1; # compute y-coord. of the tile's bottom-right corner for ( $x_top_left = 0; # for each tile column: work left to right $x_top_left < $MosaicWidth - 1; $x_top_left += $TileWidth ) { ++$colNo; # update tile column number $x_bottom_right = $x_top_left + $TileWidth - 1; # compute x-coord. of the tile's bottom-right corner print "\tTile# $rowNo,$colNo \@ $x_top_left,$y_top_left-$x_bottom_right,$y_bottom_right: " if $Verbose; # report progress if requested $geometry = "${TileWidth}x${TileHeight}+$x_top_left+$y_top_left"; # define tile geometry $best_tile = &bestTileMatch # match mean image-area colors to a tile ( &meanColor # compute mean red color ( $Mosaic->GetPixels # get normalized red intensities of all pixels ( map => 'r', geometry => $geometry, normalize => 'true' ) ), &meanColor # compute mean green color ( $Mosaic->GetPixels # get normalized green intensities of all pixels ( map => 'g', geometry => $geometry, normalize => 'true' ) ), &meanColor # compute mean blue color ( $Mosaic->GetPixels # get normalized blue intensities of all pixels ( map => 'b', geometry => $geometry, normalize => 'true' ) ) ); $Blueprint .= "$TileId{ $best_tile } "; # add tile id to assembly instructions ++$TileCounts{ $best_tile }; # update corresponding tile total $Mosaic->Draw( primitive => 'rectangle', # replace image subregion with tile fill => $TileColor{ $best_tile }, points => "$x_top_left,$y_top_left $x_bottom_right,$y_bottom_right" ); } # until all tile columns processed $Blueprint .= "\n"; # mark end of row in assembly blueprint } # until all tile rows processed $Mosaic->Write( filename => $MosaicFile ); # save the mosaic to file undef $Mosaic; # destroy the mosaic image object } #end naked block #------------------------------------------------------------------------------------------------------------------------------- # 3) REPORT TILE BREAKDOWN: open REPORT, ">$ReportFile"; print "\nWriting the report...\n\n"; print REPORT "Tile Totals: ", $No_Tile_Rows * $No_Tile_Cols, " ($No_Tile_Rows rows x $No_Tile_Cols columns)\n\n"; printf REPORT "\t%-25s: %d\n", $_, $TileCounts{$_} for sort keys %TileCounts; #------------------------------------------------------------------------------------------------------------------------------- # 4) REPORT AGGREGATED BLUEPRINT: { #start naked block my $repetitions; # number of tile-id repetitions print REPORT "\nBlueprint (bottom to top, left to right):\n\n"; # report header study $Blueprint; # prep for substitutions for ( map{ $TileId{ $_ } } keys %TileCounts ) { # for each id of tile present for ( $repetitions = $No_Tile_Cols; $repetitions > 1; --$repetitions ) { # for each possible repetition $Blueprint =~ s/($_ ){$repetitions}/"$_\[$repetitions\] "/esg; # aggregate } # until all repetitions examined } # until all tile ids processed REPORT->format_name( "BLUEPRINT" ); # declare report format for blueprint $: = " "; # set the line-break character write REPORT for split /\n/, $Blueprint; # output assembly instructions } #end naked block close REPORT; print "\a\nDone!\n"; #report end of processing exit; #end processing #===== FORMATS ================================================================================================================= { #start naked block my $rowNo; # blueprint row number format BLUEPRINT = # format for reporting the assembly instructions Row# @>>: ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ++$rowNo, $_ ^<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<~~ $_ . } #end naked block #===== SUBROUTINES ============================================================================================================= # Usage : &bestTileMatch( $RED, $GREEN, $BLUE ); # Purpose : Matches a tile to the mean RGB channel values of an image area. # Arguments : $RED = mean 8-bit red color # $GREEN = mean 8-bit green color # $BLUE = mean 8-bit blue color # Externals : $TileRGB, $Verbose # Subs : None. # Remarks : None. # History : v1.0.0 - January 23, 2008 - Original release. sub bestTileMatch { #begin sub my ( $red, $green, $blue ) = @_; # parametrize the arguments my $bestTile; # name of tile that best matches mean color my $deltaRed; # difference in red color values my $deltaGreen; # difference in green color values my $deltaBlue; # difference in blue color values my $key; # hash key = tile name my $value; # hash value = array of channel color intensities my $metric; # squared Euclidean metric of intensities my $minMetric = 65536 * 65536; # minimum value of the metric while( ( $key, $value ) = each %TileRGB ) { # repeat for each possible tile $deltaRed = $red - @{$value}[0]; # compute difference in red colors $deltaGreen = $green - @{$value}[1]; # compute difference in green colors $deltaBlue = $blue - @{$value}[2]; # compute difference in blue colors $metric = $deltaRed * $deltaRed + # compute metric $deltaGreen * $deltaGreen + $deltaBlue * $deltaBlue; $minMetric = $metric, $bestTile = $key if $metric < $minMetric; # update minimum metric & possible best tile } # until all tiles processed print "=> $bestTile\n" if $Verbose; # report if requested return $bestTile; # return best matching tile name } #end sub bestTileMatch #------------------------------------------------------------------------------------------------------------------------------- # Usage : &meanColor( @COLORS ); # Purpose : Computes the mean 8-bit channel color. # Arguments : @COLORS = list of normalized channel intensities to be averaged. # Externals : $Verbose # Subs : None. # Remarks : None. # History : v1.0.0 - January 23, 2008 - Original release. sub meanColor { #begin sub my $mean; # mean 8-bit color value $mean += $_ for @_; # sum all the normalized color values $mean = 256 * $mean / scalar @_; # compute the mean 8-bit value printf "%5.1f ", $mean if $Verbose; # report if requested return $mean; # return the mean } #end sub meanColor #===== Copyright 2008, Webpraxis Consulting Ltd. - ALL RIGHTS RESERVED - Email: webpraxis@gmail.com ============================ # end of img2mosaic.pl