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..." ), <STDIN> 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