package Games::Hangman;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-06-02'; # DATE
our $DIST = 'Games-Hangman'; # DIST
our $VERSION = '0.063'; # VERSION

#use Color::ANSI::Util qw(ansibg ansifg);
use Module::List qw(list_modules);
use Module::Load;
use Term::ReadKey;
use Text::WideChar::Util qw(wrap);
use Time::HiRes qw(sleep);

use 5.010001;
use Mo qw(build default);
use experimental 'smartmatch';

has list              => (is => 'rw');
has wl                => (is => 'rw');
has list_type         => (is => 'rw'); # either (w)ord or (p)hrase
has min_len           => (is => 'rw');
has max_len           => (is => 'rw');
has current_word      => (is => 'rw');
has num_words         => (is => 'rw', default=>0); # words that have been played
has num_guessed_words => (is => 'rw', default=>0); # have been guessed correctly
has guessed_letters   => (is => 'rw');
has num_wrong_letters => (is => 'rw');

my @pics = (
    [
        "   ____     ",
        "  |    |    ",
        "  |         ",
        "  |         ",
        "  |         ",
        "  |         ",
        " _|_        ",
        "|   |______ ",
        "|          |",
        "|__________|"],
    [
        "   ____     ",
        "  |    |    ",
        "  |    o    ",
        "  |         ",
        "  |         ",
        "  |         ",
        " _|_        ",
        "|   |______ ",
        "|          |",
        "|__________|"],
    [
        "   ____     ",
        "  |    |    ",
        "  |    o    ",
        "  |   /     ",
        "  |         ",
        "  |         ",
        " _|_        ",
        "|   |______ ",
        "|          |",
        "|__________|"],
    [
        "   ____     ",
        "  |    |    ",
        "  |    o    ",
        "  |   /|    ",
        "  |         ",
        "  |         ",
        " _|_        ",
        "|   |______ ",
        "|          |",
        "|__________|"],
    [
        "   ____     ",
        "  |    |    ",
        "  |    o    ",
        '  |   /|\   ',
        "  |         ",
        "  |         ",
        " _|_        ",
        "|   |______ ",
        "|          |",
        "|__________|"],
    [
        "   ____     ",
        "  |    |    ",
        "  |    o    ",
        '  |   /|\   ',
        "  |    |    ",
        "  |         ",
        " _|_        ",
        "|   |______ ",
        "|          |",
        "|__________|"],
    [
        "   ____     ",
        "  |    |    ",
        "  |    o    ",
        '  |   /|\   ',
        "  |    |    ",
        "  |   /     ",
        " _|_        ",
        "|   |______ ",
        "|          |",
        "|__________|"],
    [
        "   ____     ",
        "  |    |    ",
        "  |    o    ",
        '  |   /|\   ',
        "  |    |    ",
        '  |   / \   ',
        " _|_        ",
        "|   |______ ",
        "|          |",
        "|__________|"],
);

sub _word_term {
    my $self = shift;
    $self->list_type eq 'p' ? 'phrase' : 'word';
}

sub draw {
    my ($self, $message1, $message2) = @_;
    state $drawn = 0;
    state $buf = "";

    # move up to original row position
    if ($drawn) {
        # count the number of newlines
        my $num_nls = 0;
        $num_nls++ while $buf =~ /\n/g;
        printf "\e[%dA", $num_nls;
    }

    $buf = "";

    # draw the hung man + right pane
    my $pic = $pics[ $self->num_wrong_letters ];
    for my $i (0..@$pic-1) {
        $buf .= $pic->[$i];
        if ($i == 1) {
            $buf .= sprintf("%-6s #: %4d", ucfirst($self->_word_term),
                            $self->num_words);
        } elsif ($i == 2) {
            $buf .= sprintf("Guessed : %-26s", $self->guessed_letters);
        } elsif ($i == 3) {
            my $n = $self->num_words;
            $buf .= sprintf("Average : %3.0f%%",
                            $n>1 ? $self->num_guessed_words/($n-1)*100.0 : 0);
        }
        $buf .= "\n";
    }
    $buf .= "\n";

    my $word = $self->current_word;
    my ($termwidth, $wordwidth);
    {
        if (eval "require Term::Size") {
            ($termwidth, undef) = Term::Size::chars(*STDOUT{IO});
        } else {
            $termwidth = 80;
        }
        $wordwidth = $termwidth-8;
        $word = wrap($word, $wordwidth);
        $word =~ s/\n/        /g;
        my $guessed = $self->guessed_letters;
        $word =~ s{([A-Za-z])}
                  {my $l = lc($1); index($guessed, $l) >= 0 ? $1 : "-"}egx;
    }

    $buf .= sprintf("List  : %-30s\n", $self->list);
    $buf .= sprintf("%-6s: %-${wordwidth}s\n",
                    ucfirst($self->_word_term), $word);
    $buf .= sprintf("Guess : %-60s\n%-60s\n", $message1 // '', $message2 // '');
    print $buf;
    $drawn++;
}

# borrowed from Games::2048
sub read_key {
    my $self = @_;

    state @keys;

    if (@keys) {
        return shift @keys;
    }

    my $char;
    my $packet = '';
    while (defined($char = ReadKey -1)) {
        $packet .= $char;
    }

    while ($packet =~ m(
                           \G(
                               \e \[          # CSI
                               [\x30-\x3f]*   # Parameter Bytes
                               [\x20-\x2f]*   # Intermediate Bytes
                               [\x40-\x7e]    # Final Byte
                           |
                               .              # Otherwise just any character
                           )
                   )gsx) {
        push @keys, $1;
    }

    return shift @keys;
}

sub new_word {
    require Text::Unaccent;

    my $self = shift;

    my $word;
  PICK:
    {
        my $tries = 0;
        while (++$tries < 100) {
            $word = $self->wl->pick();

            # deal with empty wordlists
            last unless defined $word;

            # for now we deal with ascii only
            if ($word =~ /[^\x20-\x7f]/) {
                $word = Text::Unaccent::unac_string("utf8", $word);
                next if $word =~ /[^\x20-\x7f]/;
            }

            next if $self->min_len && length($word) < $self->min_len;
            next if $self->max_len && length($word) > $self->max_len;

            # accept
            last PICK;
        }
        die "Can't find eligible word from list ".$self->list."\n";
    }

    $self->current_word($word);
    $self->num_words( $self->num_words+1 );
    $self->guessed_letters('');
    $self->num_wrong_letters(0);
    $self->draw;
}

sub BUILD {
    my $self = shift;

    # pick word-/phraselist
    {
        my $wmods = list_modules("WordList::",
                                 {list_modules=>1, recurse=>1});
        my @wmods = grep {!/\AWordList::Phrase::/} keys %$wmods;
        s/^WordList::// for @wmods;

        my $pmods = list_modules("WordList::Phrase::",
                                 {list_modules=>1, recurse=>1});
        my @pmods = keys %$pmods; s/^WordList::// for @pmods;

        my ($list, $type) = @_;
        if ($self->list) {
            $list = $self->list;
            $list =~ s!/!::!g; # normalize Foo/Bar into Foo::Bar
            if ($list =~ s/^WordList::Phrase:://) {
                $type = 'p';
            } elsif ($list =~ /^WordList::/) {
                $type = 'w';
            } else {
                $type = '';
            }
            if ($type eq 'w') {
                die "Unknown wordlist '$list'\n" unless $list ~~ @wmods;
            } elsif ($type eq 'p') {
                die "Unknown phraselist '$list'\n" unless $list ~~ @pmods;
            } else {
                if ($list ~~ @wmods) {
                    $type = 'w';
                } elsif ($list ~~ @pmods) {
                    $type = 'p';
                } else {
                    die "Unknown word-/phraselist '$list'\n";
                }
            }
        } else {
            $type = rand() > 0.5 ? 'w':'p';
            if ($type eq 'w') {
                if (($ENV{LANG} // "") =~ /^id/ && "ID::KBBI" ~~ @wmods) {
                    $list = "ID::KBBI";
                } else {
                    if (@wmods > 1) {
                        @wmods = grep {$_ ne 'ID::KBBI'} @wmods;
                    }
                    $list = $wmods[rand @wmods];
                }
            } else {
                if (($ENV{LANG} // "") =~ /^id/ && "Phrase::ID::Proverb::KBBI" ~~ @pmods) {
                    $list = "Phrase::ID::Proverb::KBBI";
                } else {
                    if (@pmods > 1) {
                        @pmods = grep {$_ ne 'Phrase::ID::Proverb::KBBI'} @pmods;
                    }
                    $list = $pmods[rand @pmods];
                }
            }
        }
        my $mod = "WordList::$list";
        load $mod;
        $self->list_type($type);
        $self->list($list);
        if (!defined($self->min_len)) {
            $self->min_len($type eq 'w' ? 5 : 0);
        }
        $self->wl($mod->new);
    }
}

sub init {
    my $self = shift;
    $SIG{INT}     = sub { $self->cleanup; exit 1 };
    $SIG{__DIE__} = sub { warn shift; $self->cleanup; exit 1 };
    ReadMode "cbreak";

    # pick color depth
    #if ($ENV{KONSOLE_DBUS_SERVICE}) {
    #    $ENV{COLOR_DEPTH} //= 2**24;
    #} else {
    #    $ENV{COLOR_DEPTH} //= 16;
    #}
}

sub cleanup {
    my $self = shift;
    ReadMode "normal";
}

sub word_guessed {
    my $self = shift;
    my $word = $self->current_word;
    my $guessed = $self->guessed_letters;
    while ($word =~ /([A-Za-z])/g) {
        my $l = lc($1);
        if (index($guessed, $l) < 0) {
            return 0;
        }
    }
    1;
}

sub run {
    my $self = shift;

    $self->init;
  WORD:
    while (1) {
        $self->new_word;
        $self->draw;
      KEY:
        while (1) {
            my $key = $self->read_key;
            if (!defined($key)) {
                sleep 0.1;
                next KEY;
            } elsif ($key =~ /\A[A-Za-z]\z/) {
                my $guessed = $self->guessed_letters;
                my $l = lc $key;
                if (index($guessed, $l) >= 0) {
                    $self->draw("You already guess letter '$l'");
                    next KEY;
                }
                my $word = lc($self->current_word);
                $self->guessed_letters(join("", sort(split('',$guessed),$l)));
                if (index($word, $l) >= 0) {
                    # correct letter
                    if ($self->word_guessed) {
                        $self->draw("Correct! Press q to quit, or Space ".
                                        "for the next word");
                        $self->num_guessed_words( $self->num_guessed_words+1 );
                        my $key;
                        while (1) {
                            $key = $self->read_key(1);
                            if (!defined($key)) {
                                sleep 0.1; next;
                            } elsif ($key eq 'q' || $key eq 'Q') {
                                last WORD;
                            } elsif ($key eq ' ') {
                                next WORD;
                            }
                        }
                    } else {
                        $self->draw;
                    }
                } else {
                    # wrong letter
                    $self->num_wrong_letters($self->num_wrong_letters+1);
                    if ($self->num_wrong_letters >= 7) {
                        $self->draw(
                            substr("Sorry, the " . $self->_word_term .
                                       " is: " . $self->current_word,
                                   0, 60),
                            "Press q to quit, or Space for the next word",
                        );
                        while (1) {
                            $key = $self->read_key(1);
                            if (!defined($key)) {
                                sleep 0.1; next;
                            } elsif ($key eq 'q' || $key eq 'Q') {
                                last WORD;
                            } elsif ($key eq ' ') {
                                next WORD;
                            }
                        }
                    } else {
                        $self->draw;
                    }
                }
            } else {
                $self->draw("Not a valid guess");
            }
        }
    }
    $self->cleanup;
}

1;
# ABSTRACT: A text-based hangman

__END__

=pod

=encoding UTF-8

=head1 NAME

Games::Hangman - A text-based hangman

=head1 VERSION

This document describes version 0.063 of Games::Hangman (from Perl distribution Games-Hangman), released on 2020-06-02.

=head1 SYNOPSIS

 % hangman

=for Pod::Coverage ^(.+)$

=head1 HOMEPAGE

Please visit the project's homepage at L<https://metacpan.org/release/Games-Hangman>.

=head1 SOURCE

Source repository is at L<https://github.com/perlancar/perl-Games-Hangman>.

=head1 BUGS

Please report any bugs or feature requests on the bugtracker website L<https://rt.cpan.org/Public/Dist/Display.html?Name=Games-Hangman>

When submitting a bug or request, please include a test-file or a
patch to an existing test-file that illustrates the bug or desired
feature.

=head1 SEE ALSO

L<hangman>

=head1 AUTHOR

perlancar <perlancar@cpan.org>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2020, 2016, 2015, 2014 by perlancar@cpan.org.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
