#===============================================================================
#
#         FILE:  Types.pm
#
#      PODNAME:  Games::Go::AGA::DataObjects::Game
#     ABSTRACT:  library of types and constraints for Games::Go::AGA
#
#       AUTHOR:  Reid Augustin (REID), <reid@lucidport.com>
#      COMPANY:  LucidPort Technology, Inc.
#      CREATED:  11/22/2010 12:03:18 PM PST
#===============================================================================

use 5.008;
use strict;
use warnings;

package Games::Go::AGA::DataObjects::Types;

BEGIN {
    use parent 'Exporter';
    our @EXPORT_OK = qw(
        is_ID
        is_Rank
        is_Rating
        is_Rank_or_Rating
        is_Handicap
        is_Komi
        is_Winner
    );
}
use Mouse::Util::TypeConstraints;
use Scalar::Util::Numeric qw( isint isfloat );

our $VERSION = '0.107'; # VERSION

# if $_ is undef, the messages crash before they can print anything useful.
sub vbar {
    my ($bar) = @_;

    $bar = '(undef)' if (not defined $bar);
    $bar = "''" if ($bar eq '');
    return $bar;
}

# type definitions
sub is_ID {
    $_ = shift;
    return (
        m/^\w+$/    # valid alpha-numeric characters
        and m/^\D/     # not digit in first character
    );
}
subtype 'ID',
    as 'Str',
    where   { is_ID($_) },
    message { $_ = vbar($_); "Invalid ID:$_.  Must be a letter followed by letters and numbers"; };

sub is_Rank {
    $_ = shift;
    return (
        (m/^(\d+)[dD]$/ and $1 >= 1 and $1 < 20) or
        (m/^(\d+)[kK]$/ and $1 >= 1 and $1 < 100)
    );
}
subtype 'Rank',
    as 'Str',
    where   { is_Rank($_) },
    message {  $_ = vbar($_); "$_ is not a valid rank: must be 19D to 1D or 1K to 99K" };

sub is_Rating {
    $_ = shift;
    return(
        $_ and
        (isint($_) or
         isfloat($_)) and
        (($_ < 20.0 and
          $_ >= 1.0) or
         ($_ <= -1.0 and
          $_ >  -100.0))
    );
}
subtype 'Rating',
    as 'Num',
    where   { is_Rating($_) },
    message {  $_ = vbar($_); "$_ is not a valid rating: must be 19.99 to 1.0 or -1.0 to -99.99" };

sub is_Handicap {
    $_ = shift;
    return (
        defined $_ and
        isint($_) and
        (($_ >= 0) and
         ($_ <= 99))    # really should be 9, but let"s not be cops about it
    );
}
subtype 'Handicap',
    as 'Int',
    where   { is_Handicap($_) },
    message {  $_ = vbar($_); "$_ is not a valid handicap, must be between 0 and 99" };

sub is_Komi {
    $_ = shift;
    return (defined $_ and (isint($_) or isfloat($_)));
}
subtype 'Komi',
    as 'Num',
    where   { is_Komi($_) },
    message   {  $_ = vbar($_); "$_ is not a valid komi, must be a decimal number" };

sub is_Winner {
    $_ = shift;
    return $_ =~ m/^[wb?]$/i;  # w, b, or ?
}
subtype 'Winner',     # black, white, or unknown
    as 'Str',
    where   { is_Winner($_) },
    message {  $_ = vbar($_); qq[$_ is not a valid winner, must be "b", "w", or "?"] };

sub is_Rank_or_Rating {
    $_ = shift;
    return (is_Rank($_) or is_Rating($_));
}
subtype 'Rank_or_Rating',
    as 'Str',
    where   { is_Rank_or_Rating($_) },
    message {  $_ = vbar($_); qq[$_ is not a valid Rank or Rating, must be like "3D", "14K", or "-14.5"] };

no Mouse;
#__PACKAGE__->meta->make_immutable;

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Games::Go::AGA::DataObjects::Game - library of types and constraints for Games::Go::AGA

=head1 VERSION

version 0.107

=head1 SYNOPSIS

  use Games::Go::AGA::DataObjects::Types qw( is_ID is_Rank ... );

Supported types are:
    is_ID              string containing only word-like characters
    is_Rank            like 5D, 3k, etc
    is_Rating          decimal number from -100 to 20, excluding range from 1 to -1
    is_Rank_or_Rating  either a Rank or a Rating
    is_Handicap        non-negative integer less than 100
    is_Komi            decimal number
    is_Winner          b, B, w, W, or ? (black, white or unknown)

=head1 SEE ALSO

=over 4

=item Games::Go::AGA

=item Games::Go::AGA::DataObjects

=item Games::Go::AGA::Parse

=item Games::Go::AGA::Gtd

=back

=head1 AUTHOR

Reid Augustin <reid@hellosix.com>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by Reid Augustin.

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
