File Coverage

blib/lib/Game/CharacterSheetGenerator.pm
Criterion Covered Total %
statement 543 624 87.0
branch 234 316 74.0
condition 81 112 72.3
subroutine 66 73 90.4
pod 0 58 0.0
total 924 1183 78.1


line stmt bran cond sub pod time code
1             #!/usr/bin/env perl
2             # Copyright (C) 2012-2022 Alex Schroeder
3              
4             # This program is free software: you can redistribute it and/or modify it under
5             # the terms of the GNU General Public License as published by the Free Software
6             # Foundation, either version 3 of the License, or (at your option) any later
7             # version.
8             #
9             # This program is distributed in the hope that it will be useful, but WITHOUT
10             # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
11             # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details.
12             #
13             # You should have received a copy of the GNU General Public License along with
14             # this program. If not, see .
15              
16             =encoding utf8
17              
18             =head1 NAME
19              
20             Game::CharacterSheetGenerator - a web app to generate character sheets
21              
22             =head1 DESCRIPTION
23              
24             Character Sheet Generator is a web application that generates characters for the
25             Halberts & Helmets game. It does two things: it generates the stats for random
26             characters, and it populates a SVG file with those values.
27              
28             Here's an example of the stats generated:
29              
30             name: Diara
31             str: 11
32             dex: 10
33             con: 13
34             int: 10
35             wis: 9
36             cha: 7
37             level: 1
38             xp: 0
39             thac0: 19
40             class: halfling
41             hp: 4
42             ac: 6
43             property: backpack
44             property: rope
45             property: leather armour
46             property: silver dagger
47             property: sling
48             property: pouch with 30 stones
49             abilities: 1/6 for normal tasks
50             abilities: 2/6 to hide and sneak
51             abilities: 5/6 to hide and sneak outside
52             abilities: +1 for ranged weapons
53             abilities: AC -2 against giants
54             charsheet: Charaktersheet.svg
55             breath: 13
56             poison: 8
57             petrify: 10
58             wands: 9
59             spells: 12
60              
61             Think of it as key value pairs. Some keys have multiple values, resulting in
62             multiline values.
63              
64             The SVG file acts as a template. For every key in the character, a C
65             element with a matching id is searched and if found, C elements matching
66             the value are inserted.
67              
68             The C key is special because it tells the app which file to load.
69              
70             On a technical level, Character Sheet Generator is a web app based on the
71             Mojolicious framework. This class in particular uses L.
72              
73             See L for more information.
74              
75             =cut
76              
77             package Game::CharacterSheetGenerator;
78              
79             our $VERSION = 1.02;
80              
81 9     9   7343 use Modern::Perl;
  9         44  
  9         56  
82 9     9   4558 use Game::CharacterSheetGenerator::ElfNames qw(elf_name);
  9         25  
  9         509  
83 9     9   3659 use Game::CharacterSheetGenerator::DwarfNames qw(dwarf_name);
  9         94  
  9         707  
84 9     9   3813 use Game::CharacterSheetGenerator::HalflingNames qw(halfling_name);
  9         36  
  9         582  
85 9     9   3835 use Game::CharacterSheetGenerator::HumanNames qw(human_name);
  9         130  
  9         922  
86 9     9   3912 use Mojolicious::Lite;
  9         856688  
  9         56  
87 9     9   177126 use Mojo::UserAgent;
  9         22  
  9         47  
88 9     9   202 use Mojo::Log;
  9         17  
  9         45  
89 9     9   3802 use File::ShareDir "dist_dir";
  9         184713  
  9         421  
90 9     9   4148 use I18N::AcceptLanguage;
  9         8735  
  9         314  
91 9     9   4911 use XML::LibXML;
  9         229442  
  9         51  
92 9     9   1154 use List::Util qw(shuffle max);
  9         21  
  9         496  
93 9     9   52 use POSIX qw(floor ceil);
  9         20  
  9         71  
94 9     9   560 use Cwd;
  9         16  
  9         420  
95 9     9   49 no warnings qw(uninitialized numeric);
  9         20  
  9         113513  
96              
97             # Commands for the command line!
98             push @{app->commands->namespaces}, "Game::CharacterSheetGenerator::Command";
99              
100             # Change scheme if "X-Forwarded-Proto" header is set (presumably to HTTPS)
101             app->hook(before_dispatch => sub {
102             my $c = shift;
103             $c->req->url->base->scheme("https")
104             if $c->req->headers->header("X-Forwarded-Proto") } );
105              
106             =head2 Configuration
107              
108             As a Mojolicious application, it will read a config file called
109             F in the same directory, if it exists. As the
110             default log level is "debug", one use of the config file is to change the log
111             level using the C key, and if you're not running the server in a
112             terminal, using the C key to set a file.
113              
114             The default map and table are stored in the F directory. You can change
115             this directory using the C key. By default, the directory included with
116             the distribution is used. Thus, if you're a developer, you probably want to use
117             something like the following to use the files from the source directory.
118              
119             The code also needs to know where the Face Generator can be found, if at all.
120             You can set the URL using the C key. If you're a developer
121             and have it running locally on port 3020, this is what you'd use:
122              
123             {
124             loglevel => "debug",
125             logfile => undef,
126             contrib => "share",
127             face_generator_url => "http://localhost:3020",
128             }
129              
130             =cut
131              
132             plugin Config => {
133             default => {
134             loglevel => "warn",
135             logfile => undef,
136             contrib => undef,
137             },
138             file => getcwd() . "/character-sheet-generator.conf",
139             };
140              
141             my $log = Mojo::Log->new;
142             $log->level(app->config("loglevel"));
143             $log->path(app->config("logfile"));
144             $log->debug($log->path ? "Logfile is " . $log->path : "Logging to stderr");
145              
146             my $dist_dir = app->config("contrib") // dist_dir("Game-CharacterSheetGenerator");
147             $log->debug("Reading contrib files from $dist_dir");
148              
149             sub translations {
150             # strings in sinqle quotes are translated into German if necessary
151             # use %0, %1, etc. for parameters
152 10     10 0 4852 my %translations = split(/\n/, q{%0 gold
153             %0 Gold
154             %0 silver
155             %0 Silber
156             %0: How much does this cost?
157             %0: Wieviel kostet das?
158             +1 bonus to ranged weapons
159             +1 für Fernwaffen
160             +4 to hit and double damage backstabbing
161             +4 und Schaden ×2 für hinterhältigen Angriff
162             1/6 for normal tasks
163             1/6 für normale Aufgaben
164             2/6 to find secret constructions and traps
165             2/6 um Geheimbauten und Fallen zu finden
166             2/6 to find secret or concealed doors
167             2/6 um geheime und versteckte Türen zu finden
168             2/6 to hear noise
169             2/6 um Geräusche zu hören
170             2/6 to hide and sneak
171             2/6 für Verstecken und Schleichen
172             5/6 to hide and sneak outdoors
173             5/6 für Verstecken und Schleichen im Freien
174             %d/6 for all activities
175             %d/6 für alle Aktivitäten
176             AC -2 vs. opponents larger than humans
177             Rüstung -2 bei Gegnern über Menschengrösse
178             Charactersheet.svg
179             Charakterblatt.svg
180             Charactersheet-landscape.svg
181             Charakterblatt-quer.svg
182             Hireling.svg
183             Mietling.svg
184             Classes
185             Klassen
186             Property
187             Eigentum
188             Spells:
189             Zaubersprüche:
190             Unknown Price
191             Unbekannter Preis
192             and
193             und
194             backpack
195             Rucksack
196             battle axe
197             Streitaxt
198             case with 30 bolts
199             Kiste mit 30 Bolzen
200             chain mail
201             Kettenhemd
202             charm person
203             Person bezaubern
204             club
205             Keule
206             crossbow
207             Armbrust
208             d6
209             W6
210             dagger
211             Dolch
212             detect magic
213             Magie entdecken
214             dwarf
215             Zwerg
216             elderly man
217             älterer Mann
218             elderly woman
219             ältere Frau
220             elf
221             Elf
222             fighter
223             Krieger
224             flask of oil
225             Ölflasche
226             floating disc
227             Schwebende Scheibe
228             halfling
229             Halbling
230             hand axe
231             Handaxt
232             helmet
233             Helm
234             hireling
235             Mietling
236             porter
237             Träger
238             hold portal
239             Portal verschliessen
240             12 iron spikes and hammer
241             12 Eisenkeile und Hammer
242             3 stakes and hammer
243             12 Holzpfähle und Hammer
244             lantern
245             Laterne
246             leather armor
247             Lederrüstung
248             light
249             Licht
250             long bow
251             Langbogen
252             long sword
253             Langschwert
254             mace
255             Streitkeule
256             magic missile
257             Magisches Geschoss
258             magic-user
259             Magier
260             man
261             Mann
262             mirror
263             Spiegel
264             plate mail
265             Plattenpanzer
266             pole arm
267             Stangenwaffe
268             pouch with 30 stones
269             Beutel mit 30 Steinen
270             protection from evil
271             Schutz vor Bösem
272             quiver with 20 arrows
273             Köcher mit 20 Pfeilen
274             read languages
275             Sprachen lesen
276             read magic
277             Magie lesen
278             rope
279             Seil
280             shield
281             Schild
282             short bow
283             Kurzbogen
284             short sword
285             Kurzschwert
286             silver dagger
287             Silberner Dolch
288             sleep
289             Schlaf
290             sling
291             Schleuder
292             spear
293             Speer
294             spell book
295             Zauberbuch
296             staff
297             Stab
298             thief
299             Dieb
300             thieves’ tools
301             Diebeswerkzeug
302             6 torches
303             6 Fackeln
304             two handed sword
305             Zweihänder
306             ventriloquism
307             Bauchreden
308             war hammer
309             Kriegshammer
310             wolfsbane
311             Eisenhut (sog. Wolfsbann)
312             garlic
313             Knoblauch
314             woman
315             Frau
316             pole
317             Stab
318             young man
319             junger Mann
320             young woman
321             junge Frau
322             rations (1 week)
323             Wegzehrung (1 Woche)
324             });
325              
326 10         70 return \%translations;
327             }
328              
329             my $translation = translations();
330             our $lang; # we'll set it in random_parameters
331              
332             sub T {
333 37481     37481 0 53239 my ($en, @arg) = @_;
334 37481         43469 my $suffix = '';
335             # handle (2) suffixes
336 37481 100       63385 if ($en =~ /(.*)( \(\d+\))$/) {
337 1         4 $en = $1;
338 1         3 $suffix = $2;
339             }
340 37481 100 100     91958 if ($translation->{$en} and $lang eq "de") {
341 18317         24385 $en = $translation->{$en};
342             }
343             # utf8::encode($en);
344 37481         61953 for (my $i = 0; $i < scalar @arg; $i++) {
345 278         404 my $s = $arg[$i];
346 278         1976 $en =~ s/%$i/$s/g;
347             }
348 37481         93559 return $en . $suffix;
349             }
350              
351             sub svg_read {
352 13     13 0 35 my ($char) = @_;
353 13   100     46 my $filename = $char->{charsheet} || 'Charactersheet.svg';
354 13         27 my $doc;
355 13 50       360 if (-f "$dist_dir/$filename") {
356 13         146 $doc = XML::LibXML->load_xml(location => "$dist_dir/$filename");
357             } else {
358 0         0 my $ua = Mojo::UserAgent->new;
359 0         0 my $tx = $ua->get($filename);
360 0 0       0 die "«$filename»: " . $tx->res->error->{message} . "\n" unless $tx->success;
361 0         0 $doc = XML::LibXML->load_xml(string => $tx->res->body);
362             }
363 13         24726 return ($char, $doc); # used as parameters for svg_transform
364             }
365              
366             sub replace_text {
367 438     438 0 767 my ($parser, $node, $str) = @_;
368 438         1230 my @line = split(/\\\\/, $str);
369              
370             # is this multiline in the template
371             # (ignore text nodes, go for tspans only)
372 438         610 my $dy;
373 438         1015 my $tspans = $node->find(qq{svg:tspan});
374 438 100       12680 if ($tspans->size() > 1) {
375 13         79 $dy = $tspans->get_node(2)->getAttribute("y")
376             - $tspans->get_node(1)->getAttribute("y");
377             } else {
378             # mismatch, attempt readable compromise
379 425         2370 @line = (join(", ", @line));
380             }
381              
382             # delete the tspan nodes of the text node
383 438         1925 $node->removeChildNodes();
384              
385 438         1267 my $tspan = XML::LibXML::Element->new("tspan");
386 438         1042 $tspan->setAttribute("x", $node->getAttribute("x"));
387 438         6425 $tspan->setAttribute("y", $node->getAttribute("y"));
388              
389 438         5245 while (@line) {
390 506         2017 my $line = shift(@line); # cannot have this in while cond because of "0"
391 506 100       1058 next if $line eq ''; # cannot parse empty strings
392 480         827 my $fragment = $parser->parse_balanced_chunk(T($line));
393 480         66478 foreach my $child ($fragment->childNodes) {
394 480         4218 my $tag = $child->nodeName;
395 480 50 33     2476 if ($tag eq "strong" or $tag eq "b") {
    50 33        
    50          
396 0         0 my $node = XML::LibXML::Element->new("tspan");
397 0         0 $node->setAttribute("style", "font-weight:bold");
398 0         0 $node->appendText($child->textContent);
399 0         0 $tspan->appendChild($node);
400             } elsif ($tag eq "em" or $tag eq "i") {
401 0         0 my $node = XML::LibXML::Element->new("tspan");
402 0         0 $node->setAttribute("style", "font-style:italic");
403 0         0 $node->appendText($child->textContent);
404 0         0 $tspan->appendChild($node);
405             } elsif ($tag eq "a") {
406 0         0 $child->setAttributeNS("http://www.w3.org/1999/xlink", "xlink:href",
407             $child->getAttribute("href"));
408 0         0 $child->removeAttribute("href");
409 0         0 $tspan->appendChild($child);
410             } else {
411 480         2211 $tspan->appendText($child->textContent);
412             }
413             }
414 480         2632 $node->appendChild($tspan);
415 480 100       1022 if (@line) {
416 68         946 $tspan = $tspan->cloneNode();
417 68         572 $tspan->setAttribute("y", $tspan->getAttribute("y") + $dy);
418             }
419             }
420             }
421              
422             sub svg_transform {
423 11     11 0 30 my ($self, $char, $doc) = @_;
424 11         37 my $parser = XML::LibXML->new;
425 11         404 my $svg = XML::LibXML::XPathContext->new;
426 11         81 $svg->registerNs("svg", "http://www.w3.org/2000/svg");
427              
428 11         115 for my $id (keys %$char) {
429 638 50       5137 next unless $id =~ /^[-a-z0-9]+$/;
430 638         1924 my $nodes = $svg->find(qq{//svg:text[\@id="$id"]}, $doc);
431 638         97720 for my $node ($nodes->get_nodelist) {
432 438         2563 replace_text($parser, $node, $char->{$id}, $doc);
433 438         11871 next;
434             }
435 638         2513 $nodes = $svg->find(qq{//svg:image[\@id="$id"]}, $doc);
436 638         49808 for my $node ($nodes->get_nodelist) {
437             $node->setAttributeNS("http://www.w3.org/1999/xlink",
438 5         52 "xlink:href", $char->{$id});
439 5         129 next;
440             }
441             }
442              
443             # $self is not set when using the random command
444             # (Game::CharacterSheetGenerator::Command::random).
445 11 50       117 if ($self) {
446 11         34 my $nodes = $svg->find(qq{//svg:a[\@id="link"]/attribute::xlink:href}, $doc);
447 11         838 for my $node ($nodes->get_nodelist) {
448 11         90 my $params = Mojo::Parameters->new;
449 11         112 for my $key (@{$char->{provided}}) {
  11         36  
450 155   100     2394 $params->append($key => $char->{$key}||'');
451             }
452 11         220 $node->setValue($self->url_for("edit")->query($params));
453             }
454             }
455              
456 11         17733 return $doc;
457             }
458              
459             sub svg_show_id {
460 2     2 0 4 my ($char, $doc) = @_;
461              
462 2         44 my $svg = XML::LibXML::XPathContext->new;
463 2         10 $svg->registerNs("svg", "http://www.w3.org/2000/svg");
464              
465 2         7 for my $node ($svg->find(qq{//svg:text/svg:tspan/..}, $doc)->get_nodelist) {
466 225         1281 my $id = $node->getAttribute("id");
467 225 100       1733 next if $id =~ /^text[0-9]+(-[0-9]+)*$/; # skip Inkscape default texts
468 100 50       266 next unless $id =~ /^[-a-z0-9]+$/;
469 100         315 $node->removeChildNodes();
470 100         228 $node->appendText($id);
471 100         156 my $style = $node->getAttribute("style");
472 100         1092 $style =~ s/font-size:\d+px/font-size:8px/;
473 100 50       496 $style =~ s/fill:#\d+/fill:magenta/ or $style .= ";fill:magenta";
474 100         197 $node->setAttribute("style", $style);
475             }
476              
477 2         16 for my $node ($svg->find(qq{//svg:image}, $doc)->get_nodelist) {
478 2         1403 my $id = $node->getAttribute("id");
479 2 50       22 next if $id =~ /^text[0-9]+(-[0-9]+)*$/; # skip Inkscape default texts
480 2 50       11 next unless $id =~ /^[-a-z0-9]+$/;
481 2         8 my $text = XML::LibXML::Element->new("text");
482 2         5 $text->setAttribute("x", $node->getAttribute("x") + 5);
483 2         32 $text->setAttribute("y", $node->getAttribute("y") + 10);
484 2         38 $text->appendText($id);
485 2         5 $text->setAttribute("style", "font-size:8px;fill:magenta");
486 2         24 $node->addSibling($text);
487             }
488              
489 2         35 return $doc;
490             }
491              
492             sub bonus {
493 680     680 0 991 my $n = shift;
494 680 100       1214 return "-3" if $n <= 3;
495 675 100       1112 return "-2" if $n <= 5;
496 643 100       1296 return "-1" if $n <= 8;
497 486 100       1550 return "" if $n <= 12;
498 176 100       544 return "+1" if $n <= 15;
499 33 100       113 return "+2" if $n <= 17;
500 4         12 return "+3";
501             }
502              
503             sub cha_bonus {
504 7     7 0 14 my $n = shift;
505 7 50       19 return "-2" if $n <= 3;
506 7 100       18 return "-1" if $n <= 8;
507 6 100       19 return "" if $n <= 12;
508 3 50       11 return "+1" if $n <= 17;
509 0         0 return "+2";
510             }
511              
512             sub character {
513 11     11 0 24 my $char = shift;
514 11         29 for my $id (qw(str dex con int wis cha)) {
515 66 100 100     193 if ($char->{$id} and not defined $char->{"$id-bonus"}) {
516 43         80 $char->{"$id-bonus"} = bonus($char->{$id});
517             }
518             }
519 11 100 66     61 if ($char->{cha} and not defined $char->{reaction}) {
520 7         23 $char->{reaction} = cha_bonus($char->{cha});
521             }
522 11 50       36 if (not $char->{loyalty}) {
523 11         39 $char->{loyalty} = 7 + $char->{"cha-bonus"};
524             }
525 11 50       35 if (not defined $char->{hirelings}) {
526 11         27 $char->{hirelings} = 4 + $char->{"cha-bonus"};
527             }
528 11 100 66     77 if ($char->{thac0} and not defined $char->{"melee-thac0"}) {
529 7         31 $char->{"melee-thac0"} = $char->{thac0} - $char->{"str-bonus"};
530             }
531 11 100 66     50 if ($char->{thac0} and not defined $char->{"range-thac0"}) {
532 7         27 $char->{"range-thac0"} = $char->{thac0} - $char->{"dex-bonus"};
533             }
534 11 100 66     43 if ($char->{thac0} and not defined $char->{"other-thac0"}) {
535 7         15 $char->{"other-thac0"} = $char->{thac0};
536             }
537 11         27 for my $type ("melee", "range", "other") {
538 33         91 for (my $n = 0; $n <= 9; $n++) {
539 330         489 my $val = $char->{"$type-thac0"} - $n;
540 330 100       517 $val = 20 if $val > 20;
541 330 100       479 $val = 1 if $val < 1;
542 330 50       1053 $char->{"$type$n"} = $val unless $char->{"$type$n"};
543             }
544             }
545 11 50       34 if (not defined $char->{damage}) {
546 11         34 $char->{damage} = 1 . T('d6');
547             }
548 11 50       35 if (not defined $char->{"melee-damage"}) {
549 11         31 $char->{"melee-damage"} = $char->{damage} . $char->{"str-bonus"};
550             }
551 11 50       32 if (not defined $char->{"range-damage"}) {
552 11         47 $char->{"range-damage"} = $char->{damage};
553             }
554 11 50       31 if (not defined $char->{"other-damage"}) {
555 11         36 $char->{"other-damage"} = $char->{damage};
556             }
557 11         38 saves($char);
558             }
559              
560             # This function is called when preparing data for display in SVG.
561             sub compute_data {
562 11     11 0 29 my ($char, $language) = @_;
563 11         44 local $lang = $language; # make sure T works as intended
564 11         39 character($char);
565             }
566              
567             sub starting_gold {
568 304     304 0 481 my $class = shift;
569 304 50 33     475 return 0 if $class eq T('hireling') or $class eq T('porter');
570 304         641 return roll_3d6() * 10;
571             }
572              
573             my %price_cache;
574              
575             sub equipment {
576 305     305 0 412 my $char = shift;
577 305         462 my $xp = $char->{xp};
578 305         453 my $level = $char->{level};
579 305         440 my $class = $char->{class};
580 305 100 66     1190 return if $xp or $level > 1 or not $class;
      66        
581              
582 304         614 get_price_cache($char);
583 304         1061 my $money = starting_gold($class);
584 304         387 my @property;
585              
586             # free spellbook for arcane casters
587 304 100       458 if (member($class, T('magic-user'), T('elf'))) {
588 112         172 push(@property, T('spell book'));
589             }
590              
591 304         683 ($money, @property) = buy_basics($char, $money, $class, @property);
592 304         584 ($money, @property) = buy_armor($char, $money, $class, @property);
593 304         605 ($money, @property) = buy_weapon($char, $money, $class, @property);
594 304         591 ($money, @property) = buy_tools($char, $money, $class, @property);
595 304         602 ($money, @property) = buy_light($char, $money, $class, @property);
596 304         684 ($money, @property) = buy_gear($char, $money, $class, @property);
597 304         708 ($money, @property) = buy_protection($char, $money, $class, @property);
598 304         541 my $gold = int($money);
599 304         633 my $silver = int(10 * ($money - $gold) + 0.5);;
600 304 100       672 push(@property, T('%0 gold', $gold)) if $gold;
601 304 50       588 push(@property, T('%0 silver', $silver)) if $silver;
602 304         1163 provide($char, "property", join("\\\\", @property));
603             }
604              
605             # This is computed at runtime because of the translations.
606             sub get_price_cache {
607 304     304 0 405 my $char = shift;
608 304         505 %price_cache = (
609             T('backpack') => 5,
610             T('rations (1 week)') => 15,
611             T('thieves’ tools') => 25,
612             T('lantern') => 10,
613             T('flask of oil') => 2,
614             T('6 torches') => 1,
615             T('rope') => 1,
616             T('3 stakes and hammer') => 3,
617             T('12 iron spikes and hammer') => 3,
618             T('pole') => 1,
619             T('wolfsbane') => 10,
620             T('garlic') => 1,
621             T('mirror') => 5,
622             T('leather armor') => 20,
623             T('chain mail') => 40,
624             T('plate mail') => 60,
625             T('shield') => 10,
626             T('helmet') => 10,
627             T('club') => 3,
628             T('mace') => 5,
629             T('war hammer') => 5,
630             T('staff') => 2,
631             T('dagger') => 3,
632             T('silver dagger') => 30,
633             T('two handed sword') => 15,
634             T('battle axe') => 7,
635             T('pole arm') => 7,
636             T('long sword') => 10,
637             T('short sword') => 7,
638             T('long bow') => 40,
639             T('quiver with 20 arrows') => 5,
640             T('short bow') => 25,
641             T('crossbow') => 30,
642             T('case with 30 bolts') => 10,
643             T('sling') => 2,
644             T('pouch with 30 stones') => 0,
645             T('hand axe') => 4,
646             T('spear') => 3,
647             );
648             }
649              
650             sub price {
651 6460     6460 0 8709 my ($char, $item) = @_;
652 6460         8932 my $price = $price_cache{$item};
653 6460 50       9525 if (not defined $price) {
654 0         0 $log->error(T('Unknown Price'), T('%0: How much does this cost?', $item));
655 0         0 return 0;
656             }
657 6460         9090 return $price;
658             }
659              
660             # add($item, \@property) modifies @property directly
661             sub add {
662 3498     3498 0 5033 my ($item, $property) = @_;
663 3498         4835 foreach (@$property) {
664 19087 100       28638 if ($_ eq $item) {
665 235 50       464 if (/\(\d+\)$/) {
666 0         0 my $n = $1++;
667 0         0 s/\(\d+\)$/($n)/;
668             } else {
669 235         509 $_ .= " (2)";
670             }
671 235         376 $item = undef;
672 235         303 last;
673             }
674             }
675 3498 100       5178 if ($item) {
676 3263         5304 push(@$property, $item);
677             }
678             }
679              
680             # Use array references to buy one of several alternatives.
681             # Buy a and b, or buy c instead:
682             # ($money, @property) = buy($char, [[a, b], c], $money, @property)
683             sub buy {
684 4013     4013 0 8370 my ($char, $item, $money, @property) = @_;
685 4013 100       6592 if (ref $item eq "ARRAY") {
686 2019         2927 for my $elem (@$item) {
687 2895 100       4248 if (ref $elem eq "ARRAY") {
688 1312         1529 my $price = 0;
689 1312         1644 for my $thing (@$elem) {
690 2883         3687 $price += price($char, $thing);
691             }
692 1312 100       2151 if ($money >= $price) {
693 518         631 $money -= $price;
694 518 50       858 $elem->[-1] .= " (${price}gp)" if $char->{debug};
695 518         748 foreach (@$elem) {
696 1041         1529 add($_, \@property);
697             }
698 518         776 last;
699             }
700             } else {
701 1583         2150 my $price = price($char, $elem);
702 1583 100       2851 if ($money >= $price) {
703 1188         1435 $money -= $price;
704 1188 50       2016 $elem .= " (${price}gp)" if $char->{debug};
705 1188         2198 add($elem, \@property);
706 1188         1720 last;
707             }
708             }
709             }
710             } else {
711 1994         2946 my $price = price($char, $item);
712 1994 100       3288 if ($money >= $price) {
713 1269         1513 $money -= $price;
714 1269 50       2075 $item .= " (${price}gp)" if $char->{debug};
715 1269         1933 add($item, \@property);
716             }
717             }
718 4013         11565 return ($money, @property);
719             }
720              
721             sub buy_basics {
722 304     304 0 589 my ($char, $money, $class, @property) = @_;
723 304 50       551 push(@property, "- $money gp -") if $char->{debug};
724 304         453 ($money, @property) = buy($char, T('backpack'), $money, @property);
725 304         572 ($money, @property) = buy($char, T('rations (1 week)'), $money, @property);
726              
727 304         625 return ($money, @property);
728             }
729              
730             sub buy_tools {
731 304     304 0 720 my ($char, $money, $class, @property) = @_;
732 304 50       568 push(@property, "- $money gp -") if $char->{debug};
733 304 100       440 if ($class eq T('thief')) {
734 42         81 ($money, @property) = buy($char, T('thieves’ tools'), $money, @property);
735             }
736 304         898 return ($money, @property);
737             }
738              
739             sub buy_light {
740 304     304 0 662 my ($char, $money, $class, @property) = @_;
741 304 50       537 push(@property, "- $money gp -") if $char->{debug};
742 304         484 return buy($char, [[T('lantern'), T('flask of oil')],
743             T('6 torches')],
744             $money, @property);
745             }
746              
747             sub buy_gear {
748 304     304 0 714 my ($char, $money, $class, @property) = @_;
749 304 50       540 push(@property, "- $money gp -") if $char->{debug};
750 304         515 my @preferences = shuffle(
751             T('rope'),
752             T('12 iron spikes and hammer'),
753             T('3 stakes and hammer'),
754             T('pole'));
755 304         597 return buy($char, \@preferences, $money, @property);
756             }
757              
758             sub buy_protection {
759 304     304 0 724 my ($char, $money, $class, @property) = @_;
760 304 50       537 push(@property, "- $money gp -") if $char->{debug};
761 304         452 my @preferences = shuffle(
762             T('garlic'),
763             T('wolfsbane'),
764             T('mirror'));
765 304         619 return buy($char, \@preferences, $money, @property);
766             }
767              
768             sub buy_armor {
769 304     304 0 604 my ($char, $money, $class, @property) = @_;
770 304 50       513 push(@property, "- $money gp -") if $char->{debug};
771 304         543 my $budget = $money / 2;
772 304         386 $money -= $budget;
773              
774 304 100       474 if ($class eq T('magic-user')) {
    100          
775             # no armor
776             } elsif ($class eq T('thief')) {
777             # leather, no shield, no helmet
778 42         93 ($budget, @property) = buy($char, T('leather armor'), $budget, @property);
779             } else {
780             # any armor
781 195         339 ($budget, @property) = buy($char, [T('plate mail'),
782             T('chain mail'),
783             T('leather armor')], $budget, @property);
784 195         454 ($budget, @property) = buy($char, T('shield'), $budget, @property);
785 195         346 ($budget, @property) = buy($char, T('helmet'), $budget, @property);
786             }
787              
788             # compute AC
789 304         567 my $dex = $char->{dex};
790 304         492 my $ac = 9 - bonus($dex);
791              
792 304 100       545 if (member(T('plate mail'), @property)) { $ac -= 6; }
  29 100       46  
    100          
793 78         120 elsif (member(T('chain mail'), @property)) { $ac -= 4; }
794 116         182 elsif (member(T('leather armor'), @property)) { $ac -= 2; }
795              
796 304 100       603 if (member(T('shield'), @property)) { $ac -= 1; }
  110         166  
797              
798 304 100       521 if ($class eq T('halfling')) {
799 26         62 $ac .= "/" . ($ac - 2);
800             }
801 304         677 provide($char, "ac", $ac);
802              
803 304         795 return ($money + $budget, @property);
804             }
805              
806             sub buy_melee_weapon {
807 304     304 0 413 my $char = shift;
808 304         603 my ($money, $class, @property) = @_;
809 304         415 my $str = $char->{str};
810 304         405 my $hp = $char->{hp};
811 304         431 my $shield = member(T('shield'), @property);
812 304         419 my @preferences;
813              
814 304 100       453 if ($class eq T('magic-user')) {
    100          
    100          
    100          
    100          
    50          
    0          
    0          
815 67         106 @preferences = shuffle(
816             T('dagger'),
817             T('staff'));
818             } elsif ($class eq T('fighter')) {
819 81 50 100     166 if (good($str)
      66        
820             and $hp > 6
821             and not $shield) {
822             # prefer a shield!
823 0         0 push(@preferences,
824             shuffle(T('two handed sword'),
825             T('battle axe'),
826             T('pole arm')));
827             }
828 81         165 push(@preferences,
829             T('long sword'),
830             T('short sword'),
831             T('mace'));
832             } elsif ($class eq T('dwarf')) {
833 43 100       90 push(@preferences, T('battle axe')) unless $shield;
834 43         75 push(@preferences,
835             T('war hammer'),
836             T('mace'),
837             T('short sword'));
838             } elsif ($class eq T('halfling')) {
839 26         47 @preferences = (T('short sword'),
840             T('mace'),
841             T('club'));
842             } elsif ($class eq T('elf')) {
843 45         64 @preferences = (T('long sword'),
844             T('short sword'));
845             } elsif ($class eq T('thief')) {
846 42         68 @preferences = (T('long sword'),
847             T('short sword'),
848             T('mace'),
849             T('club'));
850             } elsif ($class eq T('hireling')) {
851 0         0 @preferences = (T('spear'),
852             T('club'));
853             } elsif ($class eq T('porter')) {
854 0         0 @preferences = ();
855             } else {
856 0         0 $log->warn("Unknown class $class has no preferred weapons");
857             }
858 304         671 return buy($char, \@preferences, $money, @property);
859             }
860              
861             sub buy_throwing_weapon {
862 304     304 0 391 my $char = shift;
863 304         611 my ($money, $class, @property) = @_;
864 304         396 my @preferences;
865 304 100 66     451 if ($class eq T('dwarf') or member(T('battle axe'), @property)) {
866 43         88 push(@preferences, [T('hand axe'), T('hand axe')]);
867 43         80 push(@preferences, T('hand axe'));
868             }
869 304 100       553 if ($class eq T('fighter')) {
870 81         128 push(@preferences, T('spear'));
871             }
872 304         594 return buy($char, \@preferences, $money, @property);
873             }
874              
875             sub buy_ranged_weapon {
876 304     304 0 401 my $char = shift;
877 304         582 my ($money, $class, @property) = @_;
878 304         389 my @preferences;
879 304         395 my $dex = $char->{dex};
880 304 100 100     502 if (($class eq T('fighter') or $class eq T('elf'))
      100        
881             and average($dex)) {
882 89         147 push(@preferences,
883             [T('long bow'),
884             T('quiver with 20 arrows'),
885             T('quiver with 20 arrows')],
886             [T('long bow'),
887             T('quiver with 20 arrows')]);
888             }
889 304 100       569 if ($class ne T('magic-user')) {
890 237 100       387 if (average($dex)) {
891 170         262 push(@preferences,
892             [T('short bow'),
893             T('quiver with 20 arrows'),
894             T('quiver with 20 arrows')],
895             [T('short bow'),
896             T('quiver with 20 arrows')]);
897             }
898 237         472 push(@preferences,
899             [T('crossbow'),
900             T('case with 30 bolts')]);
901 237         413 push(@preferences,
902             [T('sling'),
903             T('pouch with 30 stones')]);
904             }
905 304         609 return buy($char, \@preferences, $money, @property);
906             }
907              
908             sub buy_weapon {
909 304     304 0 404 my $char = shift;
910 304         670 my ($money, $class, @property) = @_;
911 304 50       558 push(@property, "- $money gp -") if $char->{debug};
912 304         452 my $budget = $money / 2;
913 304         386 $money -= $budget;
914              
915 304         524 ($budget, @property) = buy_melee_weapon($char, $budget, $class, @property);
916 304         712 ($budget, @property) = buy_throwing_weapon($char, $budget, $class, @property);
917 304         621 ($budget, @property) = buy_ranged_weapon($char, $budget, $class, @property);
918              
919 304         717 ($budget, @property) = buy($char, T('silver dagger'), $budget, @property);
920              
921 304         537 ($budget, @property) = buy($char, T('dagger'), $budget, @property);
922 304         555 ($budget, @property) = buy($char, T('dagger'), $budget, @property);
923              
924 304         919 return ($money + $budget, @property);
925             }
926              
927             sub spellbook {
928 112     112 0 166 my $char = shift;
929 112         161 return T('Spells:') . " "
930             . one(T('charm person'),
931             T('detect magic'),
932             T('floating disc'),
933             T('hold portal'),
934             T('light'),
935             T('magic missile'),
936             T('protection from evil'),
937             T('read languages'),
938             T('read magic'),
939             T('shield'),
940             T('sleep'),
941             T('ventriloquism'));
942             }
943              
944             sub saves {
945 11     11 0 21 my $char = shift;
946 11         24 my $class = $char->{class};
947 11         24 my $level = $char->{level};
948 11 100       41 return unless $class;
949 7         18 my ($breath, $poison, $petrify, $wands, $spells);
950 7 50 33     15 if ($class eq T('dwarf') or $class eq T('halfling')) {
    50          
    100          
    50          
    50          
951 0         0 ($breath, $poison, $petrify, $wands, $spells) =
952             improve([13, 8, 10, 9, 12], [3, 2, 2, 2, 2], int(($level-1)/3));
953             } elsif ($class eq T('elf')) {
954 0         0 ($breath, $poison, $petrify, $wands, $spells) =
955             improve([15, 12, 13, 13, 15], 2, int(($level-1)/3));
956             } elsif ($class eq T('fighter')) {
957 3         20 ($breath, $poison, $petrify, $wands, $spells) =
958             improve([15, 12, 14, 13, 16], 2, int(($level-1)/3));
959             } elsif ($class eq T('magic-user')) {
960 0         0 ($breath, $poison, $petrify, $wands, $spells) =
961             improve([16, 13, 13, 13, 14], 2, int(($level-1)/5));
962             } elsif ($class eq T('thief')) {
963 4         21 ($breath, $poison, $petrify, $wands, $spells) =
964             improve([16, 14, 13, 15, 14], 2, int(($level-1)/4));
965             } else {
966 0         0 ($breath, $poison, $petrify, $wands, $spells) =
967             (17, 14, 16, 15, 18);
968             }
969              
970 7 100       35 provide($char, "breath", $breath) unless $char->{breath};
971 7 100       32 provide($char, "poison", $poison) unless $char->{poison};
972 7 100       27 provide($char, "petrify", $petrify) unless $char->{petrify};
973 7 100       29 provide($char, "wands", $wands) unless $char->{wands};
974 7 100       26 provide($char, "spells", $spells) unless $char->{spells};
975             }
976              
977             sub improve {
978 7     7 0 14 my $saves = shift;
979 7         12 my $improvement = shift;
980 7         14 my $steps = shift;
981 7         25 for (my $i = 0; $i < @$saves; $i++) {
982 35 0       77 $saves->[$i] -= ref($improvement) ? $improvement->[$i] : $improvement for 1 .. $steps;
983             }
984 7         25 return @$saves;
985             }
986              
987             sub d3 {
988 100     100 0 215 return 1 + int(rand(3));
989             }
990              
991             sub d4 {
992 112     112 0 278 return 1 + int(rand(4));
993             }
994              
995             sub d6 {
996 6589     6589 0 10365 return 1 + int(rand(6));
997             }
998              
999             sub d8 {
1000 124     124 0 322 return 1 + int(rand(8));
1001             }
1002              
1003             sub d10 {
1004 0     0 0 0 return 1 + int(rand(10));
1005             }
1006              
1007             sub d12 {
1008 0     0 0 0 return 1 + int(rand(12));
1009             }
1010              
1011             sub roll_3d6 {
1012 2134     2134 0 3054 return d6() + d6() + d6();
1013             }
1014              
1015             sub roll_3d8 {
1016 0     0 0 0 return d8() + d8() + d8();
1017             }
1018              
1019             sub best {
1020 305     305 0 387 my $best = 0;
1021 305         386 my $max = $_[0];
1022 305         575 for (my $i = 1; $i < 6; $i++) {
1023 1525 100       2796 if ($_[$i] > $max) {
1024 377         461 $best = $i;
1025 377         694 $max = $_[$best];
1026             }
1027             }
1028 305         656 my @stat = qw(str dex con int wis cha);
1029 305         549 return $stat[$best];
1030             }
1031              
1032             sub above {
1033 1817     1817 0 2159 my $limit = shift;
1034 1817         2076 my $n = 0;
1035 1817         3091 for (my $i = 0; $i <= $#_; $i++) {
1036 3250 100       6872 $n++ if $_[$i] > $limit;
1037             }
1038 1817         5172 return $n;
1039             }
1040              
1041             sub good {
1042 491     491 0 733 return above(12, @_);
1043             }
1044              
1045             sub average {
1046 1326     1326 0 2062 return above(8, @_);
1047             }
1048              
1049             # use prototype so that Perl knows that there are only three arguments, which
1050             # allows wrap to use wantarray when used to wrap $value
1051             sub provide ($$$) {
1052 4932     4932 0 7816 my ($char, $key, $value) = @_;
1053 4932 100 66     9095 return unless not defined $char->{$key} or $char->{$key} eq '';
1054             # empty strings get overwritten, but zero does not get overwritten
1055 4928         6221 push(@{$char->{provided}}, $key);
  4928         8770  
1056 4928         10312 $char->{$key} = $value;
1057             }
1058              
1059             sub one {
1060 410     410 0 747 my $i = int(rand(scalar @_));
1061 410         904 return $_[$i];
1062             }
1063              
1064             sub two {
1065 0     0 0 0 my $i = int(rand(scalar @_));
1066 0         0 my $j = int(rand(scalar @_));
1067 0         0 $j = int(rand(scalar @_)) until $i != $j;
1068 0         0 return ($_[$i], $_[$j]);
1069             }
1070              
1071             sub member {
1072 2254     2254 0 3074 my $element = shift;
1073 2254         3389 foreach (@_) {
1074 6991 100       13197 return 1 if $element eq $_;
1075             }
1076             }
1077              
1078             sub wrap {
1079 0     0 0 0 my ($text, $width) = @_;
1080 0         0 my @result;
1081 0         0 while (length($text) > $width) {
1082 0         0 my $n = $width;
1083 0         0 while ($n > 0) {
1084 0 0       0 if (substr($text, $n, 1) eq " ") {
1085 0         0 push(@result, substr($text, 0, $n));
1086 0         0 $text = substr($text, $n + 1);
1087 0         0 last;
1088             } else {
1089 0         0 $n--;
1090             }
1091             }
1092             }
1093 0         0 push(@result, $text);
1094 0 0       0 return @result if wantarray;
1095 0         0 return join("\\\\", @result);
1096             }
1097              
1098             my $traits = {
1099             # http://charaktereigenschaften.miroso.de/
1100             de => [qw{
1101             aalglatt abenteuerlustig abfällig abgebrüht abgehoben abgeklärt abgestumpft
1102             absprachefähig abwartend abweisend abwägend achtsam affektiert affig aggressiv
1103             agil akkurat akribisch aktiv albern altklug altruistisch ambitioniert
1104             anarchisch angeberisch angepasst angriffslustig angsteinflößend angstvoll
1105             anhänglich anmutig anpassungsfähig ansprechend anspruchslos anspruchsvoll
1106             anstrengend anzüglich arbeitswütig arglistig arglos argwöhnisch arrogant artig
1107             asketisch athletisch attraktiv aufbegehrend aufbrausend aufdringlich aufgedreht
1108             aufgeregt aufgeschlossen aufgeweckt aufhetzerisch aufmerksam
1109             aufmerksamkeitsbedürftig aufmüpfig aufopfernd aufrichtig aufschneiderisch
1110             aufsässig ausdauernd ausdruckslos ausdrucksstark ausfallend ausgeflippt
1111             ausgefuchst ausgeglichen ausländerfeindlich ausnutzbar autark authentisch
1112             autonom autoritär außergewöhnlich barbarisch barmherzig barsch bedacht
1113             bedrohlich bedrückt bedächtig bedürfnislos beeinflussbar befangen befehlerisch
1114             begeistert begeisterungsfähig begierig begnügsam begriffsstutzig behaglich
1115             beharrlich behende beherrscht beherzt behutsam behäbig beirrbar belastbar
1116             belebend beliebt bemüht bequem berechnend beredsam berüchtigt bescheiden
1117             besessen besitzergreifend besonders besonnen besorgt besserwissend
1118             besserwisserisch bestechend bestechlich bestialisch bestimmend bestimmerisch
1119             beständig betriebsam betrügerisch betörend bewandert bewusst bezaubernd bieder
1120             bigott bissig bitter bizarr blasiert blass blauäugig blumig blutrünstig bockig
1121             bodenständig borniert boshaft brav breitspurig brisant brummig brutal bärbeißig
1122             bösartig böse böswillig chaotisch charismatisch charmant chauvinistisch
1123             cholerisch clever cool couragiert damenhaft dankbar defensiv dekadent
1124             demagogisch demütig depressiv derb desorganisiert despotisch destruktiv
1125             determinativ devot dezent dezidiert diabolisch dickhäutig dickköpfig diffus
1126             diktatorisch diplomatisch direkt diskret distanziert distinguiert diszipliniert
1127             disziplinlos divenhaft dogmatisch doktrinär dominant doof dramatisch
1128             dramatisierend draufgängerisch dreist drängend dubios duckmäuserisch duldsam
1129             dumm durchblickend durcheinander durchschaubar durchschauend durchsetzungsstark
1130             durchtrieben dusselig dynamisch dämlich dünkelhaft dünnhäutig echt edel
1131             effizient egoistisch egoman egozentrisch ehrenhaft ehrenwert ehrfürchtig
1132             ehrgeizig ehrlich eifersüchtig eifrig eigen eigenartig eigenbestimmt
1133             eigenbrödlerisch eigenmächtig eigennützig eigensinnig eigenständig eigenwillig
1134             eilig einfach einfallslos einfallsreich einfältig einfühlsam eingebildet
1135             eingeschüchtert einladend einnehmend einsam einsatzbereit einschüchternd
1136             einseitig einsichtig einträchtig eintönig einzelgängerisch einzigartig eisern
1137             eiskalt eitel ekelig elastisch elefantös elegant elitär emotional empathisch
1138             empfindlich empfindsam empfindungsvoll emsig energetisch energiegeladen
1139             energievoll energisch engagiert engstirnig entgegenkommend enthaltsam enthemmt
1140             enthusiastisch entscheidungsfreudig entschieden entschlossen entspannt
1141             enttäuscht erbarmungslos erbärmlich erfinderisch erfolgsorientiert erfrischend
1142             ergeben erhaben erlebnisse ermutigend ernst ernsthaft erotisch erwartungsvoll
1143             exaltiert exorbitant experimentierfreudig extravagant extravertiert
1144             extrovertiert exzentrisch facettenreich fair falsch familiär fantasielos
1145             fantasiereich fantasievoll fantastisch fatalistisch faul feige fein feindselig
1146             feinfühlig feinsinnig feminin fesselnd feurig fies fixiert flatterhaft fleissig
1147             fleißig flexibel folgsam fordernd forsch fragil frech freiheitskämfend
1148             freiheitsliebend freimütig freizügig fremdbestimmend fremdbestimmt freudvoll
1149             freundlich friedfertig friedlich friedliebend friedlos friedselig friedvoll
1150             frigide frisch frohgemut frohnatur frohsinnig fromm frostig fröhlich furchtlos
1151             furchtsam furios fügsam fürsorglich galant gallig gamsig garstig gastfreundlich
1152             gebieterisch gebildet gebührend gedankenlos gediegen geduldig gefallsüchtig
1153             gefährlich gefällig gefügig gefühllos gefühlsbetont gefühlskalt gefühlvoll
1154             geheimnisvoll gehemmt gehorsam gehässig geistreich geizig geladen gelassen
1155             geldgierig geltungssüchtig gemein gemütvoll genauigkeitsliebend generös genial
1156             genügsam gepflegt geradlinig gerecht gerechtigkeitsliebend gerissen gescheit
1157             geschickt geschmeidig geschwätzig gesellig gesprächig gesundheitsbewusst
1158             gewaltsam gewalttätig gewieft gewissenhaft gewissenlos gewitzt gewöhnlich
1159             gierig giftig glamurös glaubensstark gleichgültig gleichmütig gläubig gnadenlos
1160             gottergeben gottesfürchtig grantig grausam grazil griesgrämig grimmig grob
1161             grotesk großherzig großkotzig großmäulig großmütig großspurig großzügig
1162             gräßlich größenwahnsinnig grübelnd gründlich gutgläubig gutherzig gutmütig
1163             gönnerhaft gütig haarspalterisch habgierig habsüchtig halsstarrig harmlos
1164             harmoniebedürftig harmoniesüchtig hart hartherzig hartnäckig hasenherzig
1165             hasserfüllt hedonistisch heimatverbunden heimtückisch heiter hektisch
1166             heldenhaft heldenmütig hellhörig hemmungslos herablassend herausfordernd
1167             heroisch herrisch herrlich herrschsüchtig herzerfrischend herzlich herzlos
1168             hetzerisch heuchlerisch hibbelig hilflos hilfsbereit hingebungsvoll
1169             hinterfotzig hintergründig hinterhältig hinterlistig hinterwäldlerisch
1170             hirnrissig hitzig hitzköpfig hochbegabt hochfahrend hochmütig hochnäsig
1171             hochtrabend humorlos humorvoll hyperkorrekt hysterisch hämisch hässlich
1172             häuslich höflich höflichkeitsliebend höhnisch hübsch ichbezogen idealistisch
1173             ideenreich idiotisch ignorant impertinent impulsiv inbrünstig individualistisch
1174             infam infantil initiativ inkompetent inkonsequent innovativ instinktiv integer
1175             intelektuell intelligent intensiv interessiert intolerant intrigant
1176             introvertiert intuitiv ironisch irre jovial jugendlich jung jähzornig
1177             kalkulierend kalt kaltblütig kaltherzig kaltschnäuzig kapriziös kasuistisch
1178             katzig kauzig keck kess ketzerisch keusch kinderlieb kindisch kindlich klar
1179             kleingeistig kleinkariert kleinlaut kleinlich kleinmütig klug knackig knallhart
1180             knickrig kokett komisch kommunikationsfähig kommunikativ kompetent kompliziert
1181             kompromissbereit konfliktfreudig konfliktscheu konkret konsequent konservativ
1182             konsistent konstant kontaktarm kontaktfreudig kontraproduktiv kontrareligiös
1183             kontrolliert konziliant kooperativ kopffrorm kopflastig kordial korrekt korrupt
1184             kosmopolitisch kraftvoll krank kratzbürstig kreativ kriecherisch
1185             kriegstreiberisch kriminell kritisch kritkfähig kräftig kulant kultiviert
1186             kumpelhaft kurios kämpferisch kühl kühn künstlerisch künstlich labil lachhaft
1187             lahm lammfromm langmütig langweilig larmoyant launisch laut lebendig
1188             lebensbejahend lebensfroh lebenslustig lebhaft leicht leichtfertig leichtfüssig
1189             leichtgläubig leichtlebig leichtsinnig leidenschaftlich leidlich leise
1190             leistungsbereit leistungsstark lernbereit lethargisch leutselig liberal lieb
1191             liebenswert liebevoll lieblich lieblos locker loyal lustlos lustvoll
1192             lösungsorientiert lügnerisch lüstern machtbesessen machtgierig machthaberisch
1193             machthungrig mager magisch manipulativ markant martialisch maskulin
1194             masochistisch materialistisch matriachalisch maßlos melancholisch memmenhaft
1195             menschenscheu menschenverachtend merkwürdig mies mild militant mimosenhaft
1196             minimalistisch misanthropisch missgünstig missmutig misstrauisch mitfühlend
1197             mitleiderregend mitleidlos mitleidslos mitteilsam modisch mollig mondän
1198             moralisch motivierend motiviert musikalisch mutig männerfeindlich mürrisch
1199             mütterlich nachdenklich nachgiebig nachlässig nachsichtig nachtragend naiv
1200             naturfreudig naturverbunden natürlich nebulös neckisch negativ neiderfüllt
1201             neidisch nervig nervös nett neugierig neurotisch neutral nichtssagend
1202             niedergeschlagen niederträchtig niedlich nihilistisch nonchalant normal notgeil
1203             nutzlos nüchtern oberflächlich objektiv obszön offen offenherzig
1204             opportunistisch oppositionell optimistisch ordentlich ordinär ordnungsfähig
1205             ordnungsliebend organisiert orientierungslos originell paranoid passiv patent
1206             patriarchisch patriotisch pedantisch pejorativ penibel perfektionistisch
1207             pervers pessimistisch pfiffig pflegeleicht pflichtbewusst pflichtversessen
1208             phantasievoll philanthropisch phlegmatisch phobisch pingelig planlos plump
1209             polarisierend politisch positiv pragmatisch prinzipientreu problembewusst
1210             profilierungssüchtig progressiv prollig promiskuitiv prophetisch protektiv
1211             provokant prüde psychotisch putzig pünktlich qualifiziert quengelig querdenkend
1212             querulant quicklebendig quirlig quälend rabiat rachsüchtig radikal raffiniert
1213             rastlos ratgebend rational ratlos ratsuchend rau reaktionsschnell reaktionär
1214             realistisch realitätsfremd rebellisch rechthaberisch rechtlos rechtschaffend
1215             redegewandt redelustig redselig reflektiert rege reif reiselustig reizbar
1216             reizend reizvoll religiös renitent reserviert resigniert resolut respektlos
1217             respektvoll reumütig rigoros risikofreudig robust romantisch routineorientiert
1218             ruhelos ruhig ruppig rückgratlos rücksichtslos rücksichtsvoll rüde sachlich
1219             sadistisch sanft sanftmütig sanguinisch sardonisch sarkastisch sauertöpfisch
1220             schadenfroh schamlos scheinheilig scheu schlagfertig schlampig schlau
1221             schmeichelhaft schneidig schnell schnippisch schnoddrig schreckhaft schrullig
1222             schullehrerhaft schusselig schwach schweigsam schwermütig schäbig schöngeistig
1223             schüchtern seicht selbstbewusst selbstdarstellerisch selbstgefällig
1224             selbstgerecht selbstherrlich selbstkritisch selbstlos selbstreflektierend
1225             selbstsicher selbstständig selbstsüchtig selbstverliebt selbstzweifelnd seltsam
1226             senil sensationslüstern sensibel sensitiv sentimental seriös sexistisch sexy
1227             sicherheitsbedürftig sinnlich skeptisch skrupellos skurril smart solidarisch
1228             solide sonnig sorgfältig sorglos sorgsam souverän sparsam spaßig spießig
1229             spirituell spitzfindig spontan sportlich sprachbegabt spritzig sprunghaft
1230             spröde spöttisch staatsmännisch stabil stachelig standhaft stark starr
1231             starrköpfig starrsinnig stereotypisch stilbewusst still stilsicher stilvoll
1232             stinkig stoisch stolz strahlend strategisch streberhaft strebsam streitsüchtig
1233             streng strikt stumpf stur sturköpfig störend störrisch stürmisch subjektiv
1234             subtil suchend suchtgefährdet suspekt sympathisch süchtig tadellos taff
1235             tagträumerisch taktisch taktlos taktvoll talentiert tatkräftig tatlos teamfähig
1236             temperamentlos temperamentvoll tiefgründig tierlieb tolerant toll tollkühn
1237             tollpatschig tough transparent traurig treu trotzig träge träumerisch
1238             trübsinnig tyrannisch töricht tüchtig ulkig umgänglich umsichtig umständlich
1239             umtriebig unabhängig unanständig unantastbar unartig unaufrichtig
1240             unausgeglichen unbedeutend unbeherrscht unbeirrbar unbelehrbar unberechenbar
1241             unbeschreiblich unbeschwert unbesonnen unbeständig unbeugsam undankbar
1242             undiszipliniert undurchschaubar undurchsichtig unehrlich uneigennützig uneinig
1243             unentschlossen unerbittlich unerreichbar unerschrocken unerschütterlich
1244             unerträglich unfair unfein unflätig unfolgsam unfreundlich ungeduldig
1245             ungehorsam ungehörig ungerecht ungeschickt ungesellig ungestüm ungewöhnlich
1246             ungezogen ungezügelt unglaubwürdig ungläubig unhöflich unkompliziert
1247             unkonventionell unkonzentriert unmenschlich unnachgiebig unnahbar unordentlich
1248             unparteiisch unproblematisch unpünktlich unrealistisch unreflektiert unruhig
1249             unsachlich unscheinbar unschlüssig unschuldig unselbständig unsensibel unsicher
1250             unstet unternehmungsfreudig unternehmungslustig untertänig unterwürfig untreu
1251             unverschämt unverwechselbar unverzagt unzufrieden unzuverlässig verachtend
1252             verantwortungsbewusst verantwortungslos verantwortungsvoll verbindlich
1253             verbissen verbittert verbrecherisch verfressen verführerisch vergebend
1254             vergesslich verhandlungsstark verharrend verkopft verlangend verletzbar
1255             verletzend verliebt verlogen verlustängstlich verlässlich vermittelnd
1256             vernetzend vernünftig verrucht verräterisch verrückt verschlagen verschlossen
1257             verschmitzt verschroben verschüchtert versiert verspielt versponnen
1258             verständnislos verständnisvoll verstört vertrauensvoll vertrauenswürdig
1259             verträumt verwahrlost verwegen verwirrt verwundert verwöhnt verzweifelt
1260             vielfältig vielschichtig vielseitig vital vorausschauend voreingenommen vorlaut
1261             vornehm vorsichtig vorwitzig väterlich wagemutig waghalsig wahnhaft wahnsinnig
1262             wahnwitzig wahrhaftig wahrheitsliebend wankelmütig warm warmherzig wechselhaft
1263             wehmütig weiblich weich weinselig weise weitsichtig weltfremd weltoffen wendig
1264             wichtigtuerisch widerlich widerspenstig widersprüchlich widerstandsfähig wild
1265             willenlos willensschwach willensstark willig willkürlich wirsch wissbegierig
1266             wissensdurstig witzig wohlerzogen wohlgesinnt wortkarg wählerisch würdelos
1267             würdevoll xanthippisch zaghaft zappelig zartbesaitet zartfühlend zauberhaft
1268             zaudernd zerbrechlich zerdenkend zerknautscht zerstreut zerstörerisch zickig
1269             zielbewusst zielführend zielorientiert zielstrebig zimperlich zufrieden
1270             zugeknöpft zuhörend zukunftsgläubig zupackend zurechnungsfähig zurückhaltend
1271             zuverlässig zuversichtlich zuvorkommend zwanghaft zweifelnd zwiegespalten
1272             zwingend zäh zärtlich zögerlich züchtig ängstlich ätzend öde überdreht
1273             überemotional überfürsorglich übergenau überheblich überkandidelt überkritisch
1274             überlebensfähig überlegen überlegt übermütig überragend überraschend
1275             überreagierend überschwenglich übersensibel überspannt überwältigent}],
1276             # http://www.roleplayingtips.com/tools/1000-npc-traits/
1277             en => [qw{able abrasive abrupt absent minded abusive accepting
1278             accident prone accommodating accomplished action oriented active
1279             adaptable substance abusing adorable adventurous affable affected
1280             affectionate afraid uncommited aggressive agnostic agreeable alert
1281             alluring aloof altruistic always hungry always late ambiguous
1282             ambitious amiable amused amusing angry animated annoyed annoying
1283             anti-social anxious apathetic apologetic appreciative apprehensive
1284             approachable argumentative aristocratic arrogant artistic ashamed
1285             aspiring assertive astonished attentive audacious austere
1286             authoritarian authoritative available average awful awkward babbling
1287             babyish bad bashful beautiful belligerent bewildered biter
1288             blames others blasé blowhard boastful boisterous bold boorish bored
1289             boring bossy boundless brainy brash bratty brave brazen bright
1290             brilliant brotherly brutish bubbly busy calculating callous calm
1291             candid capable capricious carefree careful careless caring caustic
1292             cautious changeable charismatic charming chaste cheerful cheerless
1293             childish chivalrous civilised classy clean clever close closed clumsy
1294             coarse cocky coherent cold cold hearted combative comfortable
1295             committed communicative compassionate competent complacent compliant
1296             composed compulsive conceited concerned condescending confident
1297             confused congenial conscientious considerate consistent constricting
1298             content contented contrarian contrite controlling conversational
1299             cooperative coquettish courageous courteous covetous cowardly cowering
1300             coy crabby crafty cranky crazy creative credible creepy critical cross
1301             crude cruel cuddly cultured curious cutthroat cynical dainty dangerous
1302             daring dark dashing dauntless dazzling debonair deceitful deceiving
1303             decent decisive decorous deep defeated defective deferential defiant
1304             deliberate delicate delightful demanding demonic dependable dependent
1305             depressed deranged despicable despondent detached detailed determined
1306             devilish devious devoted dignified diligent direct disaffected
1307             disagreeable discerning disciplined discontented discouraged discreet
1308             disgusting dishonest disillusioned disinterested disloyal dismayed
1309             disorderly disorganized disparaging disrespectful dissatisfied
1310             dissolute distant distraught distressed disturbed dogmatic domineering
1311             dorky doubtful downtrodden draconian dramatic dreamer dreamy dreary
1312             dubious dull dumb dutiful dynamic eager easygoing eccentric educated
1313             effervescent efficient egocentric egotistic elated eloquent
1314             embarrassed embittered embraces change eminent emotional empathetic
1315             enchanting encouraging enduring energetic engaging enigmatic
1316             entertaining enthusiastic envious equable erratic ethical evasive evil
1317             exacting excellent excessive excitable excited exclusive expansive
1318             expert extravagant extreme exuberant fabulous facetious faded fair
1319             faith in self faithful faithless fake fanatical fanciful fantastic
1320             fatalistic fearful fearless feisty ferocious fidgety fierce fiery
1321             fighter filthy fine finicky flagging flakey flamboyant flashy fleeting
1322             flexible flighty flippant flirty flustered focused foolish forceful
1323             forgetful forgiving formal fortunate foul frank frantic fresh fretful
1324             friendly frightened frigid frugal frustrated fuddy duddy fun
1325             fun loving funny furious furtive fussy gabby garrulous gaudy generous
1326             genial gentle giddy giggly gives up easily giving glamorous gloomy
1327             glorious glum goal orientated good goofy graceful gracious grandiose
1328             grateful greedy gregarious grieving grouchy growly gruesome gruff
1329             grumpy guarded guilt ridden guilty gullible haggling handsome happy
1330             hard hard working hardy harmonious harried harsh hateful haughty
1331             healthy heart broken heartless heavy hearted hedonistic helpful
1332             helpless hesitant high high self esteem hilarious homeless honest
1333             honor bound honorable hopeful hopeless hormonal horrible hospitable
1334             hostile hot headed huffy humble humorous hurt hysterical ignorant ill
1335             ill-bred imaginative immaculate immature immobile immodest impartial
1336             impatient imperial impolite impotent impractical impudent impulsive
1337             inactive incoherent incompetent inconsiderate inconsistent indecisive
1338             independent indifferent indiscrete indiscriminate indolent indulgent
1339             industrious inefficient inept inflexible inimitable innocent
1340             inquisitive insecure insensitive insightful insincere insipid
1341             insistent insolent instinctive insulting intellectual intelligent
1342             intense interested interrupting intimidating intolerant intrepid
1343             introspective introverted intuitive inventive involved irresolute
1344             irresponsible irreverent irritable irritating jackass jaded jealous
1345             jittery joking jolly jovial joyful joyous judgmental keen kenderish
1346             kind hearted kittenish knowledgeable lackadaisical lacking languid
1347             lascivious late lazy leader lean lethargic level lewd liar licentious
1348             light-hearted likeable limited lineat lingering lively logical lonely
1349             loquacious lordly loud loudmouth lovable lovely loves challenge loving
1350             low confidence lowly loyal lucky lunatic lying macho mad malicious
1351             manipulative mannerly materialistic matronly matter-of-fact mature
1352             mean meek melancholy melodramatic mentally slow merciful mercurial
1353             messy meticulous mild mischievous miserable miserly mistrusting modern
1354             modest moody moping moralistic motherly motivated mysterious nagging
1355             naive narcissistic narrow-minded nasty naughty neat
1356             needs social approval needy negative negligent nervous neurotic
1357             never hungry nibbler nice night owl nihilistic nimble nit picker
1358             no purpose no self confidence noble noisy nonchalant nosy
1359             not trustworthy nuanced nuisance nurturing nut obedient obese obliging
1360             obnoxious obscene obsequious observant obstinate odd odious open
1361             open-minded opinionated opportunistic optimistic orcish orderly
1362             organized ornery ossified ostentatious outgoing outrageous outspoken
1363             overbearing overweight overwhelmed overwhelming paces pacifistic
1364             painstaking panicky paranoid particular passionate passive
1365             passive-aggressive pathetic patient patriotic peaceful penitent
1366             pensive perfect perfectionist performer perserverant perseveres
1367             persevering persistent persuasive pert perverse pessimistic petty
1368             petulant philanthropic picky pious pitiful placid plain playful
1369             pleasant pleasing plotting plucky polite pompous poor popular positive
1370             possessive practical precise predictable preoccupied pretentious
1371             pretty prim primitive productive profane professional promiscuous
1372             proper protective proud prudent psychotic puckish punctilious punctual
1373             purposeful pushy puzzled quarrelsome queer quick quick tempered quiet
1374             quirky quixotic rambunctious random rash rational rawboned realistic
1375             reasonable rebellious recalcitrant receptive reckless reclusive
1376             refined reflective regretful rejects change relaxed relents reliable
1377             relieved religious reluctant remorseful repugnant repulsive resentful
1378             reserved resilient resolute resourceful respectful responsible
1379             responsive restless retiring rhetorical rich right righteous rigid
1380             risk-taking romantic rough rowdy rude rugged ruthless sacrificing sad
1381             sadistic safe sagely saintly salient sanctimonious sanguine sarcastic
1382             sassy satisfied saucy savage scared scarred scary scattered scheming
1383             scornful scrawny scruffy secretive secure sedate seductive selective
1384             self-centered self-confident self-conscious self-controlling
1385             self-directed self-disciplined self-giving self-reliant self-serving
1386             selfish selfless senile sensitive sensual sentimental serene serious
1387             sexual sexy shallow shameless sharp sharp-tongued sharp-witted
1388             sheepish shiftless shifty short shrewd shy silent silky silly simian
1389             simple sincere sisterly skillful sleazy sloppy slovenly slow paced
1390             slutty sly small-minded smart smiling smooth sneaky snob sociable
1391             soft-hearted soft-spoken solitary sore sorry sour spendthrift spiteful
1392             splendid spoiled spontaneous spunky squeamish stately static steadfast
1393             sterile stern stimulating stingy stoical stolid straight laced strange
1394             strict strident strong strong willed stubborn studious stupid suave
1395             submissive successful succinct sulky sullen sultry supercilious
1396             superstitious supportive surly suspicious sweet sympathetic systematic
1397             taciturn tacky tactful tactless talented talkative tall tardy tasteful
1398             temperamental temperate tenacious tense tentative terrible terrified
1399             testy thankful thankless thick skinned thorough thoughtful thoughtless
1400             threatening thrifty thrilled tight timid tired tireless tiresome
1401             tolerant touchy tough trivial troubled truculent trusting trustworthy
1402             truthful typical ugly unappreciative unassuming unbending unbiased
1403             uncaring uncommitted unconcerned uncontrolled unconventional
1404             uncooperative uncoordinated uncouth undependable understanding
1405             undesirable undisciplined unenthusiastic unfeeling unfocused
1406             unforgiving unfriendly ungrateful unhappy unhelpful uninhibited unkind
1407             unmotivated unpredictable unreasonable unreceptive unreliable
1408             unresponsive unrestrained unruly unscrupulous unselfish unsure
1409             unsympathetic unsystematic unusual unwilling upbeat upset uptight
1410             useful vacant vague vain valiant vengeful venomous verbose versatile
1411             vigorous vindictive violent virtuous visual vivacious volatile
1412             voracious vulgar vulnerable warlike warm hearted wary wasteful weak
1413             weary weird well grounded whimsical wholesome wicked wild willing wise
1414             wishy washy withdrawn witty worldly worried worthless wretched
1415             xenophobic youthful zany zealous}], };
1416              
1417             # one way to test this on the command-line:
1418             # perl halberdsnhelmets.pl get --redirect /characters | w3m -T text/html
1419              
1420             sub name {
1421 405     405 0 655 my ($class, $name) = @_;
1422 405 100       672 if ($class eq T('halfling')) { return halfling_name($name) }
  26 100       94  
    100          
1423 45         151 elsif ($class eq T('elf')) { return elf_name($name) }
1424 43         142 elsif ($class eq T('dwarf')) { return dwarf_name($name) }
1425 291         847 return human_name($name);
1426             }
1427              
1428             sub traits {
1429 100     100 0 255 my ($language, $class) = @_;
1430 100         162 local $lang = $language; # make sure T works as intended
1431 100         159 my ($name, $gender) = name($class);
1432 100         263 my $description = "$name, ";
1433 100         136 my $d;
1434 100 100       231 if ($gender eq "F") {
    50          
1435 38         77 $d = d3();
1436             } elsif ($gender eq "M") {
1437 62         127 $d = 3 + d3();
1438             } else {
1439 0         0 $d = d6();
1440             }
1441 100 100       273 if ($d == 1) {
    100          
    100          
    100          
    100          
    50          
1442 6         15 $description .= T('young woman');
1443             } elsif ($d == 2) {
1444 18         37 $description .= T('woman');
1445             } elsif ($d == 3) {
1446 14         29 $description .= T('elderly woman');
1447             } elsif ($d == 4) {
1448 19         38 $description .= T('young man');
1449             } elsif ($d == 5) {
1450 20         39 $description .= T('man');
1451             } elsif ($d == 6) {
1452 23         40 $description .= T('elderly man');
1453             };
1454 100         171 $description .= ", ";
1455 100         133 my $trait = one(@{$traits->{$lang}});
  100         723  
1456 100         192 $description .= $trait;
1457 100         140 my $other = one(@{$traits->{$lang}});
  100         520  
1458 100 50       193 if ($other ne $trait) {
1459 100         162 $description .= " " . T('and') . " " . $other;
1460             }
1461 100         318 return $description;
1462             }
1463              
1464             sub random {
1465 305     305 0 420 my $char = shift;
1466             # keys that can be provided: name, class, charsheet
1467              
1468 305         426 my $class = $char->{class};
1469              
1470 305 50 33     496 my ($str, $dex, $con, $int, $wis, $cha) =
1471             $class eq T('hireling') || $class eq T('porter')
1472             ? (10, 10, 10, 10, 10, 10)
1473             : (roll_3d6(), roll_3d6(), roll_3d6(),
1474             roll_3d6(), roll_3d6(), roll_3d6());
1475              
1476             # if a class is provided, make sure minimum requirements are met
1477 305 50       585 if ($class eq T('dwarf')) {
1478 0         0 $con = roll_3d6() until average($con);
1479             }
1480 305 50       560 if ($class eq T('elf')) {
1481 0         0 $int = roll_3d6() until average($int);
1482             }
1483 305 50       543 if ($class eq T('halfling')) {
1484 0         0 $con = roll_3d6() until average($con);
1485 0         0 $dex = roll_3d6() until average($dex);
1486             }
1487              
1488 305         763 provide($char, "str", $str);
1489 305         583 provide($char, "dex", $dex);
1490 305         599 provide($char, "con", $con);
1491 305         579 provide($char, "int", $int);
1492 305         573 provide($char, "wis", $wis);
1493 305         568 provide($char, "cha", $cha);
1494              
1495 305         575 provide($char, "xp", "0");
1496              
1497 305 50 33     487 if ($class eq T('hireling') or $class eq T('porter')) {
1498 0         0 provide($char, "level", "0");
1499 0         0 provide($char, "thac0", 20);
1500             } else {
1501 305         668 provide($char, "level", "1");
1502 305         494 provide($char, "thac0", 19);
1503             }
1504              
1505 305         630 my $best = best($str, $dex, $con, $int, $wis, $cha);
1506              
1507 305 100       564 if (not $class) {
1508 302 100 100     524 if (average($con) and $best eq "str") {
    100 100        
    100 100        
    100 100        
    100 100        
    100 100        
      100        
      100        
1509 43         73 $class = T('dwarf');
1510             } elsif (average($int)
1511             and good($str, $dex)
1512             and d6() > 2) {
1513 45         68 $class = T('elf');
1514             } elsif (average($str, $dex, $con) == 3
1515             and good($str, $dex, $con)
1516             and d6() > 2) {
1517 26         48 $class = T('halfling');
1518             } elsif (average($str, $dex, $con) >= 2
1519             and ($best eq "str" or $best eq "con")
1520             or good($str, $dex, $con) >= 2) {
1521 44         85 $class = T('fighter');
1522             } elsif ($best eq "int") {
1523 33         61 $class = T('magic-user');
1524             } elsif ($best eq "dex") {
1525 13         21 $class = T('thief');
1526             } else {
1527 98         157 my @candidates = (T('thief'), T('magic-user'), T('fighter'));
1528 98         169 $class = one(@candidates);
1529             }
1530             }
1531              
1532 305         732 provide($char, "class", $class);
1533 305 100       581 unless ($char->{name}) {
1534 303         503 my ($name, $gender) = name($class);
1535 303         799 provide($char, "name", $name);
1536 303         582 $char->{gender} = $gender; # don't put it on the character sheet
1537             }
1538              
1539 305 100       537 unless ($char->{gender}) {
1540 2         16 my ($name, $gender) = name($class, $char->{name});
1541 2         6 $char->{gender} = $gender; # don't put it on the character sheet
1542             }
1543              
1544 305 100       524 if ($class eq T('halfling')) {
1545 26         52 provide($char, "range-thac0", 18 - bonus($dex));
1546             }
1547              
1548              
1549 305         555 my $level = $char->{level};
1550 305         440 my $hp = $char->{hp};
1551 305 50       525 if (not $hp) {
1552 305 100 100     467 if ($class eq T('fighter') or $class eq T('dwarf')) {
    100 100        
1553 124         515 $hp += max(1, d8() + bonus($con)) for 1.. $level;
1554             } elsif ($class eq T('elf') or $class eq T('halfling')) {
1555 71         247 $hp += max(1, d6() + bonus($con)) for 1.. $level;
1556             } else {
1557 110         451 $hp += max(1, d4() + bonus($con)) for 1.. $level;
1558             }
1559             }
1560 305         792 provide($char, "hp", $hp);
1561              
1562 305         657 equipment($char);
1563              
1564 305         613 my $abilities = abilities($char);
1565             # spellbook
1566 305 100 100     505 if ($class eq T('magic-user') or $class eq T('elf')) {
1567 112         213 $abilities .= "\\\\" . spellbook();
1568             }
1569              
1570 305         759 provide($char, "abilities", $abilities);
1571              
1572 305 50       642 if (not $char->{charsheet}) {
1573 305 50 33     449 if ($class eq T('hireling') or $class eq T('porter')) {
    50          
1574 0         0 provide($char, "charsheet", T('Hireling.svg'));
1575             } elsif ($char->{landscape}) {
1576 0         0 provide($char, "charsheet", T('Charactersheet-landscape.svg'));
1577             } else {
1578 305         497 provide($char, "charsheet", T('Charactersheet.svg'));
1579             }
1580             }
1581             }
1582              
1583             sub abilities {
1584 305     305 0 419 my $char = shift;
1585 305         458 my $class = $char->{class};
1586 305         445 my $abilities = T('1/6 for normal tasks');
1587 305 100       538 if ($class eq T('elf')) {
    100          
    100          
    100          
1588 45         90 $abilities .= "\\\\" . T('2/6 to hear noise');
1589 45         76 $abilities .= "\\\\" . T('2/6 to find secret or concealed doors');
1590             } elsif ($class eq T('dwarf')) {
1591 43         84 $abilities .= "\\\\" . T('2/6 to hear noise');
1592 43         94 $abilities .= "\\\\" . T('2/6 to find secret constructions and traps');
1593             } elsif ($class eq T('halfling')) {
1594 26         44 $abilities .= "\\\\" . T('2/6 to hear noise');
1595 26         54 $abilities .= "\\\\" . T('2/6 to hide and sneak');
1596 26         55 $abilities .= "\\\\" . T('5/6 to hide and sneak outdoors');
1597 26         48 $abilities .= "\\\\" . T('+1 bonus to ranged weapons');
1598 26         48 $abilities .= "\\\\" . T('AC -2 vs. opponents larger than humans');
1599             } elsif ($class eq T('thief')) {
1600 43         76 my $level = $char->{level};
1601 43         100 my $n = 2 + int($char->{level} / 3);
1602 43 50       90 $n = 5 if $n > 5;
1603             # override the 1/6 for normal tasks
1604 43         63 $abilities = sprintf(T('%d/6 for all activities'), $n);
1605 43         93 $abilities .= "\\\\" . T('+4 to hit and double damage backstabbing');
1606             }
1607 305         619 return $abilities;
1608             }
1609              
1610             sub classes {
1611             return {
1612 0     0 0 0 T('dwarf') => "D",
1613             T('elf') => "E",
1614             T('halfling') => "H",
1615             T('fighter') => "F",
1616             T('magic-user') => "M",
1617             T('thief') => "T",
1618             };
1619             }
1620              
1621             sub random_parameters {
1622 305     305 0 486 my ($char, $language) = @_;
1623 305         464 local $lang = $language; # make sure T works as intended
1624 305         619 random($char);
1625             # choose a random portrait based on the character gender or class
1626 305 100       682 if (member("portrait", @_)) {
1627 5 50       23 provide($char, "portrait", portrait($char)) unless $char->{portrait};
1628             }
1629             }
1630              
1631             sub portrait {
1632 5     5 0 26 my $char = shift;
1633 5 50       23 my $face_generator_url = app->config("face_generator_url") or return '';
1634 0         0 my $gender = $char->{gender};
1635 0 0 0     0 if ($char->{class} eq T('elf')
    0 0        
    0          
    0          
1636             or $char->{race} eq T('elf')) {
1637 0         0 $gender = "elf";
1638             } elsif ($char->{class} eq T('dwarf')
1639             or $char->{race} eq T('dwarf')) {
1640 0         0 $gender = "dwarf";
1641             } elsif ($gender eq "F") {
1642 0         0 $gender = "woman";
1643             } elsif ($gender eq "M") {
1644 0         0 $gender = "man";
1645             } else {
1646 0         0 $gender = one("woman", "man");
1647             }
1648 0         0 my $url = Mojo::URL->new("$face_generator_url/redirect/alex/$gender");
1649 0         0 my $ua = Mojo::UserAgent->new;
1650 0         0 my $tx = $ua->get($url);
1651 0 0       0 if ($tx->res->code == 302) {
1652 0         0 $url->path($tx->res->headers->location);
1653             } else {
1654             $log->warn("Did you configure the face_generator_url setting in the config file correctly? "
1655             . "It is currently set to $face_generator_url. "
1656             . ($tx->res->code
1657             ? "It returns: " . $tx->res->code . " " . $tx->res->message
1658 0 0       0 : "The error: " . $tx->res->error->{message}));
1659             }
1660 0         0 return $url;
1661             }
1662              
1663             sub characters {
1664 2     2 0 5 my ($char, $lang) = @_;
1665 2         22 my @characters;
1666 2         9 for (my $i = 0; $i < 50; $i++) {
1667 100         338 my %one = %$char; # defaults
1668 100         273 random_parameters(\%one, $lang);
1669 100         289 $one{traits} = traits($lang, $char->{class});
1670 100         422 push(@characters, \%one);
1671             }
1672 2         19 return \@characters;
1673             }
1674              
1675             sub stats {
1676 2     2 0 5 my ($char, $language, $n) = @_;
1677 2         5 local $lang = $language; # make sure T works as intended
1678 2         4 my (%class, %property);
1679 2         7 for (my $i = 0; $i < $n; $i++) {
1680 200         534 my %one = %$char; # defaults
1681 200         458 random_parameters(\%one, $lang);
1682 200         446 $class{$one{class}}++;
1683 200         1017 foreach (split(/\\\\/, $one{property})) {
1684 2385         4492 $property{$_}++;
1685             }
1686             }
1687              
1688 2         4 $n = 0;
1689 2         5 my $txt = T('Classes') . "\n";
1690 2         20 foreach (sort { $class{$b} <=> $class{$a} } keys %class) {
  20         36  
1691 12         36 $txt .= sprintf "%25s %4d\n", $_, $class{$_};
1692 12         45 $n += $class{$_};
1693             }
1694 2         10 $txt .= sprintf "%25s %4d\n", "total", $n;
1695              
1696 2         6 $txt .= T('Property') . "\n";
1697 2         47 foreach (sort { $property{$b} <=> $property{$a} }
  656         885  
1698             keys %property) {
1699 140 100 66     371 next if /starting gold:/ or /gold$/;
1700 108 100 66     267 next if /Startgold:/ or /Gold$/;
1701 72         192 $txt .= sprintf "%25s %4d\n", $_, $property{$_};
1702             }
1703 2         70 return $txt;
1704             }
1705              
1706             sub url_encode {
1707 0     0 0 0 my $str = shift;
1708 0 0       0 return '' unless defined $str;
1709 0         0 utf8::encode($str);
1710 0         0 my @letters = split(//, $str);
1711 0         0 my %safe = map {$_ => 1} ("a" .. "z", "A" .. "Z", "0" .. "9", "-", "_", ".", "!", "~", "*", "\"", "(", ")", "#");
  0         0  
1712 0         0 foreach my $letter (@letters) {
1713 0 0       0 $letter = sprintf("%%%02x", ord($letter)) unless $safe{$letter};
1714             }
1715 0         0 return join('', @letters);
1716             }
1717              
1718             sub init {
1719 20     20 0 41 my $self = shift;
1720 20         58 my %char = %{$self->req->params->to_hash};
  20         70  
1721 20         8051 my @provided; # We want to remember the order!
1722 20         53 my @pairs = @{$self->req->params->pairs};
  20         71  
1723 20         446 while (@pairs) {
1724 100         143 my $key = shift @pairs;
1725 100         139 my $value = shift @pairs;
1726 100         192 push(@provided, $key);
1727             }
1728 20         57 $char{provided} = \@provided;
1729 20         55 return \%char;
1730             }
1731              
1732             sub lang {
1733 7     7 0 15 my $self = shift;
1734 7         52 my $acceptor = I18N::AcceptLanguage->new(defaultLanguage => "en");
1735 7         241 return $acceptor->accepts($self->req->headers->accept_language, [qw(en de)]);
1736             }
1737              
1738             plugin "Config" => {default => {}};
1739              
1740             get "/" => sub {
1741             my $self = shift;
1742             $self->redirect_to($self->url_with("main" => {lang => lang($self)}));
1743             };
1744              
1745             get "/:lang" => [lang => qr/(?:en|de)/] => sub {
1746             my $self = shift;
1747             my $lang = $self->param("lang");
1748             my $query = $self->req->query_params->to_string;
1749             if ($query) {
1750             # deprecated
1751             $query =~ tr/;/&/;
1752             my $params = Mojo::Parameters->new($query);
1753             return $self->redirect_to($self->url_for("char" => {lang => $lang})->query(@$params));
1754             }
1755             $self->render(template => "index.$lang");
1756             } => "main";
1757              
1758             get "/help" => "help";
1759              
1760             get "/hilfe" => "hilfe";
1761              
1762             get "/random" => sub {
1763             my $self = shift;
1764             $self->redirect_to($self->url_with("random" => {lang => lang($self)}));
1765             };
1766              
1767             get "/random/text/:lang" => sub {
1768             my $self = shift;
1769             my $char = init($self);
1770             my $lang = $self->param("lang");
1771             random_parameters($char, $lang, "portrait");
1772             compute_data($char, $lang);
1773             $self->render(template => "text.$lang",
1774             format => "txt",
1775             char => $char);
1776             } => "text";
1777              
1778             get "/random/:lang" => [lang => qr/(?:en|de)/] => sub {
1779             my $self = shift;
1780             my $char = init($self);
1781             my $lang = $self->param("lang");
1782             random_parameters($char, $lang, "portrait");
1783             compute_data($char, $lang);
1784             my $svg = svg_transform($self, svg_read($char));
1785             $self->render(format => "svg",
1786             data => $svg->toString());
1787             } => "random";
1788              
1789             get "/char" => sub {
1790             my $self = shift;
1791             $self->redirect_to($self->url_with("char" => {lang => lang($self)}));
1792             };
1793              
1794             get "/char/:lang" => [lang => qr/(?:en|de)/] => sub {
1795             my $self = shift;
1796             my $char = init($self);
1797             my $lang = $self->param("lang");
1798             # no random parameters
1799             compute_data($char, $lang);
1800             my $svg = svg_transform($self, svg_read($char));
1801             $self->render(format => "svg",
1802             data => $svg->toString());
1803             } => "char";
1804              
1805             # deprecated
1806             get "/link/:lang" => [lang => qr/(?:en|de)/] => sub {
1807             my $self = shift;
1808             my $lang = $self->param("lang");
1809             my $query = $self->req->query_params;
1810             $query =~ tr/;/&/;
1811             my $params = Mojo::Parameters->new($query);
1812             $self->redirect_to($self->url_for("edit" => {lang => lang($self)})->query(@$params));
1813             };
1814              
1815             get "/edit" => sub {
1816             my $self = shift;
1817             $self->redirect_to(edit => {lang => lang($self)});
1818             };
1819              
1820             get "/edit/:lang" => [lang => qr/(?:en|de)/] => sub {
1821             my $self = shift;
1822             my $char = init($self);
1823             my $lang = $self->param("lang");
1824             $self->render(template => "edit.$lang",
1825             char => $char);
1826             } => "edit";
1827              
1828             get "/redirect" => sub {
1829             my $self = shift;
1830             $self->redirect_to($self->url_with("redirect" => {lang => lang($self)}));
1831             };
1832              
1833             get "/redirect/:lang" => [lang => qr/(?:en|de)/] => sub {
1834             my $self = shift;
1835             my $lang = $self->param("lang");
1836             my $input = $self->param("input");
1837             my $params = Mojo::Parameters->new;
1838             my $last;
1839             while ($input =~ /^([-a-z0-9]*): *(.*?)\r?$/gm) {
1840             if ($1 eq $last or $1 eq "") {
1841             $params->param($1 => $params->param($1) . "\\\\$2");
1842             } else {
1843             $params->append($1 => $2);
1844             $last = $1;
1845             }
1846             }
1847             $self->redirect_to($self->url_for("char" => {lang => $lang})->query($params));
1848             } => "redirect";
1849              
1850              
1851             get "/show" => sub {
1852             my $self = shift;
1853             my $char = init($self);
1854             my $svg = svg_show_id(svg_read($char));
1855             $self->render(format => "svg",
1856             data => $svg->toString());
1857             } => "show";
1858              
1859             get "/characters" => sub {
1860             my $self = shift;
1861             $self->redirect_to($self->url_with("characters" => {lang => lang($self)}));
1862             };
1863              
1864             get "/characters/:lang" => [lang => qr/(?:en|de)/] => sub {
1865             my $self = shift;
1866             my $lang = $self->param("lang");
1867             my $char = init($self);
1868             $self->render(template => "characters.$lang",
1869             width => "100%",
1870             characters => characters($char, $lang));
1871             } => "characters";
1872              
1873             get "/stats" => sub {
1874             my $self = shift;
1875             $self->redirect_to($self->url_with("stats" => {lang => lang($self),
1876             n => 100}));
1877             };
1878              
1879             get "/stats/:n" => [n => qr/\d+/] => sub {
1880             my $self = shift;
1881             my $n = $self->param("n");
1882             $self->redirect_to($self->url_with("stats" => {lang => lang($self),
1883             n => $n}));
1884             };
1885              
1886             get "/stats/:lang" => [lang => qr/(?:en|de)/] => sub {
1887             my $self = shift;
1888             my $lang = $self->param("lang");
1889             $self->redirect_to($self->url_with("stats" => {lang => $lang,
1890             n => 100}));
1891             };
1892              
1893             get "/stats/:lang/:n" => [lang => qr/(?:en|de)/, n => qr/\d+/] => sub {
1894             my $self = shift;
1895             my $lang = $self->param("lang");
1896             my $n = $self->param("n");
1897             my $char = init($self);
1898             $self->render(format => "txt",
1899             text => stats($char, $lang, $n));
1900             } => "stats";
1901              
1902             app->secrets([app->config("secret")]) if app->config("secret");
1903              
1904             app->start;
1905              
1906             __DATA__