ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cf.schmorp.de/maps/perl/Jeweler.pm
Revision: 1.10
Committed: Fri Dec 15 19:11:46 2006 UTC (17 years, 7 months ago) by root
Branch: MAIN
CVS Tags: HEAD
Changes since 1.9: +0 -0 lines
State: FILE REMOVED
Log Message:
move .ext to server

File Contents

# Content
1 =head1 NAME
2
3 Jeweler
4
5 =head1 DESCRIPTION
6
7 The Jeweler skill helper module.
8
9 =cut
10
11 package Jeweler;
12
13 use strict;
14 use YAML;
15
16 =over 4
17
18 =item @RESISTS
19
20 List of all resistancies that can occur on rings and amulets.
21
22 =cut
23
24 our $CFG;
25
26 sub read_config {
27 my ($filename) = @_;
28
29 unless (-e $filename) {
30 warn "$filename doesn't exists! no config for jeweler skill loaded!\n";
31 $CFG = {};
32 return
33 }
34
35 $CFG = YAML::LoadFile $filename;
36 }
37
38 sub getcfg {
39 my ($sect, $key) = @_;
40 return $CFG->{$sect} unless defined $key;
41
42 my $cfg = $CFG->{$sect}->{$key}
43 or die "Couldn't find $sect/$key in configuration!";
44
45 $cfg
46 }
47
48 our @RESISTS = (
49 cf::ATNR_PHYSICAL,
50 cf::ATNR_MAGIC,
51 cf::ATNR_FIRE,
52 cf::ATNR_ELECTRICITY,
53 cf::ATNR_COLD,
54 cf::ATNR_CONFUSION,
55
56 cf::ATNR_ACID,
57 cf::ATNR_DRAIN,
58 cf::ATNR_GHOSTHIT,
59 cf::ATNR_POISON,
60 cf::ATNR_SLOW,
61 cf::ATNR_PARALYZE,
62
63 cf::ATNR_TURN_UNDEAD,
64 cf::ATNR_FEAR,
65 cf::ATNR_DEPLETE,
66 cf::ATNR_DEATH,
67 cf::ATNR_HOLYWORD,
68 cf::ATNR_LIFE_STEALING,
69
70 cf::ATNR_BLIND,
71 cf::ATNR_DISEASE,
72 );
73
74 =item @EFFECT_RESISTS
75
76 List of all effect resistancies that occur on rings and amulets.
77 The difference is made because effect resistancies are less effective at lower levels.
78
79 =back
80
81 =cut
82
83 our @EFFECT_RESISTS = (
84 cf::ATNR_CONFUSION,
85 cf::ATNR_DRAIN,
86 cf::ATNR_POISON,
87 cf::ATNR_SLOW,
88 cf::ATNR_PARALYZE,
89 cf::ATNR_TURN_UNDEAD,
90 cf::ATNR_FEAR,
91 cf::ATNR_DEPLETE,
92 cf::ATNR_DEATH,
93 cf::ATNR_BLIND,
94 cf::ATNR_DISEASE,
95 );
96
97 our %RESMAP = (
98 cf::ATNR_PHYSICAL => "PHYSICAL",
99 cf::ATNR_MAGIC => "MAGIC",
100 cf::ATNR_FIRE => "FIRE",
101 cf::ATNR_ELECTRICITY => "ELECTRICITY",
102 cf::ATNR_COLD => "COLD",
103 cf::ATNR_CONFUSION => "CONFUSION",
104 cf::ATNR_ACID => "ACID",
105
106 cf::ATNR_DRAIN => "DRAIN",
107 cf::ATNR_GHOSTHIT => "GHOSTHIT",
108 cf::ATNR_POISON => "POISON",
109 cf::ATNR_SLOW => "SLOW",
110 cf::ATNR_PARALYZE => "PARALYZE",
111 cf::ATNR_TURN_UNDEAD => "TURN_UNDEAD",
112
113 cf::ATNR_FEAR => "FEAR",
114 cf::ATNR_DEPLETE => "DEPLETE",
115 cf::ATNR_DEATH => "DEATH",
116 cf::ATNR_HOLYWORD => "HOLYWORD",
117 cf::ATNR_LIFE_STEALING => "LIFE_STEALING",
118 cf::ATNR_BLIND => "BLIND",
119 cf::ATNR_DISEASE => "DISEASE",
120 );
121
122 our %LVL_DIFF_CHANCES = (
123 +5 => 100,
124 +4 => 95,
125 +3 => 85,
126 +2 => 75,
127 +1 => 65,
128 0 => 50,
129 -1 => 45,
130 -2 => 35,
131 -3 => 25,
132 -4 => 10,
133 -5 => 0
134 );
135
136 our %LVL_DIFF_MSG = (
137 -5 => 'Way above your skill',
138 -4 => 'Very low',
139 -3 => 'Slight chance',
140 -2 => 'Low',
141 -1 => 'Nearly 50:50',
142 0 => '50:50',
143 1 => 'Slightly above 50:50',
144 2 => 'Good',
145 3 => 'High',
146 4 => 'Nearly confident',
147 5 => '100%',
148 );
149
150 sub level_diff_to_str {
151 my ($delta) = @_;
152 $delta = -5 if $delta < -5;
153 $delta = 5 if $delta > 5;
154 return $LVL_DIFF_MSG{$delta}
155 }
156
157 sub level_diff_to_chance_perc {
158 my ($delta) = @_;
159 $delta = -5 if $delta < -5;
160 $delta = 5 if $delta > 5;
161 return $LVL_DIFF_CHANCES{$delta}
162 }
163
164 sub analyze {
165 my ($sk, $chdl, $pl) = @_;
166
167 my $hadunid = 0;
168 for ($chdl->grep_by_type (cf::RING, cf::AMULET)) {
169 if (!$_->flag (cf::FLAG_IDENTIFIED) && $_->need_identify) {
170 $hadunid = 1;
171 next;
172 }
173 my $r = Jeweler::Object->new (object => $_);
174 my $msg = $r->analyze ($sk, $pl);
175 $pl->message ($r->to_string . ": " . $msg);
176 if ($pl->flag (cf::FLAG_WIZ)) {
177 $r->wiz_analyze ($pl);
178 }
179 }
180 if ($hadunid) {
181 $pl->message ("You couldn't identify the other rings and not analyze them!");
182 }
183 }
184
185 # this function converts metals/minerals into a raw ring (of adornment)
186 sub simple_converter {
187 my ($pl, $ingred, $chdl, $conv) = @_;
188
189 $conv = lc $conv;
190 my $cnvs = $CFG->{conversions};
191
192 return unless $cnvs->{$conv};
193
194 my %ingred_groups;
195
196 my @conv_cfg = @{$cnvs->{$conv}};
197 my $outarch = $conv;
198 my ($ingr_grp, $outarchvalfact, $srcarchname, $xp_gain) = @conv_cfg;
199
200 unless (@conv_cfg <= 4) {
201 warn "ERROR: Conversion for '$outarch' has only " . (@conv_cfg) . " arguments!";
202 return;
203 }
204
205 unless ($xp_gain > 0) {
206 warn "WARNING: xp gain isn't > 0 in convesion '$outarch'\n";
207 return;
208 }
209
210 unless ($outarchvalfact) {
211 warn "ERROR: source-arch-value-multiplier == 0 in conversion '$outarch'\n";
212 return;
213 }
214
215 unless ($outarchvalfact >= 1) {
216 warn "WARNING: source-arch-value-multiplier < 1 in conversion '$outarch', results in more valuable output!\n";
217 }
218
219 my $archvalsum = $ingred->value ($ingr_grp, $srcarchname);
220 $ingred->remove ($ingr_grp, $srcarchname);
221
222 my $outarchval = cf::arch::find ($outarch)->clone->value;
223
224 my $nrof = int ($archvalsum / (($outarchval || 1000) * $outarchvalfact));
225 if ($nrof) {
226 # XXX: yes, i know what i'm doing here, i don't set nrof, but it didn't work somehow (pls. chek sometimes)
227 $chdl->put (cf::object::new $outarch) for 1..$nrof;
228
229 my $xp_sum = ($xp_gain * $nrof);
230
231 if ($xp_sum) {
232 $pl->ob->message ("You got $xp_sum xp by making $nrof ${outarch}s");
233 $pl->ob->change_exp ($xp_sum, "jeweler", cf::SK_EXP_ADD_SKILL);
234 }
235 }
236 }
237
238
239 package Jeweler::CauldronHandler;
240
241 use strict;
242
243 =head2 CauldronHandler
244
245 The Jeweler::CauldronHandler package, that helps you with handling the
246 cauldron stuff. Can also be used for other skills.
247
248 =cut
249
250 sub new {
251 my ($class, %arg) = @_;
252
253 my $self = bless {
254 %arg,
255 }, $class;
256
257 $self;
258 }
259
260 =over 4
261
262 =item find_cauldron ($arch_name, @map_stack)
263
264 This finds the cauldron with C<$arch_name> on the C<@map_stack> and initalises the CauldronHandler.
265 It takes the topmost cauldron that is found. Returns undef if no cauldron was found.
266 Returns the cauldron object if it was found.
267
268 =cut
269
270 sub find_cauldron {
271 my ($self, $arch_name, @map_stack) = @_;
272
273 my @c =
274 grep {
275 $_->flag (cf::FLAG_IS_CAULDRON)
276 and $_->arch->name eq $arch_name
277 } @map_stack;
278
279 $self->{cauldron} = $c[0];
280 }
281
282 =item grep_by_type (@types)
283
284 Finds all objects in the cauldron that have the type of one of C<@types>.
285
286 =cut
287
288 sub grep_by_type {
289 my ($self, @types) = @_;
290
291 return () unless $self->{cauldron};
292
293 my @res = grep {
294 my $ob = $_;
295 (grep { $ob->type == $_ } @types) > 0
296 } $self->{cauldron}->inv;
297
298 return @res
299 }
300
301 =item extract_jeweler_ingredients
302
303 Extracts the ingredients that matter for the Jeweler skill
304 and returns a Jeweler::Ingredients object.
305
306 =cut
307
308 sub extract_jeweler_ingredients {
309 my ($self) = @_;
310
311 return () unless $self->{cauldron};
312
313 my $ingreds = {};
314
315 my %type_to_key = (
316 cf::RING => 'rings',
317 cf::AMULET => 'ammys',
318 cf::INORGANIC => 'mets_and_mins',
319 cf::GEM => 'gems',
320 cf::POTION => 'potions',
321 cf::SCROLL => 'scrolls',
322 );
323
324 for ($self->{cauldron}->inv) {
325
326 if (my $k = $type_to_key{$_->type}) {
327 push @{$ingreds->{$k}}, $_;
328 }
329 }
330
331 return Jeweler::Ingredients->new (ingredients => $ingreds, cauldron_helper => $self)
332 }
333
334 =item put ($object)
335
336 Just puts the C<$object> into the cauldron.
337
338 =cut
339
340 sub put {
341 my ($self, $obj) = @_;
342
343 return undef unless $self->{cauldron};
344 $obj->insert_ob_in_ob ($self->{cauldron});
345 }
346
347 =back
348
349 =cut
350
351 package Jeweler::Ingredients;
352 use Storable qw/dclone/;
353 use strict;
354
355 =head2 Ingredients
356
357 This class handles the ingredients.
358
359 =over 4
360
361 =item new (ingredients => $ingred_hash)
362
363 This is called from the CauldronHandler that gives you the ingredients.
364
365 =cut
366
367 sub new {
368 my ($class, %arg) = @_;
369
370 my $self = bless {
371 %arg,
372 }, $class;
373
374 $self;
375 }
376
377 =item value ($group, $archname)
378
379 Returns the value of the ingredients in C<$group> with the archetypename C<$archname>.
380
381 =cut
382
383 sub value {
384 my ($self, $group, $archname) = @_;
385
386 my @objs = grep {
387 $_->arch->name eq $archname
388 } @{$self->{ingredients}->{$group} || []};
389
390 my $sum = 0;
391 for (@objs) {
392 $sum += ($_->nrof || 1) * $_->value;
393 }
394
395 return $sum;
396 }
397
398 =item remove ($group, $archname)
399
400 Removes the ingredients in C<$group> with archname C<$archname>.
401 It removes all in C<$group> if archname is undef.
402
403 =cut
404
405 sub remove {
406 my ($self, $group, $archname) = @_;
407
408 my $ingred = $self->{ingredients};
409
410 my @out;
411
412 for (@{$ingred->{$group}}) {
413 if (defined $archname) {
414 if ($_->arch->name eq $archname) {
415 Jeweler::Util::remove ($_);
416 } else {
417 push @out, $_;
418 }
419 } else {
420 Jeweler::Util::remove ($_);
421 }
422 }
423
424 @{$ingred->{$group}} = @out;
425 }
426
427 sub get_plan {
428 my ($self) = @_;
429
430 my $ingred = $self->{ingredients};
431
432 for my $grp (keys %$ingred) {
433 for my $pot (@{$ingred->{$grp}}) {
434 for my $plan (keys %{$Jeweler::CFG->{plans}}) {
435 my $plg = $Jeweler::CFG->{plans}->{$plan};
436 my @plga = ();
437 unless (ref $plg eq 'ARRAY') {
438 push @plga, $plg;
439 } else {
440 @plga = @$plg;
441 }
442 next unless @plga > 0;
443 if (Jeweler::Util::grep_for_match ($pot, @plga)) {
444 return $plan;
445 }
446 }
447 }
448 }
449 }
450
451 sub get_ring {
452 my ($self) = @_;
453 return (
454 @{$self->{ingredients}->{ammys} || []},
455 @{$self->{ingredients}->{rings} || []}
456 );
457 }
458
459 sub improve_ring_by_plan {
460 my ($self, $plan, $ring) = @_;
461
462 $ring = dclone ($ring);
463
464 my $ingred = $self->{ingredients};
465 my $impr = {};
466
467 if ($plan =~ m/^stat_(\S+)$/) {
468 my $statname = $1;
469 my $plingred = Jeweler::getcfg (plans => $plan)
470 or die "ingredients for plan '$plan' not defined!";
471
472 my $cnt = 0;
473 for my $pot (@{$ingred->{potions}}) {
474 if (Jeweler::Util::grep_for_match ($pot, @$plingred)) {
475 $cnt += $pot->nrof;
476 }
477 }
478
479 my $maxstat = Jeweler::getcfg (maximprovements => 'stats');
480 my $did_impr = 0;
481 for my $x (1..$maxstat) {
482 my $y = Jeweler::Object::fx ($x, 'stat_potions');
483
484 if ($cnt <= $y->[0]) {
485 $ring->{hash}->{stat}->{$statname} += $x;
486 $did_impr = 1;
487 last;
488 }
489 }
490
491 # we want at least this improvement if we have a plan...
492 $ring->{hash}->{stat}->{$statname} += 1 unless $did_impr;
493
494 } elsif ($plan =~ m/^spec_(\S+)$/) {
495 } elsif ($plan =~ m/^resist_(\S+)$/) {
496 }
497
498 return $ring;
499 }
500
501 sub do_grep {
502 my ($self, $cb, @grepar) = @_;
503
504 my $ingred = $self->{ingredients};
505
506
507 for my $cat (keys %$ingred) {
508 my @rem;
509 for my $ing (@{$ingred->{$cat}}) {
510 if (Jeweler::Util::grep_for_match ($ing, @grepar)) {
511 unless ($cb->($ing)) {
512 push @rem, $ing;
513 }
514 } else {
515 push @rem, $ing;
516 }
517 }
518 @{$ingred->{$cat}} = @rem;
519 }
520 }
521
522 sub check_costs {
523 my ($self, $costs, $do_remove) = @_;
524
525 my $costs = dclone ($costs);
526
527 for my $key (keys %$costs) {
528 my @grepar;
529 if ($key =~ m/^stat_(\S+)$/) {
530 @grepar = @{Jeweler::getcfg (plans => $key) || []};
531 } else {
532 @grepar = (undef, undef, $key);
533 }
534
535 if ($do_remove) {
536 my $rem = $costs->{$key};
537 $self->do_grep (sub { if ($rem) { $rem = Jeweler::Util::remove ($_[0], $rem); } 1 }, @grepar);
538 if ($rem > 0) {
539 warn "JEWELER BUG: removed ingredients $rem > 0 after removing!";
540 }
541 } else {
542 my $nr;
543 $self->do_grep (sub { $nr += $_[0]->nrof; 0 }, @grepar);
544 $costs->{$key} -= $nr;
545 }
546 }
547
548 return $costs;
549 }
550
551 =back
552
553 =cut
554
555 sub put_to_bench {
556 my ($self, $bench) = @_;
557
558 my $ingred = $self->{ingredients};
559
560 for my $ik (keys %$ingred) {
561 for (@{$ingred->{$ik} || []}) {
562 $bench->put ($_);
563 }
564 }
565 }
566
567 package Jeweler::Object;
568 use strict;
569 use POSIX;
570 use List::Util qw/max min sum/;
571
572 sub new {
573 my ($class, %arg) = @_;
574
575 my $self = bless { }, $class;
576
577 $self->ring_or_ammy_to_hash ($arg{object});
578
579 $self;
580 }
581
582 sub analyze {
583 my ($self, $sk, $pl) = @_;
584
585 my $sklvl = cf::exp_to_level ($sk->stats->exp);
586 my $ringlvl = $self->power_to_level;
587
588 my $tmpl;
589 if ($pl->flag (cf::FLAG_WIZ)) {
590 $tmpl = Jeweler::level_diff_to_chance_perc ($sklvl - $ringlvl);
591 } else {
592 $tmpl = Jeweler::level_diff_to_str ($sklvl - $ringlvl);
593 }
594 my $msg = sprintf "Projected success rate: %s", $tmpl;
595 return $msg;
596 }
597
598 sub wiz_analyze {
599 my ($self, $pl) = @_;
600 my $costs = $self->calc_costs;
601 my $desc = "";
602 my $lvl = $self->power_to_level (\$desc);
603 $pl->message ("costs: " . join (', ', map { "$_: " . sprintf "%.2f", $costs->{$_} } keys %$costs));
604 $pl->message ("level: " . $desc);
605 }
606
607
608 sub get_chance_perc {
609 my ($self, $sk) = @_;
610 my $sklvl = cf::exp_to_level ($sk->stats->exp);
611 my $ringlvl = $self->power_to_level;
612 return Jeweler::level_diff_to_chance_perc ($sklvl - $ringlvl);
613 }
614
615 sub fx {
616 my ($res, $cfg) = @_;
617 my $or = $res;
618 my $ar = $Jeweler::CFG->{functions}->{$cfg};
619 if (ref $ar->[0] eq 'ARRAY') {
620 $res = $res - 1;
621 } else {
622 $res = ceil ($res / 5) - 1;
623 }
624 $ar->[max (min ($res, @$ar - 1), 0)];
625 }
626
627 sub improve_by_ring {
628 my ($self, @rings) = @_;
629 my $ring = $self;
630 for my $iring (@rings) {
631 for my $cat (qw/stat spec resist/) {
632 for my $k (keys %{$iring->{hash}->{$cat}}) {
633 if ($ring->{hash}->{$cat}->{$k} < $iring->{hash}->{$cat}->{$k}) {
634 $ring->{hash}->{$cat}->{$k} = $iring->{hash}->{$cat}->{$k};
635 }
636 }
637 }
638 }
639 }
640
641 sub negate {
642 my ($self) = @_;
643 for my $cat (qw/stat spec resist/) {
644 for my $k (keys %{$self->{hash}->{$cat}}) {
645 if ($self->{hash}->{$cat}->{$k} > 0) {
646 $self->{hash}->{$cat}->{$k} *= -1;
647 }
648 }
649 }
650 }
651
652 sub to_string {
653 my ($self) = @_;
654 my $r = $self->{hash};
655 return
656 $r->{arch} . " " .
657 join ("",
658 grep { $_ ne "" }
659 join ("",
660 (map {
661 my $rv = $r->{resist}->{$_};
662 "(resist " . (lc $Jeweler::RESMAP{$_}) . " " . ($rv > 0 ? '+' : '') . $rv . ")"
663 } grep { $r->{resist}->{$_} } @Jeweler::RESISTS),
664 (map {
665 my $rv = $r->{stat}->{$_};
666 "(" . (ucfirst lc $_) . ($rv > 0 ? '+' : '') . $rv . ")"
667 } grep { $r->{stat}->{$_} } keys %{$r->{stat}}),
668 (map {
669 my $rv = $r->{spec}->{$_};
670 "(" . (lc $_) . ($rv > 0 ? '+' : '') . $rv . ")"
671 } grep { $r->{spec}->{$_} } keys %{$r->{spec}})))
672 }
673
674 sub ring_or_ammy_to_hash {
675 my ($self, $thing) = @_;
676
677 my $obj = {};
678
679 for (@Jeweler::RESISTS) {
680 $obj->{resist}->{$_} = $thing->resistance ($_);
681 }
682
683 my $stats = $thing->stats;
684
685 for (qw/Str Dex Con Wis Cha Int Pow/) {
686 $obj->{stat}->{lc $_} = $stats->$_;
687 }
688
689 $obj->{spec}{regen} = $stats->hp;
690 $obj->{spec}{magic} = $stats->sp;
691 $obj->{spec}{wc} = $stats->wc;
692 $obj->{spec}{dam} = $stats->dam;
693 $obj->{spec}{ac} = $stats->ac;
694 $obj->{spec}{speed} = $stats->exp;
695 $obj->{spec}{food} = $stats->food;
696
697 $obj->{name} = $thing->name;
698 $obj->{arch} = $thing->arch->name;
699 $obj->{face} = $thing->face;
700
701 $self->{hash} = $obj
702 }
703
704 sub to_object {
705 my ($self) = @_;
706
707 my $obj = cf::object::new $self->{hash}->{arch};
708
709 $obj->face ($self->{hash}{face});
710
711 my $stats = $obj->stats;
712
713 $stats->hp ($self->{hash}{spec}{regen});
714 $stats->sp ($self->{hash}{spec}{magic});
715 $stats->wc ($self->{hash}{spec}{wc});
716 $stats->dam ($self->{hash}{spec}{dam});
717 $stats->ac ($self->{hash}{spec}{ac});
718 $stats->exp ($self->{hash}{spec}{speed});
719 $stats->food ($self->{hash}{spec}{food});
720
721 $stats->$_ ($self->{hash}{stat}{lc $_})
722 for qw/Str Dex Con Wis Cha Int Pow/;
723
724 for (@Jeweler::RESISTS) {
725 $obj->resistance ($_, $self->{hash}->{resist}->{$_});
726 }
727
728 $obj->flag (cf::FLAG_IDENTIFIED, 1);
729
730 return $obj;
731 }
732
733 sub stat_level {
734 my ($self) = @_;
735 my $stats = $self->{hash}->{stat} || {};
736
737 my $maxlevel = Jeweler::getcfg (maxlevels => 'stat_level');
738 my $maxstat = Jeweler::getcfg (maximprovements => 'stats');
739
740 my $stat_cnt = scalar (grep { $_ > 0 } values %$stats);
741 my $stat_sum = sum (values %$stats); # also count the negative stats!
742 my $level = int (($maxlevel / $maxstat) * $stat_sum);
743
744 ($level, $stat_cnt)
745 }
746
747 sub resist_level {
748 my ($self) = @_;
749
750 my $resists = $self->{hash}->{resist} || {};
751
752 my $att_res_lvl = Jeweler::getcfg (maxlevels => 'resist_level');
753 my $efc_res_lvl = Jeweler::getcfg (maxlevels => 'effect_resist_level');
754 my $max_att_res = Jeweler::getcfg (maximprovements => 'attack_resistances');
755 my $max_efc_res = Jeweler::getcfg (maximprovements => 'effect_resistances');
756 my $max_ovr_res = Jeweler::getcfg (maximprovements => 'resistances');
757
758 my $ressum = 0;
759 my $rescnt = 0;
760 my @reslevels;
761
762 for my $resnam (keys %$resists) {
763 my $res = $resists->{$resnam};
764
765 $rescnt++
766 if $res > 0; # negative resistancies are not an improvement
767
768 $ressum += $res; # note: negative resistancies lower the sum
769
770 next unless $res > 0;
771
772 my $level = 0;
773 if (grep { $resnam eq $_ } @Jeweler::EFFECT_RESISTS) {
774 $level = ceil (($efc_res_lvl / $max_efc_res) * $res);
775 } else {
776 $level = ceil (($att_res_lvl / $max_att_res) * $res);
777 }
778 push @reslevels, $level;
779 }
780
781 my $overall_lvl = ($att_res_lvl / $max_ovr_res) * $ressum;
782
783 (max (@reslevels, $overall_lvl), $rescnt);
784 }
785
786 sub special_level {
787 my ($self) = @_;
788
789 my $specials = $self->{hash}->{spec} || {};
790
791 my $max_spc_lvl = Jeweler::getcfg (maxlevels => 'spec_level');
792 my $max_specials = Jeweler::getcfg (maximprovements => 'specials');
793
794 my @speclvls;
795 my $specsum = 0;
796 my $imprs = 0;
797
798 for my $spcnam (keys %$specials) {
799 my $spc = $specials->{$spcnam};
800 next unless $spc > 0;
801
802 $specsum += $spc;
803 $imprs++;
804
805 my $max_spc = Jeweler::getcfg (maxspecial => $spcnam);
806
807 my $lvl = ($max_spc_lvl / $max_spc) * $spc;
808 push @speclvls, $lvl;
809 }
810
811 my $sumlvl = ($max_spc_lvl / $max_specials) * $specsum;
812
813 (max (@speclvls, $sumlvl), $imprs)
814 }
815
816
817 # this function calculated the 'level' of an amulet or a ring
818 sub power_to_level {
819 my ($self, $lvldescr) = @_;
820
821 my $max_imprs = Jeweler::getcfg (maximprovements => 'improvements');
822 my $max_impr_lvl = Jeweler::getcfg (maxlevels => 'improve_level');
823
824 my ($stat_lvl, $stat_imprs) = $self->stat_level;
825 my ($resist_lvl, $res_imprs) = $self->resist_level;
826 my ($spec_lvl, $spec_imprs) = $self->special_level;
827
828 my $impr_sum = $stat_imprs + $res_imprs + $spec_imprs;
829
830 my $impr_lvl = ceil (($max_impr_lvl / ($max_imprs + 1)) * ($impr_sum - 1)); # 1 improvemnt bonus
831
832 my $levl = int max ($stat_lvl, $resist_lvl, $impr_lvl, $spec_lvl, 0);
833
834 if ($lvldescr) {
835 $$lvldescr =
836 sprintf "%3d: %s\n", $levl,
837 "stat: $stat_lvl, resist: $resist_lvl, improve: $impr_lvl, "
838 ."spec: $spec_lvl (num impr $stat_imprs + $res_imprs + $spec_imprs - 1)";
839 }
840
841 $levl
842 }
843
844 sub add_stat_costs {
845 my ($self, $cost) = @_;
846
847 my $stats = $self->{hash}->{stat};
848
849 for my $stat (keys %$stats) {
850 my $sum = $stats->{$stat};
851
852 next unless $sum > 0;
853
854 my $statfx = fx ($sum, 'stat_potions');
855 $cost->{"stat_$stat"} += $statfx->[0];
856 split_diamonds ($cost, $statfx->[1], 'stat_' . $stat);
857 }
858 }
859
860 sub add_special_costs {
861 my ($self, $cost) = @_;
862
863 my $specials = $self->{hash}->{spec};
864
865 for my $spec (keys %$specials) {
866 my $sum = $specials->{$spec};
867
868 next unless $sum > 0;
869
870 my $specfx = fx ($sum, 'spec_potions');
871 $cost->{"spec_$spec"} += $specfx->[0];
872 split_diamonds ($cost, $specfx->[1], 'spec_' . $spec);
873 }
874 }
875
876 sub calc_costs {
877 my ($self) = @_;
878
879 my $costs = {};
880
881 my $ring = $self->{hash};
882
883 for my $resnam (keys %{$ring->{resist} || {}}) {
884
885 my $res = $ring->{resist}->{$resnam};
886
887 next unless $res > 0;
888
889 $costs->{"resist_" . $Jeweler::RESMAP{$resnam} . "_item"} += $res;
890
891 my $diamonds;
892 if (grep { $resnam eq $_ } @Jeweler::EFFECT_RESISTS) {
893 $diamonds += fx ($res, 'effect_resist_diamonds');
894 } else {
895 $diamonds += fx ($res, 'attack_resist_diamonds');
896 }
897
898 split_diamonds ($costs, $diamonds, 'resist_' . $Jeweler::RESMAP{$resnam});
899 }
900
901 $self->add_stat_costs ($costs);
902 $self->add_special_costs ($costs);
903
904 return $costs;
905 }
906
907 sub split_diamonds {
908 my ($cost, $diamonds, $category) = @_;
909
910 my $stat_split = Jeweler::getcfg (diamond_split => $category);
911
912 my $sum = sum (@$stat_split);
913 if ($sum < (1 - 0.0001)) {
914 warn "JEWELER BUG: sum (@$stat_split) = $sum < 1 for $category!";
915 }
916
917 my $emarch = cf::arch::find 'emerald';
918 my $saarch = cf::arch::find 'sapphire';
919 my $pearch = cf::arch::find 'pearl';
920 my $ruarch = cf::arch::find 'ruby';
921 my $diarch = cf::arch::find 'gem';
922
923 my $sumvalue = $diarch->clone->value * $diamonds;
924
925 $cost->{emerald} += ceil $sumvalue * $stat_split->[0] / max 1, $emarch->clone->value;
926 $cost->{sapphire} += ceil $sumvalue * $stat_split->[1] / max 1, $saarch->clone->value;
927 $cost->{pearl} += ceil $sumvalue * $stat_split->[2] / max 1, $pearch->clone->value;
928 $cost->{ruby} += ceil $sumvalue * $stat_split->[3] / max 1, $ruarch->clone->value;
929 $cost->{gem} += ceil $sumvalue * $stat_split->[4] / max 1, $diarch->clone->value;
930 }
931
932 package Jeweler::Util;
933
934 use strict;
935
936 =head2 Util
937
938 Some utility functions for the Jeweler skill.
939
940 =over 4
941
942 =item remove ($object[, $nrof])
943
944 Removes the C<$object>. If C<$nrof> is given, remove only C<$nrof> objects.
945 The returnvalue is the number of 'single' objects that couldn't be removed.
946
947 =cut
948
949 sub remove {
950 my ($obj, $nrof) = @_;
951
952 my $cnt;
953
954 if (defined $nrof) {
955 return 0 if ($nrof * 1) == 0;
956 $cnt = int (($obj->nrof || 1) - (1 * $nrof));
957
958 if ($cnt > 0) {
959 $obj->nrof ($cnt);
960 return 0;
961 }
962 }
963
964 remove ($_) for $obj->inv;
965 $obj->destroy;
966 return $cnt;
967 }
968
969 sub grep_for_match {
970 my ($thing, @matchar) = @_;
971
972 my $i = 0;
973 for my $match (@matchar) {
974 if ($match =~ m/^\s*$/) {
975 $i++;
976 next;
977 }
978
979 if ($i % 3 == 0) {
980 $thing->name eq $match
981 and return 1;
982 } elsif ($i % 3 == 1) {
983 $thing->title eq $match
984 and return 1;
985 } else { # $i % 3 == 2
986 $thing->arch->name eq $match
987 and return 1;
988 }
989 $i++;
990 }
991 return 0;
992 }
993
994 =back
995
996 =back
997
998 1