| 1 | package Gruntmaster::App::Command::Add; |
| 2 | |
| 3 | use 5.014000; |
| 4 | use warnings; |
| 5 | |
| 6 | our $VERSION = '5999.000_004'; |
| 7 | |
| 8 | use Gruntmaster::App '-command'; |
| 9 | use Gruntmaster::Data; |
| 10 | |
| 11 | use Date::Parse qw/str2time/; |
| 12 | use File::Slurp qw/read_file write_file/; |
| 13 | use IO::Prompter [ -style => 'bold', '-stdio', '-verbatim' ]; |
| 14 | use JSON::MaybeXS qw/encode_json/; |
| 15 | use PerlX::Maybe; |
| 16 | use Term::ANSIColor qw/RED RESET/; |
| 17 | |
| 18 | use constant LEVEL_VALUES => { |
| 19 | beginner => 100, |
| 20 | easy => 250, |
| 21 | medium => 500, |
| 22 | hard => 1000, |
| 23 | }; |
| 24 | |
| 25 | sub usage_desc { '%c [-cp] add id' } |
| 26 | |
| 27 | my %TABLE = ( |
| 28 | contests => \&add_contest, |
| 29 | problems => \&add_problem, |
| 30 | ); |
| 31 | |
| 32 | sub validate_args { |
| 33 | my ($self, $opt, $args) = @_; |
| 34 | my @args = @$args; |
| 35 | $self->usage_error('No table selected') unless $self->app->table; |
| 36 | $self->usage_error('Don\'t know how to add to this table') unless $TABLE{$self->app->table}; |
| 37 | $self->usage_error('Wrong number of arguments') if @args != 1; |
| 38 | } |
| 39 | |
| 40 | sub execute { |
| 41 | my ($self, $opt, $args) = @_; |
| 42 | my ($id) = @$args; |
| 43 | $TABLE{$self->app->table}->($self, $id); |
| 44 | } |
| 45 | |
| 46 | sub add_contest { |
| 47 | my ($self, $id) = @_; |
| 48 | |
| 49 | my $name = prompt 'Contest name'; |
| 50 | my $owner = prompt 'Owner'; |
| 51 | my $start = str2time prompt 'Start time' or die "Cannot parse time\n"; |
| 52 | my $stop = str2time prompt 'Stop time' or die "Cannot parse time\n"; |
| 53 | |
| 54 | db->insert(contests => {id => $id, name => $name, owner => $owner, start => $start, stop => $stop}); |
| 55 | } |
| 56 | |
| 57 | sub add_problem { |
| 58 | my ($self, $id) = @_; |
| 59 | my $db = $self->app->db; |
| 60 | |
| 61 | my $name = prompt 'Problem name'; |
| 62 | my $private = prompt('Private?', '-yn') eq 'y'; |
| 63 | my $contest = prompt 'Contest'; |
| 64 | my $author = prompt 'Problem author (full name)'; |
| 65 | my $writer = prompt 'Problem statement writer (full name)'; |
| 66 | my $owner = prompt 'Problem owner (username)'; |
| 67 | my $level = prompt 'Problem level', -menu => "beginner\neasy\nmedium\nhard"; |
| 68 | my $value = LEVEL_VALUES->{$level}; |
| 69 | my $statement = read_file prompt 'File with problem statement', -complete => 'filenames'; |
| 70 | my $generator = prompt 'Generator', -menu => "File\nRun\nUndef"; |
| 71 | my $runner = prompt 'Runner', -menu => "File\nVerifier\nInteractive"; |
| 72 | my $judge = prompt 'Judge', -menu => "Absolute\nPoints"; |
| 73 | my $testcnt = prompt 'Test count', '-i'; |
| 74 | |
| 75 | my $timeout = prompt 'Time limit (seconds)', '-n'; |
| 76 | my $olimit = prompt 'Output limit (bytes)', '-i'; |
| 77 | say 'Memory limits are broken, so I won\'t ask you for one'; |
| 78 | |
| 79 | my (@tests, $gensource, $genformat, $versource, $verformat); |
| 80 | |
| 81 | if ($generator eq 'Run') { |
| 82 | $gensource = read_file prompt '[Generator::Run] Generator file name', -complete => 'filenames'; |
| 83 | $genformat = prompt '[Generator::Run] Generator format', -menu => [qw/C CPP MONO JAVA PASCAL PERL PYTHON/]; |
| 84 | } |
| 85 | |
| 86 | if ($runner eq 'File') { |
| 87 | my $default = $judge eq 'Points' ? 10 : 'Ok'; |
| 88 | $tests[$_ - 1] = prompt "[Runner::File] Score for test ${_} [$default]", -default => $default for 1 .. $testcnt; |
| 89 | } |
| 90 | |
| 91 | if ($runner eq 'Verifier' || $runner eq 'Interactive') { |
| 92 | say RED, 'WARNING: Runner::Interactive is experimental', RESET if $runner eq 'Interactive'; |
| 93 | $versource = read_file prompt "[Runner::$runner] Verifier file name", -complete => 'filenames'; |
| 94 | $verformat = prompt "[Runner::$runner] Verifier format", -menu => [qw/C CPP MONO JAVA PASCAL PERL PYTHON/]; |
| 95 | } |
| 96 | |
| 97 | my %options = ( |
| 98 | id => $id, |
| 99 | name => $name, |
| 100 | level => $level, |
| 101 | value => $value, |
| 102 | statement => $statement, |
| 103 | author => $author, |
| 104 | writer => $writer, |
| 105 | owner => $owner, |
| 106 | generator => $generator, |
| 107 | runner => $runner, |
| 108 | judge => $judge, |
| 109 | testcnt => $testcnt, |
| 110 | maybe private => $private, |
| 111 | maybe timeout => $timeout, |
| 112 | maybe olimit => $olimit, |
| 113 | maybe gensource => $gensource, |
| 114 | maybe genformat => $genformat, |
| 115 | maybe versource => $versource, |
| 116 | maybe verformat => $verformat, |
| 117 | ); |
| 118 | $options{tests} = encode_json \@tests if @tests; |
| 119 | db->insert(problems => \%options); |
| 120 | db->insert(contest_problems => {problem => $id, contest => $contest}) if $contest; |
| 121 | } |
| 122 | |
| 123 | 1; |
| 124 | __END__ |
| 125 | |
| 126 | =encoding utf-8 |
| 127 | |
| 128 | =head1 NAME |
| 129 | |
| 130 | Gruntmaster::App::Command::Add - add a problem or contest by answering a series of prompts |
| 131 | |
| 132 | =head1 SYNOPSIS |
| 133 | |
| 134 | gm -p add aplusb |
| 135 | gm -c add test_contest |
| 136 | |
| 137 | =head1 DESCRIPTION |
| 138 | |
| 139 | The add command creates a new problem or contest by prompting the user |
| 140 | for the properties of the new object. It takes a single argument, the |
| 141 | ID of the new object. |
| 142 | |
| 143 | =head1 SEE ALSO |
| 144 | |
| 145 | L<gm> |
| 146 | |
| 147 | =head1 AUTHOR |
| 148 | |
| 149 | Marius Gavrilescu, E<lt>marius@ieval.roE<gt> |
| 150 | |
| 151 | =head1 COPYRIGHT AND LICENSE |
| 152 | |
| 153 | Copyright (C) 2015 by Marius Gavrilescu |
| 154 | |
| 155 | This library is free software; you can redistribute it and/or modify |
| 156 | it under the same terms as Perl itself, either Perl version 5.20.1 or, |
| 157 | at your option, any later version of Perl 5 you may have available. |
| 158 | |
| 159 | |
| 160 | =cut |