use strict; use File::Basename; use Image::Magick; #===== Copyright 2008, Webpraxis Consulting Ltd. - ALL RIGHTS RESERVED - Email: webpraxis@gmail.com ============================ # img2photomosaic_slides.pl: Photo mosaic slide generator. #=============================================================================================================================== # Usage : perl img2photomosaic_slides.pl ImageFile TileCollections TileWidth TileHeight # SlideWidth SlideHeight InitType InitRepeat Verbose # Arguments : ImageFile = path of image file to be filtered. # TileCollections = CSV string specifying which tiles to use or exclude, via references to their source # collections: # "ALL" to use all the available tiles, or # "+,ImageCollectionName1,ImageCollectionName2,..." to use just the tiles in the subset, or # "-,ImageCollectionName1,ImageCollectionName2,..." to exclude the subset from use. # TileWidth = width of a tile in pixels # TileHeight = height of a tile in pixels # SlideWidth = width of each slide in pixels # SlideHeight = height of each slide in pixels # InitType = number of turtles per quadrant: 1,2 or 4 # InitRepeat = recursion depth for partioning the image into quadrants # Verbose = boolean flag for verbose output # Input Files : See arguments. Also "photomosaic_tiles.dbm", the DBM file of tile information. # Output Directory : Slide subdirectory "frames". Directory will be created if it does not exist. # Output Files : (a) 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, # (b) the slide JPEG files, in the form "nnn.jpg" where "nnn" denotes a positive zero-padded integer. # Temporary Files : None. # Remarks : (a) Requires PerlMagick. Used module from ImageMagick 6.3.7, # (b) Setting both 'SlideWidth' and 'SlideHeight' to zero will suppress any scaling of the slides, # (c) The number of turtles, corresponding to the values of 'InitType' and 'InitRepeat', will be as follows: # InitRepeat # 0 1 2 3 4 .... # +--------------------------------------------- # 1 | 1 4 16 64 256 # InitType 2 | 2 8 32 128 512 # 4 | 4 16 64 256 1024 # History : v1.0.0 - March 9, 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 $Collections = shift || die 'ERROR: No tile collection references specified'; #get tile collection references 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 $SlideWidth = shift; my $SlideHeight = shift; my $InitType = shift; my $InitRepeat = shift; my $Verbose = shift; #get boolean flag for verbose mode die "ERROR: Cannot locate image file '$SourceFile'" unless -e $SourceFile; die "ERROR: Also set 'SlideWidth' to zero to suppress scaling" if $SlideHeight == 0 and $SlideWidth; die "ERROR: Also set 'SlideHeight' to zero to suppress scaling" if $SlideWidth == 0 and $SlideHeight; die "ERROR: Invalid value for 'InitType'" unless ( $InitType == 1 ) or ( $InitType == 2 ) or ( $InitType == 4 ); die "ERROR: Invalid value for 'InitRepeat'" if $InitRepeat < 0; 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.jpg"; #compose filename of mosaic image my $NoSlides; #slide count my $FrameDir = 'frames'; #frame subdirectory die "ERROR: Cannot create directory '$FrameDir': $!" unless ( -d $FrameDir ) or ( mkdir $FrameDir, 0600 ); my $Tile = Image::Magick->new( magick=>"GIF" ); #instantiate an image object for a tile my $TileDir = "tiles_${TileWidth}x${TileHeight}_px"; #tile subdirectory my $TileDBM = "$TileDir/photomosaic_tiles.dbm"; #DBM filepath for tile info my %TileRGB; #hash of tile rgb values { #start naked block my %tileInfo; # DBM hash my ($collOption) = $Collections =~ /^(ALL|\+|\-)/; # collections processing option die "ERROR: Cannot recognize collection option '$collOption' in '$Collections'" unless $collOption; my $collName; # name of a tile's associated image collection my $key; # DBM hash key my $value; # DBM hash value my @rgb; # array of rgb values for a tile dbmopen( %tileInfo, $TileDBM, undef ) # open the DBM file of tile info or die "ERROR: No tiles available of the specified width and height."; while( ( $key, $value ) = each %tileInfo ) { # repeat for each tile record ( $collName, @rgb ) = split /,/, $value; # parse collection name & rgb values push @{$TileRGB{$key}}, @rgb # retain this tile if ( $collOption eq 'ALL' ) or # if inclusion of all tiles requested, or ( $collOption eq '+' and $Collections =~ /\Q$collName\E,*/ ) or # if use only some collections, or ( $collOption eq '-' and $Collections !~ /\Q$collName\E,*/ ); # if not excluded } # until all tile records processed dbmclose %tileInfo; # close the DBM file undef %tileInfo; # discard DBM hash } #end naked block #------------------------------------------------------------------------------------------------------------------------------- # 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=>"JPG" ); #instantiate an image object for the mosaic $Mosaic->Read( $SourceFile ); #init mosaic with source image file $Mosaic->Quantize( 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", "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"; #------------------------------------------------------------------------------------------------------------------------------- # 2) INITIALIZE BALE: my @Bale; #array of hashes for the turtle headings & coordinates my @Tracks; #array for recording bale's prior locations { #start naked block my $no_turtles; # number of turtles $no_turtles = 4**$InitRepeat if $InitType == 1; # compute number of turtles according to initialization type $no_turtles = 2*4**$InitRepeat if $InitType == 2; $no_turtles = 4**($InitRepeat+1) if $InitType == 4; print "Bale Details: $no_turtles turtles\n", " Init Type: $InitType turtle(s) per quadrant\n", " Init Repeat: $InitRepeat\n\n"; die "ERROR: Bale size exceeds number of tiles" if $no_turtles > $No_Tile_Cols * $No_Tile_Rows; } &initBale( 0, 0, $No_Tile_Cols - 1, $No_Tile_Rows - 1, $InitRepeat ); # init all turtles print( "Pause. Press the ENTER key to continue..." ), if $Verbose; #------------------------------------------------------------------------------------------------------------------------------- # 3) PUT TURTLES IN MOTION: my $Snapshot = Image::Magick->new( magick=>"JPG" ); #instantiate an image object for the mosaic my $SnapshotIdx = 0; #snapshot index my $SnapshotIdxWidth = length( $No_Tile_Cols * $No_Tile_Rows ); #set width of slide basenames my @No_Consecutive_Turns; #array for number of consecutive left turns by each turtle &outputSnapshot(); #output source image as first slide &overlayTile($_) for ( 0..$#Bale ); #overlay first tiles before putting bale in motion &outputSnapshot(); #output resulting slide until( &sumArray(@No_Consecutive_Turns) == 4 * @Bale ) { #repeat for my $turtle ( 0..$#Bale ) { # repeat for each turtle next if $No_Consecutive_Turns[$turtle] == 4; # skip if turtle has spun around if( &noTracksAhead($turtle) and &noBoundaryAhead($turtle) ) { # if next step forward is permitted &stepForward($turtle); # move forward one step &overlayTile($turtle); # overlay tile at location } else { # else &turnLeft($turtle); # turn left } # end if-else } # until all turtles processed &outputSnapshot(); # output resulting slide } #until all turtles have spun around $Mosaic->Write( filename => $MosaicFile ); #save the mosaic to file print "\a\nNumber of slides: $NoSlides\n\nDone!\n"; #report end of processing exit; #end processing #===== 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 #------------------------------------------------------------------------------------------------------------------------------- # Usage : &overlayTile( TURTLE ); # Purpose : Overlays the region corresponding to a turtle's location with the best matching photomosaic tile. # Arguments : TURTLE = turtle's array index for @Bale. # Externals : $Tile, $TileDir, $TileHeight, $TileWidth, $Verbose, @Bale # Subs : &bestTileMatch, &meanColor. # Remarks : None. # History : v1.0.0 - March 9, 2008 - Original release. sub overlayTile { #begin sub my $turtle = shift; # turtle index my $x_top_left = $Bale[$turtle]{X} * $TileWidth; # image x-coordinate of a tile's top-left corner my $y_top_left = $Bale[$turtle]{Y} * $TileHeight; # image y-coordinate of a tile's top-left corner my $x_bottom_right = $x_top_left + $TileWidth - 1 ; # image x-coordinate of a tile's bottom-right corner my $y_bottom_right = $y_top_left + $TileHeight - 1 ; # image y-coordinate of a tile's bottom-right corner my $best_tile; # name of best matching tile my $geometry; # geometry of a tile: width, height & x,y offsets print " overlayTile: $x_top_left,$y_top_left-$x_bottom_right,$y_bottom_right: " # report progress if requested if $Verbose; $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' ) ) ); @$Tile = (); # reset tile object $Tile->Read( "$TileDir/$best_tile" ); # init tile with its image file $Mosaic->Composite( # overlay image subregion with tile image => $Tile, compose => 'Over', geometry => $geometry ); } #end sub overlayTile #------------------------------------------------------------------------------------------------------------------------------- # Usage : &noTracksAhead( TURTLE ); # Purpose : Returns true if the next grid location ahead has not been visited. Otherwise, returns false. # Arguments : TURTLE = turtle's array index for @Bale. # Externals : @Bale, @Tracks # Subs : None. # Remarks : None. # History : v1.0.0 - March 3, 2008 - Original release. sub noTracksAhead { #begin sub my $turtle = shift; 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 : &noBoundaryAhead( TURTLE ); # Purpose : Returns true if the next grid location ahead is beyond a boundary. Otherwise, returns false. # Arguments : TURTLE = turtle's array index for @Bale. # Externals : @Bale, @Tracks # Subs : None. # Remarks : None. # History : v1.0.0 - March 3, 2008 - Original release. sub noBoundaryAhead { #begin sub my $turtle = shift; if ( $Bale[$turtle]{HEADING} eq 'S' ) { return $Bale[$turtle]{Y} + 1 < $No_Tile_Rows; } elsif( $Bale[$turtle]{HEADING} eq 'N' ) { return $Bale[$turtle]{Y} - 1 >= 0; } elsif( $Bale[$turtle]{HEADING} eq 'E' ) { return $Bale[$turtle]{X} + 1 < $No_Tile_Cols; } elsif( $Bale[$turtle]{HEADING} eq 'W' ) { return $Bale[$turtle]{X} - 1 >= 0; } } #end sub noBoundaryAhead #------------------------------------------------------------------------------------------------------------------------------- # Usage : &stepForward( TURTLE ); # Purpose : Repositions a turtle to an adjacent grid location in accordance with its heading. # Arguments : TURTLE = turtle's array index for @Bale. # Externals : $Verbose, @Bale, @No_Consecutive_Turns # Subs : None. # Remarks : None. # History : v1.0.0 - March 3, 2008 - Original release. sub stepForward { #begin sub my $turtle = shift; 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}; } $Tracks[$Bale[$turtle]{X}][$Bale[$turtle]{Y}] = 1; # update bale's accessed locations $No_Consecutive_Turns[$turtle] = 0; # reset turtle's turn count print "stepForward: Turtle #$turtle - $Bale[$turtle]{X}, $Bale[$turtle]{Y}\n" # report new location if requested if $Verbose; } #end sub stepForward #------------------------------------------------------------------------------------------------------------------------------- # Usage : &turnLeft( TURTLE ); # Purpose : Changes a turtle's heading in accordance with a left turn. # Arguments : TURTLE = turtle's array index for @Bale. # Externals : $Verbose, @Bale, @No_Consecutive_Turns # Subs : None. # Remarks : None. # History : v1.0.0 - March 3, 2008 - Original release. sub turnLeft { #begin sub my $turtle = shift; $Bale[$turtle]{HEADING} =~ tr/NSEW/WENS/; # change heading to the left ++$No_Consecutive_Turns[$turtle]; # update turtle's turn count print "turnLeft: Turtle #$turtle - $Bale[$turtle]{HEADING}\n" # report new heading if requested if $Verbose; } #end sub turnLeft #------------------------------------------------------------------------------------------------------------------------------- # Usage : &sumArray( ARRAY ); # Purpose : Returns the sum of the elements of the specified array . # Arguments : ARRAY = array to be summed # Externals : None. # Subs : None. # Remarks : None. # History : v1.0.0 - March 3, 2008 - Original release. sub sumArray { #begin sub my $sum; $sum += $_ for @_; return $sum; } #end sub sumArray #------------------------------------------------------------------------------------------------------------------------------- # Usage : &outputSnapshot(); # Purpose : Outputs a scaled snapshot of the photomosaic to file. # Arguments : None. # Externals : $FrameDir, $NoSlides, $SlideHeight, $SlideWidth, $Snapshot, $SnapshotIdx, $SnapshotIdxWidth # Subs : None. # Remarks : None. # History : v1.0.0 - March 9, 2008 - Original release. sub outputSnapshot { #begin sub my $snapshotFile = "$FrameDir/" . # compose file name sprintf( "%${SnapshotIdxWidth}.${SnapshotIdxWidth}d", ++$SnapshotIdx ) . '.jpg'; @$Snapshot = (); # reset snapshot object $Snapshot = $Mosaic->Clone(); # init snapshot to full mosaic image $Snapshot->Scale( geometry => "${SlideWidth}x${SlideHeight}!" ); # scale snapshot image $Snapshot->Write( filename => $snapshotFile ); # save snapshot to file ++$NoSlides; # increment slide count } #end sub outputSnapshot #------------------------------------------------------------------------------------------------------------------------------- # Usage : &initBale( X_TOP_LEFT, Y_TOP_LEFT, X_BOTTOM_RIGHT, Y_BOTTOM_RIGHT, RECURSION_COUNT ); # Purpose : Recursively assigns initial grid locations and headings to all the turtles on a per quadrant basis. # Arguments : X_TOP_LEFT = grid x-coordinate of top-left corner # X_TOP_LEFT = grid y-coordinate of top-left corner # X_BOTTOM_RIGHT = grid x-coordinate of bottom-right corner # Y_BOTTOM_RIGHT = grid y-coordinate of bottom-right corner # RECURSION_COUNT = counter for the recursion depth # Externals : $InitType, @Bale, @Tracks # Subs : None. # Remarks : None. # History : v1.0.0 - March 4, 2008 - Original release. sub initBale { #begin sub my $x_top_left = shift; # grid x-coordinate of top-left corner my $y_top_left = shift; # grid y-coordinate of top-left corner my $x_bottom_right = shift; # grid x-coordinate of bottom-right corner my $y_bottom_right = shift; # grid y-coordinate of bottom-right corner my $recursionCount = shift; # recursion counter { # start naked block unless( $Tracks[$x_top_left][$y_top_left] ) { # if top-left corner vacant push @Bale, { HEADING => 'S', X => $x_top_left, Y => $y_top_left }; # define turtle at corner $Tracks[$x_top_left][$y_top_left] = 1; # record turtle location } # end if last if $InitType == 1; # check if only one turtle to be defined unless( $Tracks[$x_bottom_right][$y_bottom_right] ) { # if bottom-right corner vacant push @Bale, { HEADING => 'N', X => $x_bottom_right, Y => $y_bottom_right }; # define turtle at corner $Tracks[$x_bottom_right][$y_bottom_right] = 1; # record turtle location } # end if last if $InitType == 2; # check if only two turtles to be defined unless( $Tracks[$x_top_left][$y_bottom_right] ) { # if bottom-left corner vacant push @Bale, { HEADING => 'E', X => $x_top_left, Y => $y_bottom_right }; # define turtle at corner $Tracks[$x_top_left][$y_bottom_right] = 1; # record turtle location } # end if unless( $Tracks[$x_bottom_right][$y_top_left] ) { # if top-right corner vacant push @Bale, { HEADING => 'W', X => $x_bottom_right, Y => $y_top_left }; # define turtle at corner $Tracks[$x_bottom_right][$y_top_left] = 1; # record turtle location } # end if } # end naked block if( $recursionCount ) { # if recursion in effect my $x_center = $x_top_left + int( 0.5 * ( $x_bottom_right - $x_top_left ) ); # x-coordinate at 'center' my $y_center = $y_top_left + int( 0.5 * ( $y_bottom_right - $y_top_left ) ); # y-coordinate at 'center' &initBale( $x_top_left, $y_top_left, $x_center, $y_center, $recursionCount-1 ); # init top-left quadrant &initBale( $x_top_left, $y_center+1, $x_center, $y_bottom_right, $recursionCount-1 ); # init bottom-left quadrant &initBale( $x_center+1, $y_top_left, $x_bottom_right, $y_center, $recursionCount-1 ); # init top-right quadrant &initBale( $x_center+1, $y_center+1, $x_bottom_right, $y_bottom_right, $recursionCount-1 ); # init bottom-right quadrant } # end if } #end sub initBale #===== Copyright 2008, Webpraxis Consulting Ltd. - ALL RIGHTS RESERVED - Email: webpraxis@gmail.com ============================ # end of img2photomosaic_slides.pl