use strict; use threads; use threads::shared; use File::Basename; use Image::Magick; use POSIX qw(HUGE_VAL); #===== Copyright 2008, Webpraxis Consulting Ltd. - ALL RIGHTS RESERVED - Email: webpraxis@gmail.com ============================ # img2mosaic_threaded.pl: Threaded mosaic image filter. #=============================================================================================================================== # Usage : perl img2mosaic_threaded.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_threaded.gif" where "basename" denotes the basename of the # source image file, "w" the tile width and "h" the tile height. # Temporary Files : None. # Remarks : Requires PerlMagick. Used module from ImageMagick 6.3.7. # History : v1.0.0 - July 18, 2008 - Original release. #=============================================================================================================================== # 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(''); #force Unix syntax my ( $basename, #extract basename & $path #extract path ) = fileparse( $SourceFile, '\..*' ); # of source image file my $MosaicFile = "$path${basename}_${TileWidth}x${TileHeight}_px_tiles_threaded.gif"; #compose filename of mosaic image undef $basename; #discard to minimise data copying to threads undef $path; 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 undef $ChartFile; #discard to minimise data copying to threads my %TileRGB; #hash of arrays for each color channel value my %TileColor; #hash of rgb fill attributes 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 } # until all chart entries processed undef %ColorChart; #discard to minimise data copying to threads undef $key; undef $value; undef @rgb; #------------------------------------------------------------------------------------------------------------------------------- # 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; #discard to minimise data copying to threads 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 my @MosaicBlob :shared = $Mosaic->ImageToBlob(); #convert mosaic image to a blob undef $Mosaic; #thrash mosaic object as pixel cache won't survive threading 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", "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; undef $SourceFile; #discard to minimise data copying to threads undef $sourceHeight; undef $sourceWidth; #------------------------------------------------------------------------------------------------------------------------------- # 2) INITIALIZE A TURTLE AT EACH GRID CORNER: my @Bale :shared; #array of hashes for the turtle headings & coordinates my %turtle0 :shared = ( HEADING => 'S', X => 0, Y => 0 ); #definition for turtle at top left corner my %turtle1 :shared = ( HEADING => 'W', X => $No_Tile_Cols - 1, Y => 0 ); #definition for turtle at top right corner my %turtle2 :shared = ( HEADING => 'N', X => $No_Tile_Cols - 1, Y => $No_Tile_Rows - 1 ); #definition for turtle at bottom right corner my %turtle3 :shared = ( HEADING => 'E', X => 0, Y => $No_Tile_Rows - 1 ); #definition for turtle at bottom left corner push @Bale, \%turtle0, \%turtle1, \%turtle2, \%turtle3; #init bale #------------------------------------------------------------------------------------------------------------------------------- # 3) DEFINE AN OPERATIONAL ZONE FOR EACH TURTLE: my $midRow = int( $No_Tile_Rows / 2 ); #compute a mid grid row number my $midCol = int( $No_Tile_Cols / 2 ); #compute a mid drid column number my @Zones :shared; #array of hashes for defining the zone edges my %edges0 :shared = ( TOP => 0, BOTTOM => $midRow, LEFT => 0, RIGHT => $midCol ); my %edges1 :shared = ( TOP => 0, BOTTOM => $midRow, LEFT => $midCol + 1, RIGHT => $No_Tile_Cols - 1 ); my %edges2 :shared = ( TOP => $midRow + 1, BOTTOM => $No_Tile_Rows - 1, LEFT => $midCol + 1, RIGHT => $No_Tile_Cols - 1 ); my %edges3 :shared = ( TOP => $midRow + 1, BOTTOM => $No_Tile_Rows - 1, LEFT => 0, RIGHT => $midCol ); push @Zones, \%edges0, \%edges1, \%edges2, \%edges3; #init zones undef $midRow; #discard to minimise data copying to threads undef $midCol; #------------------------------------------------------------------------------------------------------------------------------- # 4) RECORD THE INITIAL TURTLE LOCATIONS: my @Tracks :shared; #array for recording bale's prior locations & the best matching tile names $Tracks[$_] = &share([]) for ( 0..$No_Tile_Cols - 1 ); #extend as array of arrays by adding shared leaf nodes $Tracks[$_{X}][$_{Y}] = 1 for ( @Bale ); #record each initial location #------------------------------------------------------------------------------------------------------------------------------- # 5) FIND THE BEST TILE MATCHES: my @No_Consecutive_Turns :shared; #array for number of consecutive left turns by each turtle my @No_Matches :shared; #array for number of tiles matched by each turtle my @threads; #array of threads print "Finding the best tile matches...\n"; #inform user $threads[$_] = threads->create( \&launchTurtle, $_ ) for ( 0..$#Bale ); #launch a thread for each turtle $threads[$_]->join() for ( 0..$#Bale ); #wait for each thread to exit #------------------------------------------------------------------------------------------------------------------------------- # 6) OUTPUT THE MOSAIC: my $best_tile; #name of best matching tile my $colNo; #tile column number my $rowNo; #tile row number 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"; #inform user $Mosaic = Image::Magick->new( magick=>"GIF" ); #re-instantiate an image object for the mosaic $Mosaic->Set(size=>"${MosaicWidth}x${MosaicHeight}!"); #set canvas size $Mosaic->Quantize( colors=>scalar keys %TileColor, colorspace=>'RGB', dither=>0 ); #insure correct colorspace & no dithering $Mosaic->ReadImage('xc:none'); #set no background for $rowNo ( 0..$No_Tile_Rows - 1 ) { #repeat for each tile row $y_top_left = $rowNo * $TileHeight; # image y-coordinate of the tile's top-left corner $y_bottom_right = $y_top_left + $TileHeight - 1; # image y-coordinate of the tile's bottom-right corner for $colNo ( 0..$No_Tile_Cols - 1 ) { # repeat for each tile column $x_top_left = $colNo * $TileWidth; # image x-coordinate of the tile's top-left corner $x_bottom_right = $x_top_left + $TileWidth - 1; # image x-coordinate of the tile's bottom-right corner $best_tile = $Tracks[$colNo][$rowNo]; # retrieve name of best matching tile $Mosaic->Draw( primitive => 'rectangle', # draw the tile fill => $TileColor{ $best_tile }, points => "$x_top_left,$y_top_left $x_bottom_right,$y_bottom_right" ); } # until all tile columns processed } #until all tile rows processed $Mosaic->Write( filename => $MosaicFile ); #save the mosaic to file #------------------------------------------------------------------------------------------------------------------------------- # 7) REPORT THE NUMBER OF TILES MATCHED BY EACH TURTLE: my $totalMatches; #total number of tile matches print "\n"; for ( 0..$#No_Matches ) { #repeat for each turtle print "Turtle #$_ matched $No_Matches[$_] tiles "; # report count printf "(%4.1f\%)\n", int ( 100 * $No_Matches[$_] / ( $No_Tile_Cols * $No_Tile_Rows ) ); $totalMatches += $No_Matches[$_]; # update total } #until all turtles processed print "\n\aOOOPS! Number of tile matches ($totalMatches) doesn't equal the tile count!" #report any discrepancy unless $totalMatches == $No_Tile_Cols * $No_Tile_Rows; exit; #end processing #===== SUBROUTINES ============================================================================================================= # Usage : &launchTurtle( $TURTLE ); # Purpose : Governs the movement of a threaded turtle to find the best matching tiles. # Arguments : $TURTLE = turtle's array index for @Bale. # Externals : $TileHeight, $TileRGB, $TileWidth, $Verbose # Shared Externals : @Bale, @MosaicBlob, @No_Consecutive_Turns, @No_Matches, @Tracks, @Zones # Subs : None. # Remarks : Names of the best matching tiles are stored in @Tracks. # History : v1.0.0 - July 18, 2008 - Original release. sub launchTurtle { #begin sub my $turtle = shift; # turtle index my $mosaic = Image::Magick->new( magick=>"GIF" ); # instantiate an image object for the image $mosaic->BlobToImage( @MosaicBlob ); # init image object &findBestTile(); # find best matching tile at starting location until( &spunAround() ) { # repeat until end of trek if( &noBoundaryAhead() and &noTracksAhead() ) { # if next step forward is permitted &stepForward(); # move forward one step &findBestTile(); # find matching best tile at location } else { # else &turnLeft(); # turn left } # end if-else } # until turtle has spun around completely threads->exit(); #end thread processing # Usage : &spunAround(); # Purpose : Checks if a turtle has done 4 consecutive left turns. If so, returns true, otherwise false. # Arguments : None. # Externals : $turtle # Shared Externals : @No_Consecutive_Turns # Subs : None. # Remarks : None. # History : v1.0.0 - July 18, 2008 - Original release. sub spunAround { # begin sub lock( @No_Consecutive_Turns ); # lock no-of-turns array for read return $No_Consecutive_Turns[$turtle] == 4; # return check } # end sub spunAround # Usage : &bestTileMatch( $RED, $GREEN, $BLUE ); # Purpose : Matches a tile to the mean RGB channel values of an image area. Returns the name of the tile. # Arguments : $RED = mean 8-bit red color # $GREEN = mean 8-bit green color # $BLUE = mean 8-bit blue color # Externals : $TileRGB, $Verbose # Shared Externals : None. # Subs : None. # Remarks : None. # History : v1.0.0 - July 18, 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 = &POSIX::HUGE_VAL; # 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 : Returns the mean channel color as an 8-bit value. # Arguments : @COLORS = list of normalized channel intensities to be averaged. # Externals : $Verbose # Shared Externals : None. # Subs : None. # Remarks : None. # History : v1.0.0 - July 18, 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 # Usage : &findBestTile(); # Purpose : Finds the best matching tile for the image area corresponding to a turtle's location. # Arguments : None. # Externals : $mosaic, $turtle, $TileHeight, $TileWidth, $Verbose # Shared Externals : @Bale, @No_Matches, @Tracks # Subs : &bestTileMatch, &meanColor. # Remarks : The tile name is stored in the shared array @Tracks. # History : v1.0.0 - July 18 - Original release. sub findBestTile { # begin sub my $x_top_left; # image x-coordinate of a tile's top-left corner my $y_top_left; # image y-coordinate of a tile's top-left corner { # start naked block to scope lock lock( @Bale ); # lock bale array for read $x_top_left = $Bale[$turtle]{X} * $TileWidth; # compute x-coordinate of a tile's top-left corner $y_top_left = $Bale[$turtle]{Y} * $TileHeight; # compute y-coordinate of a tile's top-left corner } # end naked block, releasing lock my $geometry = "${TileWidth}x${TileHeight}+$x_top_left+$y_top_left"; # geometry of a tile: width, height & x,y offsets my $best_tile; # name of best matching tile print "Turtle #$turtle: findBestTile - " if $Verbose; # report progress if requested $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' ) ) ); lock( @Bale ); # lock bale array for read lock( @Tracks ); # lock tracks array for write $Tracks[$Bale[$turtle]{X}][$Bale[$turtle]{Y}] = $best_tile; # record name of best matching tile lock( @No_Matches ); # lock no-of-matches array for write ++$No_Matches[$turtle]; # update match count } # end sub findBestTile # Usage : &noBoundaryAhead(); # Purpose : Returns true if the next grid location ahead is beyond an operational boundary. Otherwise, returns false. # Arguments : None. # Externals : $turtle # Shared Externals : @Bale, @Zones # Subs : None. # Remarks : None. # History : v1.0.0 - July 18, 2008 - Original release. sub noBoundaryAhead { # begin sub lock( @Bale ); # lock bale array for read lock( @Zones ); # lock zone array for read if ( $Bale[$turtle]{HEADING} eq 'S' ) { return !( $Bale[$turtle]{Y} + 1 > $Zones[$turtle]{BOTTOM} ) } elsif( $Bale[$turtle]{HEADING} eq 'N' ) { return !( $Bale[$turtle]{Y} - 1 < $Zones[$turtle]{TOP} ) } elsif( $Bale[$turtle]{HEADING} eq 'E' ) { return !( $Bale[$turtle]{X} + 1 > $Zones[$turtle]{RIGHT} ) } elsif( $Bale[$turtle]{HEADING} eq 'W' ) { return !( $Bale[$turtle]{X} - 1 < $Zones[$turtle]{LEFT} ) } } # end sub noBoundaryAhead # Usage : &noTracksAhead( $TURTLE ); # Purpose : Returns true if the next grid location ahead has not been visited. Otherwise, returns false. # Arguments : None. # Externals : $turtle # Shared Externals : @Bale, @Tracks # Subs : None. # Remarks : None. # History : v1.0.0 - July 18, 2008 - Original release. sub noTracksAhead { # begin sub lock( @Bale ); # lock bale array for read lock( @Tracks ); # lock tracks array for read if ( $Bale[$turtle]{HEADING} eq 'S' ) { return !$Tracks[$Bale[$turtle]{X} ][$Bale[$turtle]{Y} + 1] } elsif( $Bale[$turtle]{HEADING} eq 'N' ) { return !$Tracks[$Bale[$turtle]{X} ][$Bale[$turtle]{Y} - 1] } elsif( $Bale[$turtle]{HEADING} eq 'E' ) { return !$Tracks[$Bale[$turtle]{X} + 1][$Bale[$turtle]{Y} ] } elsif( $Bale[$turtle]{HEADING} eq 'W' ) { return !$Tracks[$Bale[$turtle]{X} - 1][$Bale[$turtle]{Y} ] } } # end sub noTracksAhead # Usage : &stepForward(); # Purpose : Repositions a turtle to an adjacent grid location in accordance with its heading. # Arguments : None. # Externals : $turtle, $Verbose # Shared Externals : @Bale, @No_Consecutive_Turns, @Tracks # Subs : None. # Remarks : None. # History : v1.0.0 - July 18, 2008 - Original release. sub stepForward { # begin sub lock( @Bale ); # lock bale array for read-write if ( $Bale[$turtle]{HEADING} eq 'S' ) { ++$Bale[$turtle]{Y} } elsif( $Bale[$turtle]{HEADING} eq 'N' ) { --$Bale[$turtle]{Y} } elsif( $Bale[$turtle]{HEADING} eq 'E' ) { ++$Bale[$turtle]{X} } elsif( $Bale[$turtle]{HEADING} eq 'W' ) { --$Bale[$turtle]{X} } lock( @No_Consecutive_Turns ); # lock no-of-turns array for write $No_Consecutive_Turns[$turtle] = 0; # reset turtle's turn count lock( @Tracks ); # lock tracks array for write $Tracks[$Bale[$turtle]{X}][$Bale[$turtle]{Y}] = 1; # update bale's accessed locations print "Turtle #$turtle: stepForward - $Bale[$turtle]{X}, $Bale[$turtle]{Y}\n" # report new location if requested if $Verbose; } # end sub stepForward # Usage : &turnLeft( ); # Purpose : Changes a turtle's heading in accordance with a left turn. # Arguments : None. # Externals : $turtle, $Verbose # Shared Externals : @Bale, @No_Consecutive_Turns # Subs : None. # Remarks : None. # History : v1.0.0 - July 18, 2008 - Original release. sub turnLeft { # begin sub lock( @Bale ); # lock bale array for write $Bale[$turtle]{HEADING} =~ tr/NSEW/WENS/; # change heading to the left lock( @No_Consecutive_Turns ); # lock no-of-turns array for write ++$No_Consecutive_Turns[$turtle]; # update turtle's turn count print "Turtle #$turtle: turnLeft - $Bale[$turtle]{HEADING}\n" if $Verbose; # report new heading if requested } # end sub turnLeft } #end sub launchTurtle #===== Copyright 2008, Webpraxis Consulting Ltd. - ALL RIGHTS RESERVED - Email: webpraxis@gmail.com ============================ # end of img2mosaic_threaded.pl