maps/perl/jeweler.ext

#! perl
#CONVERSION: NONE

use POSIX;
use Data::Dumper;
use List::Util qw/max min sum/;
use Jeweler;
use strict;

my $DEBUG = 1;
my $CFG;

# this is a simple quad polynom, it takes it's factors from
# the configuration
sub fx {
   my ($x, $setting) = @_;
   my $facts = getcfg (functions => $setting);
   return $facts->[0] * ($x ** 2) + $facts->[1] * $x + $facts->[2];
}

# makes a template arch (for example to get the value)
sub get_arch {
   my ($outarch) = @_;
   unless ($CFG->{arch}->{$outarch}) {
      $CFG->{arch}->{$outarch} = cf::object::new $outarch;

      unless ($CFG->{arch}->{$outarch}) {
         warn "ERROR: Couldn't make $outarch in conversion for $outarch!";
         return;
      }
   }
   $CFG->{arch}->{$outarch}
}

sub calc_costs {
   my ($ring) = @_;

   my $costs = {};

   for my $resnam (keys %{$ring->{resist} || {}}) {

      my $res = $ring->{resist}->{$resnam};

      next unless $res > 0;

      $costs->{"food_$resnam"} += $res;
      $costs->{"resist_" . $Jeweler::RESMAP{$resnam} . "_potion"}++;

      my $diamonds;
      if (grep { $resnam eq $_ } @Jeweler::EFFECT_RESISTS) {
         $diamonds += fx ($res, 'effect_resist_diamonds');
      } else {
         $diamonds += fx ($res, 'attack_resist_diamonds');
      }
      $costs->{diamonds} += $diamonds;
   }

   $costs = calc_stat_costs ($ring->{stat}, $costs);
   $costs = calc_special_costs ($ring->{spec}, $costs);

   warn
     sprintf "JEWEL ANALYSE: %40s: %s" ,
        $ring->{name},
        join (', ', map { "$_: " . sprintf "%.2f", $costs->{$_} } keys %$costs);
   return $costs;
}

sub read_config {
   my ($filename) = @_;

#   open my $fh, $filename
#     or die "Couldn't open '$filename': $!";

   my $cfg = {}; #LoadFile $filename;

#   my $section = 'main';
#
#  my $cont = join '', <$fh>;
#
#  for (<$fh>) {
#     s/#.*$//;
#
#     if (m/^\[([^\]]+)\]/) {
#        $section = $1;
#
#     } elsif (m/^\s*(\S+)\s*=\s*(.*?)\s*$/) {
#        my ($k, $v) = ($1, $2);
#
#        my @v = split /\s*,\s*/, $v;
#
#        if (@v > 1) {
#           $v = [ @v ];
#        }
#
#        $cfg->{$section}->{$k} = $v;
#     }
#  }

   return $cfg;
}

sub getcfg {
   my ($sect, $key) = @_;
   my $cfg = $CFG->{$sect}->{$key}
      or die "Couldn't find $sect/$key in configuration!";

   $cfg
}

sub ring_or_ammy_to_hash {
   my ($thing) = @_;

   my $obj = {};

   for (@Jeweler::RESISTS) {
      $obj->{resist}->{$_} = $thing->get_resistance ($_);
   }

   my $stats = $thing->stats;

   for (qw/Str Dex Con Wis Cha Int Pow/) {
      $obj->{stat}->{$_} = $stats->$_;
   }

   $obj->{spec}->{regen} = $thing->hp;
   $obj->{spec}->{magic} = $thing->sp;
   $obj->{spec}->{wc}    = $thing->wc;
   $obj->{spec}->{dam}   = $thing->dam;
   $obj->{spec}->{ac}    = $thing->ac;
   $obj->{spec}->{speed} = $thing->stats->exp;
   $obj->{spec}->{suste} = $thing->food;

   $obj->{name} = $thing->name;

   $obj
}

sub split_diamonds {
   my ($cost, $diamonds, $category) = @_;

   my $stat_split = getcfg (diamond_split => $category);

   my $emarch = get_arch ('emerald');
   my $saarch = get_arch ('sapphire');
   my $pearch = get_arch ('pearl');
   my $ruarch = get_arch ('ruby');
   my $diarch = get_arch ('gem');

   my $sumvalue = $diarch->value * $diamonds;

   $cost->{emeralds}  += ceil (($sumvalue * $stat_split->[0]) / $emarch->{value});
   $cost->{sapphires} += ceil (($sumvalue * $stat_split->[1]) / $saarch->{value});
   $cost->{pearls}    += ceil (($sumvalue * $stat_split->[2]) / $pearch->{value});
   $cost->{rubies}    += ceil (($sumvalue * $stat_split->[3]) / $ruarch->{value});
   $cost->{diamonds}  += ceil (($sumvalue * $stat_split->[4]) / $diarch->{value});

   return $cost;
}

sub calc_stat_level {
   my ($stats) = @_;

   my $maxlevel = getcfg (maxlevels => 'stat_level');
   my $maxstat  = getcfg (maximprovements => 'stats');

   my $stat_cnt = scalar (grep { $_ > 0 } values %$stats);
   my $stat_sum = sum (values %$stats);
   my $level    = int (($maxlevel / $maxstat) * $stat_sum);

   ($level, $stat_cnt)
}

sub calc_resist_level {
   my ($resists) = @_;

   my $att_res_lvl = getcfg (maxlevels => 'resist_level');
   my $efc_res_lvl = getcfg (maxlevels => 'effect_resist_level');
   my $max_att_res = getcfg (maximprovements => 'attack_resistances');
   my $max_efc_res = getcfg (maximprovements => 'effect_resistances');
   my $max_ovr_res = getcfg (maximprovements => 'resistances');

   my $ressum = 0;
   my $rescnt = 0;
   my @reslevels;

   for my $resnam (keys %$resists) {
      my $res = $resists->{$resnam};

      $rescnt++
         if $res > 0;     # negative resistancies are not an improvement

      $ressum += $res;    # note: negative resistancies lower the sum

      next unless $res > 0;

      my $level = 0;
      if (grep { $resnam eq $_ } @Jeweler::EFFECT_RESISTS) {
         $level = ceil (($efc_res_lvl / $max_efc_res) * $res);
      } else {
         $level = ceil (($att_res_lvl / $max_att_res) * $res);
      }
      push @reslevels, $level;
   }

   my $overall_lvl = ($att_res_lvl / $max_ovr_res) * $ressum;

   (max (@reslevels, $overall_lvl), $rescnt);
}

sub calc_special_level {
   my ($specials) = @_;

   my $max_spc_lvl  = getcfg (maxlevels => 'spec_level');
   my $max_specials = getcfg (maximprovements => 'specials');

   my @speclvls;
   my $specsum = 0;
   my $imprs = 0;

   for my $spcnam (keys %$specials) {
      my $spc = $specials->{$spcnam};
      next unless $spc > 0;

      $specsum += $spc;
      $imprs++;

      my $max_spc = getcfg (maxspecial => $spcnam);

      my $lvl = ($max_spc_lvl / $max_spc) * $spc;
      push @speclvls, $lvl;
   }

   my $sumlvl = ($max_spc_lvl / $max_specials) * $specsum;

   (max (@speclvls, $sumlvl), $imprs)
}

sub calc_stat_costs {
   my ($stats, $cost) = @_;

   my $sum = sum grep { $_ > 0 } values %$stats;

   return $cost unless $sum > 0;

   $cost->{stat_potions} += fx ($sum, 'stat_potions');
   $cost->{diamonds}     += fx ($sum, 'stat_diamonds');

   $cost
}

sub calc_special_costs {
   my ($specials, $cost) = @_;

   my $sum = sum grep { $_ > 0 } values %$specials;

   return $cost unless $sum > 0;

   $cost->{spec_potions} += fx ($sum, 'spec_potions');
   $cost->{diamonds}     += fx ($sum, 'spec_diamonds');

   $cost
}

# this function calculated the 'level' of an amulet or a ring
sub power_to_level {
   my ($ring) = @_;

   my $max_imprs    = getcfg (maximprovements => 'improvements');
   my $max_impr_lvl = getcfg (maxlevels       => 'improve_level');

   my ($stat_lvl,   $stat_imprs) = calc_stat_level ($ring->{stat} || {});
   my ($resist_lvl, $res_imprs)  = calc_resist_level ($ring->{resist} || {});
   my ($spec_lvl,   $spec_imprs) = calc_special_level ($ring->{spec} || {});

   my $impr_lvl = ceil (($max_impr_lvl / ($max_imprs + 1)) * ($stat_imprs + $res_imprs + $spec_imprs - 1));

   my $levl = int max ($stat_lvl, $resist_lvl, $impr_lvl, $spec_lvl, 0);

   my $cost = calc_costs ($ring);
   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)";
#  warn sprintf "   %s\n", join (',', map { sprintf "$_: %5d", $cost->{$_} } keys %$cost);

   $levl
}

# this function converts metals/minerals into a raw ring (of adornment)
sub simple_converter {
   my ($pl, $ingred, $chdl, $conv) = @_;

   $conv = lc $conv;
   my $cnvs = $CFG->{conversions};

   return unless $cnvs->{$conv};

   my %ingred_groups;

   my @conv_cfg = @{$cnvs->{$conv}};
   my $outarch = $conv;
   my ($ingr_grp, $outarchvalfact, $srcarchname, $xp_gain) = @conv_cfg;

   unless (@conv_cfg <= 4) {
      warn "ERROR: Conversion for '$outarch' has only " . (@conv_cfg) . " arguments!";
      return;
   }

   unless ($xp_gain > 0) {
      warn "WARNING: xp gain isn't > 0 in convesion '$outarch'\n";
      return;
   }

   unless ($outarchvalfact) {
      warn "ERROR: source-arch-value-multiplier == 0 in convesion '$outarch'\n";
      return;
   }

   unless ($outarchvalfact >= 1) {
      warn "WARNING: source-arch-value-multiplier < 1 in convesion '$outarch', results in more valuable output!\n";
   }

   my $archvalsum = $ingred->value ($cnvs->{$outarch}->[0], $cnvs->{$outarch}->[2]);
   $ingred->remove ($cnvs->{$outarch}->[0], $cnvs->{$outarch}->[2]);

   my $outarchval = get_arch ($outarch)->value;

   my $nrof = int ($archvalsum / (($outarchval || 1000) * $outarchvalfact));
   if ($nrof) {
      # XXX: yes, i know what i'm doing here, i don't set nrof, but it didn't work somehow (pls. chek sometimes)
      $chdl->put (cf::object::new $outarch) for 1..$nrof;

      my $xp_sum = ($xp_gain * $nrof);

      if ($xp_sum) {
         $pl->ob->message ("You got $xp_sum xp by making $nrof ${outarch}s");
         $pl->ob->change_exp ($xp_sum, "jeweler", cf::SK_EXP_ADD_SKILL);
      }
   }
}


sub put_ingred_to_bench {
   my ($ingred, $bench) = @_;

   for my $ik (keys %$ingred) {
      for (@{$ingred->{$ik} || []}) {
         $_->insert_ob_in_ob ($bench);
      }
   }
}

my %lvl_diff_chances = (
   +5 => 100,
   +4 => 95,
   +3 => 85,
   +2 => 75,
   +1 => 65,
   0  => 50,
   -1 => 45,
   -2 => 35,
   -3 => 25,
   -4 => 10,
   -5 => 0
);

my %lvl_diff_msg = (
   -5 => '%s is way above your skill',
   -4 => 'The chance to make %s is very low',
   -3 => 'You hava a slight chance to make %s',
   -2 => 'There is a low chance you finish %s',
   -1 => 'You could make %s with a chance of nearly 50:50',
   0  => 'The chances to fininsh %s is 50:50',
   1  => 'To make %s your chance is slightly above 50:50',
   2  => 'You could make with a good chance %s if you concentrate a lot',
   3  => 'The chance you finish %s with some efford is high',
   4  => 'You are nearly confident to finish %s',
   5  => 'There is no chance you could fail to make %s',
);

sub level_diff_to_str {
   my ($delta) = @_;
   $delta = -5 if $delta < -5;
   $delta =  5 if $delta >  5;
   return $lvl_diff_msg{$delta}
}

sub level_diff_to_chance_perc {
   my ($delta) = @_;
   $delta = -5 if $delta < -5;
   $delta =  5 if $delta >  5;
   return $lvl_diff_chances{$delta}
}

sub grep_for_match {
   my ($thing, @matchar) = @_;

   my $i = 0;
   for my $match (@matchar) {
      if ($match =~ m/^\s*$/) {
         $i++;
         next;
      }

      if ($i % 3 == 0) {
#    warn ":FE1:" .  $thing->name . ": $match\n";
         $thing->name eq $match
            and return 1;
      } elsif ($i % 3 == 1) {
#        warn ":FE2:" .  $thing->title . ": $match\n";
         $thing->title eq $match
            and return 1;
      } else { # $i % 3 == 2
#        warn ":FE3:" .  $thing->archetype->name . ": $match\n";
         $thing->archetype->name eq $match
            and return 1;
      }
      $i++;
   }
   return 0;
}

sub get_plan {
   my ($ingred) = @_;

   for my $pot (@{$ingred->{potions}}) {
      for my $plan (keys %{$CFG->{plans}}) {
         my $plg = $CFG->{plans}->{$plan};
         my @plga = ();
         unless (ref $plg eq 'ARRAY') {
            push @plga, $plg;
         } else {
            @plga = @$plg;
         }
         next unless @plga > 0;
         if (grep_for_match ($pot, @plga)) {
            warn "MATCHED: $plan: @plga\n";
            return $plan;
         }
      }
   }
}

sub get_ring {
   my ($ingred) = @_;
   return @{$ingred->{rings} || []};
}

sub get_improv_amount {
   my ($plan, $ingred) = @_;

   if ($plan =~ m/^stat_(\S+)$/) {
      my $plingred = getcfg (plan_ingred => $plan)
         or die "ingredients for plan '$plan' not defined!";

      my $cnt = 0;
      for my $pot (@{$ingred->{potions}}) {
         if (grep_for_match ($pot, @$plingred)) {
            $cnt += $pot->nrof;
         }
      }
      warn "Found $cnt potions for plan $plan\n";

      my $amount = 0;
      for my $x (1..10) {
         my $y = fx ($x, 'stat_potions');
         warn "TEST: fx($x): $y <= $cnt \n";
         warn "FE: " . ($y == $cnt) . "\n";
         if ($y <= $cnt) {
            $amount = $x;
            warn "Found stat increase at: $x\n";
            last;
         }
      }

      return $amount;
   } elsif ($plan =~ m/^spec_(\S+)$/) {
      return 0;
   } elsif ($plan =~ m/^resist_(\S+)$/) {
      return 0;
   }
}

sub get_plan_costs {
   my ($plan, $ring, $amount) = @_;

   my $pre_costs = calc_costs ($ring);

   # alter ring spec
   if ($plan =~ m/^stat_(\S+)$/) {
   } elsif ($plan =~ m/^spec_(\S+)$/) {
   } elsif ($plan =~ m/^resist_(\S+)$/) {
      my ($resid) = map { $Jeweler::RESMAP{$_} } grep { $Jeweler::RESMAP{$_} eq $1 } keys %Jeweler::RESMAP;
      unless (defined $resid) {
         die "Couldn't find resistancy for plan: '$plan'\n";
      }

      $ring->{resist}->{$resid} += $amount;
   }

   my $post_costs = calc_costs ($ring);

   my $delta_costs = {};
   for (keys %{$post_costs}) {
      my $cost = $post_costs->{$_} - $pre_costs->{$_};
      if ($cost > 0) {
         warn "DELTA COST: $_ => $cost\n";
         $delta_costs->{$_} = $cost;
      }
   }
   return $delta_costs
}

sub on_player_use_skill {
   return 0; # disabled not yet ready#d##TODO#
   my ($ob, $part, $sk, $dir, $msg) = @_;
   my $pl = $ob;

   my $skobj = $sk;

   my $chdl = new Jeweler::CauldronHandler;

   return 0 unless $sk->subtype == cf::SK_JEWELER;

   my $rv = 1;
   eval {
      $CFG = read_config ($ENV{CROSSFIRE_LIBDIR} . '/jeweler.yaml'); #XXX: This has to become cached properly!
      $DEBUG ||= $CFG->{main}->{debug};

      my $player = $ob->contr;#cf::player::find $ob->name;

      unless ($chdl->find_cauldron ('jeweler_bench', $ob->map->at ($ob->x, $ob->y))) {
         $rv = 0;
         return # return 0 if no cauldron found (default action: identify)
      }

      my $ingred = $chdl->extract_jeweler_ingredients;

      if ($msg =~ m/^\s*analy[sz]e\s*$/i) {
         for ($chdl->grep_by_type (cf::RING, cf::AMULET)) {
            my $sklvl = cf::exp_to_level ($sk->stats->exp);
            my $ringlvl = power_to_level (ring_or_ammy_to_hash ($_));

            if ($pl->get_flag (cf::FLAG_WIZ)) {
               $pl->message ("The " . $_->name . " is at level $ringlvl chance for you: " . level_diff_to_chance_perc ($sklvl - $ringlvl));
            } else {
               my $tmpl = level_diff_to_str ($sklvl - $ringlvl);
               my $msg = sprintf $tmpl, $_->name;
               $pl->message ($msg);
            }
         }

      } elsif ($msg =~ m/^\s*make\s+(\S+)\s*$/i) {
         unless ($CFG->{conversions}->{lc $1}) {
            $pl->message ("You don't know how to make '$1', is does such a thing even exist?");
            return
         }

         simple_converter ($player, $ingred, $chdl, $1);

#         for (@{$ingred->{rings}}) {
#           ring_or_ammy_to_hash ($_);
#        }
         #put_ingred_to_bench ($ingred, $c[0]);

      } else {
         my $plan = get_plan ($ingred);

         if ($plan) {
            my @ring = get_ring ($ingred);

            if (@ring > 1) {
               # actually the algorithm cant handle more than one improvement at a time
               $pl->message ("You can't manage to improve more than one ring!");

            } elsif (@ring < 1) {
               # actually the algorithm cant
               $pl->message ("You slap yourself, you forgot the ring!");

            } else {
               my $ringh = ring_or_ammy_to_hash ($ring[0]);
               my $amount = get_improv_amount ($plan, $ingred);
#               my $costs = get_plan_costs ($plan[0], $ringh, $amount);
#
#               if (my $chk = check_plan_costs ($costs, $ingred)) {
#                  # output some error that he lacks the ingredients
#               } else {
#                  execute_plan ($costs, $ringh, $ingred);
#               }
            }

         } else {
            $pl->message ("You've got no idea what you are planning to do!");
         }
      }
   };
   $@ and warn "ERROR: $@\n";

   my $r = cf::random_roll (0, 101, $pl, cf::PREFER_LOW);
   $rv;
}
Revision:	1.4
Committed:	Fri Aug 25 15:07:43 2006 UTC (17 years, 8 months ago) by root
Branch:	MAIN
Changes since 1.3:	+2 -0 lines
Log Message:	Convert remainin scripts to new event system, noted conversion status of all plugins in second line, to aid in further event conversions.
#	User	Rev	Content
1	elmex	1.1	#! perl
2	root	1.4	#CONVERSION: NONE
3
4	elmex	1.1	use POSIX;
5			use Data::Dumper;
6			use List::Util qw/max min sum/;
7	elmex	1.3	use Jeweler;
8	elmex	1.1	use strict;
9
10			my $DEBUG = 1;
11			my $CFG;
12
13			# this is a simple quad polynom, it takes it's factors from
14			# the configuration
15			sub fx {
16			my ($x, $setting) = @_;
17			my $facts = getcfg (functions => $setting);
18			return $facts->[0] * ($x ** 2) + $facts->[1] * $x + $facts->[2];
19			}
20
21			# makes a template arch (for example to get the value)
22			sub get_arch {
23			my ($outarch) = @_;
24			unless ($CFG->{arch}->{$outarch}) {
25			$CFG->{arch}->{$outarch} = cf::object::new $outarch;
26
27			unless ($CFG->{arch}->{$outarch}) {
28			warn "ERROR: Couldn't make $outarch in conversion for $outarch!";
29			return;
30			}
31			}
32			$CFG->{arch}->{$outarch}
33			}
34
35			sub calc_costs {
36			my ($ring) = @_;
37
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 {
53			$diamonds += fx ($res, 'attack_resist_diamonds');
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	elmex	1.3	my $cfg = {}; #LoadFile $filename;
75	elmex	1.1
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			}
337			}
338
339
340
341			sub put_ingred_to_bench {
342			my ($ingred, $bench) = @_;
343
344			for my $ik (keys %$ingred) {
345			for (@{$ingred->{$ik} \|\| []}) {
346			$_->insert_ob_in_ob ($bench);
347			}
348			}
349			}
350
351			my %lvl_diff_chances = (
352			+5 => 100,
353			+4 => 95,
354			+3 => 85,
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
365			my %lvl_diff_msg = (
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
379			sub level_diff_to_str {
380			my ($delta) = @_;
381			$delta = -5 if $delta < -5;
382			$delta = 5 if $delta > 5;
383			return $lvl_diff_msg{$delta}
384			}
385
386			sub level_diff_to_chance_perc {
387			my ($delta) = @_;
388			$delta = -5 if $delta < -5;
389			$delta = 5 if $delta > 5;
390			return $lvl_diff_chances{$delta}
391			}
392
393			sub grep_for_match {
394			my ($thing, @matchar) = @_;
395
396			my $i = 0;
397			for my $match (@matchar) {
398			if ($match =~ m/^\s*$/) {
399			$i++;
400			next;
401			}
402
403			if ($i % 3 == 0) {
404			# warn ":FE1:" . $thing->name . ": $match\n";
405			$thing->name eq $match
406			and return 1;
407			} elsif ($i % 3 == 1) {
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
421			sub get_plan {
422			my ($ingred) = @_;
423
424			for my $pot (@{$ingred->{potions}}) {
425			for my $plan (keys %{$CFG->{plans}}) {
426			my $plg = $CFG->{plans}->{$plan};
427			my @plga = ();
428			unless (ref $plg eq 'ARRAY') {
429			push @plga, $plg;
430			} else {
431			@plga = @$plg;
432			}
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
442			sub get_ring {
443			my ($ingred) = @_;
444			return @{$ingred->{rings} \|\| []};
445			}
446
447			sub get_improv_amount {
448			my ($plan, $ingred) = @_;
449
450			if ($plan =~ m/^stat_(\S+)$/) {
451			my $plingred = getcfg (plan_ingred => $plan)
452			or die "ingredients for plan '$plan' not defined!";
453
454			my $cnt = 0;
455			for my $pot (@{$ingred->{potions}}) {
456			if (grep_for_match ($pot, @$plingred)) {
457			$cnt += $pot->nrof;
458			}
459			}
460			warn "Found $cnt potions for plan $plan\n";
461
462			my $amount = 0;
463			for my $x (1..10) {
464			my $y = fx ($x, 'stat_potions');
465			warn "TEST: fx($x): $y <= $cnt \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
474			return $amount;
475			} elsif ($plan =~ m/^spec_(\S+)$/) {
476			return 0;
477			} elsif ($plan =~ m/^resist_(\S+)$/) {
478			return 0;
479			}
480			}
481
482			sub get_plan_costs {
483			my ($plan, $ring, $amount) = @_;
484
485			my $pre_costs = calc_costs ($ring);
486
487			# alter ring spec
488			if ($plan =~ m/^stat_(\S+)$/) {
489			} elsif ($plan =~ m/^spec_(\S+)$/) {
490			} elsif ($plan =~ m/^resist_(\S+)$/) {
491			my ($resid) = map { $Jeweler::RESMAP{$_} } grep { $Jeweler::RESMAP{$_} eq $1 } keys %Jeweler::RESMAP;
492			unless (defined $resid) {
493			die "Couldn't find resistancy for plan: '$plan'\n";
494			}
495
496			$ring->{resist}->{$resid} += $amount;
497			}
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	root	1.2	return 0; # disabled not yet ready#d##TODO#
514	elmex	1.1	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/^\sanaly[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 {
545			my $tmpl = level_diff_to_str ($sklvl - $ringlvl);
546			my $msg = sprintf $tmpl, $_->name;
547			$pl->message ($msg);
548			}
549			}
550
551			} elsif ($msg =~ m/^\smake\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);
598			$rv;
599			}