File Coverage

blib/lib/Games/Dukedom.pm
Criterion Covered Total %
statement 102 575 17.7
branch 3 176 1.7
condition 4 73 5.4
subroutine 33 60 55.0
pod 4 5 80.0
total 146 889 16.4


line stmt bran cond sub pod time code
1             package Games::Dukedom;
2              
3             our $VERSION = 'v0.1.2';
4              
5 4     4   74470 use Storable qw( freeze thaw );
  4         10850  
  4         283  
6 4     4   23 use Carp;
  4         6  
  4         204  
7              
8 4     4   1689 use Games::Dukedom::Signal;
  4         11  
  4         133  
9              
10 4     4   26 use Moo 1.004003;
  4         95  
  4         28  
11 4     4   2900 use MooX::StrictConstructor;
  4         1633  
  4         19  
12 4     4   14148 use MooX::ClassAttribute;
  4         28169  
  4         23  
13              
14 4         57 use MooX::Struct -rw, Land => [
15             qw(
16             +trades
17             +spoils
18             +price
19             +sell_price
20             +planted
21             )
22             ],
23             Population => [
24             qw(
25             +starvations
26             +levy
27             +casualties
28             +looted
29             +diseased
30             +deaths
31             +births
32             )
33             ],
34             Grain => [
35             qw(
36             +food
37             +trades
38             +seed
39             +spoilage
40             +wages
41             +spoils
42             +yield
43             +expense
44             +taxes
45             )
46             ],
47             War => [
48             qw(
49             +first_strike
50             +tension
51             +desire
52             +will
53             +grain_damage
54             +risk
55             )
56 4     4   2855 ];
  4         443529  
57              
58             # status codes
59 4     4   9957 use constant RUNNING => 0;
  4         16  
  4         260  
60 4     4   17 use constant RETIRED => 1;
  4         6  
  4         152  
61 4     4   15 use constant KINGDOM => 2;
  4         5  
  4         133  
62 4     4   17 use constant QUIT_GAME => -1;
  4         7  
  4         144  
63 4     4   16 use constant DEPOSED => -2;
  4         5  
  4         127  
64 4     4   20 use constant ABOLISHED => -3;
  4         12  
  4         152  
65              
66             # magic numbers
67 4     4   18 use constant TAX_RATE => .5;
  4         4  
  4         140  
68 4     4   16 use constant MAX_YEAR => 45;
  4         8  
  4         129  
69 4     4   14 use constant MIN_LAND => 45;
  4         6  
  4         212  
70 4     4   16 use constant MIN_POPULATION => 33;
  4         4  
  4         132  
71 4     4   13 use constant MIN_GRAIN => 429;
  4         4  
  4         129  
72 4     4   14 use constant MAX_FOOD_BONUS => 4;
  4         4  
  4         120  
73 4     4   13 use constant LABOR_CAPACITY => 4;
  4         4  
  4         134  
74 4     4   13 use constant SEED_PER_HA => 2;
  4         4  
  4         156  
75 4     4   18 use constant MAX_SALE => 4000;
  4         4  
  4         151  
76 4     4   13 use constant MAX_SELL_TRIES => 3;
  4         4  
  4         143  
77 4     4   15 use constant MIN_LAND_PRICE => 4;
  4         4  
  4         138  
78 4     4   14 use constant MIN_EXPENSE => 429;
  4         5  
  4         181  
79 4     4   14 use constant WAR_CONSTANT => 1.95;
  4         5  
  4         123  
80 4     4   12 use constant UNREST_FACTOR => .85;
  4         4  
  4         131  
81 4     4   15 use constant MAX_1YEAR_UNREST => 88;
  4         3  
  4         132  
82 4     4   14 use constant MAX_TOTAL_UNREST => 99;
  4         5  
  4         21103  
83              
84             my @steps = (
85             qw(
86             _init_year
87             _feed_the_peasants
88             _starvation_and_unrest
89             _purchase_land
90             _war_with_the_king
91             _grain_production
92             _kings_levy
93             _war_with_neigbor
94             _population_changes
95             _harvest_grain
96             _update_unrest
97             )
98             );
99              
100             my @settable_steps = (
101             qw(
102             _display_msg
103             _feed_the_peasants
104             _purchase_land
105             _sell_land
106             _king_wants_war
107             _grain_production
108             _kings_levy
109             _first_strike
110             _goto_war
111             _quit_game
112             )
113             );
114              
115              
116             my %traits = (
117             price => {
118             q1 => 4,
119             q2 => 7,
120             },
121             yield => {
122             q1 => 4,
123             q2 => 8,
124             },
125             spoilage => {
126             q1 => 4,
127             q2 => 6,
128             },
129             levies => {
130             q1 => 3,
131             q2 => 8,
132             },
133             war => {
134             q1 => 5,
135             q2 => 8,
136             },
137             first_strike => {
138             q1 => 3,
139             q2 => 6,
140             },
141             disease => {
142             q1 => 3,
143             q2 => 8,
144             },
145             birth => {
146             q1 => 4,
147             q2 => 8,
148             },
149             merc_quality => {
150             q1 => 8,
151             q2 => 8,
152             },
153             );
154              
155             my $fnr = sub {
156             my ( $q1, $q2 ) = @_;
157              
158             return int( rand() * ( 1 + $q2 - $q1 ) ) + $q1;
159             };
160              
161             my $gauss = sub {
162             my ( $q1, $q2 ) = @_;
163              
164             my $g0;
165              
166             my $q3 = &$fnr( $q1, $q2 );
167             if ( &$fnr( $q1, $q2 ) > 5 ) {
168             $g0 = ( $q3 + &$fnr( $q1, $q2 ) ) / 2;
169             }
170             else {
171             $g0 = $q3;
172             }
173              
174             return $g0;
175             };
176              
177             class_has signal => (
178             is => 'ro',
179             init_arg => undef,
180             default => 'Games::Dukedom::Signal',
181             handles => 'Throwable',
182             );
183              
184             has _base_values => (
185             is => 'ro',
186             init_arg => undef,
187             default => sub {
188             my $base = {};
189             for ( keys(%traits) ) {
190             $base->{$_} = &$gauss( $traits{$_}{q1}, $traits{$_}{q2} );
191             }
192             return $base;
193             },
194             );
195              
196             has year => (
197             is => 'rwp',
198             init_arg => undef,
199             default => 0,
200             );
201              
202             has population => (
203             is => 'rwp',
204             init_arg => undef,
205             default => 100,
206             );
207              
208             has _population => (
209             is => 'ro',
210             lazy => 1,
211             clearer => 1,
212             default => sub { Population->new; },
213             init_arg => undef,
214             );
215              
216             has grain => (
217             is => 'rwp',
218             init_arg => undef,
219             default => 4177,
220             );
221              
222             has _grain => (
223             is => 'ro',
224             clearer => 1,
225             lazy => 1,
226             default => sub { Grain->new; },
227             init_arg => undef,
228             );
229              
230             has land => (
231             is => 'rwp',
232             init_arg => undef,
233             default => 600,
234             );
235              
236             has _land => (
237             is => 'ro',
238             lazy => 1,
239             clearer => 1,
240             default => sub { Land->new; },
241             init_arg => undef,
242             );
243              
244             has land_fertility => (
245             is => 'ro',
246             init_arg => undef,
247             default => sub {
248             {
249             100 => 216,
250             80 => 200,
251             60 => 184,
252             40 => 0,
253             20 => 0,
254             0 => 0,
255             };
256             },
257             );
258              
259             has _war => (
260             is => 'ro',
261             lazy => 1,
262             clearer => 1,
263             default => sub { War->new; },
264             init_arg => undef,
265             );
266              
267             has yield => (
268             is => 'rwp',
269             init_arg => undef,
270             default => 3.95,
271             );
272              
273             has unrest => (
274             is => 'rwp',
275             init_arg => undef,
276             default => 0,
277             );
278              
279             has _unrest => (
280             is => 'ro',
281             default => 0,
282             init_arg => undef,
283             );
284              
285             has king_unrest => (
286             is => 'rwp',
287             init_arg => undef,
288             default => 0,
289             );
290              
291             has tax_paid => (
292             is => 'ro',
293             init_arg => undef,
294             default => 0,
295             );
296              
297             has _black_D => (
298             is => 'ro',
299             init_arg => undef,
300             default => 0,
301             );
302              
303             has input => (
304             is => 'rw',
305             init_arg => undef,
306             clearer => 1,
307             default => undef,
308             );
309              
310             has _steps => (
311             is => 'lazy',
312             init_arg => undef,
313             clearer => 1,
314             default => sub { [@steps] },
315             );
316              
317             has status => (
318             is => 'rwp',
319             init_arg => undef,
320             default => RUNNING,
321             );
322              
323             has _msg => (
324             is => 'rw',
325             init_arg => undef,
326             clearer => 1,
327             default => undef,
328             );
329              
330             has detail_report => (
331             is => 'ro',
332             init_arg => undef,
333             default => '',
334             );
335              
336             sub BUILD {
337 3     3 0 27 my $self = shift;
338              
339 3         41 return;
340             }
341              
342             # guarantee we have a clean input if needed.
343             before throw => sub {
344             my $self = shift;
345              
346             $self->clear_input;
347              
348             return;
349             };
350              
351             # intercept a "quit" request
352             around input => sub {
353             my $orig = shift;
354             my $self = shift;
355             my $input = $_[0] || '';
356              
357             $self->_next_step('_quit_game') if $input =~ /^(?:q|quit)\s*$/i;
358              
359             return $self->$orig(@_);
360             };
361              
362             sub input_is_yn {
363 17     17 1 39 my $self = shift;
364              
365 17         268 my $value = $self->input;
366 17 50       41 chomp($value) if defined($value);
367              
368 17   66     102 return !!( defined($value) && $value =~ /^(?:y|n)$/i );
369             }
370              
371             sub input_is_value {
372 19     19 1 48 my $self = shift;
373              
374 19         310 my $value = $self->input;
375 19 50       44 chomp($value) if defined($value);
376              
377 19   66     128 return !!( defined($value) && ( $value =~ /^\d+$/ ) );
378             }
379              
380             sub play_one_year {
381 0     0 1 0 my $self = shift;
382 0         0 my $params = @_;
383              
384 0 0       0 return if $self->game_over;
385              
386 0         0 while ( @{ $self->_steps } ) {
  0         0  
387 0         0 my $step = shift( @{ $self->_steps } );
  0         0  
388              
389 0         0 $self->$step;
390 0         0 $self->clear_input;
391             }
392              
393 0         0 $self->_prep_detail_report();
394              
395 0         0 $self->{tax_paid} += $self->_grain->taxes;
396 0         0 $self->_clear_steps;
397 0         0 $self->_clear_population;
398 0         0 $self->_clear_grain;
399 0         0 $self->_clear_land;
400 0         0 $self->_clear_war;
401              
402 0         0 $self->_end_of_game_check;
403              
404 0         0 return;
405             }
406              
407             sub game_over {
408 0     0 1 0 my $self = shift;
409              
410 0         0 return !( $self->status == RUNNING );
411             }
412              
413             sub _next_step {
414 4     4   4 my $self = shift;
415 4         6 my $next = shift;
416              
417 4 50       59 croak "Illegal value for '_next_step': $next"
418             unless grep( /^$next$/, @settable_steps);
419              
420 4         4 return unshift( @{ $self->_steps }, $next );
  4         50  
421             }
422              
423             sub _randomize {
424 0     0     my $self = shift;
425 0           my $trait = shift;
426              
427 0           return int( &$fnr( -2, 2 ) + $self->_base_values->{$trait} );
428             }
429              
430             sub _init_year {
431 0     0     my $self = shift;
432              
433 0           ++$self->{year};
434              
435 0           $self->{_unrest} = 0;
436              
437 0           $self->_land->{price} =
438             int( ( 2 * $self->yield ) + $self->_randomize('price') - 5 );
439 0 0         $self->_land->{price} = MIN_LAND_PRICE
440             if $self->_land->price < MIN_LAND_PRICE;
441              
442 0           $self->_land->{sell_price} = $self->_land->price;
443              
444 0           $self->{_msg} = $self->_summary_report;
445 0           $self->{_msg} .= $self->_fertility_report;
446              
447 0           $self->_next_step('_display_msg');
448              
449 0           return;
450             }
451              
452             sub _display_msg {
453 0     0     my $self = shift;
454              
455             # a Moo clearer returns the existing value, if any, like delete does.
456 0           $self->throw( $self->_clear_msg );
457             }
458              
459             sub _summary_report {
460 0     0     my $self = shift;
461              
462 0           my $msg = sprintf( "\nYear %d Peasants %d Land %d Grain %d Taxes %d\n",
463             $self->year, $self->population, $self->land, $self->grain,
464             $self->tax_paid );
465              
466 0           return $msg;
467             }
468              
469             sub _fertility_report {
470 0     0     my $self = shift;
471              
472 0           my $msg = "Land Fertility:\n";
473 0           $msg .= " 100% 80% 60% 40% 20% Depl\n";
474 0           for ( 100, 80, 60, 40, 20, 0 ) {
475 0           $msg .= sprintf( "%5d", $self->land_fertility->{$_} );
476             }
477 0           $msg .= "\n";
478              
479 0           return $msg;
480             }
481              
482             sub _feed_the_peasants {
483 0     0     my $self = shift;
484              
485 0 0         my $hint = ( $self->grain / $self->population ) < 11 ? $self->grain : 14;
486              
487 0 0 0       $self->_next_step('_feed_the_peasants')
488             and $self->throw(
489             msg => "Grain for food [$hint]: ",
490             action => 'get_value',
491             default => $hint,
492             ) unless $self->input_is_value;
493              
494 0           my $food = $self->input;
495              
496             # shortcut
497 0 0 0       $food *= $self->population if ( $food < 100 && $self->grain > $food );
498              
499 0 0 0       if ( $food > $self->grain ) {
    0          
500 0           $self->_next_step('_feed_the_peasants');
501              
502 0           $self->throw( $self->_insufficient_grain('feed') );
503             }
504             elsif (( ( $food / $self->population ) < 11 )
505             && ( $food != $self->grain ) )
506             {
507 0           $self->{_unrest} += 3;
508              
509 0           $self->_next_step('_feed_the_peasants');
510              
511 0           my $msg = "The peasants demonstrate before the castle\n";
512 0           $msg .= "with sharpened scythes\n\n";
513 0           $self->throw($msg);
514             }
515              
516 0           $self->_grain->{food} = -$food;
517 0           $self->{grain} += $self->_grain->{food};
518              
519 0           return;
520             }
521              
522             sub _starvation_and_unrest {
523 0     0     my $self = shift;
524              
525 0           my $food = -$self->_grain->food;
526              
527 0           my $x1 = $food / $self->population;
528 0 0         if ( $x1 < 13 ) {
529 0           $self->_population->{starvations} =
530             -int( ( $self->population - ( $food / 13 ) ) );
531 0           $self->{population} += $self->_population->starvations;
532             }
533              
534             # only allow bonus for extra food up to 18HL/peasant
535 0           $x1 -= 14;
536 0 0         $x1 = MAX_FOOD_BONUS if $x1 > MAX_FOOD_BONUS;
537              
538 0           $self->{_unrest} =
539             $self->_unrest - ( 3 * $self->_population->starvations ) - ( 2 * $x1 );
540              
541 0 0         if ( $self->_population->starvations < 0 ) {
542 0           $self->_msg("Some peasants have starved during the winter\n");
543 0           $self->_next_step('_display_msg');
544             }
545              
546 0   0       return ( ( $self->_unrest > 88 ) || ( $self->population < 33 ) );
547             }
548              
549             sub _purchase_land {
550 0     0     my $self = shift;
551              
552 0           my $land = $self->_land;
553 0           my $grain = $self->_grain;
554              
555 0           my $msg = '';
556              
557 0           $msg .= sprintf( "Land to buy at %d HL/HA [0]: ", int( $land->{price} ) );
558 0 0 0       $self->_next_step('_purchase_land')
559             and $self->throw( msg => $msg, action => 'get_value', default => 0 )
560             unless $self->input_is_value();
561              
562 0 0 0       $self->_next_step('_sell_land') and return
563             unless my $buy = $self->input;
564              
565 0 0 0       $self->_next_step('_purchase_land')
566             and $self->throw( $self->_insufficient_grain('buy') )
567             if ( $buy * $land->price > $self->grain );
568              
569 0           $self->land_fertility->{60} += $buy;
570 0           $land->{trades} = $buy;
571 0           $self->{land} += $buy;
572 0           $grain->{trades} = -$buy * $land->{price};
573 0           $self->{grain} += $grain->{trades};
574              
575 0           return;
576             }
577              
578             sub _sell_land {
579 0     0     my $self = shift;
580              
581 0           my $land = $self->_land;
582 0           my $grain = $self->_grain;
583              
584 0 0         if ( $land->price - $land->sell_price > MAX_SELL_TRIES ) {
585 0           $grain->{trades} = 0;
586              
587 0           $self->throw("Buyers have lost interest\n");
588             }
589              
590 0           my $price = --$land->{sell_price};
591              
592 0           my $msg = sprintf( "Land to sell at %d HL/HA [0]: ", $price );
593 0 0 0       $self->_next_step('_sell_land')
594             and $self->throw( msg => $msg, action => 'get_value', default => 0 )
595             unless $self->input_is_value();
596              
597 0 0         return unless my $sold = $self->input;
598              
599 0           my $x1 = 0;
600 0           for ( 100, 80, 60 ) {
601 0           $x1 += $self->land_fertility->{$_};
602             }
603              
604 0           $self->{_msg} = undef;
605 0 0         if ( $sold > $x1 ) {
    0          
606 0           $self->_next_step('_display_msg');
607 0           $self->{_msg} = sprintf( "You only have %d HA. of good land\n", $x1 );
608             }
609             elsif ( ( $grain->{trades} = $sold * $price ) > MAX_SALE ) {
610 0           $self->_next_step('_display_msg');
611 0           $self->{_msg} = "No buyers have that much grain - sell less\n";
612             }
613 0 0         return if $self->_msg;
614              
615 0           $land->{trades} = -$sold;
616              
617 0           my $valid = 0;
618 0           my $sold_q;
619 0           for ( 60, 80, 100 ) {
620 0           $sold_q = $_;
621 0 0         if ( $sold <= $self->land_fertility->{$_} ) {
622 0           $valid = 1;
623 0           last;
624             }
625             else {
626 0           $sold -= $self->land_fertility->{$_};
627 0           $self->land_fertility->{$_} = 0;
628             }
629             }
630              
631 0 0         if ( !$valid ) {
632 0           my $msg = "LAND SELLING LOOP ERROR - CONTACT PROGRAM AUTHOR IF\n";
633 0           $msg .= "ERROR IS NOT YOURS IN ENTERING PROGRAM,\n";
634 0           $msg .= "AND SEEMS TO BE FAULT OF PROGRAM'S LOGIC.\n";
635              
636 0           die $msg;
637             }
638              
639 0           $self->land_fertility->{$sold_q} -= $sold;
640 0           $self->{land} += $land->trades;
641              
642 0 0         $self->_set_status(ABOLISHED) if $self->land < 10;
643              
644 0           $msg = '';
645 0 0 0       if ( ( $price < MIN_LAND_PRICE ) && $sold ) {
646 0           $grain->{trades} = int( $grain->{trades} / 2 );
647 0           $msg = "\nThe High King appropriates half your earnings\n";
648 0           $msg .= "as punishment for selling at such a low price\n";
649             }
650              
651 0           $self->{grain} += $grain->{trades};
652 0 0         $self->throw($msg) if $msg;
653              
654 0           return;
655             }
656              
657             sub _war_with_the_king {
658 0     0     my $self = shift;
659              
660 0 0         $self->_king_wants_war if $self->king_unrest > 0;
661              
662 0 0         return if $self->king_unrest > -2;
663              
664 0           my $mercs = int( $self->grain / 100 );
665              
666 0           my $msg = "\nThe King's army is about to attack your duchy\n";
667 0           $msg .= sprintf( "You have hired %d foreign mercenaries\n", $mercs );
668 0           $msg .= "at 100 HL. each (payment in advance)\n\n";
669              
670             # assuming a population > 200 at the time of your revolt, # the C source
671             # i ported from allowed one to win with as few as 5 mercs.
672             # if ( ( $self->grain * $mercs ) + $self->population > 2399 ) {
673             #
674             # the Java source changed it so it took significantly more, about 275 but
675             # was still a fixed value.
676             # if ( ( 8 * $mercs ) + $self->population > 2399 ) {
677             #
678             # i've added an element of chance. again, assuming a populaton of 200, it
679             # now requires anywhere from 219 to 366 mercs to win depending on the
680             # quality of merc you hire. this means you must have at least 22,000 in
681             # grain to win, and as much as 37,000 if your mercs suck.
682 0 0         if ( ( int( $self->_randomize('merc_quality') ) * $mercs ) +
683             $self->population > 2399 )
684             {
685 0           $msg .= "Wipe the blood from the crown - you are now High King!\n\n";
686 0           $msg .= "A nearby monarchy threatens war; ";
687 0           $msg .= "how many .........\n\n\n\n";
688              
689 0           $self->_set_status(KINGDOM);
690             }
691             else {
692 0           $msg .= "The placement of your head atop the castle gate signifies\n";
693 0           $msg .= "that the High King has abolished your Ducal right\n\n";
694              
695 0           $self->_set_status(ABOLISHED);
696             }
697              
698 0           $self->{_msg} = $msg;
699 0           $self->{_steps} = ['_display_msg'];
700              
701 0           return;
702             }
703              
704             sub _king_wants_war {
705 0     0     my $self = shift;
706              
707 0 0         return unless $self->king_unrest > 0;
708              
709 0           my $msg = "\nThe King demands twice the royal tax in the\n";
710 0           $msg .= 'hope of provoking war. Will you pay? [Y/n]: ';
711              
712 0 0 0       $self->_next_step('_king_wants_war')
713             and $self->throw( msg => $msg, action => 'get_yn', default => 'Y' )
714             unless $self->input_is_yn;
715              
716 0           my $ans = $self->input;
717 0   0       $ans ||= 'Y';
718              
719 0 0         $self->_set_king_unrest( ( $ans =~ /^n/i ) ? -1 : 2 );
720              
721 0           return;
722             }
723              
724             sub _grain_production {
725 0     0     my $self = shift;
726              
727 0           my $done = 0;
728              
729 0           my $pop_plant = $self->population * LABOR_CAPACITY;
730 0           my $grain_plant = int( $self->grain / SEED_PER_HA );
731 0 0         my $max_grain_plant =
732             $grain_plant > $self->land ? $self->land : $grain_plant;
733 0 0         my $max_plant =
734             $pop_plant > $max_grain_plant ? $max_grain_plant : $pop_plant;
735              
736 0           my $msg = '';
737              
738 0           $msg .= sprintf( "Land to plant [%d]: ", $max_plant );
739 0 0 0       $self->_next_step('_grain_production')
740             and $self->throw(
741             msg => $msg,
742             action => 'get_value',
743             default => $max_plant
744             ) unless $self->input_is_value();
745              
746 0   0       my $plant = $self->input || $max_plant;
747              
748 0           my $grain = $self->_grain;
749 0           $msg = '';
750              
751 0 0         if ( $plant > $self->land ) {
752 0           $msg = "You don't have enough land\n";
753 0           $msg .= sprintf( "You only have %d HA. of land left\n", $self->land );
754             }
755 0 0         if ( $plant > ($pop_plant) ) {
756 0           $msg = "You don't have enough peasants\n";
757 0           $msg .= sprintf( "Your peasants can only plant %d HA. of land\n",
758             $pop_plant );
759             }
760 0           $grain->{seed} = -( SEED_PER_HA * $plant );
761 0 0         if ( -$grain->seed > $self->grain ) {
762 0           $msg = $self->_insufficient_grain('plant');
763             }
764              
765 0 0         if ($msg) {
766 0           $self->_next_step('_grain_production');
767 0           $self->throw($msg);
768             }
769              
770 0           $grain->{yield} = $plant;
771 0           $self->_land->{planted} = $plant;
772 0           $self->{grain} += $grain->seed;
773              
774 0           my $tmp_quality = $self->_update_land_tables($plant);
775 0           $self->_crop_yield_and_losses($tmp_quality);
776              
777 0           return;
778             }
779              
780             sub _update_land_tables {
781 0     0     my $self = shift;
782 0           my $plant = shift;
783              
784 0           my $valid = 0;
785              
786 0           my %tmp_quality = (
787             100 => 0,
788             80 => 0,
789             60 => 0,
790             40 => 0,
791             20 => 0,
792             0 => 0,
793             );
794              
795 0           my $quality = $self->land_fertility;
796              
797 0           my $qfactor;
798 0           for (qw( 100 80 60 40 20 0 )) {
799 0           $qfactor = $_;
800 0 0         if ( $plant <= $quality->{$qfactor} ) {
801 0           $valid = 1;
802 0           last;
803             }
804             else {
805 0           $plant -= $quality->{$qfactor};
806 0           $tmp_quality{$qfactor} = $quality->{$qfactor};
807 0           $quality->{$qfactor} = 0;
808             }
809             }
810              
811 0 0         if ( !$valid ) {
812 0           warn "LAND TABLE UPDATING ERROR - PLEASE CONTACT PROGRAM AUTHOR\n";
813 0           warn "IF ERROR IS NOT A FAULT OF ENTERING THE PROGRAM, BUT RATHER\n";
814 0           warn "FAULT OF THE PROGRAM LOGIC.\n";
815              
816 0           exit(1);
817             }
818              
819 0           $tmp_quality{$qfactor} = $plant;
820 0           $quality->{$qfactor} -= $plant;
821 0           $quality->{100} += $quality->{80};
822 0           $quality->{80} = 0;
823              
824 0           for ( 60, 40, 20, 0 ) {
825 0           $quality->{ $_ + 40 } += $quality->{$_};
826 0           $quality->{$_} = 0;
827             }
828              
829 0           for ( 100, 80, 60, 40, 20 ) {
830 0           $quality->{ $_ - 20 } += $tmp_quality{$_};
831             }
832              
833 0           $quality->{0} += $tmp_quality{0};
834              
835 0           return \%tmp_quality;
836             }
837              
838             sub _crop_yield_and_losses {
839 0     0     my $self = shift;
840 0           my $tmp_q = shift;
841              
842 0           $self->{_msg} = '';
843              
844 0           $self->{yield} = $self->_randomize('yield') + 3;
845 0 0         if ( !( $self->year % 7 ) ) {
846 0           $self->{_msg} .= "Seven year locusts\n";
847 0           $self->{yield} /= 2;
848             }
849              
850 0           my $x1 = 0;
851 0           for ( 100, 80, 60, 40, 20 ) {
852 0           $x1 += $tmp_q->{$_} * ( $_ / 100 );
853             }
854              
855 0           my $grain = $self->_grain;
856              
857 0 0         if ( $self->_land->planted == 0 ) {
858 0           $self->{yield} = 0;
859             }
860             else {
861 0           $self->{yield} =
862             int( $self->yield * ( $x1 / $self->_land->planted ) * 100 ) / 100;
863             }
864 0           $self->{_msg} .= sprintf( "Yield = %0.2f HL./HA.\n", $self->yield );
865              
866 0           $x1 = $self->_randomize('spoilage') + 3;
867 0 0         unless ( $x1 < 9 ) {
868 0           $grain->{spoilage} = -int( ( $x1 * $self->grain ) / 83 );
869 0           $self->{grain} += $grain->{spoilage};
870 0           $self->{_msg} .= "Rats infest the grainery\n";
871             }
872              
873 0           $self->_next_step('_display_msg');
874              
875 0           return;
876             }
877              
878             sub _kings_levy {
879 0     0     my $self = shift;
880              
881 0 0 0       return if ( $self->population < 67 ) || ( $self->king_unrest == -1 );
882              
883             # there is an edge case where entering an invalid answer might allow
884             # one to avoid this, but ... who cares
885 0           my $x1 = $self->_randomize('levies');
886 0 0         return if $x1 > ( $self->population / 30 );
887              
888 0           my $msg = sprintf( "\nThe High King requires %d peasants for his estates ",
889             int($x1) );
890 0           $msg .= "and mines.\n";
891 0           $msg .= sprintf( "Will you supply them or pay %d ", int( $x1 * 100 ) );
892 0           $msg .= "HL. of grain instead [Y/n]: ";
893              
894 0 0 0       $self->_next_step('_kings_levy')
895             and $self->throw( msg => $msg, action => 'get_yn', default => 'Y' )
896             unless $self->input_is_yn();
897              
898 0 0         if ( $self->input =~ /^n/i ) {
899 0           $self->_grain->{taxes} = -100 * $x1;
900 0           $self->{grain} += $self->_grain->{taxes};
901             }
902             else {
903 0           $self->_population->{levy} = -int($x1);
904 0           $self->{population} += $self->_population->{levy};
905             }
906              
907 0           return;
908             }
909              
910             # TODO: find names for the "magic numbers" and change them to constants
911             sub _war_with_neigbor {
912 0     0     my $self = shift;
913              
914 0 0         if ( $self->king_unrest == -1 ) {
915 0           $self->{_msg} = "\nThe High King calls for peasant levies\n";
916 0           $self->{_msg} .= "and hires many foreign mercenaries\n";
917              
918 0           $self->{king_unrest} = -2;
919             }
920             else {
921 0           my $war = $self->_war;
922              
923             # are you worth coming after?
924 0           $war->{tension} = int( 11 - ( 1.5 * $self->yield ) );
925 0 0         $war->{tension} = 2 if ( $war->tension < 2 );
926              
927 0 0 0       if ( $self->king_unrest
      0        
928             || ( $self->population <= 109 )
929             || ( ( 17 * ( $self->land - 400 ) + $self->grain ) <= 10600 ) )
930             {
931 0           $war->{desire} = 0;
932             }
933             else {
934 0           $self->{_msg} = "\nThe High King grows uneasy and may\n";
935 0           $self->{_msg} .= "be subsidizing wars against you\n";
936              
937 0           $war->{tension} += 2;
938 0           $war->{desire} = $self->year + 5;
939             }
940              
941 0           $war->{risk} = int( $self->_randomize('war') );
942 0 0         $self->_next_step('_first_strike') if $war->tension > $war->risk;
943              
944 0           $war->{first_strike} =
945             int(
946             $war->{desire} + 85 + ( 18 * $self->_randomize('first_strike') ) );
947             }
948 0 0         $self->_next_step('_display_msg') if $self->_msg;
949              
950 0           return;
951             }
952              
953             sub _first_strike {
954 0     0     my $self = shift;
955              
956 0           my $war = $self->_war;
957 0           $war->{will} = 1.2 - ( $self->_unrest / 16 );
958 0           my $resistance = int( $self->population * $war->will ) + 13;
959              
960 0           my $msg = "A nearby Duke threatens war; Will you attack first [y/N]? ";
961              
962 0 0 0       $self->_next_step('_first_strike')
963             and $self->throw( msg => $msg, action => 'get_yn', default => 'N' )
964             unless $self->input_is_yn();
965              
966 0           my $population = $self->_population;
967              
968 0           $self->{_msg} = '';
969 0 0         if ( $self->input !~ /^n/i ) {
970 0 0         if ( $war->{first_strike} >= $resistance ) {
971 0           $self->_next_step('_goto_war');
972 0           $self->{_msg} = "First strike failed - you need professionals\n";
973 0           $population->{casualties} = -$war->risk - $war->tension - 2;
974 0           $war->{first_strike} += ( 3 * $population->casualties );
975             }
976             else {
977 0           $self->{_msg} = "Peace negotiations were successful\n";
978              
979 0           $population->{casualties} = -$war->tension - 1;
980 0           $war->{first_strike} = 0;
981             }
982 0           $self->{population} += $population->casualties;
983 0 0         if ( $war->first_strike < 1 ) {
984 0           $self->{_unrest} -=
985             ( 2 * $population->casualties ) + ( 3 * $population->looted );
986             }
987             }
988             else {
989 0           $self->_next_step('_goto_war');
990             }
991 0 0         $self->_next_step('_display_msg') if $self->_msg;
992              
993 0           return;
994             }
995              
996             sub _goto_war {
997 0     0     my $self = shift;
998              
999 0           my $possible = int( $self->grain / 40 );
1000 0 0         $possible = 75 if $possible > 75;
1001 0 0         $possible = 0 if $possible < 0;
1002              
1003 0           my $msg = "Hire how many mercenaries at 40 HL each [$possible]? ";
1004 0 0 0       $self->_next_step('_goto_war')
1005             and $self->throw(
1006             msg => $msg,
1007             action => 'get_value',
1008             default => $possible
1009             ) unless $self->input_is_value();
1010              
1011 0   0       my $hired = $self->input || $possible;
1012              
1013 0 0         if ( $hired > 75 ) {
1014 0           my $msg = "There are only 75 mercenaries available for hire\n";
1015 0           $self->_next_step('_goto_war');
1016              
1017 0           $self->throw($msg);
1018             }
1019              
1020 0           my $war = $self->_war;
1021 0           my $land = $self->_land;
1022              
1023 0           my $resistance = int( ( $self->population * $war->will ) + ( 7 * $hired ) + 13 );
1024              
1025 0           $war->{desire} = int( $war->desire * WAR_CONSTANT );
1026              
1027 0           my $x6 = $war->desire - ( 4 * $hired ) - int( $resistance / 4 );
1028 0           $war->{desire} = $resistance - $war->desire;
1029 0           $land->{spoils} = int( 0.8 * $war->desire );
1030 0 0         if ( -$land->spoils > int( 0.67 * $self->land ) ) {
1031 0           $self->{_steps} = [];
1032 0           $self->_set_status(ABOLISHED);
1033              
1034 0           my $msg = "You have been overrun and have lost the entire Dukedom\n";
1035 0           $msg .= "The placement of your head atop the castle gate\n";
1036 0           $msg .= "signifies that ";
1037 0           $msg .= "the High King has abolished your Ducal right\n\n";
1038              
1039 0           $self->throw($msg);
1040             }
1041              
1042 0           my $x1 = $land->spoils;
1043              
1044 0           my $fertility = $self->land_fertility;
1045 0           for ( 100, 80, 60 ) {
1046 0           my $x3 = int( $x1 / ( 3 - ( 5 - ( $_ / 20 ) ) ) );
1047 0 0         if ( -$x3 <= $fertility->{$_} ) {
1048 0           $resistance = $x3;
1049             }
1050             else {
1051 0           $resistance = -$fertility->{$_};
1052             }
1053 0           $fertility->{$_} += $resistance;
1054 0           $x1 = $x1 - $resistance;
1055             }
1056 0           for ( 40, 20, 0 ) {
1057 0 0         if ( -$x1 <= $fertility->{$_} ) {
1058 0           $resistance = $x1;
1059             }
1060             else {
1061 0           $resistance = -$fertility->{$_};
1062             }
1063 0           $fertility->{$_} += $resistance;
1064 0           $x1 = $x1 - $resistance;
1065             }
1066              
1067 0           my $grain = $self->_grain;
1068              
1069 0           $msg = '';
1070 0 0         if ( $land->spoils < 399 ) {
1071 0 0         if ( $war->desire >= 0 ) {
1072 0           $msg = "You have won the war\n";
1073              
1074 0           $war->{grain_damage} = 0.67;
1075 0           $grain->{spoils} = int( 1.7 * $land->spoils );
1076 0           $self->grain += $grain->spoils;
1077             }
1078             else {
1079 0           $msg = "You have lost the war\n";
1080              
1081 0           $war->{grain_damage} =
1082             int( ( $grain->yield / $self->land ) * 100 ) / 100;
1083             }
1084 0 0         if ( $x6 <= 9 ) {
1085 0           $x6 = 0;
1086             }
1087             else {
1088 0           $x6 = int( $x6 / 10 );
1089             }
1090             }
1091             else {
1092 0           $msg = "You have overrun the enemy and annexed his entire Dukedom\n";
1093              
1094 0           $grain->{spoils} = 3513;
1095 0           $self->{grain} += $grain->spoils;
1096 0           $x6 = -47;
1097 0           $war->{grain_damage} = 0.55;
1098 0 0         if ( $self->king_unrest <= 0 ) {
1099 0           $self->{king_unrest} = 1;
1100 0           $msg .= "The King fears for his throne and\n";
1101 0           $msg .= "may be planning direct action\n";
1102             }
1103             }
1104              
1105 0 0         $x6 = $self->population if ( $x6 > $self->population );
1106              
1107 0           my $population = $self->_population;
1108              
1109 0           $population->{casualties} -= $x6;
1110 0           $self->{population} -= $x6;
1111 0           $grain->{yield} += int( $war->grain_damage * $land->spoils );
1112 0           $x6 = 40 * $hired;
1113 0 0         if ( $x6 <= $self->grain ) {
1114 0           $grain->{wages} = -$x6;
1115              
1116             # what is P[5] (looted) in this case?
1117             }
1118             else {
1119 0           $grain->{wages} = -$self->grain;
1120 0           $population->{looted} = -int( ( $x6 - $self->grain ) / 7 ) - 1;
1121 0           $msg .= "There isn't enough grain to pay the mercenaries\n";
1122             }
1123 0           $self->{grain} += $grain->wages;
1124              
1125 0 0         --$self->{population} if ( -$population->looted > $self->population );
1126              
1127 0           $self->{population} += $population->looted;
1128 0           $self->{land} += $land->spoils;
1129 0           $self->{_unrest} -=
1130             ( 2 * $population->casualties ) - ( 3 * $population->looted );
1131              
1132 0 0         $self->_next_step('_display_msg') if $self->{_msg} = $msg;
1133              
1134 0           return;
1135             }
1136              
1137             sub _population_changes {
1138 0     0     my $self = shift;
1139              
1140 0           my $x1 = $self->_randomize('disease');
1141              
1142 0           my $population = $self->_population;
1143 0           my $x2;
1144 0 0         if ( $x1 <= 3 ) {
1145 0 0         if ( $x1 != 1 ) {
    0          
1146 0           $self->{_msg} = "A POX EPIDEMIC has broken out\n";
1147 0           $self->_next_step('_display_msg');
1148              
1149 0           $x2 = $x1 * 5;
1150 0           $population->{diseased} = -int( $self->population / $x2 );
1151 0           $self->{population} += $population->diseased;
1152             }
1153             elsif ( $self->_black_D <= 0 ) {
1154 0           $self->{_msg} = "The BLACK PLAGUE has struck the area\n";
1155 0           $self->_next_step('_display_msg');
1156              
1157 0           $self->{_black_D} = 13;
1158 0           $x2 = 3;
1159 0           $population->{diseased} = -int( $self->population / $x2 );
1160 0           $self->{population} += $population->diseased;
1161             }
1162             }
1163              
1164 0 0         $x1 = $population->looted ? 4.5 : $self->_randomize('birth') + 4;
1165              
1166 0           $population->{births} = int( $self->population / $x1 );
1167 0           $population->{deaths} = int( 0.3 - ( $self->population / 22 ) );
1168 0           $self->{population} += $population->deaths + $population->births;
1169              
1170 0           --$self->{_black_D};
1171              
1172 0           return;
1173             }
1174              
1175             sub _harvest_grain {
1176 0     0     my $self = shift;
1177              
1178 0           my $grain = $self->_grain;
1179              
1180 0           $grain->{yield} = int( $self->yield * $self->_land->planted );
1181 0           $self->{grain} += $grain->yield;
1182              
1183 0           my $x1 = $grain->yield - 4000;
1184 0 0         $grain->{expense} = -int( 0.1 * $x1 ) if $x1 > 0;
1185              
1186 0           $grain->{expense} -= MIN_EXPENSE;
1187 0           $self->{grain} += $grain->expense;
1188              
1189             # you've already told the King what to do with his taxes, he's coming
1190             # to collect them (and more) in person now.
1191 0 0         return if $self->king_unrest < 0;
1192              
1193 0 0         my $tax_rate = $self->king_unrest >= 2 ? TAX_RATE * 2 : TAX_RATE;
1194 0           $x1 = -int( $self->land * $tax_rate );
1195              
1196 0 0         if ( -$x1 > $self->grain ) {
1197 0           $self->{_msg} = "You have insufficient grain to pay the royal tax\n";
1198 0           $self->{_msg} .= "the High King has abolished your Ducal right\n\n";
1199 0           $self->_next_step('_display_msg');
1200              
1201 0           $self->_set_status(ABOLISHED);
1202 0           return 1;
1203             }
1204 0           $grain->{taxes} += $x1;
1205 0           $self->{grain} += $x1;
1206              
1207 0           return;
1208             }
1209              
1210             sub _update_unrest {
1211 0     0     my $self = shift;
1212              
1213 0           $self->{unrest} = int( $self->unrest * UNREST_FACTOR ) + $self->_unrest;
1214              
1215 0           return;
1216             }
1217              
1218             sub _quit_game {
1219 0     0     my $self = shift;
1220              
1221             # empty the stack, don't clear it or it will re-initialize!
1222 0           $self->{_steps} = [];
1223 0           $self->_set_status(QUIT_GAME);
1224              
1225 0           return;
1226             }
1227              
1228             sub _end_of_game_check {
1229 0     0     my $self = shift;
1230              
1231 0           my $msg = '';
1232              
1233 0 0 0       if ( $self->status eq QUIT_GAME ) {
    0 0        
    0 0        
    0          
    0          
1234 0           $msg = "\nYou have conceded the game\n\n";
1235             }
1236             elsif (( $self->grain < MIN_GRAIN )
1237             || ( $self->_unrest > MAX_1YEAR_UNREST )
1238             || ( $self->unrest > MAX_TOTAL_UNREST ) )
1239             {
1240 0           $msg = "\nThe peasants tire of war and starvation\n";
1241 0           $msg .= "You are deposed!\n\n";
1242              
1243 0           $self->_set_status(DEPOSED);
1244             }
1245             elsif ( $self->population < MIN_POPULATION ) {
1246 0           $msg = "You have so few peasants left that\n";
1247 0           $msg .= "the High King has abolished your Ducal right\n\n";
1248              
1249 0           $self->_set_status('ABOLISHED');
1250             }
1251             elsif ( $self->land < MIN_LAND ) {
1252 0           $msg = "You have so little land left that\n";
1253 0           $msg .= "the High King has abolished your Ducal right\n\n";
1254              
1255 0           $self->_set_status(ABOLISHED);
1256             }
1257             elsif ( $self->year >= MAX_YEAR && !$self->king_unrest ) {
1258 0           $msg = "You have reached the age of mandatory retirement\n\n";
1259              
1260 0           $self->_set_status(RETIRED);
1261             }
1262              
1263 0 0         $self->throw($msg) if $self->game_over;
1264              
1265 0           return;
1266             }
1267              
1268             sub _insufficient_grain {
1269 0     0     my $self = shift;
1270 0           my $action = shift;
1271              
1272 0           my %msgs = (
1273             feed => sprintf( "You have %d HL. of grain left,\n", $self->grain ),
1274             buy => sprintf( "Enough to buy %d HA. of land\n",
1275             int( $self->grain / $self->_land->{price} ) ),
1276             plant => sprintf( "Enough to plant %d HA. of land\n\n",
1277             int( $self->grain / SEED_PER_HA ) ),
1278             );
1279              
1280 0           my $msg = "You don't have enough grain\n";
1281 0           $msg .= $msgs{$action};
1282              
1283 0           return $msg;
1284             }
1285              
1286             sub _prep_detail_report {
1287 0     0     my $self = shift;
1288              
1289 0           my $msg = "\n";
1290 0           for ( sort( keys( %{ $self->_population } ) ) ) {
  0            
1291 0           $msg .= sprintf( "%-20.20s %d\n", $_, $self->_population->$_ );
1292             }
1293 0           $msg .= sprintf( "%-20.20s %d\n\n", "Peasants at end", $self->population );
1294              
1295 0           for ( sort( keys( %{ $self->_land } ) ) ) {
  0            
1296 0           $msg .= sprintf( "%-20.20s %d\n", $_, $self->_land->$_ );
1297             }
1298 0           $msg .= sprintf( "%-20.20s %d\n\n", "Land at end", $self->land );
1299              
1300 0           for ( sort( keys( %{ $self->_grain } ) ) ) {
  0            
1301 0           $msg .= sprintf( "%-20.20s %d\n", $_, $self->_grain->$_ );
1302             }
1303 0           $msg .= sprintf( "%-20.20s %d\n\n", "Grain at end", $self->grain );
1304              
1305 0           for ( sort( keys( %{ $self->_war } ) ) ) {
  0            
1306 0           $msg .= sprintf( "%-20.20s %d\n", $_, $self->_war->$_ );
1307             }
1308              
1309 0           $self->{detail_report} = $msg;
1310              
1311 0           return;
1312             }
1313              
1314             1;
1315              
1316             __END__