view release on metacpan or  search on metacpan

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

	    srand($app->series);
	    @word_hidden = shuffle @word_hidden;
	}
	# ask the dataset for an answer which is not in the local data
	my $fetch = $app->series == 0 && $pkg->can('fetch_answer');
	if ($app->index > $#word_hidden and $fetch
	    and my $answer = $fetch->($app->index)) {
	    push @word_all, $answer unless $word_all{$answer}++;
	    $app->answer = $answer;
	    return;
	}
	my $index = $app->index;
	if ($index > $#word_hidden) {
	    $index %= @word_hidden;
	    warn sprintf "no data for %d, so use answer #%d instead\n",
		$app->index, $index if $app->series == 0;
	}
	$app->answer = $word_hidden[ $index ];
    }
}

sub patterns {
    my $app = shift;
    my $answer = $app->answer;
    my @re = map
	    { sprintf "(?<=^.{%d})%s", $_, substr($answer, $_, 1) }
	    0 .. length($answer) - 1;
    my $green  = join '|', @re;
    my $yellow = "[$answer]";
    my $black  = "(?=[a-z])[^$answer]";
    map { ( '--re' => $_ ) } $green, $yellow, $black;
}

sub title {
    my $app = shift;
    my $label = 'Greple::wordle';
    return $label if not defined $app->index;
    sprintf('%s %s%s',
	    $label,
	    $app->series == 0 ? '' : sprintf("%d-", $app->series),
	    $app->index);
}

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

my $app = __PACKAGE__->new or die;
my $game;

sub prompt {
    sprintf '%d: ', $game->attempt + 1;
}

sub initialize {
    my($mod, $argv) = @_;
    $app->parseopt($argv)->setup;
    $game = App::Greple::wordle::game->new(answer => $app->answer);
    push @$argv, $app->patterns;
    if (-t STDIN) {
	push @$argv, '--interactive', ('/dev/stdin') x $app->total;
	select->autoflush;
	say $app->title;
	print prompt();
    }
}

sub respond {
    local $_ = $_;
    my $chomped = chomp;
    print ansi_code("{CHA}{CUU}") if $chomped;
    print ansi_code(sprintf("{CHA(%d)}",
			    max(11, vwidth($_) + length(prompt()) + 2)));
    print s/(?<=.)\z/\n/r for @_;
}

sub show_answer {
    say colorize('#6aaa64', uc $game->answer);
}

sub show_result {
    printf "\n%s %d/%d\n\n", $app->title, $game->attempt, $app->trial;
    say $game->result;
}

sub check {
    my $word = lc s/\n//r;
    if (not $word_all{$word}) {
	command($word) or respond $app->wrong;
	$_ = '';
    } else {
	# show previous attempts above the line greple prints
	say for $app->history ? $game->guess_color(@{$game->attempts}) : ();
	$game->try($word);
	# greple matches case-insensitively, so show the word in upper case
	$_ = uc $_;
    }
}

sub command {
    my $word = shift;
    my @cmd = split ' ', $word or return;
    my @word = @word_all;
    state @remember;
    my $done;
    $cmd[0] =~ /^u(niq)?$/ and unshift @cmd, 'hint';

    while (@cmd) {
	local $_ = shift @cmd;
	# "return" in try block only leaves the block, so use $done
	try {
	    if    ($_ eq '|')   {}
	    elsif (/^d$/)       {
		$app->debug ^= 1;
		printf "Debug %s\n", $app->debug ? 'on' : 'off';
		return $done = 1;
	    }
	    elsif (/^\?$/)      { help(); return $done = 1 }
	    elsif (/^!!$/)      { @word = @remember }
	    elsif (/^h(int)?$/) { @word = choose($game->hint, @word) }
	    elsif (/^u(niq)?$/) { @word = grep { !/(.).*\1/i } @word }
	    elsif (/^=(.+)/)    { @word = choose(includes($1), @word) }
	    elsif (/^!(.+)/)    { @word = choose("^(?!.*[$1])", @word) }
	    elsif (/\W/)        { @word = choose($_, @word); }
	    else  { return }
	    1;
	} or do {
	    warn "ERROR: $_" if $app->debug;
	    return /^[a-z]+$/i ? 0 : 1;
	};
	return 1 if $done;
    }
    if (@word == 0) {
	warn "No match\n";
	return 1;
    }
    @remember = @word;
    do {
	local $, = ' ';
	say $game->hint_color(@word);
    };
    1;
}

sub help {
    my $message = << "    END";
#   d      debug
    ?      help
    h      show hint
    u      uniq
    !!     repeat last result
    =<str> include characters
    !<str> exclude characters
    END
    print $message =~ s/^\s*(#.*)\n//gr;
}

sub includes {
    '^' . join '', map { "(?=.*$_)" } $_[0] =~ /./g;
}

sub choose {
    my $p = shift;
    $p =~ s/([A-Z])/[^$1]/g;
    warn "> $p\n" if $app->debug;
    grep /$p/, @_;
}

sub inspect {
    if ($game->solved) {
	respond $app->correct x ($app->trial - $game->attempt + 1);
	show_result if $app->result;
	exit 0;
    }
    if (length) {
	if ($game->attempt >= $app->trial) {
	    show_answer;
	    exit 1;
	}
	$app->keymap and respond $game->keymap;
    }
    print prompt();
}

1;

__DATA__

mode function

define GREEN  #6aaa64
define YELLOW #c9b458
define BLACK  #787c7e

option default \
	-i --need 1 --no-filename \
	--cm 555/GREEN  \
	--cm 555/YELLOW \
	--cm 555/BLACK