File Coverage

blib/lib/FuseBead/From/PNG.pm

Criterion	Covered	Total	%
statement	8	10	80.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	12	14	85.7

package FuseBead::From::PNG;

use strict;
use warnings;

BEGIN {
    $FuseBead::From::PNG::VERSION = '0.01';
}

use Image::PNG::Libpng qw(:all);
use Image::PNG::Const qw(:all);

use FuseBead::From::PNG::Const qw(:all);

use FuseBead::From::PNG::Bead;

use Data::Debug;

use Memoize;
memoize('_find_bead_color', INSTALL => '_find_bead_color_fast');

sub new {
    my $class = shift;
    my %args = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;

    my $hash = {};

    $hash->{'filename'} = $args{'filename'};

    $hash->{'unit_size'} = $args{'unit_size'} || 1;

    # White list default
    $hash->{'whitelist'} = ($args{'whitelist'} && ref($args{'whitelist'}) eq 'ARRAY' && scalar(@{$args{'whitelist'}}) > 0) ? $args{'whitelist'} : undef;

    # Black list default
    $hash->{'blacklist'} = ($args{'blacklist'} && ref($args{'blacklist'}) eq 'ARRAY' && scalar(@{$args{'blacklist'}}) > 0) ? $args{'blacklist'} : undef;

    my $self = bless ($hash, ref ($class) || $class);

    return $self;
}

sub bead_dimensions {
    my $self = shift;

    return $self->{'bead_dimensions'} ||= do {
        my $hash = {};

        for my $type (qw/imperial metric/) {
            my $bead_diameter =
                FuseBead::From::PNG::Const->BEAD_DIAMETER
                * ($type eq 'imperial' ? FuseBead::From::PNG::Const->MILLIMETER_TO_INCH : 1);

            $hash->{$type} = {
                bead_diameter => $bead_diameter,
            };
        }

        $hash;
    };
}

sub bead_colors {
    my $self = shift;

    return $self->{'bead_colors'} ||= do {
        my $hash = {};

        for my $color ( BEAD_COLORS ) {
            my ($n_key, $hex_key, $r_key, $g_key, $b_key) = (
                $color . '_NAME',
                $color . '_HEX_COLOR',
                $color . '_RGB_COLOR_RED',
                $color . '_RGB_COLOR_GREEN',
                $color . '_RGB_COLOR_BLUE',
            );

            no strict 'refs';

            $hash->{ $color } = {
                'cid'         => $color,
                'name'        => FuseBead::From::PNG::Const->$n_key,
                'hex_color'   => FuseBead::From::PNG::Const->$hex_key,
                'rgb_color'   => [
                    FuseBead::From::PNG::Const->$r_key,
                    FuseBead::From::PNG::Const->$g_key,
                    FuseBead::From::PNG::Const->$b_key,
                ],
            };
        }

        $hash;
    };
}

sub beads {
    my $self = shift;

    return $self->{'beads'} ||= do {
        my $hash = {};

        for my $color ( BEAD_COLORS ) {
            my $bead = FuseBead::From::PNG::Bead->new( color => $color );

            $hash->{ $bead->identifier } = $bead;
        }

        $hash;
    };
}

sub png {
    my $self = shift;

    return $self->{'png'} ||= do {
        my $png = read_png_file($self->{'filename'}, transforms => PNG_TRANSFORM_STRIP_ALPHA);

        $png;
    };
};

sub png_info {
    my $self = shift;

    return $self->{'png_info'} ||= $self->png->get_IHDR;
}

sub bead_row_length {
    my $self = shift;

    return $self->{'bead_row_length'} ||= $self->png_info->{'width'} / $self->{'unit_size'};
}

sub bead_col_height {
    my $self = shift;

    return $self->{'bead_col_height'} ||= $self->png_info->{'height'} / $self->{'unit_size'};
}

sub process {
    my $self = shift;
    my %args = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;

    my $tally = {
        beads => {},
        plan   => [],
    };

    if($self->{'filename'}) {
        my @blocks = $self->_png_blocks_of_color;

        my @units = $self->_approximate_bead_colors( blocks => \@blocks );

        my @beads = $self->_generate_bead_list(units => \@units);

        $tally->{'plan'} = [ map { $_->flatten } @beads ];

        my %list;
        for my $bead(@beads) {
            if(! exists $list{ $bead->identifier }) {
                $list{ $bead->identifier } = $bead->flatten;

                delete $list{ $bead->identifier }{'meta'}; # No need for meta in bead list

                $list{ $bead->identifier }{'quantity'} = 1;
            }
            else {
                $list{ $bead->identifier }{'quantity'}++;
            }
        }

        $tally->{'beads'} = \%list;

        $tally->{'info'} = $self->_plan_info();
    }

    if($args{'view'}) {
        my $view   = $args{'view'};
        my $module = "FuseBead::From::PNG::View::$view";

        $tally = eval {
            (my $file = $module) =~ s|::|/|g;
            require $file . '.pm';

            $module->new($self)->print($tally);
        };

        die "Failed to format as a view ($view). $@" if $@;
    }

    return $tally;
}

sub whitelist { shift->{'whitelist'} }

sub has_whitelist {
    my $self    = shift;
    my $allowed = shift; # arrayref listing filters we can use

    my $found = 0;
    for my $filter(values $self->_list_filters($allowed)) {
        $found += scalar( grep { /$filter/ } @{ $self->whitelist || [] } );
    }

    return $found;
}

sub is_whitelisted {
    my $self    = shift;
    my $val     = shift;
    my $allowed = shift; # arrayref listing filters we can use

    return 1 if ! $self->has_whitelist($allowed); # return true if there is no whitelist

    for my $entry( @{ $self->whitelist || [] } ) {
        for my $filter( values %{ $self->_list_filters($allowed) } ) {
            next unless $entry =~ /$filter/; # if there is at least a letter at the beginning then this entry has a color we can check

            my $capture = $entry;
            $capture =~ s/$filter/$1/;

            return 1 if $val eq $capture;
        }
    }

    return 0; # value is not in whitelist
}

sub blacklist { shift->{'blacklist'} }

sub has_blacklist {
    my $self    = shift;
    my $allowed = shift; # optional filter restriction

    my $found = 0;

    for my $filter(values $self->_list_filters($allowed)) {
        $found += scalar( grep { /$filter/ } @{ $self->blacklist || [] } );
    }

    return $found;
}

sub is_blacklisted {
    my $self    = shift;
    my $val     = shift;
    my $allowed = shift; # optional filter restriction

    return 0 if ! $self->has_blacklist($allowed); # return false if there is no blacklist

    for my $entry( @{ $self->blacklist || [] } ) {
        for my $filter( values %{ $self->_list_filters($allowed) } ) {
            next unless $entry =~ /$filter/; # if there is at least a letter at the beginning then this entry has a color we can check

            my $capture = $1 || $entry;

            return 1 if $val eq $capture;
        }
    }

    return 0; # value is not in blacklist
}

sub _png_blocks_of_color {
    my $self = shift;
    my %args = ref $_[0] eq 'HASH' ? %{$_[0]} : @_;

    my @blocks;

    return @blocks unless $self->{'filename'}; # No file, no blocks

    my $pixel_bytecount = 3;

    my $y = -1;

    for my $pixel_row( @{$self->png->get_rows} ) {
        $y++;

        next unless ($y % $self->{'unit_size'}) == 0;

        my $row = $y / $self->{'unit_size'}; # get actual row of blocks we are current on

        my @values = unpack 'C*', $pixel_row;

        my $row_width = ( scalar(@values) / $pixel_bytecount ) / $self->{'unit_size'};

        for(my $col = 0; $col < $row_width; $col++) {
            my ($r, $g, $b) = (
                $values[ ($self->{'unit_size'} * $pixel_bytecount * $col)     ],
                $values[ ($self->{'unit_size'} * $pixel_bytecount * $col) + 1 ],
                $values[ ($self->{'unit_size'} * $pixel_bytecount * $col) + 2 ]
            );

            $blocks[ ($row * $row_width) + $col ] = {
                r => $r,
                g => $g,
                b => $b,
            };
        }
    }

    return @blocks;
}

sub _color_score {
    my $self      = shift;
    my ($c1, $c2) = @_;

    return abs( $c1->[0] - $c2->[0] ) + abs( $c1->[1] - $c2->[1] ) + abs( $c1->[2] - $c2->[2] );
}

sub _find_bead_color {
    my $self  = shift;
    my $rgb   = [ @_ ];

    my @optimal_color =
        map  { $_->{'cid'} }
        sort { $a->{'score'} <=> $b->{'score'} }
        map  {
            +{
                cid => $_->{'cid'},
                score => $self->_color_score($rgb, $_->{'rgb_color'}),
            };
        }
        values %{ $self->bead_colors };

    my ($optimal_color) = grep {
        $self->is_whitelisted( $_, 'color' )
        && ! $self->is_blacklisted( $_, 'color' )
    } @optimal_color; # first color in list that passes whitelist and blacklist should be the optimal color for tested block

    return $optimal_color;
}

sub _approximate_bead_colors {
    my $self = shift;
    my %args = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;

    die 'blocks not valid' unless $args{'blocks'} && ref( $args{'blocks'} ) eq 'ARRAY';

    my @colors;

    for my $block(@{ $args{'blocks'} }) {
        push @colors, $self->_find_bead_color_fast( $block->{'r'}, $block->{'g'}, $block->{'b'} );
    }

    return @colors;
}

sub _generate_bead_list {
    my $self = shift;
    my %args = ref $_[0] eq 'HASH' ? %{ $_[0] } : @_;

    die 'units not valid' unless $args{'units'} && ref( $args{'units'} ) eq 'ARRAY';

    my @beads = $self->_bead_list($args{'units'});

    return @beads;
}

sub _bead_list {
    my $self  = shift;
    my @units = ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_;

    my $unit_count   = scalar(@units);
    my $row_width    = $self->bead_row_length;
    my $bead_ref     = -1; # artificial auto-incremented id
    my @beads;

    for (my $y = 0; $y < ($unit_count / $row_width); $y++) {
        my @row = splice @units, 0, $row_width;
        my $x   = 0;

        for my $color( @row ) {
            push @beads, FuseBead::From::PNG::Bead->new(
                color  => $color,
                meta   => {
                    x   => $x,
                    y   => $y,
                    ref => ++$bead_ref,
                },
            );
            $x++;
        }
    }

    return @beads;
}

sub _list_filters {
    my $self    = shift;
    my $allowed = $_[0] && ref($_[0]) eq 'ARRAY' ? $_[0]
                    : ($_[0]) ? [ shift ]
                    : []; # optional filter restriction

    my $filters = {
        color => qr{^([A-Z_]+)$}i,
        bead  => qr{^([A-Z_]+)$}i,
    };

    $filters = +{ map { $_ => $filters->{$_} } @$allowed } if scalar @$allowed;

    return $filters;
}

sub _plan_info {
    my $self = shift;

    my %info;

    for my $type (qw/metric imperial/) {
        $info{$type} = {
            length => $self->bead_row_length * $self->bead_dimensions->{$type}->{'bead_diameter'},
            height => $self->bead_col_height * $self->bead_dimensions->{$type}->{'bead_diameter'},
        };
    }

    return \%info;
}

=pod

=head1 NAME

FuseBead::From::PNG - Convert PNGs into plans to build a two dimensional fuse bead replica.

=head1 SYNOPSIS

  use FuseBead::From::PNG;

  my $object = FuseBead::From::PNG;

  $object->bead_tally();

=head1 DESCRIPTION

Convert a PNG into a block list and plans to build a fuse bead replica of the PNG.

$hash->{'filename'} = $args{'filename'};

    $hash->{'unit_size'} = $args{'unit_size'} || 1;

    # White list default
    $hash->{'whitelist'} = ($args{'whitelist'} && ref($args{'whitelist'}) eq 'ARRAY' && scalar(@{$args{'whitelist'}}) > 0) ? $args{'whitelist'} : undef;

    # Black list default
    $hash->{'blacklist'} = ($args{'blacklist'} && ref($args{'blacklist'}) eq 'ARRAY' && scalar(@{$args{'blacklist'}}) > 0) ? $args{'blacklist'} : undef;

=head1 USAGE

=head2 new

 Usage     : ->new()
 Purpose   : Returns FuseBead::From::PNG object

 Returns   : FuseBead::From::PNG object
 Argument  :
    filename - Optional. The file name of the PNG to process. Optional but if not provided, can't process the png.
        e.g. filename => '/location/of/the.png'

    unit_size - Optional. The size of pixels squared to determine a single unit of a bead. Defaults to 1.
        e.g. unit_size => 2 # pixelated colors are 2x2 in size

    whitelist - Optional. Array ref of colors, dimensions or color and dimensions that are allowed in the final plan output.
        e.g. whitelist => [ 'BLACK', 'WHITE', '1x1x1', '1x2x1', '1x4x1', 'BLACK_1x6x1' ]

    blacklist - Optional. Array ref of colors, dimensions or color and dimensions that are not allowed in the final plan output.
        e.g. blacklist => [ 'RED', '1x10x1', '1x12x1', '1x16x1', 'BLUE_1x8x1' ]

 Throws    :

 Comment   :
 See Also  :

=head2 bead_dimensions

 Usage     : ->bead_dimensions()
 Purpose   : returns a hashref with bead dimension information in millimeters (metric) or inches (imperial)

 Returns   : hashref with bead dimension information, millimeters is default
 Argument  : $type - if set to imperial then dimension information is returned in inches
 Throws    :

 Comment   :
 See Also  :

=head2 bead_colors

 Usage     : ->bead_colors()
 Purpose   : returns bead color constants consolidated as a hash.

 Returns   : hashref with color constants keyed by the official color name in key form.
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 beads

 Usage     : ->beads()
 Purpose   : Returns a list of all possible bead beads

 Returns   : Hash ref with L objects keyed by their identifier
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 png

 Usage     : ->png()
 Purpose   : Returns Image::PNG::Libpng object.

 Returns   : Returns Image::PNG::Libpng object. See L for more details.
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 png_info

 Usage     : ->png_info()
 Purpose   : Returns png IHDR info from the Image::PNG::Libpng object

 Returns   : A hash of values containing information abou the png such as width and height. See get_IHDR in L for more details.
 Argument  : filename  => the PNG to load and part
             unit_size => the pixel width and height of one unit, blocks are generally identified as Nx1 blocks where N is the number of units of the same color
 Throws    :

 Comment   :
 See Also  :

=head2 bead_row_length

 Usage     : ->bead_row_length()
 Purpose   : Return the width of one row of beads. Since a bead list is a single dimension array this is useful to figure out whict row a bead is on.

 Returns   : The length of a row of beads (image width / unit size)
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 bead_col_height

 Usage     : ->bead_col_height()
 Purpose   : Return the height in beads.

 Returns   : The height of a col of beads (image height / unit size)
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 process

 Usage     : ->process()
 Purpose   : Convert a provided PNG into a list of bead blocks that will allow building of a two dimensional bead replica.

 Returns   : Hashref containing information about particular bead beads found to be needed based on the provided PNG.
             Also included is the build order for those beads.
 Argument  : view => 'a view' - optionally format the return data. options include: JSON and HTML
 Throws    :

 Comment   :
 See Also  :

=head2 whitelist

 Usage     : ->whitelist()
 Purpose   : return any whitelist settings stored in this object

 Returns   : an arrayref of whitelisted colors and/or blocks, or undef
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 has_whitelist

 Usage     : ->has_whitelist(), ->has_whitelist($filter)
 Purpose   : return a true value if there is a whitelist with at least one entry in it based on the allowed filters, otherwise a false value is returned

 Returns   : 1 or 0
 Argument  : $filter - optional scalar containing the filter to restrict test to
 Throws    :

 Comment   :
 See Also  :

=head2 is_whitelisted

 Usage     : ->is_whitelisted($value), ->is_whitelisted($value, $filter)
 Purpose   : return a true if the value is whitelisted, otherwise false is returned

 Returns   : 1 or 0
 Argument  : $value - the value to test, $filter - optional scalar containing the filter to restrict test to
 Throws    :

 Comment   :
 See Also  :

=head2 blacklist

 Usage     : ->blacklist
 Purpose   : return any blacklist settings stored in this object

 Returns   : an arrayref of blacklisted colors and/or blocks, or undef
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 has_blacklist

 Usage     : ->has_blacklist(), ->has_whitelist($filter)
 Purpose   : return a true value if there is a blacklist with at least one entry in it based on the allowed filters, otherwise a false value is returned

 Returns   : 1 or 0
 Argument  : $filter - optional scalar containing the filter to restrict test to
 Throws    :

 Comment   :
 See Also  :

=head2 is_blacklisted

 Usage     : ->is_blacklisted($value), ->is_whitelisted($value, $filter)
 Purpose   : return a true if the value is blacklisted, otherwise false is returned

 Returns   : 1 or 0
 Argument  : $value - the value to test, $filter - optional scalar containing the filter to restrict test to
 Throws    :

 Comment   :
 See Also  :

=head2 _png_blocks_of_color

 Usage     : ->_png_blocks_of_color()
 Purpose   : Convert a provided PNG into a list of rgb values based on [row][color]. Size of blocks are determined by 'unit_size'

 Returns   : A list of hashes contain r, g and b values. e.g. ( { r => #, g => #, b => # }, { ... }, ... )
 Argument  :
 Throws    :

 Comment   :
 See Also  :

 =head2  _color_score

 Usage     : ->_color_score()
 Purpose   : returns a score indicating the likeness of one color to another. The lower the number the closer the colors are to each other.

 Returns   : returns a positive integer score
 Argument  : $c1 - array ref with rgb color values in that order
             $c2 - array ref with rgb color values in that order
 Throws    :

 Comment   :
 See Also  :

=head2 _find_bead_color

 Usage     : ->_find_bead_color
 Purpose   : given an rgb params, finds the optimal bead color

 Returns   : A bead color common name key that can then reference bead color information using L
 Argument  : $r - the red value of a color
             $g - the green value of a color
             $b - the blue value of a color
 Throws    :

 Comment   : this subroutine is memoized as the name _find_bead_color_fast
 See Also  :

=head2 _approximate_bead_colors

 Usage     : ->_approximate_bead_colors()
 Purpose   : Generate a list of bead colors based on a list of blocks ( array of hashes containing rgb values )

 Returns   : A list of bead color common name keys that can then reference bead color information using L
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 _generate_bead_list

 Usage     : ->_approximate_bead_colors()
 Purpose   : Generate a list of bead colors based on a list of blocks ( array of hashes containing rgb values ) for either knob orientation (calls _knob_forward_bead_list or _knob_up_bead_list)

 Returns   : A list of bead color common name keys that can then reference bead color information using L
 Argument  :
 Throws    :

 Comment   :
 See Also  :

 =head2 _bead_list

 Usage     : ->_bead_list()
 Purpose   : Generate a list of bead colors based on a list of blocks ( array of hashes containing rgb values ) for knob up orientation

 Returns   : A list of bead color common name keys that can then reference bead color information using L
 Argument  :
 Throws    :

 Comment   :
 See Also  :

=head2 _list_filters

 Usage     : ->_list_filters()
 Purpose   : return whitelist/blacklist filters

 Returns   : an hashref of filters
 Argument  : an optional filter restriction to limit set of filters returned to just one
 Throws    :

 Comment   :
 See Also  :

=head1 BUGS

=head1 SUPPORT

=head1 AUTHOR

    Travis Chase
    CPAN ID: GAUDEON
    [e-mail]
    https://github.com/gaudeon/FuseBead-From-Png

=head1 COPYRIGHT

This program is free software licensed under the...

    The MIT License

The full text of the license can be found in the
LICENSE file included with this module.

=head1 SEE ALSO

perl(1).

=cut

1;