1 | #! perl |
1 | #! perl |
2 | #CONVERSION: NONE |
2 | #CONVERSION: NONE |
3 | |
|
|
4 | use POSIX; |
|
|
5 | use Data::Dumper; |
3 | use Data::Dumper; |
|
|
4 | use Jeweler; |
6 | use List::Util qw/max min sum/; |
5 | use List::Util qw/max min sum/; |
7 | use Jeweler; |
|
|
8 | use strict; |
6 | use strict; |
9 | |
7 | |
10 | my $DEBUG = 1; |
8 | sub ingred_alias { |
11 | my $CFG; |
9 | my ($ing) = @_; |
12 | |
10 | |
13 | # this is a simple quad polynom, it takes it's factors from |
11 | my %aliases = ( |
14 | # the configuration |
12 | pow => 'power', |
15 | sub fx { |
13 | cha => 'charisma', |
16 | my ($x, $setting) = @_; |
14 | wis => 'wisdom', |
17 | my $facts = getcfg (functions => $setting); |
15 | int => 'intelligence', |
18 | return $facts->[0] * ($x ** 2) + $facts->[1] * $x + $facts->[2]; |
16 | dex => 'dexterity', |
19 | } |
17 | con => 'constitution', |
|
|
18 | str => 'strength', |
|
|
19 | ); |
20 | |
20 | |
21 | # makes a template arch (for example to get the value) |
21 | if ($ing =~ m/resist_(\S+)/) { |
22 | sub get_arch { |
22 | my $a = $aliases{lc $1} || $1; |
23 | my ($outarch) = @_; |
23 | "something for '". lc ($a). "' resistance"; |
24 | unless ($CFG->{arch}->{$outarch}) { |
|
|
25 | $CFG->{arch}->{$outarch} = cf::object::new $outarch; |
|
|
26 | |
24 | |
27 | unless ($CFG->{arch}->{$outarch}) { |
25 | } elsif ($ing =~ m/stat_(\S+)/) { |
28 | warn "ERROR: Couldn't make $outarch in conversion for $outarch!"; |
26 | my $a = $aliases{lc $1} || $1; |
29 | return; |
27 | "something for the ". lc ($a). " stat"; |
30 | } |
|
|
31 | } |
|
|
32 | $CFG->{arch}->{$outarch} |
|
|
33 | } |
|
|
34 | |
28 | |
35 | sub calc_costs { |
29 | } elsif ($ing =~ m/spec_(\S+)/) { |
36 | my ($ring) = @_; |
30 | my $a = $aliases{lc $1} || $1; |
|
|
31 | "something for the ". lc ($a). "' special"; |
37 | |
32 | |
38 | my $costs = {}; |
|
|
39 | |
|
|
40 | for my $resnam (keys %{$ring->{resist} || {}}) { |
|
|
41 | |
|
|
42 | my $res = $ring->{resist}->{$resnam}; |
|
|
43 | |
|
|
44 | next unless $res > 0; |
|
|
45 | |
|
|
46 | $costs->{"food_$resnam"} += $res; |
|
|
47 | $costs->{"resist_" . $Jeweler::RESMAP{$resnam} . "_potion"}++; |
|
|
48 | |
|
|
49 | my $diamonds; |
|
|
50 | if (grep { $resnam eq $_ } @Jeweler::EFFECT_RESISTS) { |
|
|
51 | $diamonds += fx ($res, 'effect_resist_diamonds'); |
|
|
52 | } else { |
33 | } else { |
53 | $diamonds += fx ($res, 'attack_resist_diamonds'); |
34 | $ing |
54 | } |
|
|
55 | $costs->{diamonds} += $diamonds; |
|
|
56 | } |
|
|
57 | |
|
|
58 | $costs = calc_stat_costs ($ring->{stat}, $costs); |
|
|
59 | $costs = calc_special_costs ($ring->{spec}, $costs); |
|
|
60 | |
|
|
61 | warn |
|
|
62 | sprintf "JEWEL ANALYSE: %40s: %s" , |
|
|
63 | $ring->{name}, |
|
|
64 | join (', ', map { "$_: " . sprintf "%.2f", $costs->{$_} } keys %$costs); |
|
|
65 | return $costs; |
|
|
66 | } |
|
|
67 | |
|
|
68 | sub read_config { |
|
|
69 | my ($filename) = @_; |
|
|
70 | |
|
|
71 | # open my $fh, $filename |
|
|
72 | # or die "Couldn't open '$filename': $!"; |
|
|
73 | |
|
|
74 | my $cfg = {}; #LoadFile $filename; |
|
|
75 | |
|
|
76 | # my $section = 'main'; |
|
|
77 | # |
|
|
78 | # my $cont = join '', <$fh>; |
|
|
79 | # |
|
|
80 | # for (<$fh>) { |
|
|
81 | # s/#.*$//; |
|
|
82 | # |
|
|
83 | # if (m/^\[([^\]]+)\]/) { |
|
|
84 | # $section = $1; |
|
|
85 | # |
|
|
86 | # } elsif (m/^\s*(\S+)\s*=\s*(.*?)\s*$/) { |
|
|
87 | # my ($k, $v) = ($1, $2); |
|
|
88 | # |
|
|
89 | # my @v = split /\s*,\s*/, $v; |
|
|
90 | # |
|
|
91 | # if (@v > 1) { |
|
|
92 | # $v = [ @v ]; |
|
|
93 | # } |
|
|
94 | # |
|
|
95 | # $cfg->{$section}->{$k} = $v; |
|
|
96 | # } |
|
|
97 | # } |
|
|
98 | |
|
|
99 | return $cfg; |
|
|
100 | } |
|
|
101 | |
|
|
102 | sub getcfg { |
|
|
103 | my ($sect, $key) = @_; |
|
|
104 | my $cfg = $CFG->{$sect}->{$key} |
|
|
105 | or die "Couldn't find $sect/$key in configuration!"; |
|
|
106 | |
|
|
107 | $cfg |
|
|
108 | } |
|
|
109 | |
|
|
110 | sub ring_or_ammy_to_hash { |
|
|
111 | my ($thing) = @_; |
|
|
112 | |
|
|
113 | my $obj = {}; |
|
|
114 | |
|
|
115 | for (@Jeweler::RESISTS) { |
|
|
116 | $obj->{resist}->{$_} = $thing->get_resistance ($_); |
|
|
117 | } |
|
|
118 | |
|
|
119 | my $stats = $thing->stats; |
|
|
120 | |
|
|
121 | for (qw/Str Dex Con Wis Cha Int Pow/) { |
|
|
122 | $obj->{stat}->{$_} = $stats->$_; |
|
|
123 | } |
|
|
124 | |
|
|
125 | $obj->{spec}->{regen} = $thing->hp; |
|
|
126 | $obj->{spec}->{magic} = $thing->sp; |
|
|
127 | $obj->{spec}->{wc} = $thing->wc; |
|
|
128 | $obj->{spec}->{dam} = $thing->dam; |
|
|
129 | $obj->{spec}->{ac} = $thing->ac; |
|
|
130 | $obj->{spec}->{speed} = $thing->stats->exp; |
|
|
131 | $obj->{spec}->{suste} = $thing->food; |
|
|
132 | |
|
|
133 | $obj->{name} = $thing->name; |
|
|
134 | |
|
|
135 | $obj |
|
|
136 | } |
|
|
137 | |
|
|
138 | sub split_diamonds { |
|
|
139 | my ($cost, $diamonds, $category) = @_; |
|
|
140 | |
|
|
141 | my $stat_split = getcfg (diamond_split => $category); |
|
|
142 | |
|
|
143 | my $emarch = get_arch ('emerald'); |
|
|
144 | my $saarch = get_arch ('sapphire'); |
|
|
145 | my $pearch = get_arch ('pearl'); |
|
|
146 | my $ruarch = get_arch ('ruby'); |
|
|
147 | my $diarch = get_arch ('gem'); |
|
|
148 | |
|
|
149 | my $sumvalue = $diarch->value * $diamonds; |
|
|
150 | |
|
|
151 | $cost->{emeralds} += ceil (($sumvalue * $stat_split->[0]) / $emarch->{value}); |
|
|
152 | $cost->{sapphires} += ceil (($sumvalue * $stat_split->[1]) / $saarch->{value}); |
|
|
153 | $cost->{pearls} += ceil (($sumvalue * $stat_split->[2]) / $pearch->{value}); |
|
|
154 | $cost->{rubies} += ceil (($sumvalue * $stat_split->[3]) / $ruarch->{value}); |
|
|
155 | $cost->{diamonds} += ceil (($sumvalue * $stat_split->[4]) / $diarch->{value}); |
|
|
156 | |
|
|
157 | return $cost; |
|
|
158 | } |
|
|
159 | |
|
|
160 | sub calc_stat_level { |
|
|
161 | my ($stats) = @_; |
|
|
162 | |
|
|
163 | my $maxlevel = getcfg (maxlevels => 'stat_level'); |
|
|
164 | my $maxstat = getcfg (maximprovements => 'stats'); |
|
|
165 | |
|
|
166 | my $stat_cnt = scalar (grep { $_ > 0 } values %$stats); |
|
|
167 | my $stat_sum = sum (values %$stats); |
|
|
168 | my $level = int (($maxlevel / $maxstat) * $stat_sum); |
|
|
169 | |
|
|
170 | ($level, $stat_cnt) |
|
|
171 | } |
|
|
172 | |
|
|
173 | sub calc_resist_level { |
|
|
174 | my ($resists) = @_; |
|
|
175 | |
|
|
176 | my $att_res_lvl = getcfg (maxlevels => 'resist_level'); |
|
|
177 | my $efc_res_lvl = getcfg (maxlevels => 'effect_resist_level'); |
|
|
178 | my $max_att_res = getcfg (maximprovements => 'attack_resistances'); |
|
|
179 | my $max_efc_res = getcfg (maximprovements => 'effect_resistances'); |
|
|
180 | my $max_ovr_res = getcfg (maximprovements => 'resistances'); |
|
|
181 | |
|
|
182 | my $ressum = 0; |
|
|
183 | my $rescnt = 0; |
|
|
184 | my @reslevels; |
|
|
185 | |
|
|
186 | for my $resnam (keys %$resists) { |
|
|
187 | my $res = $resists->{$resnam}; |
|
|
188 | |
|
|
189 | $rescnt++ |
|
|
190 | if $res > 0; # negative resistancies are not an improvement |
|
|
191 | |
|
|
192 | $ressum += $res; # note: negative resistancies lower the sum |
|
|
193 | |
|
|
194 | next unless $res > 0; |
|
|
195 | |
|
|
196 | my $level = 0; |
|
|
197 | if (grep { $resnam eq $_ } @Jeweler::EFFECT_RESISTS) { |
|
|
198 | $level = ceil (($efc_res_lvl / $max_efc_res) * $res); |
|
|
199 | } else { |
|
|
200 | $level = ceil (($att_res_lvl / $max_att_res) * $res); |
|
|
201 | } |
|
|
202 | push @reslevels, $level; |
|
|
203 | } |
|
|
204 | |
|
|
205 | my $overall_lvl = ($att_res_lvl / $max_ovr_res) * $ressum; |
|
|
206 | |
|
|
207 | (max (@reslevels, $overall_lvl), $rescnt); |
|
|
208 | } |
|
|
209 | |
|
|
210 | sub calc_special_level { |
|
|
211 | my ($specials) = @_; |
|
|
212 | |
|
|
213 | my $max_spc_lvl = getcfg (maxlevels => 'spec_level'); |
|
|
214 | my $max_specials = getcfg (maximprovements => 'specials'); |
|
|
215 | |
|
|
216 | my @speclvls; |
|
|
217 | my $specsum = 0; |
|
|
218 | my $imprs = 0; |
|
|
219 | |
|
|
220 | for my $spcnam (keys %$specials) { |
|
|
221 | my $spc = $specials->{$spcnam}; |
|
|
222 | next unless $spc > 0; |
|
|
223 | |
|
|
224 | $specsum += $spc; |
|
|
225 | $imprs++; |
|
|
226 | |
|
|
227 | my $max_spc = getcfg (maxspecial => $spcnam); |
|
|
228 | |
|
|
229 | my $lvl = ($max_spc_lvl / $max_spc) * $spc; |
|
|
230 | push @speclvls, $lvl; |
|
|
231 | } |
|
|
232 | |
|
|
233 | my $sumlvl = ($max_spc_lvl / $max_specials) * $specsum; |
|
|
234 | |
|
|
235 | (max (@speclvls, $sumlvl), $imprs) |
|
|
236 | } |
|
|
237 | |
|
|
238 | sub calc_stat_costs { |
|
|
239 | my ($stats, $cost) = @_; |
|
|
240 | |
|
|
241 | my $sum = sum grep { $_ > 0 } values %$stats; |
|
|
242 | |
|
|
243 | return $cost unless $sum > 0; |
|
|
244 | |
|
|
245 | $cost->{stat_potions} += fx ($sum, 'stat_potions'); |
|
|
246 | $cost->{diamonds} += fx ($sum, 'stat_diamonds'); |
|
|
247 | |
|
|
248 | $cost |
|
|
249 | } |
|
|
250 | |
|
|
251 | sub calc_special_costs { |
|
|
252 | my ($specials, $cost) = @_; |
|
|
253 | |
|
|
254 | my $sum = sum grep { $_ > 0 } values %$specials; |
|
|
255 | |
|
|
256 | return $cost unless $sum > 0; |
|
|
257 | |
|
|
258 | $cost->{spec_potions} += fx ($sum, 'spec_potions'); |
|
|
259 | $cost->{diamonds} += fx ($sum, 'spec_diamonds'); |
|
|
260 | |
|
|
261 | $cost |
|
|
262 | } |
|
|
263 | |
|
|
264 | # this function calculated the 'level' of an amulet or a ring |
|
|
265 | sub power_to_level { |
|
|
266 | my ($ring) = @_; |
|
|
267 | |
|
|
268 | my $max_imprs = getcfg (maximprovements => 'improvements'); |
|
|
269 | my $max_impr_lvl = getcfg (maxlevels => 'improve_level'); |
|
|
270 | |
|
|
271 | my ($stat_lvl, $stat_imprs) = calc_stat_level ($ring->{stat} || {}); |
|
|
272 | my ($resist_lvl, $res_imprs) = calc_resist_level ($ring->{resist} || {}); |
|
|
273 | my ($spec_lvl, $spec_imprs) = calc_special_level ($ring->{spec} || {}); |
|
|
274 | |
|
|
275 | my $impr_lvl = ceil (($max_impr_lvl / ($max_imprs + 1)) * ($stat_imprs + $res_imprs + $spec_imprs - 1)); |
|
|
276 | |
|
|
277 | my $levl = int max ($stat_lvl, $resist_lvl, $impr_lvl, $spec_lvl, 0); |
|
|
278 | |
|
|
279 | my $cost = calc_costs ($ring); |
|
|
280 | warn sprintf "%3d: %50s: %s\n", $levl, $ring->{name}, "stat: $stat_lvl, resist: $resist_lvl, improve: $impr_lvl, spec: $spec_lvl (num impr $stat_imprs + $res_imprs + $spec_imprs - 1)"; |
|
|
281 | # warn sprintf " %s\n", join (',', map { sprintf "$_: %5d", $cost->{$_} } keys %$cost); |
|
|
282 | |
|
|
283 | $levl |
|
|
284 | } |
|
|
285 | |
|
|
286 | # this function converts metals/minerals into a raw ring (of adornment) |
|
|
287 | sub simple_converter { |
|
|
288 | my ($pl, $ingred, $chdl, $conv) = @_; |
|
|
289 | |
|
|
290 | $conv = lc $conv; |
|
|
291 | my $cnvs = $CFG->{conversions}; |
|
|
292 | |
|
|
293 | return unless $cnvs->{$conv}; |
|
|
294 | |
|
|
295 | my %ingred_groups; |
|
|
296 | |
|
|
297 | my @conv_cfg = @{$cnvs->{$conv}}; |
|
|
298 | my $outarch = $conv; |
|
|
299 | my ($ingr_grp, $outarchvalfact, $srcarchname, $xp_gain) = @conv_cfg; |
|
|
300 | |
|
|
301 | unless (@conv_cfg <= 4) { |
|
|
302 | warn "ERROR: Conversion for '$outarch' has only " . (@conv_cfg) . " arguments!"; |
|
|
303 | return; |
|
|
304 | } |
|
|
305 | |
|
|
306 | unless ($xp_gain > 0) { |
|
|
307 | warn "WARNING: xp gain isn't > 0 in convesion '$outarch'\n"; |
|
|
308 | return; |
|
|
309 | } |
|
|
310 | |
|
|
311 | unless ($outarchvalfact) { |
|
|
312 | warn "ERROR: source-arch-value-multiplier == 0 in convesion '$outarch'\n"; |
|
|
313 | return; |
|
|
314 | } |
|
|
315 | |
|
|
316 | unless ($outarchvalfact >= 1) { |
|
|
317 | warn "WARNING: source-arch-value-multiplier < 1 in convesion '$outarch', results in more valuable output!\n"; |
|
|
318 | } |
|
|
319 | |
|
|
320 | my $archvalsum = $ingred->value ($cnvs->{$outarch}->[0], $cnvs->{$outarch}->[2]); |
|
|
321 | $ingred->remove ($cnvs->{$outarch}->[0], $cnvs->{$outarch}->[2]); |
|
|
322 | |
|
|
323 | my $outarchval = get_arch ($outarch)->value; |
|
|
324 | |
|
|
325 | my $nrof = int ($archvalsum / (($outarchval || 1000) * $outarchvalfact)); |
|
|
326 | if ($nrof) { |
|
|
327 | # XXX: yes, i know what i'm doing here, i don't set nrof, but it didn't work somehow (pls. chek sometimes) |
|
|
328 | $chdl->put (cf::object::new $outarch) for 1..$nrof; |
|
|
329 | |
|
|
330 | my $xp_sum = ($xp_gain * $nrof); |
|
|
331 | |
|
|
332 | if ($xp_sum) { |
|
|
333 | $pl->ob->message ("You got $xp_sum xp by making $nrof ${outarch}s"); |
|
|
334 | $pl->ob->change_exp ($xp_sum, "jeweler", cf::SK_EXP_ADD_SKILL); |
|
|
335 | } |
|
|
336 | } |
35 | } |
337 | } |
36 | } |
338 | |
37 | |
|
|
38 | my $DEBUG = 1; |
339 | |
39 | |
|
|
40 | cf::attach_to_type cf::SKILL, cf::SK_JEWELER, |
|
|
41 | on_use_skill => sub { |
|
|
42 | my ($sk, $ob, $part, $dir, $msg) = @_; |
|
|
43 | my $pl = $ob; |
|
|
44 | warn "USE SKILL JEWEL[$msg]!\n"; |
340 | |
45 | |
341 | sub put_ingred_to_bench { |
46 | my $skobj = $sk; |
342 | my ($ingred, $bench) = @_; |
|
|
343 | |
47 | |
344 | for my $ik (keys %$ingred) { |
48 | my $chdl = new Jeweler::CauldronHandler; |
345 | for (@{$ingred->{$ik} || []}) { |
|
|
346 | $_->insert_ob_in_ob ($bench); |
|
|
347 | } |
|
|
348 | } |
|
|
349 | } |
|
|
350 | |
49 | |
351 | my %lvl_diff_chances = ( |
50 | my $rv = 1; |
352 | +5 => 100, |
51 | eval { |
353 | +4 => 95, |
52 | Jeweler::read_config ($ENV{CROSSFIRE_LIBDIR} . '/jeweler.yaml'); |
354 | +3 => 85, |
53 | $DEBUG = 1; |
355 | +2 => 75, |
|
|
356 | +1 => 65, |
|
|
357 | 0 => 50, |
|
|
358 | -1 => 45, |
|
|
359 | -2 => 35, |
|
|
360 | -3 => 25, |
|
|
361 | -4 => 10, |
|
|
362 | -5 => 0 |
|
|
363 | ); |
|
|
364 | |
54 | |
365 | my %lvl_diff_msg = ( |
55 | my $player = $ob->contr; |
366 | -5 => '%s is way above your skill', |
|
|
367 | -4 => 'The chance to make %s is very low', |
|
|
368 | -3 => 'You hava a slight chance to make %s', |
|
|
369 | -2 => 'There is a low chance you finish %s', |
|
|
370 | -1 => 'You could make %s with a chance of nearly 50:50', |
|
|
371 | 0 => 'The chances to fininsh %s is 50:50', |
|
|
372 | 1 => 'To make %s your chance is slightly above 50:50', |
|
|
373 | 2 => 'You could make with a good chance %s if you concentrate a lot', |
|
|
374 | 3 => 'The chance you finish %s with some efford is high', |
|
|
375 | 4 => 'You are nearly confident to finish %s', |
|
|
376 | 5 => 'There is no chance you could fail to make %s', |
|
|
377 | ); |
|
|
378 | |
56 | |
379 | sub level_diff_to_str { |
57 | unless ($chdl->find_cauldron ('jeweler_bench', $ob->map->at ($ob->x, $ob->y))) { |
380 | my ($delta) = @_; |
58 | return; |
381 | $delta = -5 if $delta < -5; |
59 | } |
382 | $delta = 5 if $delta > 5; |
|
|
383 | return $lvl_diff_msg{$delta} |
|
|
384 | } |
|
|
385 | |
60 | |
386 | sub level_diff_to_chance_perc { |
61 | cf::override; |
387 | my ($delta) = @_; |
|
|
388 | $delta = -5 if $delta < -5; |
|
|
389 | $delta = 5 if $delta > 5; |
|
|
390 | return $lvl_diff_chances{$delta} |
|
|
391 | } |
|
|
392 | |
62 | |
393 | sub grep_for_match { |
63 | if ($msg =~ m/^\s*analy[sz]e\s*$/i) { |
394 | my ($thing, @matchar) = @_; |
64 | Jeweler::analyze ($sk, $chdl, $pl); |
395 | |
65 | |
396 | my $i = 0; |
66 | } elsif ($msg =~ m/^\s*make\s+(\S+)\s*$/i) { |
397 | for my $match (@matchar) { |
67 | my $ingred = $chdl->extract_jeweler_ingredients; |
398 | if ($match =~ m/^\s*$/) { |
|
|
399 | $i++; |
|
|
400 | next; |
|
|
401 | } |
|
|
402 | |
68 | |
403 | if ($i % 3 == 0) { |
69 | unless ($Jeweler::CFG->{conversions}->{lc $1}) { |
404 | # warn ":FE1:" . $thing->name . ": $match\n"; |
70 | $pl->message ("You don't know how to make '$1', is does such a thing even exist?"); |
405 | $thing->name eq $match |
|
|
406 | and return 1; |
71 | return |
407 | } elsif ($i % 3 == 1) { |
72 | } |
408 | # warn ":FE2:" . $thing->title . ": $match\n"; |
|
|
409 | $thing->title eq $match |
|
|
410 | and return 1; |
|
|
411 | } else { # $i % 3 == 2 |
|
|
412 | # warn ":FE3:" . $thing->archetype->name . ": $match\n"; |
|
|
413 | $thing->archetype->name eq $match |
|
|
414 | and return 1; |
|
|
415 | } |
|
|
416 | $i++; |
|
|
417 | } |
|
|
418 | return 0; |
|
|
419 | } |
|
|
420 | |
73 | |
421 | sub get_plan { |
74 | simple_converter ($player, $ingred, $chdl, $1); |
422 | my ($ingred) = @_; |
75 | } elsif ($msg =~ m/^\s*merge\s*$/i) { |
|
|
76 | my $ingred = $chdl->extract_jeweler_ingredients; |
|
|
77 | my @ring = $ingred->get_ring; |
|
|
78 | my @rings = map { Jeweler::Object->new (object => $_) } @ring; |
423 | |
79 | |
424 | for my $pot (@{$ingred->{potions}}) { |
80 | my $ring = shift @rings; |
425 | for my $plan (keys %{$CFG->{plans}}) { |
81 | $ring->improve_by_ring (@rings); |
426 | my $plg = $CFG->{plans}->{$plan}; |
82 | $ring->power_to_level; |
427 | my @plga = (); |
83 | |
428 | unless (ref $plg eq 'ARRAY') { |
|
|
429 | push @plga, $plg; |
|
|
430 | } else { |
84 | } else { |
431 | @plga = @$plg; |
85 | my $ingred = $chdl->extract_jeweler_ingredients; |
432 | } |
86 | my $plan = $ingred->get_plan; |
433 | next unless @plga > 0; |
|
|
434 | if (grep_for_match ($pot, @plga)) { |
|
|
435 | warn "MATCHED: $plan: @plga\n"; |
|
|
436 | return $plan; |
|
|
437 | } |
|
|
438 | } |
|
|
439 | } |
|
|
440 | } |
|
|
441 | |
87 | |
442 | sub get_ring { |
88 | if ($plan) { |
443 | my ($ingred) = @_; |
89 | my @ring = $ingred->get_ring; |
444 | return @{$ingred->{rings} || []}; |
|
|
445 | } |
|
|
446 | |
90 | |
447 | sub get_improv_amount { |
91 | if (@ring > 1) { |
448 | my ($plan, $ingred) = @_; |
92 | # actually the algorithm cant handle more than one improvement at a time |
|
|
93 | $pl->message ("You can't manage to improve more than one ring!"); |
449 | |
94 | |
450 | if ($plan =~ m/^stat_(\S+)$/) { |
95 | } elsif (@ring < 1) { |
451 | my $plingred = getcfg (plan_ingred => $plan) |
96 | # actually the algorithm cant |
452 | or die "ingredients for plan '$plan' not defined!"; |
97 | $pl->message ("You slap yourself, you forgot the ring!"); |
453 | |
98 | |
454 | my $cnt = 0; |
99 | } else { |
455 | for my $pot (@{$ingred->{potions}}) { |
100 | my $ringo = Jeweler::Object->new (object => $ring[0]); |
456 | if (grep_for_match ($pot, @$plingred)) { |
101 | my $iring = $ingred->improve_ring_by_plan ($plan, $ringo); |
457 | $cnt += $pot->nrof; |
102 | my $c1 = $ringo->calc_costs; |
458 | } |
103 | my $c2 = $iring->calc_costs; |
459 | } |
|
|
460 | warn "Found $cnt potions for plan $plan\n"; |
|
|
461 | |
104 | |
462 | my $amount = 0; |
105 | my %keys; |
463 | for my $x (1..10) { |
106 | my %cdiff; |
464 | my $y = fx ($x, 'stat_potions'); |
107 | for (keys %$c1, keys %$c2) { $keys{$_} = 1 } |
465 | warn "TEST: fx($x): $y <= $cnt \n"; |
108 | warn 'COSTS[' . (join ",", map { $cdiff{$_} = $c2->{$_} - $c1->{$_}; "$_: $cdiff{$_}" } keys %keys) . "]\n"; |
466 | warn "FE: " . ($y == $cnt) . "\n"; |
|
|
467 | if ($y <= $cnt) { |
|
|
468 | $amount = $x; |
|
|
469 | warn "Found stat increase at: $x\n"; |
|
|
470 | last; |
|
|
471 | } |
|
|
472 | } |
|
|
473 | |
109 | |
474 | return $amount; |
110 | unless (grep { $_ > 0 } values %cdiff) { |
475 | } elsif ($plan =~ m/^spec_(\S+)$/) { |
111 | $pl->message ("This plan doesn't improve the ring, you find yourself puzzled about what you missed..."); |
476 | return 0; |
112 | return; |
477 | } elsif ($plan =~ m/^resist_(\S+)$/) { |
113 | } |
478 | return 0; |
|
|
479 | } |
|
|
480 | } |
|
|
481 | |
114 | |
482 | sub get_plan_costs { |
115 | my $remcosts = $ingred->check_costs (\%cdiff); |
483 | my ($plan, $ring, $amount) = @_; |
116 | warn 'REMCOSTS[' . (join ",", map { "$_: $remcosts->{$_}" } keys %$remcosts) . "]\n"; |
484 | |
117 | |
485 | my $pre_costs = calc_costs ($ring); |
118 | if (grep { $_ > 0 } values %$remcosts) { |
486 | |
119 | $pl->message ("You recognize that you are short of: " |
487 | # alter ring spec |
120 | . (join ", ", |
488 | if ($plan =~ m/^stat_(\S+)$/) { |
121 | map { my $cost = $remcosts->{$_}; $cost . " " . ($cost > 1 ? "times" : "time") . " " . ingred_alias ($_) } |
489 | } elsif ($plan =~ m/^spec_(\S+)$/) { |
122 | grep { $remcosts->{$_} > 0 } keys %$remcosts)) |
490 | } elsif ($plan =~ m/^resist_(\S+)$/) { |
123 | } else { |
491 | my ($resid) = map { $Jeweler::RESMAP{$_} } grep { $Jeweler::RESMAP{$_} eq $1 } keys %Jeweler::RESMAP; |
124 | $ingred->check_costs (\%cdiff, 1); |
492 | unless (defined $resid) { |
125 | $ingred->remove ('rings'); |
493 | die "Couldn't find resistancy for plan: '$plan'\n"; |
126 | $ingred->remove ('ammys'); |
494 | } |
127 | $chdl->put ($iring->to_object); |
495 | |
128 | $pl->message ("You succeed!"); |
496 | $ring->{resist}->{$resid} += $amount; |
129 | } |
497 | } |
130 | } |
498 | |
|
|
499 | my $post_costs = calc_costs ($ring); |
|
|
500 | |
|
|
501 | my $delta_costs = {}; |
|
|
502 | for (keys %{$post_costs}) { |
|
|
503 | my $cost = $post_costs->{$_} - $pre_costs->{$_}; |
|
|
504 | if ($cost > 0) { |
|
|
505 | warn "DELTA COST: $_ => $cost\n"; |
|
|
506 | $delta_costs->{$_} = $cost; |
|
|
507 | } |
|
|
508 | } |
|
|
509 | return $delta_costs |
|
|
510 | } |
|
|
511 | |
|
|
512 | sub on_player_use_skill { |
|
|
513 | return 0; # disabled not yet ready#d##TODO# |
|
|
514 | my ($ob, $part, $sk, $dir, $msg) = @_; |
|
|
515 | my $pl = $ob; |
|
|
516 | |
|
|
517 | my $skobj = $sk; |
|
|
518 | |
|
|
519 | my $chdl = new Jeweler::CauldronHandler; |
|
|
520 | |
|
|
521 | return 0 unless $sk->subtype == cf::SK_JEWELER; |
|
|
522 | |
|
|
523 | my $rv = 1; |
|
|
524 | eval { |
|
|
525 | $CFG = read_config ($ENV{CROSSFIRE_LIBDIR} . '/jeweler.yaml'); #XXX: This has to become cached properly! |
|
|
526 | $DEBUG ||= $CFG->{main}->{debug}; |
|
|
527 | |
|
|
528 | my $player = $ob->contr;#cf::player::find $ob->name; |
|
|
529 | |
|
|
530 | unless ($chdl->find_cauldron ('jeweler_bench', $ob->map->at ($ob->x, $ob->y))) { |
|
|
531 | $rv = 0; |
|
|
532 | return # return 0 if no cauldron found (default action: identify) |
|
|
533 | } |
|
|
534 | |
|
|
535 | my $ingred = $chdl->extract_jeweler_ingredients; |
|
|
536 | |
|
|
537 | if ($msg =~ m/^\s*analy[sz]e\s*$/i) { |
|
|
538 | for ($chdl->grep_by_type (cf::RING, cf::AMULET)) { |
|
|
539 | my $sklvl = cf::exp_to_level ($sk->stats->exp); |
|
|
540 | my $ringlvl = power_to_level (ring_or_ammy_to_hash ($_)); |
|
|
541 | |
|
|
542 | if ($pl->get_flag (cf::FLAG_WIZ)) { |
|
|
543 | $pl->message ("The " . $_->name . " is at level $ringlvl chance for you: " . level_diff_to_chance_perc ($sklvl - $ringlvl)); |
|
|
544 | } else { |
131 | } else { |
545 | my $tmpl = level_diff_to_str ($sklvl - $ringlvl); |
132 | $pl->message ("You've got no idea what you are planning to do!"); |
546 | my $msg = sprintf $tmpl, $_->name; |
|
|
547 | $pl->message ($msg); |
|
|
548 | } |
133 | } |
549 | } |
134 | } |
|
|
135 | }; |
|
|
136 | $@ and warn "ERROR: $@\n"; |
550 | |
137 | |
551 | } elsif ($msg =~ m/^\s*make\s+(\S+)\s*$/i) { |
|
|
552 | unless ($CFG->{conversions}->{lc $1}) { |
|
|
553 | $pl->message ("You don't know how to make '$1', is does such a thing even exist?"); |
|
|
554 | return |
|
|
555 | } |
|
|
556 | |
|
|
557 | simple_converter ($player, $ingred, $chdl, $1); |
|
|
558 | |
|
|
559 | # for (@{$ingred->{rings}}) { |
|
|
560 | # ring_or_ammy_to_hash ($_); |
|
|
561 | # } |
|
|
562 | #put_ingred_to_bench ($ingred, $c[0]); |
|
|
563 | |
|
|
564 | } else { |
|
|
565 | my $plan = get_plan ($ingred); |
|
|
566 | |
|
|
567 | if ($plan) { |
|
|
568 | my @ring = get_ring ($ingred); |
|
|
569 | |
|
|
570 | if (@ring > 1) { |
|
|
571 | # actually the algorithm cant handle more than one improvement at a time |
|
|
572 | $pl->message ("You can't manage to improve more than one ring!"); |
|
|
573 | |
|
|
574 | } elsif (@ring < 1) { |
|
|
575 | # actually the algorithm cant |
|
|
576 | $pl->message ("You slap yourself, you forgot the ring!"); |
|
|
577 | |
|
|
578 | } else { |
|
|
579 | my $ringh = ring_or_ammy_to_hash ($ring[0]); |
|
|
580 | my $amount = get_improv_amount ($plan, $ingred); |
|
|
581 | # my $costs = get_plan_costs ($plan[0], $ringh, $amount); |
|
|
582 | # |
|
|
583 | # if (my $chk = check_plan_costs ($costs, $ingred)) { |
|
|
584 | # # output some error that he lacks the ingredients |
|
|
585 | # } else { |
|
|
586 | # execute_plan ($costs, $ringh, $ingred); |
|
|
587 | # } |
|
|
588 | } |
|
|
589 | |
|
|
590 | } else { |
|
|
591 | $pl->message ("You've got no idea what you are planning to do!"); |
|
|
592 | } |
|
|
593 | } |
|
|
594 | }; |
|
|
595 | $@ and warn "ERROR: $@\n"; |
|
|
596 | |
|
|
597 | my $r = cf::random_roll (0, 101, $pl, cf::PREFER_LOW); |
138 | my $r = cf::random_roll (0, 101, $pl, cf::PREFER_LOW); |
598 | $rv; |
139 | } |
599 | } |
|
|