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