Of Moose and Men, well Class really!
I left off on my last post stubbing in a little code to take care of loading my 'Player Class' (Fighter, Thief etc) into my 'Character' class. I did mention that there are some real subtle rules, I will look at just one of them.
Unfortunately 'Mordol the Moose' rolled a '1' and failed his 'Saving Throw' vs traps and ended up like this;
Like 'Player Class' at first glance it looks very simple thing to do '4 Player Classes' and '5 types of saving throws' for each. Well what happens if you player is 'Mutil-Classed' such as 'Gutboy Barlehouse' a 9th/8th level Dwarf Fighter/Thief. In the game saving throws for a muti-classed player always use the most favorable result from the tables. So there are times when 'Gutboy' saves as a thief or saves as a fighter.
Well how to model that? One really had to fight the old habit of just creating a 'FighterThief' as I would have to eventually make at least 13 new classes or roles and I am just too lazy for that. Even worse I could just write the super if-else-given-when function from hell that covers all situations.
So the first thing I did was create a "Fighter::SavingThrows" and a "Thief::SavingThrows" role that I can reuse here they are, (to save space I just put in save_vs_WSR throw).
package Thief::SaveingThrows;
use Moose::Role;
requires 'level';
sub save_vs_WSR {
my $self = shift;
my ($bonus,$level) = @_;
$level = $level||$self->level;
if ($level >= 21 ){
return 2
if ((4 - $bonus) <=1);
return (4 - $bonus);
};
my $save = 14;
my $save_level = (($level-1)/4);
$save = $save - (int($save_level)*2);
return $save - $bonus
if ($save - $bonus >=2);
return 2;
}
package Fighter::SaveingThrows;
use Moose::Role;
requires 'level';
sub save_vs_WSR {
my $self = shift;
my ($bonus,$level) = @_;
$level = $level||$self->level;
return 18 - $bonus
if ($level <= 0);
if ($level >= 17 ){
return 2
if ((5 - $bonus) <=1);
return (5 - $bonus);
};
my $save = 18;
given ($level){
when ([1..2]){
$save--;
};
when ([7..10]){
$save++;
};
when ([11..14]){
$save+=2;
};
when ([15..16]){
$save+=3;
};
};
if ($level %2){
$save = $save - $level;
}
else {
$save-= ($level-1);
}
return $save - $bonus
if ($save - $bonus >=2);
return 2;
}
Next I have to play with the 'BEGIN' in my 'Character' class a little to take either a string of a single class or a 'hashref' of classes where the 'key' is my 'Character Class' and the value is the current level. Something like this
my $self = shift;
my ($attr) = @_;
my $race = $self->race();
$attr->{self} = $self;
if (ref($self->class) eq 'HASH'){
$attr->{attr} = $attr;
apply_all_roles($self,("MultiClassed",=>$attr));
}
else {
apply_all_roles($self,( $self->class,=>$attr));
}
...
So what I did was create a new MooseX::Role::Parameterized 'MultiClassed' that I will do all the annoying subtle rule work for me. Note now that I also pass in the "$attr" as the attr param you will see why in the moment.
So here is my 'MultiClassed' role
package MultiClassed;
use MooseX::Role::Parameterized;
use Moose::Util qw(apply_all_roles throw_exception );
parameter self => (
isa => 'Character',
required => 1,
);
parameter attr => (
isa => 'HashRef',
required => 1,
);
parameter class => (
isa => 'HashRef',
required => 1,
);
role {
my $params = shift;
my $classes = $params->class();
foreach my $class (keys(%{$classes})){
my $new_attr = $params->attr();
$new_attr->{aliases }={$class.'::SaveingThrows'=>{-alias =>{ save_vs_WSR =>$class.'_save_vs_WSR'},
-excluded =>'save_vs_WSR'}};
apply_all_roles($params->self(),($class,=>$new_attr));
}
sub save_vs_WSR {
my $self = shift;
my ($bonus) = @_;
$bosus = 0 || $bonus;
my $return = 20;
foreach my $class (keys(%{$self->class})){
my $throw = $class.'_save_vs_WSR';
my $save = $self->$throw($bonus,$self->class->{$class});
$return = $save
if ($save < $return);
}
return $return;
};
};
So what am I doing here. I am first passing along, to any roles I add, the original attr hashref as they may want something from it. I am passing in a new hashref 'aliases' of the 'subs' I want to alias and exclude for the roles I am going to be using in this role. The same way I did with ExceptionSthrength. I do have to modify the Fighter and Thief role a little like this;
package Fighter;
use MooseX::Role::Parameterized;
use Moose::Util qw(apply_all_roles find_meta throw_exception );
parameter self => ( isa => 'Character',
required => 1,);
parameter attr => ( isa => 'HashRef',
required => 1, );
parameter exceptional => ( isa => 'Int',);
role {
my $params = shift;
requires 'strength';
my $aliases = $params->attr()->{aliases};
apply_all_roles($params->{self}, qw(Fighter::SaveingThrows),=>$aliases->{'Fighter::SaveingThrows'});
if ($params->self()->strength() == 18){
apply_all_roles($params->self(), qw(ExceptionalStrength));
$params->self()->exceptional($params->exceptional());
if ($params->self()->exceptional() >90 and $params->self()->exceptional() <=99){
apply_all_roles($params->{self}, qw(OpenBarredDoorsOnA1));
}
elsif ($params->self()->exceptional() ==0 ){
apply_all_roles($params->self(), qw(OpenBarredDoorsOnA1));
}
}
};
and for thief role;
package Thief;
use MooseX::Role::Parameterized;
use Moose::Util qw(apply_all_roles find_meta throw_exception );
parameter self => (
isa => 'Character',
required => 1, );
parameter attr => (
isa => 'HashRef',
required => 1, );
parameter dexterity => (
isa => 'Int', );
role {
my $params = shift;
requires 'dexterity';
my $aliases = $params->attr()->{aliases};
apply_all_roles($params->{self}, qw(Thief::SaveingThrows),=>$aliases->{'Thief::SaveingThrows'});
};
Now lets see if it works
my $str = Character->new({class=>{Fighter=>9,Thief=>8},dexterity=>9,constitution=>18,charisma=>18,race=>'Dwarf',name=>'Gutboy Barlehouse',strength=>18,exceptional=>91});
print $str->name()."\n";
print "Saves vs WSR= ".$str->save_vs_WSR();
Gutboy Barlehouse
Saves vs WSR= 6
No way man. A 'level 9' fighter saves at '10' and a 'level 8' Thief saves at '12' so what gives DM??
Well you forgot that 'Gutboy' has a +4 bonus for being a Dwarf with 18 constitution.
Moose even remembers that stuff form me even though it is buried deep in the code.
I am quite hapy with it. There is of course some clean up to do at least I know it will work.
Long time Perl guy, a few CPAN mods allot of work on DBD::Oracle and a few YAPC presentations
Leave a comment