server/ext/jeweler.ext

#! perl

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

sub ingred_alias {
   my ($ing) = @_;

   my %aliases = (
      pow => 'power',
      cha => 'charisma',
      wis => 'wisdom',
      int => 'intelligence',
      dex => 'dexterity',
      con => 'constitution',
      str => 'strength',
      gem => 'diamond',
   );

   if ($ing =~ m/resist_(\S+)/) {
      my $a = $aliases{lc $1} || $1;
      "something for '". lc ($a). "' resistance";

   } elsif ($ing =~ m/stat_(\S+)/) {
      my $a = $aliases{lc $1} || $1;
      "something for the ". lc ($a). " stat";

   } elsif ($ing =~ m/spec_(\S+)/) {
      my $a = $aliases{lc $1} || $1;
      "something for the ". lc ($a). "' special";

   } elsif ($aliases{$ing}) {
      $aliases{$ing}

   } else {
      $ing
   }
}

my $DEBUG = 1;

sub merge {
   my ($chdl, $sk, $pl, $do_analyze) = @_;

   my $ingred = get_ingred ($pl, $chdl) || return;

   my @ring = $ingred->get_ring;
   my @rings = map { Jeweler::Object->new (object => $_) } @ring;

   @rings >= 2
      or return $pl->reply (undef, "You slap yourself, you forgot to put at least 2 jewels in!");

   my $input_level;
   my $value;
   for (@rings) {
      $input_level = max ($_->power_to_level, $input_level);
      $value += $_->{hash}->{value};
   }

   my $ring = shift @rings;
   $ring->improve_by_ring (@rings);

   if ($do_analyze) {
      $pl->reply (undef, "You want to make a " . $ring->to_string . ": " . $ring->analyze ($sk, $pl));
      $ring->wiz_analyze ($pl)
         if $pl->flag (cf::FLAG_WIZ);
      return;
   }

   make_ring ($chdl, $ingred, $ring, $value, $sk, $pl, $input_level);
}

sub make_ring {
   my ($chdl, $ingred, $ring, $value, $sk, $pl, $input_level) = @_;

   if (!$pl->flag (cf::FLAG_WIZ)) {
      $ingred->remove ('rings');
      $ingred->remove ('ammys');
   }

   my $ch = $ring->get_chance_perc ($sk);
   my $succ = 0;
   my $r = cf::random_roll (0, 100, $pl, cf::PREFER_HIGH);

   my $make_status;
   my $exp;

   if ($r <= $ch or $pl->flag (cf::FLAG_WIZ)) {
      my $lvl = max ($ring->power_to_level, 1);
      $exp = (cf::level_to_min_exp ($lvl) - cf::level_to_min_exp ($lvl - 1)) / 100;

      if (defined $input_level) {
         my $subexp =
            (cf::level_to_min_exp ($input_level)
               - cf::level_to_min_exp ($input_level - 1))
                  / 100;
         $exp -= $subexp;
         $exp = max ($exp, 0);
      }

      $pl->change_exp ($exp, "jeweler", cf::SK_EXP_SKILL_ONLY);
      $pl->message ("You succeed and get $exp experience points.");
      $make_status = "succeeded";

      $ring->set_value ($value * 0.8); # 20% of the input values will vanish

   } else {
      $pl->message ("You fail!");
      $ring->negate;
      $make_status = "fail";
      $exp = 0;
   }

   my $ring_ob = $ring->to_object;

   { # some audit info calculation
      my $sklvl = cf::exp_to_level ($sk->stats->exp);

      my $make_info = sprintf
         "JEWELER AUDIT: '%s' made '%s' (%s) (sk lvl %d, ring lvl %d, got %d exp): %s",
            $pl->name, $ring->to_string, $ring_ob->uuid, $sklvl,
            $ring->power_to_level, $exp, $make_status;

      warn "$make_info\n" if $make_status eq 'succeeded';

      $ring_ob->set_ob_key_value (ext_jeweler_made_by   => $pl->name);
      $ring_ob->set_ob_key_value (ext_jeweler_make_info => $make_info);
   }

   $chdl->put ($ring_ob);
}

sub get_ingred {
   my ($pl, $chdl) = @_;
   my $ingred = eval { $chdl->extract_jeweler_ingredients };
   if ($@ =~ /cursed/) {
      $pl->message ("There are cursed items in the workbench, take them out before you do anything.").
      return
   } elsif ($@ =~ /unidentified/) {
      $pl->message ("There are unidentified items in the workbench, identify them before you do anything.").
      return
   } elsif ($@) {
      warn "error in jeweler ingredient extraction: $@";
      return;
   }
   $ingred;
}

cf::object::attachment check_ring_drop_on =>
   on_drop_on => sub {
      my ($self, $obj, $who) = @_;
      my $cfg = $self->{check_ring_drop_on};
      if ($obj->type == cf::RING
          && !$obj->flag (cf::FLAG_CURSED)
          && !$obj->flag (cf::FLAG_DAMNED)
      ) {
         my $ringo = Jeweler::Object->new (object => $obj);
         for (grep { /^resist_/ } keys %$cfg) {
            if (/^resist_(\S+)$/) {
               if ($ringo->has_resist ($1)) {
                  $self->map->trigger (
                     $cfg->{connection},
                     $cfg->{state}
                  );
                  cf::override;
               }
            }
         }
      }
   };

cf::object->attach (
   type         => cf::SKILL,
   subtype      => cf::SK_JEWELER,
   on_use_skill => sub {
      my ($sk, $ob, $part, $dir, $msg) = @_;
      my $pl = $ob;

      my $skobj = $sk;

      my $chdl = new Jeweler::CauldronHandler;

      my $rv = 1;
      eval {
         $DEBUG = 1;

         my $player = $ob->contr;

         unless ($chdl->find_cauldron ('jeweler_bench', $ob->map->at ($ob->x, $ob->y))) {
            return;
         }

         cf::override;

         if ($msg =~ m/^\s*analy[sz]e\s*$/i) {
            Jeweler::analyze ($sk, $chdl, $pl);

         } elsif ($msg =~ m/^\s*make\s*$/i) {
            $pl->message ("You can make: " . (join ', ', keys %{Jeweler::getcfg ('conversions') || {}}));

         } elsif ($msg =~ m/^\s*make\s+(\S+)\s*$/i) {
            my $ingred = get_ingred ($pl, $chdl) || return;

            unless ($Jeweler::CFG->{conversions}->{lc $1}) {
               $pl->message ("You don't know how to make '$1', is does such a thing even exist?");
               return
            }

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

         } elsif ($msg =~ m/^\s*merge\s*analy[sz]e\s*$/i) {
            merge ($chdl, $sk, $pl, 1);

         } elsif ($msg =~ m/^\s*merge\s*$/i) {
            merge ($chdl, $sk, $pl, 0);

         } else {
            my $ingred = get_ingred ($pl, $chdl) || return;

            my $plan   = $ingred->get_plan;

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

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

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

               } else {
                  my $ringo = Jeweler::Object->new (object => $ring[0]);
                  my $iring = $ingred->improve_ring_by_plan ($plan, $ringo);
                  my $c1    = $ringo->calc_costs;
                  my $c2    = $iring->calc_costs;
                  my $value = $iring->calc_value_from_cost ($c2);

                  my %keys;
                  my %cdiff;
                  for (keys %$c1, keys %$c2) { $keys{$_} = 1 }
                  for (keys %keys) { $cdiff{$_} = $c2->{$_} - $c1->{$_}; }

                  unless ($iring->is_better_than ($ringo)) {
                     $pl->message ("This plan doesn't improve anything, you find yourself puzzled about what you missed...");
                     return;
                  }

                  my $remcosts = $ingred->check_costs (\%cdiff);

                  if (grep { $_ > 0 } values %$remcosts) {
                     $pl->message ("You want to make a " . $iring->to_string . ": " . $iring->analyze ($sk, $pl));
                     $pl->message ("You recognize that you are short of: "
                        . (join ", ",
                              map { my $cost = $remcosts->{$_}; $cost . " " . ($cost > 1 ? "times" : "time") . " " . ingred_alias ($_) }
                                 grep { $remcosts->{$_} > 0 } keys %$remcosts));

                     if ($pl->flag (cf::FLAG_WIZ)) {
                        $iring->wiz_analyze ($pl);
                     }
                  } else {
                     if (!$pl->flag (cf::FLAG_WIZ)) {
                        $ingred->check_costs (\%cdiff, 1);
                     }
                     make_ring ($chdl, $ingred, $iring, $value, $sk, $pl);
                  }
               }
            } else {
               $pl->message ("You've got no idea what you are planning to do!");
            }
         }
      };
      $@ and warn "ERROR: $@\n";
   }
);

Jeweler::read_config (cf::datadir . '/jeweler.yaml');
Revision:	1.7
Committed:	Sun Feb 4 11:17:52 2007 UTC (17 years, 3 months ago) by elmex
Branch:	MAIN
CVS Tags:	rel-2_0
Changes since 1.6:	+45 -11 lines
Log Message:	implemented more sanity. aliases gem to diamond. fixed the plan finding algorithm. linear interpolate the costs for resistancies.
#	Content
1	#! perl
2
3	use Data::Dumper;
4	use Jeweler;
5	use List::Util qw/max min sum/;
6	use strict;
7
8	sub ingred_alias {
9	my ($ing) = @_;
10
11	my %aliases = (
12	pow => 'power',
13	cha => 'charisma',
14	wis => 'wisdom',
15	int => 'intelligence',
16	dex => 'dexterity',
17	con => 'constitution',
18	str => 'strength',
19	gem => 'diamond',
20	);
21
22	if ($ing =~ m/resist_(\S+)/) {
23	my $a = $aliases{lc $1} \|\| $1;
24	"something for '". lc ($a). "' resistance";
25
26	} elsif ($ing =~ m/stat_(\S+)/) {
27	my $a = $aliases{lc $1} \|\| $1;
28	"something for the ". lc ($a). " stat";
29
30	} elsif ($ing =~ m/spec_(\S+)/) {
31	my $a = $aliases{lc $1} \|\| $1;
32	"something for the ". lc ($a). "' special";
33
34	} elsif ($aliases{$ing}) {
35	$aliases{$ing}
36
37	} else {
38	$ing
39	}
40	}
41
42	my $DEBUG = 1;
43
44	sub merge {
45	my ($chdl, $sk, $pl, $do_analyze) = @_;
46
47	my $ingred = get_ingred ($pl, $chdl) \|\| return;
48
49	my @ring = $ingred->get_ring;
50	my @rings = map { Jeweler::Object->new (object => $_) } @ring;
51
52	@rings >= 2
53	or return $pl->reply (undef, "You slap yourself, you forgot to put at least 2 jewels in!");
54
55	my $input_level;
56	my $value;
57	for (@rings) {
58	$input_level = max ($_->power_to_level, $input_level);
59	$value += $_->{hash}->{value};
60	}
61
62	my $ring = shift @rings;
63	$ring->improve_by_ring (@rings);
64
65	if ($do_analyze) {
66	$pl->reply (undef, "You want to make a " . $ring->to_string . ": " . $ring->analyze ($sk, $pl));
67	$ring->wiz_analyze ($pl)
68	if $pl->flag (cf::FLAG_WIZ);
69	return;
70	}
71
72	make_ring ($chdl, $ingred, $ring, $value, $sk, $pl, $input_level);
73	}
74
75	sub make_ring {
76	my ($chdl, $ingred, $ring, $value, $sk, $pl, $input_level) = @_;
77
78	if (!$pl->flag (cf::FLAG_WIZ)) {
79	$ingred->remove ('rings');
80	$ingred->remove ('ammys');
81	}
82
83	my $ch = $ring->get_chance_perc ($sk);
84	my $succ = 0;
85	my $r = cf::random_roll (0, 100, $pl, cf::PREFER_HIGH);
86
87	my $make_status;
88	my $exp;
89
90	if ($r <= $ch or $pl->flag (cf::FLAG_WIZ)) {
91	my $lvl = max ($ring->power_to_level, 1);
92	$exp = (cf::level_to_min_exp ($lvl) - cf::level_to_min_exp ($lvl - 1)) / 100;
93
94	if (defined $input_level) {
95	my $subexp =
96	(cf::level_to_min_exp ($input_level)
97	- cf::level_to_min_exp ($input_level - 1))
98	/ 100;
99	$exp -= $subexp;
100	$exp = max ($exp, 0);
101	}
102
103	$pl->change_exp ($exp, "jeweler", cf::SK_EXP_SKILL_ONLY);
104	$pl->message ("You succeed and get $exp experience points.");
105	$make_status = "succeeded";
106
107	$ring->set_value ($value * 0.8); # 20% of the input values will vanish
108
109	} else {
110	$pl->message ("You fail!");
111	$ring->negate;
112	$make_status = "fail";
113	$exp = 0;
114	}
115
116	my $ring_ob = $ring->to_object;
117
118	{ # some audit info calculation
119	my $sklvl = cf::exp_to_level ($sk->stats->exp);
120
121	my $make_info = sprintf
122	"JEWELER AUDIT: '%s' made '%s' (%s) (sk lvl %d, ring lvl %d, got %d exp): %s",
123	$pl->name, $ring->to_string, $ring_ob->uuid, $sklvl,
124	$ring->power_to_level, $exp, $make_status;
125
126	warn "$make_info\n" if $make_status eq 'succeeded';
127
128	$ring_ob->set_ob_key_value (ext_jeweler_made_by => $pl->name);
129	$ring_ob->set_ob_key_value (ext_jeweler_make_info => $make_info);
130	}
131
132	$chdl->put ($ring_ob);
133	}
134
135	sub get_ingred {
136	my ($pl, $chdl) = @_;
137	my $ingred = eval { $chdl->extract_jeweler_ingredients };
138	if ($@ =~ /cursed/) {
139	$pl->message ("There are cursed items in the workbench, take them out before you do anything.").
140	return
141	} elsif ($@ =~ /unidentified/) {
142	$pl->message ("There are unidentified items in the workbench, identify them before you do anything.").
143	return
144	} elsif ($@) {
145	warn "error in jeweler ingredient extraction: $@";
146	return;
147	}
148	$ingred;
149	}
150
151	cf::object::attachment check_ring_drop_on =>
152	on_drop_on => sub {
153	my ($self, $obj, $who) = @_;
154	my $cfg = $self->{check_ring_drop_on};
155	if ($obj->type == cf::RING
156	&& !$obj->flag (cf::FLAG_CURSED)
157	&& !$obj->flag (cf::FLAG_DAMNED)
158	) {
159	my $ringo = Jeweler::Object->new (object => $obj);
160	for (grep { /^resist_/ } keys %$cfg) {
161	if (/^resist_(\S+)$/) {
162	if ($ringo->has_resist ($1)) {
163	$self->map->trigger (
164	$cfg->{connection},
165	$cfg->{state}
166	);
167	cf::override;
168	}
169	}
170	}
171	}
172	};
173
174	cf::object->attach (
175	type => cf::SKILL,
176	subtype => cf::SK_JEWELER,
177	on_use_skill => sub {
178	my ($sk, $ob, $part, $dir, $msg) = @_;
179	my $pl = $ob;
180
181	my $skobj = $sk;
182
183	my $chdl = new Jeweler::CauldronHandler;
184
185	my $rv = 1;
186	eval {
187	$DEBUG = 1;
188
189	my $player = $ob->contr;
190
191	unless ($chdl->find_cauldron ('jeweler_bench', $ob->map->at ($ob->x, $ob->y))) {
192	return;
193	}
194
195	cf::override;
196
197	if ($msg =~ m/^\sanaly[sz]e\s$/i) {
198	Jeweler::analyze ($sk, $chdl, $pl);
199
200	} elsif ($msg =~ m/^\smake\s$/i) {
201	$pl->message ("You can make: " . (join ', ', keys %{Jeweler::getcfg ('conversions') \|\| {}}));
202
203	} elsif ($msg =~ m/^\smake\s+(\S+)\s$/i) {
204	my $ingred = get_ingred ($pl, $chdl) \|\| return;
205
206	unless ($Jeweler::CFG->{conversions}->{lc $1}) {
207	$pl->message ("You don't know how to make '$1', is does such a thing even exist?");
208	return
209	}
210
211	Jeweler::simple_converter ($player, $ingred, $chdl, $1);
212
213	} elsif ($msg =~ m/^\smerge\sanaly[sz]e\s*$/i) {
214	merge ($chdl, $sk, $pl, 1);
215
216	} elsif ($msg =~ m/^\smerge\s$/i) {
217	merge ($chdl, $sk, $pl, 0);
218
219	} else {
220	my $ingred = get_ingred ($pl, $chdl) \|\| return;
221
222	my $plan = $ingred->get_plan;
223
224	if ($plan) {
225	my @ring = $ingred->get_ring;
226
227	if ((@ring > 1) \|\| ($ring[0]->nrof > 1)) {
228	# actually the algorithm cant handle more than one improvement at a time
229	$pl->message ("You can't manage to improve more than one thing at a time!");
230	return;
231
232	} elsif (@ring < 1) {
233	# actually the algorithm cant
234	$pl->message ("You slap yourself, you forgot the jewelery!");
235	return;
236
237	} else {
238	my $ringo = Jeweler::Object->new (object => $ring[0]);
239	my $iring = $ingred->improve_ring_by_plan ($plan, $ringo);
240	my $c1 = $ringo->calc_costs;
241	my $c2 = $iring->calc_costs;
242	my $value = $iring->calc_value_from_cost ($c2);
243
244	my %keys;
245	my %cdiff;
246	for (keys %$c1, keys %$c2) { $keys{$_} = 1 }
247	for (keys %keys) { $cdiff{$_} = $c2->{$_} - $c1->{$_}; }
248
249	unless ($iring->is_better_than ($ringo)) {
250	$pl->message ("This plan doesn't improve anything, you find yourself puzzled about what you missed...");
251	return;
252	}
253
254	my $remcosts = $ingred->check_costs (\%cdiff);
255
256	if (grep { $_ > 0 } values %$remcosts) {
257	$pl->message ("You want to make a " . $iring->to_string . ": " . $iring->analyze ($sk, $pl));
258	$pl->message ("You recognize that you are short of: "
259	. (join ", ",
260	map { my $cost = $remcosts->{$_}; $cost . " " . ($cost > 1 ? "times" : "time") . " " . ingred_alias ($_) }
261	grep { $remcosts->{$_} > 0 } keys %$remcosts));
262
263	if ($pl->flag (cf::FLAG_WIZ)) {
264	$iring->wiz_analyze ($pl);
265	}
266	} else {
267	if (!$pl->flag (cf::FLAG_WIZ)) {
268	$ingred->check_costs (\%cdiff, 1);
269	}
270	make_ring ($chdl, $ingred, $iring, $value, $sk, $pl);
271	}
272	}
273	} else {
274	$pl->message ("You've got no idea what you are planning to do!");
275	}
276	}
277	};
278	$@ and warn "ERROR: $@\n";
279	}
280	);
281
282	Jeweler::read_config (cf::datadir . '/jeweler.yaml');