view release on metacpan or  search on metacpan

lib/App/Greple/wordle/game.pm  view on Meta::CPAN

    my $keys = $obj->map;
    for my $try (@_) {
	my @b = $try =~ /./g;
	pairwise { $keys->{$a} = 'G' if $a eq $b } @a, @b;
	$keys->{$_} ||= $a{$_} ? 'Y' : 'K' for @b;
    }
    $obj;
}

######################################################################
# keymap
######################################################################

my %map_color = (
    G => '555/#6aaa64',
    Y => '555/#c9b458',
    K => '#787c7e/#787c7e',
    K => 'L17/#787c7e',
    _ => '555/#787c7e',
    );

sub keycolor {
    my($kmap, $cmap, $s) = @_;
    join '', map colorize($cmap->{$kmap->{$_}//'_'}, uc $_), $s =~ /./g;
}

sub keymap {
    my $obj = shift;
    my $keys = keycolor $obj->map, \%map_color, join('', 'a'..'z');
    $keys;
}

######################################################################
# result
######################################################################

my %square = (
    G => "\N{U+1F7E9}", # LARGE GREEN SQUARE
    Y => "\N{U+1F7E8}", # LARGE YELLOW SQUARE
    K => "\N{U+2B1C}",  # WHITE LARGE SQUARE
    );

sub result {
    my $obj = shift;
    my @result = _result(map lc, $obj->answer, @{$obj->attempts});
    my $result = join "\n", map s/([GYK])/$square{$1}/ger, @result;
    $result;
}

sub _result {
    my $answer = shift;
    my %a = map { $_ => 1 } my @a = $answer =~ /./g;
    map {
	my @b = /./g;
	join '', pairwise {
	    $a eq $b ? 'G' : $a{$b} ? 'Y' : 'K'
	} @a, @b;
    } @_;
}

my %guess_color = (
    G => '555/#6aaa64',
    Y => '555/#c9b458',
    K => '555/#787c7e',
    );

sub guess_color {
    my $obj = shift;
    my @result = _result(map lc, $obj->answer, @_);
    map {
	my @c = shift(@result) =~ /./g;
	my @w = /./g;
	join '', pairwise { colorize($guess_color{$a}, uc $b) } @c, @w;
    } @_;
}

######################################################################
# hint
######################################################################

my %hint_color = (
    G => 'G',
    Y => 'Y',
    K => 'U',
    _ => '',
    );

sub hint_color {
    my $obj = shift;
    map keycolor($obj->map, \%hint_color, $_), @_;
}

sub hint {
    my $obj = shift;
    my $pattern = _hint(map lc, $obj->answer, @{$obj->attempts});
}

sub _hint {
    my $answer = shift;
    my %a = map { $_ => 1 } my @a = $answer =~ /./g;
    my(@yes, @no);
    my $seen = '';
    map {
	my @b = /./g;
	for my $i (0 .. $#b) {
	    if ($a{$b[$i]}) {
		$seen .= $b[$i];
	    } else {
		$seen .= "-$b[$i]";
	    }
	    if ($a[$i] eq $b[$i]) {
		$yes[$i] = $a[$i];
	    } else {
		$no[$i] .= $b[$i];
	    }
	}
    } @_;
    my $match = join '', pairwise {
	$b = join '', uniq $b =~ /./g if $b;
	$a ? $a : "[^$b]";
    } @yes, @no;
    my $in = join '', map { "(?=.*$_)" } uniq $seen =~ /(?<!-)\w/g;
    my $ex = join '', uniq $seen =~ /(?<=-)\w/g;
    $ex = "(?!.*[$ex])" if $ex ne '';
    '^' . $in . $ex . $match;
}

1;