]> iEval git - app-mafia.git/blob - lib/App/Mafia.pm
Initial commit
[app-mafia.git] / lib / App / Mafia.pm
1 package App::Mafia;
2
3 use 5.014000;
4 use strict;
5 use warnings;
6 no warnings qw/experimental::smartmatch/;
7
8 our $VERSION = '0.001';
9
10 use Mafia;
11 use Tk::BrowseEntry;
12 use Tk::CodeText;
13 use Tk::DialogBox;
14 use Tk::ROText;
15 use Tk::Table;
16 use Tk;
17
18 use Data::Dumper qw/Dumper/;
19 use List::Util qw/shuffle/;
20
21 use constant TABLE_PAD => 2;
22 use constant ACTIONS => [qw/lynch factionkill protect vig roleblock jailkeep guncheck track watch guard rolecopcheck copcheck skill hide/];
23
24 ##################################################
25
26 my ($day, $night) = (0, 0);
27 my ($top, $editor, $phase_frame, $new_day, $new_night);
28 my (@names, @roles, @factions, %actions);
29
30 sub set_section_text{
31 my ($tag, $text, @tag_config) = @_;
32 if (my @ranges = $editor->tagRanges($tag)) {
33 # $ranges[0] = int $ranges[0];
34 say "Inerting text at $ranges[0] chars";
35 $editor->DeleteTextTaggedWith($tag);
36 $editor->insert($ranges[0], $text, $tag);
37 } else {
38 $editor->insert(end => $text, $tag, "\n");
39 }
40 $editor->tagConfigure($tag => @tag_config);
41 }
42
43 sub edit_player_list{
44 my $dialog = $top->Toplevel;
45 my $table = $dialog->Frame->pack;
46 my $rownum = 0;
47
48 my $role_listbox = sub{
49 my $num = $_[0];
50 my $box = $table->BrowseEntry(-variable => \$roles[$num], qw/-state readonly/);
51 $box->insert(end => @{ROLE()});
52 $box->grid(-column => 1, -row => $num + 1, -padx => TABLE_PAD, -pady => TABLE_PAD);
53 };
54
55 my $faction_listbox = sub{
56 my $num = $_[0];
57 my $box = $table->BrowseEntry(-variable => \$factions[$num], qw/-state readonly/);
58 $box->insert(end => @{FACTION()});
59 $box->grid(-column => 2, -row => $num + 1, -padx => TABLE_PAD, -pady => TABLE_PAD);
60 };
61
62 my $add_row = sub{
63 my $num = $rownum++;
64 $table->Entry(-textvariable => \$names[$num])->grid(-column => 0, -row => $num + 1, -padx => TABLE_PAD, -pady => TABLE_PAD);
65 $role_listbox->($num);
66 $faction_listbox->($num);
67 };
68
69 my $randomize_names = sub{
70 my @snames = shuffle @names;
71 $names[$_] = $snames[$_] for 0 .. $#snames;
72 };
73
74 my $write_setup = sub{
75 my $result = '';
76 $result .= "player '$names[$_]' => $roles[$_], $factions[$_];\n" for 0 .. $#names;
77 set_section_text playerlist => $result, qw/-background snow/;
78 $dialog->withdraw;
79 };
80
81 $table->Label(-text => 'Name')->grid(-column => 0, -row => 0, -padx => TABLE_PAD, -pady => TABLE_PAD);
82 $table->Label(-text => 'Role')->grid(-column => 1, -row => 0, -padx => TABLE_PAD, -pady => TABLE_PAD);
83 $table->Label(-text => 'Faction')->grid(-column => 2, -row => 0, -padx => TABLE_PAD, -pady => TABLE_PAD);
84
85 $add_row->() for 1 .. ($#names + 1);
86
87 my $buttons = $dialog->Frame;
88 $buttons->Button(-text => 'Add player', -command => $add_row)->pack(qw/-side left/);
89 $buttons->Button(-text => 'Randomize names', -command => $randomize_names)->pack(qw/-side left/);
90 $buttons->Button(-text => 'Write setup', -command => $write_setup)->pack(qw/-side left/);
91 $buttons->pack;
92 }
93
94 sub edit_phase{
95 my $phase = $_[0];
96 my ($phase_type, $phase_number) = split //, $phase, 2;
97 my $dialog = $top->Toplevel;
98 my $table = $dialog->Frame->pack;
99 my $rownum = 0;
100
101 my $action_listbox = sub{
102 my $num = $_[0];
103 my $box = $table->BrowseEntry(-variable => \$actions{$phase}[$num]{action}, qw/-state readonly/);
104 $box->insert(end => @{ACTIONS()});
105 $box->grid(-column => 0, -row => $num + 1, -padx => TABLE_PAD, -pady => TABLE_PAD);
106 };
107
108 my $player_listbox = sub{
109 my ($num, $column, $key) = @_;
110 my $box = $table->BrowseEntry(-variable => \$actions{$phase}[$num]{$key}, qw/-state readonly/);
111 $box->insert(end => @names);
112 $box->grid(-column => $column, -row => $num + 1, -padx => TABLE_PAD, -pady => TABLE_PAD);
113 };
114
115 my $add_row = sub {
116 my $num = $rownum++;
117 $action_listbox->($num);
118 $player_listbox->($num, 1, 'source');
119 $player_listbox->($num, 2, 'target');
120 };
121
122 my $write_section = sub{
123 my $result = $phase_type == 'N' ? "night; #Night $night\n" : "day; #Day $day\n";
124 $result .= "$actions{$phase}[$_]{action} '$actions{$phase}[$_]{source}', '$actions{$phase}[$_]{target}';\n" for 0 .. scalar @{$actions{$phase}} - 1;
125 set_section_text $phase => $result, -background => ($phase_type == 'N' ? 'Light Sky Blue' : 'Antique White');
126 $dialog->withdraw;
127 };
128
129 $table->Label(-text => 'Action')->grid(-column => 0, -row => 0, -padx => TABLE_PAD, -pady => TABLE_PAD);
130 $table->Label(-text => 'Source')->grid(-column => 1, -row => 0, -padx => TABLE_PAD, -pady => TABLE_PAD);
131 $table->Label(-text => 'Target')->grid(-column => 2, -row => 0, -padx => TABLE_PAD, -pady => TABLE_PAD);
132
133 my $buttons = $dialog->Frame;
134 $buttons->Button(-text => 'Add action', -command => $add_row)->pack(qw/-side left/);
135 $buttons->Button(-text => 'Write section', -command => $write_section)->pack(qw/-side left/);
136 $buttons->pack;
137 }
138
139 sub run_script{
140 my $out = '';
141 $|=1;
142 close STDOUT;
143 open STDOUT, '>', \$out;
144 eval $editor->Contents;
145 close STDOUT;
146 my $dialog = $top->DialogBox(-title => 'Result', -buttons => ['OK']);
147 my $rotext = $dialog->add('ROText');
148 utf8::decode($out);
149 $rotext->Contents($out);
150 $rotext->pack;
151 $dialog->Show;
152 }
153
154 sub menu_new{
155 say 'New!';
156 }
157
158 sub menu_open{
159 say 'Open!';
160 }
161
162 sub menu_save{
163 say 'Save!';
164 }
165
166 sub menu_save_as{
167 say 'Save As!';
168 }
169
170 sub add_menu_item{
171 $_[0]->command(-label => $_[1], -command => $_[2], -accelerator => $_[3]);
172 $top->bind($_[4], $_[2]);
173 }
174
175 sub new_day{
176 $day++;
177 $new_day->configure(qw/-state disabled/);
178 $new_night->configure(qw/-state normal/);
179 $phase_frame->Button(-text => "D$day", qw/-padx 1 -pady 1 -overrelief raised -relief flat/, -command => [\&edit_phase, "D$day"])->pack(qw/-side left/);
180 set_section_text "D$day" => "day; #Day $day\n", -background => 'Antique White';
181 }
182
183 sub new_night{
184 $night++;
185 $new_day->configure(qw/-state normal/);
186 $new_night->configure(qw/-state disabled/);
187 $phase_frame->Button(-text => "N$night", qw/-padx 1 -pady 1 -overrelief raised -relief flat/, -command => [\&edit_phase, "N$night"])->pack(qw/-side left/);
188 set_section_text "N$night" => "night; #Night $night\n", -background => 'Light Sky Blue';
189 }
190
191 ##################################################
192
193 $top = MainWindow->new;
194 $editor = $top->Scrolled(qw/CodeText -syntax Perl -scrollbars osoe -font/, ['Terminus', 12])->pack;
195
196 my $buttons = $top->Frame->pack;
197 $buttons->Button(-text => 'Edit player list', -command => \&edit_player_list)->pack(qw/-side left/);
198 $buttons->Button(-text => 'Run script', -command => \&run_script)->pack(qw/-side left/);
199 $new_day = $buttons->Button(-text => 'New day', -command => \&new_day)->pack(qw/-side left/);
200 $new_night = $buttons->Button(-text => 'New night', -command => \&new_night)->pack(qw/-side left/);
201
202 my $phase_frame_container = $top->Frame->pack;
203 $phase_frame_container->Label(-text => 'Edit phase: ')->pack(qw/-side left/);
204 $phase_frame = $phase_frame_container->Frame->pack;
205
206 $top->configure(-menu => my $menu = $top->Menu);
207 my $file = $menu->cascade(-label => '~File');
208 add_menu_item $file, '~New', \&menu_new, 'Ctrl+N', '<Control-KeyRelease-n>';
209 add_menu_item $file, '~Open...', \&menu_open, 'Ctrl+O', '<Control-KeyRelease-o>';
210 add_menu_item $file, '~Save', \&menu_save, 'Ctrl+S', '<Control-KeyRelease-s>';
211 add_menu_item $file, 'Save ~As...', \&menu_save_as, 'Shift+Ctrl+S', '<Shift-Control-KeyRelease-S>';
212
213 1;
214 __END__
215
216 =head1 NAME
217
218 App::Mafia - Perl extension for blah blah blah
219
220 =head1 SYNOPSIS
221
222 use App::Mafia;
223 blah blah blah
224
225 =head1 DESCRIPTION
226
227 Stub documentation for App::Mafia, created by h2xs. It looks like the
228 author of the extension was negligent enough to leave the stub
229 unedited.
230
231 Blah blah blah.
232
233
234 =head1 SEE ALSO
235
236 Mention other useful documentation such as the documentation of
237 related modules or operating system documentation (such as man pages
238 in UNIX), or any relevant external documentation such as RFCs or
239 standards.
240
241 If you have a mailing list set up for your module, mention it here.
242
243 If you have a web site set up for your module, mention it here.
244
245 =head1 AUTHOR
246
247 Marius Gavrilescu, E<lt>marius@E<gt>
248
249 =head1 COPYRIGHT AND LICENSE
250
251 Copyright (C) 2013 by Marius Gavrilescu
252
253 This library is free software; you can redistribute it and/or modify
254 it under the same terms as Perl itself, either Perl version 5.18.1 or,
255 at your option, any later version of Perl 5 you may have available.
256
257
258 =cut
This page took 0.07984 seconds and 5 git commands to generate.