Programmer: new to the area… seeks support

Back in the day, I took a writing course in a special fine arts program. The advise that the professional writer gave us aspiring novelists and poets was to put an ad in the paper when you move to a new place. “Writer; new to the area… seeks support.” Something like that. His point was that we weren’t going to get any better without having some good feedback from our fellow craftsmen. We need to form little groups where we share what we’re working on– not just for tips about style and technique, but also just to get the encouragement we need to persevere. (Also, he told us to watch out for the pompous guys in the turtle necks with pipes: these guys are expert at looking like “writers” without actually ever writing anything!)

Fast forward to today. I’m a professional “programmer”… but most of my colleagues have no interest in sharing code and discussing it. (At the last place I worked, the other guys would roll their eyes at any request I would make for design meetings or brief “show and tell” type exchanges.) Maybe it’s different in your area of expertise, but the general attitude appears to be that folks want to just be left alone to do things their own way. In some cases, I doubt that we even a common framework or language from which to discuss good design principles…. (I’m sure Alan Kay has noticed something like this and maybe even cited it as evidence that we’re still in the dark ages of programming….)

Similarly, I remember an art teacher I had. I asked him how to get good at drawing. He said everyone has a million bad drawings in them and that the sooner you get those out of the way, the more likely you are to get good. Learning a new programming language is like that, except… I guess it’s more like you have to get 100 bad short programs out of the way… and then you have to get at least 10 medium sized programs out of the way.

So here I am learning Perl in general and Moose in particular. Definitely “new to the area” in that department! Also, I have below my second “bad” medium sized program for this platform. There are a lot of directions I can go with this stuff, but I’d like to tune things up some more before I get too deep into anything else. Please feel free to jump in with your comments if you’re into it. Here are a few random notes:

* Installing Moose on cygwin didn’t work for me. I tried a few different ways, but always got hung up on the dependencies.

* Installing Moose on Windows was pretty painless. Whatever the package manager was that I used, it worked great.

* The default shell for Emacs on Windows is pretty retarded. The whole concept of STDIN seems gone there…. Argh….

* You can’t seem to cut and paste text from a standard Windows console window. Argh.

* In the code below, I haven’t completely refactored the Parser to be completely “Moose-ish”. I did factor out a Table object, though.

* There are a few instances of cut & paste code repetition below.

* The program attempts to implement a strict by-the-book character generation sequence for Classic Traveller. I used the revised rules from The Traveller Book. (All classic Traveller materials are available on CD-Rom from FFE. Mongoose has recently released a new version of the game. e23 and Comstar both have pdf products available. I’m partial to the original stuff, myself.) There are other character generation programs floating around, but I’m not sure how well they tend to follow the rules as written.

* The current design is mostly data-driven. Someone that knows Traveller should be able to customize the program to some extent without knowing Perl. I would like to extend the capabilities of the configuration language so that ordinary joes can hack things into whatever houserules they’ve cooked up. My concept for this would be something halfway between 8-bit BASIC and a spreadsheet… but slightly OOPish, maybe. Maybe I should write a compiler to convert the script file into standard Perl? I dunno…. We’ll see where this goes….

* After cleaning up the program as it stands, I should be in a position to code up other chargen schemes (as my spare time allows)… and I should have an opportunity to use more of Moose’s features then. Going forward (assuming I go forward) I would want to strike some sort of balance between improving the generic parser tool and adding more scope and comprehensiveness to the generator. I wouldn’t want to have a perfect parser that isn’t implementing anything… and I wouldn’t want my code to turn to sludge and then collapse under the weight of its own scope, either. At some point, I do want the hypothetical “power user” to be able to make this work however they want, though.

#!/usr/bin/perl
package Routines;

# get random number from 0 to n-1 using rand function
sub get_rand { int (rand $_[0]); }

sub d_six { return get_rand(6) + 1; }

sub two_d_six { return d_six() + d_six(); }

# TODO: This routine should omit I and O results to be real 'Traveller extended-hex' values
sub tr_hex {
    my $num = shift;
    return 0 if $num <= 0;
    return $num if $num <= 9;
    die "$num is greater than 36-- too big for 'hex' conversion" if $num > 36;
    return chr($num + 64 - 9);
}
    
###################################################################################################
    
package Callback;
use Moose;

sub process {
    print "Hello World!\n";
}

sub choose {
    my ($self, $text) = @_;
    my @options = split /;/, $text;
    #print "the text is $text\n";
    my $i = 0;
    print "\n";
    foreach(@options){
        $i++;
        print "$i: $_\n";
    }
    
    my $answer;
    until ($answer) {
        print ">> ";
        chomp(my $line = <STDIN>);
        if ($line =~ /^\d+$/) {
            $answer = $options[$line - 1];
        } else {
            foreach(@options){
                if(/^$line/i){
                    $answer = $_;
                    last;
                }
            }
        }
    }
    return $answer;
}

###################################################################################################

package Table;
use Moose;

my $show_debug2 = 0;

has Name => (is => 'rw', isa => 'Str', default => 'Bob');
has 'Rows' => (isa => 'HashRef', is => 'rw', default => sub { my %hash; return \%hash; } ); 
has 'Columns' => (isa => 'ArrayRef[Str]', is => 'rw', default => sub { my @a; return \@a; } );
has 'ColumnRegexes' => (isa => 'ArrayRef[Str]', is => 'rw', default => sub { my @a; return \@a; } );

sub initialize {
    my ($self, $table, $text) = @_;
    $self->Name($table);
    my ($columns, $column_regexes) = parse_column_header($text);
    $self->Columns($columns);
    $self->ColumnRegexes($column_regexes);
    my %rows;
    $self->Rows(\%rows);
}

sub load_line {
    my ($self, $text) = @_;
    my ($rowkey, $row) = parse_row_detail($self->Name(), $text, $self->Columns());
    $self->Rows->{$rowkey} = $row;
}

sub cell {
    my ($self, $row, $column) = @_;
    return $self->Rows->{$row}->{$column};
}

### pass a comma delimited header line from a table definition
### and get two array references describing the table structure
sub parse_column_header {
    my ($line) = @_;
    my @fields = split /,/, $line;
    my $column_number = 0;
    my @columns;
    my @regexes;
    print "reading columns to table: $line\n" if $show_debug2;
    foreach(@fields){
        my $field = $_;
        $field =~ s/^\s+|\s+$//g; # trim field
        if($field =~ /^([^\/]*)\/([^\/]*)\//){
            $field = $1;
            $regexes[$column_number] = $2;
        }
        $columns[$column_number] = $field;
        $column_number++;
    }
    return (\@columns, \@regexes);
}

### pass a table name and a comma delimited header line from a table definition
### and also pass a reference to an array of column names...
### and get the row's key and a hash of detail data
sub parse_row_detail {
    my ($table, $line, $columns) = @_;
    my @fields = split /,/, $line;
    print "reading rows to table $table: $line\n" if $show_debug2;
    my %row;
    my $column_number = 0;
    my $rowkey;
    my $didit;
    foreach(@fields){
        my $field = $_;
        $field =~ s/^\s+|\s+$//g; # trim field
        # Need to allow some keys to be '0'!
        if ($didit){
            $row{$columns->[$column_number]} = $field;
        } else {
            $rowkey = $field;
        }
        $column_number++;
        $didit = 1;
    }
    return ($rowkey, \%row);
}

sub show_keys {
    my ($self) = @_;
    my $key;
    my $table = $self->Name();
    my $rs = $self->Rows();
    foreach $key (sort keys %{$rs}){
        print "$table row    : $key\n";
    }
    my $cs = $self->Columns();
    foreach (@{$cs}){
        print "$table column : $_\n";
    }
}

###################################################################################################

package Parser;
use Moose;

has 'Tables' => (isa => 'HashRef[Table]', is => 'rw', default => sub { my %hash; return \%hash; } );
has ReadAsTable => (isa => 'HashRef[Table]', is => 'rw', default => sub { my %hash; return \%hash; } );

my $read_type = 0;
my $current_table = "None";
my %widgets;
my $current_widget = "None";
my $widget_parser_sub = \&reading_widget_fields;
my $show_debug = 0;

my $lame_hack;

sub lameness {
    my $self = shift;
    $lame_hack = $self;
}

sub cell {
    my ($self, $table, $key, $column) = @_;
    return $self->Tables->{$table}->cell($key, $column);
}

sub show_keys {
    my ($self, $table) = @_;
    if ($table){
        $self->Tables()->{$table}->show_keys();
    } else {
        foreach my $key (sort keys %{$self->Tables()}){
            print "Table: $key\n";
        }        
    }
}

### why can't I call my properties without $self?
sub reading_table_header {
    my ($line) = @_;
    my $T = new Table();
    $T->initialize($current_table, $line);
    $lame_hack->Tables()->{$current_table} = $T;
    $read_type = 2;
}

sub reading_table_detail {
    my ($line) = @_;
    my $T = $lame_hack->Tables()->{$current_table};
    $T->load_line($line);
}

my %dispatch_data = (

    '^Table ([A-Za-z]+):'  => {
        code    => sub { $current_table = $1; $read_type = 1 },
        debug   => sub { print "(reading table $1)\n" },
    },

    '^\#(.*)' => {
        code  => {},
        debug   => sub { print "found a comment: $1\n" },
    },

    '^[\w]*$' => {
        code    => sub { $read_type = 0 },
        debug   => sub { print "(Whitespace line)\n" },
    },
    
    '^ReadCell "([^"]+)" As "([^"]+)"' => {
        code    => sub { $lame_hack->ReadAsTable->{$1} = $2; },
        debug   => sub { print "(Whitespace line)\n" },
    },
    
    );

# build the dispatch table-- but only for regex's with code or debug routines
### (thanks to draegtun again)
my $dispatch_table = {};
while ( my ( $regex, $dispatch ) = each %dispatch_data ) {
    $dispatch_table->{ $regex } = sub {
        $dispatch->{ code  }->()  if exists $dispatch->{ code };
        $dispatch->{ debug }->()  if $show_debug;
    } if exists $dispatch->{ code } or ($show_debug and exists $dispatch->{ debug });
}

my $alternate_dispatch_table =
    { 1 => \&reading_table_header,
      2 => \&reading_table_detail,
    };

sub parse {
    my $self = shift;
    my ($file) = @_;
    #print "You are trying to open $file.\n";
    open SCRIPT, "< $file";
    while (<SCRIPT>) {
        my $line = $_;
        my $success = 0;
        my $key;
        foreach $key (sort keys %{$dispatch_table}) {
            if ($line =~ /$key/){
                $dispatch_table->{$key}->();
                $success = 1;
                last;
            }
        }
        if ($success == 0 and $read_type > 0) {
            chomp($line);
            my $altcode = $alternate_dispatch_table->{$read_type};
            $altcode->($line);
        }
    }
    close SCRIPT;
    
}

###################################################################################################

package Character;
use Moose;
#use Parser;

has 'Callback' => (isa => 'Callback', is => 'rw', default => sub { Callback->new(); } );
has 'Environment' => (isa => 'Parser', is => 'rw', default => sub { my $P = Parser->new();
                                                                    $P->lameness();
                                                                    $P->parse('BookOne.dat');
                                                                    return $P;} );

has 'AttributeNames' => (isa => 'ArrayRef[Str]', is => 'rw');
has 'AttributeValues' => (isa => 'ArrayRef[Int]', is => 'rw', default => sub { my @a; return \@a; });
has 'Commissioned' => (isa => 'Bool', is => 'rw');
has 'Terms' => (isa => 'Int', is => 'rw');
has 'Rank' => (isa => 'Int', is => 'rw');
has 'Cash' => (isa => 'Int', is => 'rw');
has 'UnspentBenefits' => (isa => 'Int', is => 'rw');
has 'CashRollsTaken' => (isa => 'Int', is => 'rw');
has 'Alive' => (isa => 'Bool', is => 'rw');
has 'Skills' => (isa => 'HashRef[Int]', is => 'rw');
has 'Benefits' => (isa => 'HashRef[Int]', is => 'rw');
has 'ServiceName' => (isa => 'Str', is => 'rw');
has 'Service' => (isa => 'Int', is => 'rw');
has 'Drafted' => (isa => 'Bool', is => 'rw');
has 'Reenlisted' => (isa => 'Bool', is => 'rw');
has 'SkillsToPick' => (isa => 'Int', is => 'rw');
has 'BenefitsToPick' => (isa => 'Int', is => 'rw');

sub set_attributes {
    my $self = shift;
    for(0..5){
        $self->AttributeValues->[$_] = Routines::two_d_six();
    }
}

sub initialize {
     my $self = shift;
     my @Attributes = qw/Strength Dexterity Endurance Intelligence Education Social/;
     $self->AttributeNames(\@Attributes);
     $self->Commissioned(0);
     $self->Terms(0);
     $self->Rank(0);
     $self->Cash(0);
     $self->UnspentBenefits(0);
     $self->CashRollsTaken(0);
     $self->Alive(1);
     $self->ServiceName("");
     $self->Service(0);
     $self->Drafted(0);
     my %skills;
     my %benefits;
     $self->Skills(\%skills);
     $self->Benefits(\%benefits);
     set_attributes($self);
}

sub display {
    my $self = shift;
    my $rankname = '';
    $rankname = $self->cell('Titles', $self->{Rank}, $self->{Service}) if $self->{Rank}; 
    my $age = 18 + $self->{Terms} * 4;
    $age += 2 unless $self->{Alive};
    my $t = "Terms";
    $t = "Term" if $self->{Terms} == 1;
    print "$self->{ServiceName} $rankname ($self->{Terms} $t)\t\t";
    for(0..5){
        print Routines::tr_hex($self->AttributeValues->[$_]);
    }
    print "  Age: $age  Cash: $self->{Cash}";
    print "  (DECEASED)" unless $self->Alive;
    print "\n";
    $self->display_skills();
    $self->display_benefits();
}

sub display_attributes {
    my ($self, $message) = @_;
    for(0..5){
        print Routines::tr_hex($self->AttributeValues->[$_]);
    }

    $message = '' unless defined($message);
    print "$message\n";
}

sub enlist {
    my ($self) = @_;
    my $choice = $self->Callback->choose("Navy;Marines;Army;Scouts;Merchants;Other");
    my $num = $self->cell('Services', $choice, 'ServiceNum');
    print "You are attempting to enter service #$num $choice.\n";
    my $target = $self->cell('PriorService', 'Enlistment', $num);
    print "Your base enlistment target is $target.\n";

    unless ($self->cell('PriorService', 'EOneVal', $num) eq '-'){
        my $attone = $self->cell('PriorService', 'EOneAtt', $num);
        my $valone = $self->cell('PriorService', 'EOneVal', $num);
        my $atttwo = $self->cell('PriorService', 'ETwoAtt', $num);
        my $valtwo = $self->cell('PriorService', 'ETwoVal', $num);

        if ($self->attribute($attone) >= $valone){
            print "Enlistment DM of +1 due to $attone.\n";
            $target--;
        }
        if ($self->attribute($atttwo) >= $valtwo){
            print "Enlistment DM of +2 due to $atttwo.\n";
            $target -= 2;
        }
        print "Your net Enlistment Target is $target.\n"
    }

    my $roll = $self->get_two_d_six();

    if ($roll >= $target){
        print "You're in!!\n";
        $self->Drafted(0);
        $self->Service($num);
        $self->ServiceName($choice);
    } else {
        print "You failed to enlist into the $choice.\n";
        $self->Drafted(1);
        $roll = Routines::d_six();
        my $draft = $self->cell('PriorService', 'ServiceName', $roll);
        $self->Service($roll);
        $self->ServiceName($draft);
        print "You have been drafted into $draft.\n";
    }

    $self->check_rank_skills();
}

sub get_d_six(){
    my $roll = Routines::d_six();
    print "You rolled a $roll.\n";
    return $roll;
}
    
sub get_two_d_six(){
    my $roll = Routines::two_d_six();
    print "You rolled a $roll.\n";
    return $roll;
}

sub check_rank_skills {
    my ($self) = @_;
    if ($self->Rank() < 7) {
        my $skill = $self->cell("RankAndServiceSkills", $self->{Rank}, $self->{Service});
        unless ($skill eq '-'){
            print "You gain a rank/service skill level in $skill.\n";
            if ($skill eq 'Social'){
                $self->AttributeValues->[5] += 1; #TODO: add attributes to raise routine
            } else {
                $self->raise($skill);
            }
        } else {
            print "No rank/service skill for you this time...\n";
        }
    }
}

sub survival {
    my ($self) = @_;
    my $target = $self->cell("PriorService", "Survival", $self->{Service});
    unless ($target eq '-'){
        print "Your base survival target is $target.\n";
        my $att = $self->cell("PriorService", "STwoAtt", $self->{Service});
        my $val = $self->cell("PriorService", "STwoVal", $self->{Service});        if ($self->attribute($att) >= $val){
            $target -= 2;
            print "Survival DM of +2 due to $att.\n";
            print "Your net survival target is $target.\n";
        }
        
        $self->check_survival($target);
    }
}

sub check_survival {
    my ($self, $target) = @_;
    my $roll = $self->get_two_d_six();
    if ($roll >= $target){
        print "You survived!\n";
        $self->Alive(1);
    } else {
        print "You have died!\n";
        $self->Alive(0);
    }
}

sub commission {
    my $self = shift;
    my $target = $self->cell("PriorService", "Commission", $self->{Service});
    unless ($target eq '-'){
        print "Your base commission target is $target.\n";
        my $att = $self->cell("PriorService", "COneAtt", $self->{Service});
        my $val = $self->cell("PriorService", "COneVal", $self->{Service});
        if ($self->attribute($att) >= $val){
            $target--;
            print "Commission DM of +1 due $att.\n";
            print "Your net commission target is $target.\n";
        }
        my $roll = $self->get_two_d_six();
        if ($roll >= $target){
            print "You gained a commission!\n";
            $self->Commissioned(1);
            $self->{'SkillsToPick'}++;
            $self->{'Rank'}++;
            $self->check_rank_skills();
        } else {
            print "You did not get a commission.\n";
            $self->Commissioned(0); # Just to be sure
        }
    }
}

sub promotion {
    my $self = shift;
    my $target = $self->cell("PriorService", "Promotion", $self->{Service});
    unless ($target eq '-'){
        print "Your base promotion target is $target.\n";
        my $att = $self->cell("PriorService", "POneAtt", $self->{Service});
        my $val = $self->cell("PriorService", "POneVal", $self->{Service});
        if ($self->attribute($att) >= $val){
            $target--;
            print "Promotion DM of +1 due $att.\n";
            print "Your net commission target is $target.\n";
        }
        my $roll = $self->get_two_d_six();
        if ($roll >= $target){
            print "You gained a promotion!\n";
            $self->{'SkillsToPick'}++;
            $self->{'Rank'}++;
            $self->check_rank_skills();
        } else {
            print "You did not gain a promotion.\n";
        }            
    }
}

sub reenlist {
    my $self = shift;
    my $target = $self->cell("PriorService", "Reenlist", $self->{Service});
    my $try;
    
    if ($self->Terms() >= 7){
        print "After your seventh term, you must roll an exact 12 to reenlist.\n";
        $try = 'Muster Out';
    } else {
        print "Your reenlistment target is $target.\n";
        $try = $self->Callback->choose("Reenlist;Muster Out");
    }
    my $roll = $self->get_two_d_six();

    if ($try eq 'Reenlist'){
        if ($roll >= $target){
            print "You successfully reenlisted!\n";
            $self->Reenlisted(1);
        } else {
            print "You have been forced to muster out.\n";
            $self->Reenlisted(0);
        }
    } else {
        # Even if you want to muster out, you're back in on a 12.
        if ($roll == 12){
            print "You have been forced to reenlist!!\n";
            $self->Reenlisted(1);
        } else {
            print "You have mustered out.\n";
            $self->Reenlisted(0);
        }
    }
}

sub skills {
    my $self = shift;
    my $table;
    if ($self->attribute("Education") >= 8){
        $table = $self->Callback->choose("PersonalDevelopmentSkills;ServiceSkills;AdvancedSkills;HighlyAdvancedSkills");
    } else {
        $table = $self->Callback->choose("PersonalDevelopmentSkills;ServiceSkills;AdvancedSkills");
    }
    my $roll = $self->get_d_six();
    my $skill = $self->cell($table, $roll, $self->{Service});
    $self->raise($skill);
    $self->{'SkillsToPick'}--;
    $self->skills() if $self->SkillsToPick() > 0;
}

sub raise {
    my ($self, $thing) = @_;
   
    if (defined($self->attribute($thing))){
        my $value = $self->attribute($thing);
        $value++;
        $self->attribute($thing, $value);
        $self->display_attributes(" ($thing raised)");
    } else {
        $self->Skills->{$thing}++;
        $self->display_skills($thing);
    }
}

sub display_skills {
    my ($self, $skill) = @_;
    $skill = 'Nothing' unless $skill; # silly hack
    my $comma;
    my $star = '';
    foreach my $key (sort keys %{$self->Skills}){
        my $value = $self->Skills->{$key};
        my $star = '*' if $key eq $skill;
        print ", " if $comma;
        print $star if $star; # can't print this in concatenation for some reason (?)
        print "$key";
        print $star if $star;
        print "-$value";
        $comma = 1;
        $star = '';
    }
    print "\n";
}

sub display_benefits {
    my ($self, $benefit) = @_;
    $benefit = 'Nothing' unless $benefit; # silly hack
    my $comma;
    my $star = '';
    foreach my $key (sort keys %{$self->Benefits}){
        my $value = $self->Benefits->{$key};
        my $star = '*' if $key eq $benefit;
        print ", " if $comma;
        print "$value " if $value > 1;
        print $star if $star; # can't print this in concatenation for some reason (?)
        print "$key";
        print $star if $star;
        $comma = 1;
        $star = '';
    }
    print "\n";
}

# TODO: Can't set attribute to zero.  (Doesn't matter technically, though!)
sub attribute {
    my ($self, $att, $val) = @_;
    for(0..5){
        my $num = $_;
        if ($self->AttributeNames->[$num] =~ /^$att/i){
            my $silly = $self->AttributeValues->[$num];
            $self->AttributeValues->[$num] = $val if $val;
            return $self->AttributeValues->[$num];
        }
    }
    #returns undef if attribute not found.
    return undef();
}

sub process {
    my ($self) = @_;
    $self->Callback->process();
}

# The Environment should take care of this...
# But the Environment doesn't know about the CallBack object...
sub cell {
    my $self = shift;
    my $value = $self->Environment->cell(@_);
    #Check ReadAsTable for any required translation/interpretation
    $value = $self->Environment->ReadAsTable()->{$value} if $self->Environment->ReadAsTable()->{$value};
    #Check Callback to resolve any required user input if we have semi-colons...
    if ($value =~ /;/){
        $value = $self->Callback->choose($value);
    }
    return $value;
}

sub generate {
    my $self = shift;
    
    $self->initialize();
    $self->display_attributes();
    $self->enlist();
    $self->mainloop();
    
    my $terms = $self->Terms();
    print "You completed $terms terms.\n";

    if ($self->Alive()){
        $self->BenefitsToPick($self->Terms());
        $self->{BenefitsToPick}++ if $self->Rank() >= 1;
        $self->{BenefitsToPick}++ if $self->Rank() >= 3;
        $self->{BenefitsToPick}++ if $self->Rank() >= 5;
        print "You get $self->{BenefitsToPick} at rank $self->{Rank}.\n";
        $self->benefits() if $self->BenefitsToPick() > 0;
    } else {
        print "You are dead.\n";
    }

    print "\nFinal Results:\n";
    $self->display();
}

sub mainloop {
    my $self = shift;
    print "\n";
    $self->survival();

    if ($self->Alive()){
        $self->{Terms}++;

        if ($self->Terms() == 1){
            $self->SkillsToPick(2);
        } else {
            $self->SkillsToPick($self->cell('PriorService', 'Skills', $self->{Service}));
        }

        # only check for commission if it hasn't been received
        unless ($self->Commissioned()){
            if ($self->Drafted() and $self->Terms() == 1){
                print "No commission possible on first term if drafted.\n";
            } else {
                $self->commission();
            }
        }
    
        $self->promotion() if $self->Commissioned();
        print "You get to roll for $self->{SkillsToPick} skills this term.\n";    
        $self->skills();
        $self->aging if $self->Terms() >= 4;
        
        if ($self->Alive()){
            $self->reenlist();
            $self->mainloop if ($self->Reenlisted());
        }   
    }
}

sub benefits {
    my $self = shift;
    my $choice;
    if ($self->{CashRollsTaken} < 3){ # Up to three rolls
        $choice = $self->Callback->choose("Benefits;Cash");
    } else {
        $choice = "Benefits";
    }

    if ($choice eq "Cash"){
        my $roll = $self->get_d_six();
        my $bonus = $self->cell("CashTable", $roll, $self->{Service});
        print "You gained $bonus cash.\n";
        $self->{Cash} += $bonus;
        $self->{CashRollsTaken}++;
    } else {
        my $dm = 0;
        if ($self->{Rank} >= 5){
            $dm++ if $self->Callback->choose("Add One to Roll;Standard Die Roll") eq 'Add One to Roll';
        }
        my $roll = $self->get_d_six() + $dm;
        my $benefit = $self->cell("BenefitsTable", $roll, $self->{Service});
        my $amount = 1;
        if ($benefit =~ /\+(\d)(\w+)/){
            $benefit = $2;
            $amount = +2;
        }

        if (defined($self->attribute($benefit))){
            my $value = $self->attribute($benefit);
            $value += $amount;
            print "Your $benefit was raised by $amount.\n";
            $self->attribute($benefit, $value);
        } elsif ($benefit eq 'Blade' or $benefit eq 'Gun') {
            print "You receive a weapon benefit!\n";
            my $choice = $self->Callback->choose($self->Environment->ReadAsTable->{"$benefit Cbt"});
            if ($self->Benefits->{$choice}) {
                print "You're raising $choice skill by one level.\n";
                $self->raise($choice);
            } else {
                $self->Benefits->{$choice}++;
            }
        } else {
            print "You gained a $benefit.\n";
            $self->Benefits->{$benefit}++;
        }        
    }
    $self->{BenefitsToPick}--;
    $self->benefits() if $self->BenefitsToPick() > 0;
}

sub aging {
    my $self = shift;
    my $column = 4;
    $column = 8 if $self->Terms() >= 8;
    $column = 12 if $self->Terms() >= 12;
    print "Checking for aging effects...\n";
    
    my $roll = $self->get_two_d_six();
    if ($roll < $self->cell('AgingTable', 'StrenSave', $column)){
        my $loss = $self->cell('AgingTable', 'StrenPenalty', $column);
        print "Stength dropped by $loss.\n";
        $self->AttributeValues->[0] += $loss; #TODO: add attributes to raise routine
        if ($self->AttributeValues->[0] <= 0){
            $roll = $self->get_two_d_six();
            if ($roll >= 8){
                print "You survived your aging crisis.\n";
                $self->AttributeValues->[0] = 1;
            } else {
                $self->Alive(0);
            }
        }
    }

    $roll = $self->get_two_d_six();
    if ($roll < $self->cell('AgingTable', 'DextSave', $column)){
        my $loss = $self->cell('AgingTable', 'DextPenalty', $column);
        print "Dexterity dropped by $loss.\n";
        $self->AttributeValues->[1] += $loss; #TODO: add attributes to raise routine
        if ($self->AttributeValues->[1] <= 0){
            $roll = $self->get_two_d_six();
            if ($roll >= 8){
                print "You survived your aging crisis.\n";
                $self->AttributeValues->[1] = 1;
            } else {
                $self->Alive(0);
            }
        }
    }
    
    $roll = $self->get_two_d_six();
    if ($roll < $self->cell('AgingTable', 'EndurSave', $column)){
        my $loss = $self->cell('AgingTable', 'EndurPenalty', $column);
        print "Endurance dropped by $loss.\n";
        $self->AttributeValues->[2] += $loss; #TODO: add attributes to raise routine
        if ($self->AttributeValues->[2] <= 0){
            $roll = $self->get_two_d_six();
            if ($roll >= 8){
                print "You survived your aging crisis.\n";
                $self->AttributeValues->[2] = 1;
            } else {
                $self->Alive(0);
            }
        }
    }

    $self->display();
}

###################################################################################################

package TestMe;
use strict;
use warnings;

my $C = new Character::();
$C->generate();
print "--------------------------------------------------------------------------------";
my $line = <STDIN>;

This is the data file for the program. Save it as “BookOne.dat”:

ReadCell "Blade Cbt" As "Dagger;Blade;Foil;Sword;Cutlass;Broadsword;Bayonet;Spear;Halberd;Pike;Cudgal"
ReadCell "Gun Cbt" As "Body Pistol;Auto Pistol;Revolver;Carbine;Rifle;Auto Rifle;Shotgun;SMG;Laser Carbine;Laser Rifle"
ReadCell "Vehicle" As "Grav Vehicle;Tracked Vehicle;Wheeled Vehicle;Prop-driven Fixed Wing;Jet-driven Fixed Wing;Jet-driven Fixed Wing;Helicopter;Large Watercraft;Small Watercraft;Hovercraft;Submersible"

Table Services:
	ServiceName,	ServiceNum
	Navy,		1
	Marines,	2
	Army,		3
	Scouts,		4
	Merchants,	5
	Other,		6


Table PriorService:
	Property,	1,		2,		3,		4,		5,		6
	ServiceName,	Navy,		Marines,	Army,		Scouts,		Merchants,	Other
	Enlistment, 	8,		9,		5,		7,		7,		3
	EOneAtt,	Intel,		Intel,		Dext,		Intel,		Stren,		-
	EOneVal,	8,		8,		6,		6,		7,		-
	ETwoAtt,	Educ,		Stren,		Endur,		Stren,		Intel,		-
	ETwoVal,	9,		8,		5,		8,		6,		-
	Survival,	5,		6,		5,		7,		5,		5
	STwoAtt,	Intel,		Endur,		Educ,		Endur,		Intel,		Intel
	STwoVal,	7,		8,		6,		9,		7,		9
	Commission,	10,		9,		5,		-,		4,		-
	COneAtt,	Social,		Educ,		Endur,		-,		Intel,		-
	COneVal,	9,		7,		7,		-,		6,		-
	Promotion,	8,		9,		6,		-,		10,		-
	POneAtt,	Educ,		Social,		Educ,		-,		Intel,		-
	POneVal,	8,		8,		7,		-,		9,		-
	Reenlist,	6,		6,		7,		3,		4,		5
	Skills,		1,		1,		1,		2,		1,		1


Table Titles:
	Rank,   	1,		2,		3,		4,		5,		6
        1,              Ensign,         Lieutenant,     Lieutenant,     -,              4th Officer,    -
        2,              Lieutenant,     Captain,        Captain,        -,              3rd Officer,    -
        3,              Lt Cmdr,        Force Cmdr,     Major,          -,              2nd Officer,    -
        4,              Commander,      Lt Colonel,     Lt Colonel,     -,              1st Officer,    -
        5,              Captain,        Colonel,        Colonel,        -,              Captain,        -
        6,              Admiral,        Brigadier,      General,        -,              Captain,        -
        
        
Table BenefitsTable:
	Roll,		1,		2,		3,		4,		5,		6
	1,		Low Psg,	Low Psg,	Low Psg,	Low Psg,	Low Psg,	Low Psg
	2,		+1Intel,	+2Intel,	+1Intel,	+2Intel,	+1Intel,	+1Intel
	3,		+2Educ,		+1Educ,		+2Educ,		+2Educ,		+1Educ,		+1Educ
	4,		Blade,		Blade,		Gun,		Blade,		Gun,		Gun
	5,		Travellers,	Travellers,	High Psg,	Gun,		Blade,		High Psg
	6,		High Psg,	High Psg,	Mid Psg,	Scout Ship,	Low Psg,	-
	7,		+2Social,	+2Social,	+1Social,	-,		Free Trader,	-


Table CashTable:
	Roll,		1,		2,		3,		4,		5,		6
	1,		1000,		2000,		2000,		20000,		1000,		1000
	2,		5000,		5000,		5000,		20000,		5000,		5000
	3,		5000,		5000,		10000,		30000,		10000,		10000
	4,		10000,		10000,		10000,		30000,		20000,		10000
	5,		20000,		20000,		10000,		50000,		20000,		10000
	6,		50000,		30000,		20000,		50000,		40000,		50000
	7,		50000,		40000,		30000,		50000,		40000,		100000


Table RankAndServiceSkills:
	Rank,		1,		2,		3,		4,		5,		6
	0,		-,		Cutlass,	Rifle,		Pilot,		-,		-
	1,		-,		Revolver,	SMG,		-,		-,		-
	2,		-,		-,		-,		-,		-,		-
	3,		-,		-,		-,		-,		-,		-
	4,		-,		-,		-,		-,		-,		-
	5,		Social,		-,		-,		-,		Pilot,		-
	6,		Social,		-,		-,		-,		-,		-


Table PersonalDevelopmentSkills:
	Roll,		1,		2,		3,		4,		5,		6
	1,		Stren,		Stren,		Stren,		Stren,		Stren,		Stren
	2,		Dext,		Dext,		Dext,		Dext,		Dext,		Dext
	3,		Endur,		Endur,		Endur,		Endur,		Endur,		Endur
	4,		Intel,		Gambling,	Gambling,	Intel,		Stren,		Blade Cbt
	5,		Educ,		Brawling,	Educ,		Educ,		Blade Cbt,	Brawling
	6,		Social,		Blade Cbt,	Brawling,	Gun Cbt,	Bribery,	Social


Table ServiceSkills:
	Roll,		1,		2,		3,		4,		5,		6
	1,		Ships Boat, 	ATV,		ATV,		Air/Raft,	Vehicle,	Vehicle
	2,		Vacc Suit,	Vacc Suit,	Air/Raft,	Vacc Suit,	Vacc Suit,	Gambling
	3,		Fwd Obsvr,	Blade Cbt,	Gun Cbt,	Mechanical,	Jack-o-T,	Brawling
	4,		Gunnery,	Gun Cbt,	Fwd Obsvr,	Navigation,	Steward,	Bribery
	5,		Blade Cbt,	Blade Cbt,	Blade Cbt,	Electronics,	Electronics,	Blade Cbt
	6,		Gun Cbt,	Gun Cbt,	Gun Cbt,	Jack-o-T,	Gun Cbt,	Gun Cbt


Table AdvancedSkills:
	Roll,		1,		2,		3,		4,		5,		6
	1,		Vacc Suit,	Vehicle,	Vehicle,	Vehicle,	Streetwise,	Streetwise
	2,		Mechanical,	Mechanical,	Mechanical,	Mechanical,	Mechanical,	Mechanical
	3,		Electronics,	Electronics,	Electronics,	Electronics,	Electronics,	Electronics
	4,		Engineering,	Tactics,	Tactics,	Jack-o-T,	Navigation,	Gambling
	5,		Gunnery,	Blade Cbt,	Blade Cbt,	Gunnery,	Gunnery,	Brawling
	6,		Jack-o-T,	Gun Cbt,	Gun Cbt,	Medical,	Medical,	Forgery


Table HighlyAdvancedSkills:
	Roll,		1,		2,		3,		4,		5,		6
	1,		Medical,	Medical,	Medical,	Medical,	Medical,	Medical
	2,		Navigation,	Tactics,	Tactics,	Navigation,	Navigation,	Forgery
	3,		Engineering,	Tactics,	Tactics,	Engineering,	Engineering,	Electronics
	4,		Computer,	Computer,	Computer,	Computer,	Computer,	Computer
	5,		Pilot,		Leader,		Leader,		Pilot,		Pilot,		Streetwise
	6,		Admin,		Admin,		Admin,		Jack-o-T,	Admin,		Jack-o-T


Table AgingTable:
	Attribute,	4,		8,		12
	StrenPenalty,	-1,		-1,		-2
	StrenSave,	8,		9,		9
	DextPenalty,	-1,		-1,		-2
	DextSave,	7,		8,		9
	EndurPenalty,	-1,		-1,		-2
	EndurSave,	8,		9,		9
	IntelPenalty,	0,		0,		-1
	IntelSave,	2,		2,		9			
Advertisements

7 Responses to “Programmer: new to the area… seeks support”

  1. jhc Says:

    i’m not sure if this is what you are referring to, but you can copy and paste from windows cmd (although, you are right in saying that you can’t cut).

    first, right click on the title bar of a cmd window and select ‘properties’. then select the ‘options’ tab and enable QuickEdit mode.

    now you can highlight the text that you want copied with your mouse. right click to copy the active mark to the clipboard.

    if there is no active mark in a cmd window, a right click will paste into the cmd window from the clipboard.

  2. lispy Says:

    Nice tip. Thanks.

  3. Mark Miller Says:

    From my recollection stdin and stdout work on Windows, in the Command window anyway. I used to program in C on DOS and I’m pretty sure I used stdin/stdout at least a few times. It could just be that the Perl runtime doesn’t support it well in the Windows version.

    As for Alan Kay, something he’s railed about for years is how there’s barely a literary culture in the computer field. There’s no sense of history. We keep reinventing the wheel, because “we don’t read”, he says. One example he cited was that Rand had figured out in the late 1960s how to do handwriting recognition really well, but no one’s bothered to read how they did it, and instead industry has produced crappy handwriting recognition systems.

    I’ve been reading your last few posts on the Perl stuff you’re working on, as much as I can without knowing much about Perl. In terms of what you’re working on you’re ahead of me. I have yet to develop a good sense of system architecture. I’ve mostly been building a philosophical basis for ultimately getting into this stuff.

    I’ll just say that your dispatch table looks a lot like code I’ve seen from a language that’s being developed at Viewpoints Research Institute, Alan Kay’s organization, called OMeta. It’s a pattern language that uses PEGs (Parsing Expression Grammars), memoization, and objects. It looks a bit like BNF, but it doesn’t act like older LR parsers. Instead it tries to find the closest match in subsets of rules. Whichever subset is closer, it goes through that subset, and then goes through it sequentially to find a match. If it finds a match, it executes the corresponding action block. It handles left-recursion just fine via. memoization, making grammars simpler to write. You can check out OMeta at http://www.cs.ucla.edu/~awarth/ometa/. You can run it right inside your browser (the current version only works on Firefox, and I think Safari) since the primary version is written in Javascript. I think there’s a PDF link there that shows documentation on a different implementation they worked on. This gives you an idea of the concepts being used anyway.

    Other people are working on ports. Jeff Moser is working on making a version that runs in .Net 3.0. He’s been writing about it on his blog (the link I cite).

    You can write multiple languages in OMeta and bring in parts of them for whatever you’re working on, however you choose. One of the goals they have with the project is being able to write code in a way that’s more self-explanatory. Jeff Moser has written a couple posts that illustrate this idea.

    One thought I had on your program overall, though it may be totally uninformed, is why not have the goals drive the program? This is thinking in more of a functional, perhaps Prolog-ish style. Rather than taking the data and saying “if (blah) then”, what I was thinking was along the lines of “(enlistedp (blah))”, where the predicate drives functionality that seeks structures that will match its conditions, and either succeeds or fails. If it does, then the next predicate is tried.

  4. Perl source filters: evil or not? « Learning Lisp Says:

    […] Learning Lisp (notes from an average programmer studying the hard stuff) « Programmer: new to the area… seeks support […]

  5. lispy Says:

    Hey Mark.

    Yeah… it’s definitely time to (a) start reading more code and (b) start learning about parsing and grammers.

    There’s a big difference between code written to get something done and code written to explore an idea. The code above is more of the former than the latter right now.

    I think what I want… sort of like how sed is a command-line driven text editor… I want a script driven subtitute for spreadsheets and desktop databases…. I’m going to need to write a BASIC-like mini-language for writing simple functions and operating on the environment….

    I tried playing with some source filtering, but it was an absolute pain to implement. Extending the dispatch tables is pretty easy in comparison even though it might be less efficient.

    That reminds me of something I want to go figure out real quick….

  6. Mark Miller Says:

    @Lispy:

    Check out this article by Jeff Moser for inspiration. He uses his port of OMeta (OMeta#) to write a small language in which to implement FizzBuzz. Really neat! Instead of writing a program in Java, C#, Ruby, etc. that directly implements FizzBuzz (which is like, DUH! EASY!), he wrote his own mini-language to provide the structures he needed in order to write FizzBuzz. He first shows the implementation of FizzBuzz in the language he wrote. Then he shows the complete source code, in OMeta#, for the language.

  7. draegtun Says:

    Blimey… you’ve written more Perl code here than I’ve done in last few months! You’ve certainly got the bit between the teeth on this one.

    Couple of things which you probably jumped across by now but just in case for other passers by here…

    1. Packages. Something I’ve fallen over before was this….

    use strict;
    use warnings;
    
    package A;
    our $X = 'X create while in Package A';
    my $x = "lexical x";
    
    package B;
    say "In package B...", $X;
    say "In package B...", $x;
    

    Package B will happily print whats in $X & $x without giving an error ;-(

    Instead you need to put packages into separate files or enclose a block around them….

    {
        package A;
        our $X = 'X create while in Package A';
        my $x = "lexical x";
    }
    
    {
        package B;
        say "In package B...", $X;
        say "In package B...", $x;
    }
    

    Now above will throw a compile error on both those say lines in Package B.

    2. Easy way to return hash or array references from sub….

    sub return_hashref {
        return { hello => 'Hello' };
    }
    
    sub return_arrayref {
        return [ 'zero', 'one', 'two' ];
    }
    
    # thus your Moose has statement can be a bit sweeter....
    
    has 'Rows' => (isa => 'HashRef', is => 'rw', default => sub { {} } );
    has 'Columns' => (isa => 'ArrayRef[Str]', is => 'rw', default => sub { [] } );
    

    Learning Perl is fun eh!

    /I3az/

Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s


%d bloggers like this: