Skip to content

Commit

Permalink
rewrote space basis class
Browse files Browse the repository at this point in the history
  • Loading branch information
@lichtkind
lichtkind committed Apr 21, 2024
1 parent b866012 commit 788a0fd
Show file tree
Hide file tree
Showing 7 changed files with 549 additions and 288 deletions.
1 change: 1 addition & 0 deletions Changes
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,6 +5,7 @@
* * added color space support: XYZ LAB LUV HCL LCH
* + extended range definitions with explicit type names
* ? added documentation for color space object and missing formats
* & moved code into space::Format attr object class
* & removed Carp and Test::Warn as dependencies
* & moved color set function into own package
* ~ default space of methods 'distance', 'blend' and 'gradient'
Expand Down
68 changes: 16 additions & 52 deletions lib/Graphics/Toolkit/Color/Space.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,75 +10,39 @@ use Graphics::Toolkit::Color::Space::Shape;
sub new {
my $pkg = shift;
my %args = @_;
my $basis = Graphics::Toolkit::Color::Space::Basis->new( $args{'axis'}, $args{'short'}, $args{'prefix'}, $args{'name'}, $args{'suffix'});
my $basis = Graphics::Toolkit::Color::Space::Basis->new( $args{'axis'}, $args{'short'}, $args{'prefix'}, $args{'name'});
return $basis unless ref $basis;
my $shape = Graphics::Toolkit::Color::Space::Shape->new( $basis, $args{'type'}, $args{'range'}, $args{'precision'} );
return $shape unless ref $shape;

# which formats the constructor will accept, that can be deconverted into list
my %deformats = ( hash => sub { $basis->list_from_hash(@_) if $basis->is_hash(@_) },
named_array => sub { @{$_[0]}[1 .. $#{$_[0]}] if $basis->is_named_array(@_) },
string => sub { $basis->list_from_string(@_) if $basis->is_string(@_) },
css_string => sub { $basis->list_from_css(@_) if $basis->is_css_string(@_) },
);
# which formats we can output
my %formats = (list => sub { @_ }, # 1, 2, 3
hash => sub { $basis->key_hash_from_list(@_) }, # { red => 1, green => 2, blue => 3 }
char_hash => sub { $basis->shortcut_hash_from_list(@_) },# { r =>1, g => 2, b => 3 }
array => sub { $basis->named_array_from_list(@_) }, # ['rgb',1,2,3]
string => sub { $basis->named_string_from_list(@_) }, # 'rgb: 1, 2, 3'
css_string => sub { $basis->css_string_from_list(@_) }, # 'rgb(1,2,3)'
);

bless { basis => $basis, shape => $shape, format => \%formats, deformat => \%deformats, convert => {} };
my $format = Graphics::Toolkit::Color::Space::Format->new( $basis, $shape, $args{'suffix'} );

Check failure on line 17 in lib/Graphics/Toolkit/Color/Space.pm

View workflow job for this annotation

GitHub Actions / OS ubuntu-latest Perl 5.32 

Can't locate object method "new" via package "Graphics::Toolkit::Color::Space::Format" (perhaps you forgot to load "Graphics::Toolkit::Color::Space::Format"?)
return $format unless ref $format;
bless { basis => $basis, shape => $shape, format => $format, convert => {} };
}
sub basis { $_[0]{'basis'}}

########################################################################

sub basis { $_[0]{'basis'} }
sub name { $_[0]->basis->name }
sub dimensions { $_[0]->basis->count }
sub is_array { $_[0]->basis->is_array( $_[1] ) }
sub add_suffix { $_[0]->basis->add_suffix( $_[1] ) }
sub remove_suffix { $_[0]->basis->remove_suffix( $_[1] ) }
sub has_format { (defined $_[1] and exists $_[0]{'format'}{ lc $_[1] }) ? 1 : 0 }
sub can_convert { (defined $_[1] and exists $_[0]{'convert'}{ uc $_[1] }) ? 1 : 0 }
sub is_vector { $_[0]->basis->is_vector( $_[1] ) }

########################################################################

sub shape { $_[0]{'shape'}}
sub delta { shift->shape->delta( @_ ) } # @values -- @vector, @vector --> |@vector # on normalize values
sub shape { $_[0]{'shape'} }
sub in_range { shift->shape->in_range( @_ ) } # @values -- @range --> |!~ # errmsg
sub clamp { shift->shape->clamp( @_ ) } # @values -- @range --> |@vector
sub normalize { shift->shape->normalize(@_)} # @values -- @range --> |@vector
sub denormalize { shift->shape->denormalize(@_)} # @values -- @range --> |@vector
sub denormalize_delta { shift->shape->denormalize_delta(@_)} # @values -- @range --> |@vector
sub delta { shift->shape->delta( @_ ) } # @values -- @vector, @vector --> |@vector # on normalize values

########################################################################

sub add_formatter {
my ($self, $format, $code) = @_;
return 0 if not defined $format or ref $format or ref $code ne 'CODE';
return 0 if $self->has_format( $format );
$self->{'format'}{ $format } = $code;
}
sub format {
my ($self, $values, $format) = @_;
return unless $self->basis->is_array( $values );
$self->{'format'}{ lc $format }->(@$values) if $self->has_format( $format );
}

sub add_deformatter {
my ($self, $format, $code) = @_;
return 0 if not defined $format or ref $format or exists $self->{'deformat'}{$format} or ref $code ne 'CODE';
$self->{'deformat'}{ lc $format } = $code;
}
sub deformat {
my ($self, $values) = @_;
return undef unless defined $values;
for my $deformatter (values %{$self->{'deformat'}}){
my @values = $deformatter->($values);
return \@values if @values == $self->dimensions;
}
return undef;
}
sub format { $_[0]{'format'} }
sub add_formatter { shift->format->add_formatter(@_) }
sub add_deformatter { shift->format->add_deformatter(@_) }
sub format { shift->format->format(@_) }

Check failure on line 44 in lib/Graphics/Toolkit/Color/Space.pm

View workflow job for this annotation

GitHub Actions / OS ubuntu-latest Perl 5.32 

Subroutine format redefined

Check failure on line 44 in lib/Graphics/Toolkit/Color/Space.pm

View workflow job for this annotation

GitHub Actions / OS ubuntu-latest Perl 5.32 

Subroutine format redefined

Check failure on line 44 in lib/Graphics/Toolkit/Color/Space.pm

View workflow job for this annotation

GitHub Actions / OS ubuntu-latest Perl 5.32 

Subroutine format redefined

Check failure on line 44 in lib/Graphics/Toolkit/Color/Space.pm

View workflow job for this annotation

GitHub Actions / OS ubuntu-latest Perl 5.32 

Subroutine format redefined
sub deformat { shift->format->deformat(@_) }

########################################################################

Expand Down
241 changes: 75 additions & 166 deletions lib/Graphics/Toolkit/Color/Space/Basis.pm
View file
Original file line number Diff line number Diff line change
@@ -1,205 +1,114 @@
use v5.12;
use warnings;

# logic of value hash keys for all color spacs
# store color space name and its axis short and long names, derived core methods

package Graphics::Toolkit::Color::Space::Basis;

sub new {
my ($pkg, $axis_names, $axis_shortcuts, $space_prefix, $space_name, $suffix ) = @_;
return 'first argument (axis names) has to be an ARRAY reference' unless ref $axis_names eq 'ARRAY';
return 'amount of shortcut names have to match that of full names' if defined $axis_shortcuts and (ref $axis_shortcuts ne 'ARRAY' or @$axis_names != @$axis_shortcuts);
my @keys = map {lc} @$axis_names;
my @shortcuts = map { _color_key_shortcut($_) } (defined $axis_shortcuts) ? @$axis_shortcuts : @keys;
return unless @keys > 0;

my @iterator = 0 .. $#keys;
my %key_order = map { $keys[$_] => $_ } @iterator;
my %shortcut_order = map { $shortcuts[$_] => $_ } @iterator;
my $name = $space_name // uc join('', @shortcuts);
my ($pkg, $axis_long_names, $axis_shortcuts, $space_prefix, $space_name) = @_;
return 'first argument (axis names) has to be an ARRAY reference' unless ref $axis_long_names eq 'ARRAY';
return 'amount of shortcut names have to match that of full names'
if defined $axis_shortcuts and (ref $axis_shortcuts ne 'ARRAY' or @$axis_long_names != @$axis_shortcuts);

my @axis_long = map {lc} @$axis_long_names;
my @axis_short = map { _color_key_shortcut($_) } (defined $axis_shortcuts) ? @$axis_shortcuts : @axis_long;
return unless @axis_long > 0;

my @iterator = 0 .. $#axis_long;
my %long_order = map { $axis_long[$_] => $_ } @iterator;
my %short_order = map { $axis_short[$_] => $_ } @iterator;
my $name = $space_name // uc join( '', @axis_short );
$name = $space_prefix.$name if defined $space_prefix and $space_prefix;
my $count = int @keys;
$suffix = [('') x $count] unless defined $suffix;
$suffix = [($suffix) x $count] unless ref $suffix;
return 'need an ARRAY as definition of axis value suffix' unless ref $suffix eq 'ARRAY';
return 'definition of axis value suffix has to have same lengths as basis' unless @$suffix == $count;

bless { axis_names => [@keys], axis_short => [@shortcuts],
key_order => \%key_order, shortcut_order => \%shortcut_order,
name => $name, count => $count, iterator => \@iterator, suffix => $suffix }
}

sub keys { @{$_[0]{'axis_names'}} } # axis full names
sub shortcuts{ @{$_[0]{'axis_short'}} }
sub iterator { @{$_[0]{'iterator'}} }
sub count { $_[0]{'count'} }
sub name { $_[0]{'name'} }

sub key_pos { defined $_[1] ? $_[0]->{'key_order'}{ lc $_[1] } : undef}
sub shortcut_pos { defined $_[1] ? $_[0]->{'shortcut_order'}{ lc $_[1] } : undef }
sub is_key { (defined $_[1] and exists $_[0]->{'key_order'}{ lc $_[1] }) ? 1 : 0 }
sub is_shortcut { (defined $_[1] and exists $_[0]->{'shortcut_order'}{ lc $_[1] }) ? 1 : 0 }
sub is_key_or_shortcut { $_[0]->is_key($_[1]) or $_[0]->is_shortcut($_[1]) }
sub is_string { #
my ($self, $string) = @_;
return 0 unless defined $string and not ref $string;
$string = lc $string;
my $name = lc $self->name;
return 0 unless index($string, $name.':') == 0;
my $nr = '\s*-?\d+(?:\.\d+)?\s*';
my $nrs = join(',', ('\s*-?\d+(?:\.\d+)?\s*') x $self->count);
($string =~ /^$name:$nrs$/) ? 1 : 0;
}
sub is_css_string {
my ($self, $string) = @_;
return 0 unless defined $string and not ref $string;
$string = lc $string;
my $name = lc $self->name;
return 0 unless index($string, $name.'(') == 0;
my $nr = '\s*-?\d+(?:\.\d+)?\s*';
my $nrs = join(',', ('\s*-?\d+(?:\.\d+)?\s*') x $self->count);
($string =~ /^$name\($nrs\)$/) ? 1 : 0;
}
sub is_array {
my ($self, $value_array) = @_;
(ref $value_array eq 'ARRAY' and @$value_array == $self->{'count'}) ? 1 : 0;
}
sub is_named_array {
my ($self, $value_array) = @_;
(ref $value_array eq 'ARRAY' and @$value_array == ($self->{'count'}+1)
and uc $value_array->[0] eq uc $self->name) ? 1 : 0;
bless { axis_long => \@axis_long, axis_short => \@axis_short,
long_order => \%long_order, short_order => \%short_order,
name => $name, count => int @axis_long, iterator => \@iterator }
}

#### getter ############################################################

sub space_name { $_[0]{'name'} } # color space name
sub long_names { @{$_[0]{'axis_long'}} } # axis full names
sub short_names { @{$_[0]{'axis_short'}} } # axis short names
sub iterator { @{$_[0]{'iterator'}} } # counting all axis 0 .. -1
sub count { $_[0]{'count'} } # amount of axis

sub pos_from_long { defined $_[1] ? $_[0]->{'long_order'}{ lc $_[1] } : undef }
sub pos_from_short { defined $_[1] ? $_[0]->{'short_order'}{ lc $_[1] } : undef }

#### predicates ########################################################

sub is_long_name { (defined $_[1] and exists $_[0]->{'long_order'}{ lc $_[1] }) ? 1 : 0 }
sub is_short_name { (defined $_[1] and exists $_[0]->{'short_order'}{ lc $_[1] }) ? 1 : 0 }
sub is_name { $_[0]->is_long_name($_[1]) or $_[0]->is_short_name($_[1]) }

sub is_hash {
my ($self, $value_hash) = @_;
return 0 unless ref $value_hash eq 'HASH' and CORE::keys %$value_hash == $self->{'count'};
for (CORE::keys %$value_hash) {
return 0 unless $self->is_key_or_shortcut($_);
}
return 1;
$self->is_partial_hash( $value_hash ) and (keys %$value_hash == $self->count);
}
sub is_partial_hash {
my ($self, $value_hash) = @_;
return 0 unless ref $value_hash eq 'HASH';
my $key_count = CORE::keys %$value_hash;
return 0 unless $key_count and $key_count <= $self->{'count'};
for (CORE::keys %$value_hash) {
return 0 unless $self->is_key_or_shortcut($_);
my $key_count = keys %$value_hash;
return 0 unless $key_count and $key_count <= $self->count;
for (keys %$value_hash) {
return 0 unless $self->is_name( $_ );
}
return 1;
}

########################################################################
sub is_value_tuple { (ref $_[1] eq 'ARRAY' and @{$_[1]} == $_[0]->count) ? 1 : 0 }

sub add_suffix {
my ($self, $values, $suffix) = @_;
return unless $self->is_array( $values );
$suffix //= $self->{'suffix'};
$suffix = [($suffix) x $self->count] unless ref $suffix;
[ map { ($self->{'suffix'}[$_] and substr( $values->[$_], - length($self->{'suffix'}[$_])) ne $self->{'suffix'}[$_])
? $values->[$_] . $self->{'suffix'}[$_] : $values->[$_] } $self->iterator ];
}
#### converter #########################################################

sub remove_suffix {
my ($self, $values, $suffix) = @_;
return unless $self->is_array( $values );
$suffix //= $self->{'suffix'};
$suffix = [($suffix) x $self->count] unless ref $suffix;
[ map { ($self->{'suffix'}[$_] and
substr( $values->[$_], - length($self->{'suffix'}[$_])) eq $self->{'suffix'}[$_])
? (substr( $values->[$_], 0, length($values->[$_]) - length($self->{'suffix'}[$_]))) : $values->[$_] } $self->iterator ];
sub short_from_long_name {
my ($self, $name) = @_;
return unless $self->is_long_name( $name );
($self->short_names)[ $self->pos_from_long( $name ) ];
}

########################################################################

sub key_shortcut {
my ($self, $key) = @_;
return unless $self->is_key( $key );
($self->shortcuts)[ $self->{'key_order'}{ lc $key } ];
sub long_from_short_name {
my ($self, $name) = @_;
return unless $self->is_short_name( $name );
($self->long_names)[ $self->pos_from_short( $name ) ];
}

sub list_value_from_key {
my ($self, $key, @values) = @_;
$key = lc $key;
return unless @values == $self->{'count'};
return unless exists $self->{'key_order'}{ $key };
return $values[ $self->{'key_order'}{ $key } ];
sub long_hash_from_tuple {
my ($self, $values) = @_;
return unless $self->is_value_tuple( $values );
return { map { $self->{'axis_long'}[$_] => $values->[$_]} $self->iterator };
}

sub list_value_from_shortcut {
my ($self, $shortcut, @values) = @_;
$shortcut = lc $shortcut;
return unless @values == $self->{'count'};
return unless exists $self->{'shortcut_order'}{ $shortcut };
return $values[ $self->{'shortcut_order'}{ $shortcut } ];
sub short_hash_from_tuple {
my ($self, $values) = @_;
return unless $self->is_value_tuple( $values );
return { map {$self->{'axis_short'}[$_] => $values->[$_]} $self->iterator };
}

sub list_from_hash {
sub tuple_from_hash {
my ($self, $value_hash) = @_;
return undef unless ref $value_hash eq 'HASH' and CORE::keys %$value_hash == $self->{'count'};
my @values = (0) x $self->{'count'};
for my $value_key (CORE::keys %$value_hash) {
if ($self->is_key( $value_key )) { $values[ $self->{'key_order'}{ lc $value_key } ] = $value_hash->{ $value_key } }
elsif ($self->is_shortcut( $value_key )) { $values[ $self->{'shortcut_order'}{ lc $value_key } ] = $value_hash->{ $value_key } }
else { return }
}
return @values;
return $self->tuple_from_partial_hash( $value_hash ) if $self->is_hash( $value_hash );
}

sub deformat_partial_hash {
sub tuple_from_partial_hash {
my ($self, $value_hash) = @_;
return unless ref $value_hash eq 'HASH';
my @keys_got = CORE::keys %$value_hash;
return unless @keys_got and @keys_got <= $self->{'count'};
my $result = {};
for my $key (@keys_got) {
if ($self->is_key( $key )) { $result->{ int $self->key_pos( $key ) } = $value_hash->{ $key } }
elsif ($self->is_shortcut( $key )){ $result->{ int $self->shortcut_pos( $key ) } = $value_hash->{ $key } }
else { return undef }
return unless $self->is_partial_hash( $value_hash );
my @values = (0) x $self->count;
for my $key (keys %$value_hash) {
if ($self->is_long_name( $key )) { $values[ $self->pos_from_long($key) ] = $value_hash->{ $key } }
elsif ($self->is_short_name( $key )) { $values[ $self->pos_from_short($key) ] = $value_hash->{ $key } }
else { return; }
}
return $result;
}

sub list_from_string {
my ($self, $string) = @_;
my @parts = split(/:/, $string);
return split(/,/, $parts[1]);
}

sub list_from_css {
my ($self, $string) = @_;
1 until chop($string) eq ')';
my @parts = split(/\(/, $string);
return split(/,/, $parts[1]);
return \@values;
}

sub key_hash_from_list {
my ($self, @values) = @_;
return unless @values == $self->{'count'};
return { map { $self->{'axis_names'}[$_] => $values[$_]} @{$self->{'iterator'}} };
sub select_tuple_value_from_name {
my ($self, $name, $values) = @_;
$name = lc $name;
return unless $self->is_value_tuple( $values );
return $values->[ $self->{'long_order'}{$name} ] if exists $self->{'long_order'}{$name};
return $values->[ $self->{'short_order'}{$name} ] if exists $self->{'short_order'}{$name};
}

sub shortcut_hash_from_list {
my ($self, @values) = @_;
return unless @values == $self->{'count'};
return { map {$self->{'axis_short'}[$_] => $values[$_]} @{$self->{'iterator'}} };
}

sub named_array_from_list {
my ($self, @values) = @_;
return [lc $self->name, @values] if @values == $self->{'count'};
}

sub named_string_from_list {
my ($self, @values) = @_;
return unless @values == $self->{'count'};
lc( $self->name).': '.join(', ', @values);
}

sub css_string_from_list {
my ($self, @values) = @_;
return unless @values == $self->{'count'};
lc( $self->name).'('.join(',', @values).')';
}
#### util ##############################################################

sub _color_key_shortcut { lc substr($_[0], 0, 1) if defined $_[0] }

Expand Down
Loading

0 comments on commit 788a0fd

Please sign in to comment.