Archive for the ‘Perl’ Category

Bodging alternatives to full-on compilers– and the true meaning of OOPness

October 16, 2008

“You say, well if we were using Haskell for this then we would just do this thing; can we adapt that to what we’re doing here? Not saying you have to use Haskell to solve it, but could you use that kind of approach?” — Damian Conway

I’ve been experimenting with parsing for a while now. I’m on the verge of digging into tokenizing and grammars. Before I hunker down and educate myself, I just want to see how far you can go with less industrial-strength approaches. I think it’s pretty cool how combining a single good regex with a closure gets you what is for all intents and purposes a mini-compiler. This is a pretty handy trick; filing away such dynamically generated functions in a hash table can lead to some pretty powerful techniques, too. A dispatch table like that can even be used to create a simple programming language on the fly. Tokenizing a string is just another algorithm… and on first glance, grammars appear (in a way) to be fancy dispatch tables. How do you bring them all together? Some kind of deep magic from the dawn of time– something I would never figure out by trial and error or intuition. I’m getting there. But just for fun, let’s generalize some of these ideas and (at the same time) temporarily ignore them. Let’s go entirely orthogonal to this plane of thinking for a moment.

OOP as it gets applied in ‘the real world’ is primarily a defensive exercise: “I don’t like you and I don’t like the way you code. Let me just wall off on my little corner and do my thing. Let me work with your stuff without having to understand your code. Don’t break the contract, either, bub. Somehow, I don’t think this is where Alan Kay intended us to go with this….

Think about the difference between Checkers and Chess for a second. The permutations of moves are effectively infinite in both games. But the space of possibilities have different ‘shapes’. If you were, like some sort of Paul Atreides, to look out at the limitless patterns in the games, for chess you’d see an expansive plane of cascading options. Checkers would look more like an infinitely deep well.

The way we tend to do OOP is more like Checkers than it is like Chess. The calls between and among the various objects seems brittle and constricted. Like talking to someone through an incredibly long pipe instead of face to face…. So how to open things up and make things more fluid and fluent? My idea is to swing the emphasis in OOP back much more toward the message passing concept, steal a few idioms from Lisp, and generalize heavily on the overall theme of DSL’s. (I always thought it was cool how in Lisp practically everything had a straight-forward text representation. The reader transforms what you type into a tidier, more consistent representation… and then shows it to you as the response.)

What if in designing a programming language, you divided it up into various objects or components. To extend the language you just drop in new objects. The classes that the objects derive from each come (after a fashion) with their own DSL. Each object would ‘know’ how to generate its own source code. While working with an object via a REPL, you could modify the object… then view and/or save the modified source without dropping back to the IDE or text editor. The object source code should understand the concept of testing and incorporate test code into its specification. When you talk to code via a REPL, you end up doing lots of little tests anyway. You should be able to incorporate those off-the-cuff tests into the code without thinking about it. (Any inconvenience in automated testing development just makes it that much more likely that it doesn’t get done. Get rid of everything that stands in the way of it.)

So each object in the system would know how to do stuff like read, source, save, and load. Each object would have its own mini-language that you can focus on separately without having to think of all of the parsing at once. Your collection of objects would get wrapped in a unified reader. The main reader would pass messages to each object-group in the deck until something understood the message. (And just like “library lists” on the AS/400, you could rearrange the reading order on the fly.) Simple! Now you can build a programming language without having to think about the whole thing at once– and you get modularity and testability benefits in the process. If you don’t have time to write ‘real’ compilers and DSL’s, this might be enough to get you by for a while. Of course, it might be enough to make you buckle down and learn some real computing techniques, too. Judge for yourself.

If you’d like to play with this (or see more specifically part of what I’m trying to describe), I’ve implemented the gist of the idea in Perl. There’s nothing fancy in it; I’m just using the bottom 30% of the language for the most part. There’s plenty of places the overall idea could be further generalized and tightened up. (I think I’m part way through reinventing Smalltalk, but this is just for fun anyway.)

Here’s a couple of sample screen shots plus the code:

Do what I mean; Who cares about joins?

Do what I mean; Who cares about joins?

Some Lame Syntactic Sugar Hacks

Some Lame Syntactic Sugar Hacks

###################################################################################################
{
    
package Functions;
use Moose;

has Functions => (isa => 'HashRef', is => 'rw', default => sub { {} } );
has Source => (isa => 'HashRef', is => 'rw', default => sub { {} } );
has Environment => (isa => 'Environment', is => 'rw'); ### required only if implementing syntactic sugar for table refernces

sub set {
    my ($self, $key, $text) = @_;
    my ($ref, $code, $r);
    $code = $text;
    $code =~ s/(\d+[dD]\d+)/\$self->roll_maker('$1')->()/g; ### the regex could be improved-- missing some cases....
    $code =~ s/!(\w+)/\$self->Functions->{$1}->()/g; ### should this call Environment or the local deck?   [YES!]
    $r = '[^~\s;]';
    $code =~ s/($r+)~($r+)~($r+)/\$self->Environment->Tables->cell($1, $2, $3)/g;
    $code = "sub { $code }";
    print "The actual code is $code\n";
    $ref = eval $code;
    if ($@){
        print "Error setting $key: $@" if $@;
    } else {
        $self->Source->{$key} = $text;
        $self->Functions->{$key} = $ref;
    }
}

sub call {
    my ($self, $key) = @_;
    if ($self->Functions->{$key}){
        eval { $self->Functions->{$key}->(); };
        print "Error calling $key: $@" if $@;
    } else {
        print "No such function '$key'.\n";
    }
}

sub show {
    my ($self, $key) = @_;
    print "\n\n";
    if ($key){
        if ($self->Source->{$key}) {
            my $source = $self->Source->{$key};
            print "set $key: $source\n";
        } else {
            print "No source available for $key.\n";
        }
    } else {
        foreach $key (sort keys %{$self->Source}) {
            my $source = $self->Source->{$key};
            print "set $key: $source\n";
        }
    }
    print "\n";
}

sub read {
    my ($self, $line) = @_;
    if ($line =~ /^set (\w+):\s*(.+)/){
        if (defined($self->set($1, $2))) {
            print "Function $1 set.\n";
        }
    } elsif ($line =~ /^call (\w+)$/){
        $self->call($1);
        print "\n";
    } elsif ($line =~ /^show\s*(\w*)/){
        if ($1) {
            $self->show($1);
        } else {
            $self->show();
        }
    } elsif ($line =~ /^load\s+([\w.]+)/){
        $self->load($1);
    } elsif ($line =~ /^save\s+([\w.]+)/){
        $self->save($1);
    } else {
        return 0;
    }
    return 1;
}

sub load {
    my ($self, $file) = @_;
    open FILE, "< $file";
    while (<FILE>){
        chomp;
        $self->read($_);
    }
    close FILE;
}

sub save {
    my ($self, $file) = @_;
    open FILE, "> $file";
    foreach my $key (sort keys %{$self->Source}) {
        my $source = $self->Source->{$key};
        print FILE "set $key: $source\n";
    }
    close FILE;
}

sub roll_maker ($) {
    my($self, $line, $num, $type);
    $self = shift;
    $line = shift;
    
    return undef unless $line =~ m/^(\d+)?[dD](\d+|%)/;

    $num    = $1 || 1;
    $type   = $2;

    $type  = 100 if $type eq '%';

    return sub {
        my $result;
        for( 1 .. $num ) {
            $result += int (rand $type) + 1;
        }
        return $result;
    }
}

}
###################################################################################################
{    

package Callback;
use Moose;

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 { {} } ); 
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";
    }
}

sub show {
    my ($self) = @_;
    print $self->text();
}

sub text {
    my ($self) = @_;
    my $text;
    my $x;
    
    $text =  "table $self->{Name}:\n";
    $text .= "head: ";
    foreach(@{$self->Columns}){
        $text .=  ", " if $x;
        $text .=  $_;
        $x = 1;
    }
    $text .=  "\n";
    foreach my $key (sort keys %{$self->Rows}){
        $x = 0;
        $text .=  "row: ";
        foreach(@{$self->Columns}){
            $text .=  ", " if $x;
            $text .=  $key unless $x;
            $text .=  $self->cell($key, $_) if $x;
            $x = 1;
        }
        $text .=  "\n";
    }

    return $text;
}

}
###################################################################################################
{

package Tables;
use Moose;

has Tables => (isa => 'HashRef[Table]', is => 'rw', default => sub { {} } );
has ReadAsTable => (isa => 'HashRef[Str]', is => 'rw', default => sub { {} } );
has Current => (isa => 'Str', is => 'rw');
has Callback => (isa => 'Callback', is => 'rw', default => sub { Callback->new(); } );

sub cur {
    my ($self, $table) = @_;
    $self->Current($table);
    if ($self->Tables->{$table}) {
        print "Table $table is the active table.\n";
    } else {
        print "Ready to initialize table $table.\n";
    }
}

sub cell {
    my ($self, $table, $row, $column) = @_;
    my $T = $self->Tables->{$table};
    if ($T){
        my $value = $T->cell($row, $column);
        $value = $self->private_check_other_tables($table, $row, $column, $T) unless $value;        
        if ($value){
            $value = $self->ReadAsTable()->{$value} if $self->ReadAsTable()->{$value};
            if ($value =~ /;/){
                $value = $self->Callback->choose($value);
            }
            return $value;
        } else {
            print "Row $row Column $column not found in table $table.\n";
            return undef;
        }
    } else {
        print "Table $table does not exist.\n";
        return undef;
    }        
}

### if value not found, loop through each table
### if a table contains the column *and* the key is contained in the specified table
### then return the foreign value!
sub private_check_other_tables {
    my ($self, $table, $row, $column, $T) = @_;
    foreach my $key (sort keys %{$self->Tables}) {
        unless ($key eq $table){
            my $OTHER = $self->Tables->{$key};
            foreach(@{$OTHER->Columns}){
                #print "col-- $_\n";
                if ($_ eq $column){
                    ### does the first column match the table we're looking at?
                    foreach(@{$T->Columns}){
                        #print "mycol-- $_\n";
                        if ($_ eq $OTHER->Columns->[0]){
                            my $foreign_key = $T->cell($row, $_);
                            my $foreign_cell = $OTHER->cell($foreign_key, $column);
                            #print "Found it! (foreign key $foreign_key) (value $foreign_cell)\n";
                            return $foreign_cell;
                            #last; ### this doesn't really *last* it.
                        }
                    }
                }
            }
        }
    }           
}

sub show {
    my ($self, $key) = @_;
    print $self->text($key);
}

sub text {
    my ($self, $key) = @_;
    my $text;
    
    $text = "\n\n";
    if ($key){
        $text .= $self->Tables->{$key}->text();
    } else {
        foreach $key (sort keys %{$self->Tables}) {
            $text .= $self->Tables->{$key}->text();
            $text .= "\n\n";
        }
    }
    $text .= "\n";

    return $text;
}

sub read {
    my ($self, $line) = @_;
    my $table = $self->Current();
    if ($line =~ /^table (\w+):?/){
        $self->cur($1);
        #print "Table $1 is now active.\n";
    } elsif ($line =~ /head: (.*)/) {
        my $T = new Table();
        $T->initialize($table, $1);
        $self->Tables->{$table} = $T;
        print "Table $table initialized.\n";
    } elsif ($line =~ /row: (.*)/) {
        my $T = $self->Tables->{$table};
        if ($T) {
            $T->load_line($1);
            print "Table $table line loaded.\n";
        } else {
            print "Table not found.\n";
        }
    } elsif ($line =~ /^(\w+)~(\w+)~(\w+)/){
        my $cell = $self->cell($1, $2, $3);
        if (defined($cell)) {
            print "$cell\n";
        } else {
            print "Cell not found.\n";
        }
    } elsif ($line =~ /^readas ([\w\s]+)\s+->\s+(.+)/){
        $self->ReadAsTable->{$1} = $2;
        print "Reading '$1' as '$2'.\n";
    } elsif ($line =~ /^show\s*(\w*)/){
        if ($1){
            if ($self->Tables->{$1}){
                $self->show($1);
            } else {
                print "Table not found.\n";
            }
        } else {
            $self->show();
        }
    } elsif ($line =~ /^show/){
        $self->show();
    } elsif ($line =~ /^load\s+([\w.]+)/){
        $self->load($1);
    } elsif ($line =~ /^save\s+([\w.]+)/){
        $self->save($1);
    } else {
        return 0;
    }
    return 1;
}

### same routine as in Functions class
sub load {
    my ($self, $file) = @_;
    open FILE, "< $file";
    while (<FILE>){
        chomp;
        $self->read($_);
    }
    close FILE;
}

sub save {
    my ($self, $file) = @_;
    open FILE, "> $file";
    print FILE $self->text();
    close FILE;
}

}
###################################################################################################
{

package Environment;
use Moose;

has Functions => (isa => 'Functions', is => 'rw', default => sub { new Functions() } );
has Tables => (isa => 'Tables', is => 'rw', default => sub { new Tables() } );
has Settings => (isa => 'HashRef', is => 'rw', default => sub { my %hash; $hash{WorkingWith} = 'Functions'; return \%hash; } );

### This should be in the constuctor
sub hack {
    my ($self) = @_;
    $self->Functions->Environment($self);
}

sub read {
    my ($self, $line) = @_;

    if ($line =~ /^work functions/){
        print "Working with functions.\n";
        $self->Settings->{WorkingWith} = 'Functions';
        return;
    }

    if ($line =~ /^work tables/){
        print "Working with tables.\n";
        $self->Settings->{WorkingWith} = 'Tables';
        return;
    }

    ### Refactor Me Sometime
    if ($self->Settings->{WorkingWith} eq 'Tables'){
        unless ($self->Tables->read($line)){
            unless ($self->Functions->read($line)){
                print "Unknown command.\n";
            }
        }        
    } else {
        unless ($self->Functions->read($line)){
            unless ($self->Tables->read($line)){
                print "Unknown command.\n";
            }
        }
    }
}

}
###################################################################################################
{
    
package Test;
use strict;
use warnings;
my $T = new Tables();
my $F = new Functions();
my $E = new Environment(Tables => $T, Functions => $F);

print "\n>> ";
while(<STDIN>){
    chomp;
    $E->read($_);
    print "\n>> "
}

}
###################################################################################################
Advertisements

Learning Perl by Reading and Stealing Code from CPAN…

October 10, 2008

DadHacker has recently posted about interviewing people that simply can’t name the “most interesting code they’ve read.” At work I mostly look at mediocre accounting application code, but I tend to try to stick to cutting SQL and parsing report text files. That doesn’t lead to a lot of interesting code reading. Books give you the basics of syntax and concepts… but the pressures of the real world are very different. There’s definitely a hole in my education here, so it’s time to start surfing source code files instead of programming blogs. CPAN makes it easy. Let’s see what we can turn up today….

Starting with something simple that I’ve implemented many times myself, let’s look at the dice rolling code first….

Philip Newton’s Games::Dice is pretty nifty. His regex is broken down with the /x option to make it easy to understand. I like how he uses ‘||’ to default functions that don’t pull anything from the regex:

$sign = $2 || ”;

In the past I’ve used two or three lines to do the same thing. It might be cryptic to certain classes of non-Perl programmers, but it seems to be typical of more idiomatic Perl. Another thing you see him do with his function variables is declare them all at the top. (I tend to declare them willy nilly….) Finally, you see him explicitly returning undef if the argument criteria aren’t met. I’ll keep that one in my ditty bag….

David Cantrell’s Games::Dice::Advanced uses a pretty flexible object oriented style interface. He blithely tosses in a folding operation in there:

sub foldl {
  my($f, $z, @xs) = @_;
  $z = $f->($z, $_) foreach(@xs);
  return $z;
}

sub sum { foldl(sub { shift() + shift(); }, @_); }
print "This sum is ... " .  sum(1, 2, 3, 4) . "\n";

To make sure I understood what this one was doing I wrote a little function to illuminate what was happening:

sub visible_sum {
    foldl( sub { my $x = shift;
                 my $y = shift;
                 print "adding $x and $y\n";
                 return $x + $y; },
           @_);
}

visible_sum(1, 2, 3, 4);

Here’s a gratuitous attempt to emulate the style of SICP in Perl:

sub myfold {
    my($function, $first, @rest) = @_;
    return $first unless @rest;
    return myfold($function,
                  $function->($first, shift(@rest)),
                  @rest);
}

my $add = sub { $_[0] + $_[1]; };

print "myfold returns " . myfold( $add,
                                  1, 2, 3, 4)
                        . "\n";

Just messing around…. I like how you basically get first and rest functions for “free”. The anonymous function syntax of Perl is perfectly workable, but not very pretty. I checked through Higher Order Perl hoping to find something better than the shifting and the array references we used above, but was disappointed. Sigh. You can’t have it all.

I like David’s idea about making reusable dice objects. Without taking a lot of time to try to read it, I’m not going to get around to understanding his code, though. I’m not too fond of ‘bless’ or Perl’s object system in general…. On the other hand, Philip’s code is running the regex to parse the dice text every single time you call his functions. Hmm….

OOP is overkill here. If ever there’s a time to trot out closures, this is it. In my apps, I’d probably steal Philip’s well-documented regex’s and roll them out with something like this:

sub roll_maker ($) {
    my($line, $num, $type);

    $line = shift;

    return undef unless $line =~ m{
                 ^      # beginning of line
                 (\d+)? # optional count in $1
                 [dD]   # 'd' for dice
                 (      # type of dice in $2:
                    \d+ # either one or more digits
                  |     # or
                    %   # a percent sign for d% = d100
                 )
              }x;       # whitespace allowed

    $num    = $1 || 1;
    $type   = $2;

    $type  = 100 if $type eq '%';

    return sub {
        my $result;
        for( 1 .. $num ) {
            $result += int (rand $type) + 1;
        }
        return $result;
    }
}

my $roller = roll_maker("3d6");
print "Roll 3d6: " . $roller->() . "\n";

Philip Newton’s code allows for some customization by taking on an expression to modify it. It seems strange to have to write an impromptu parser just for this. I think we should use the regex to validate what comes into the function, here… but this may be an acceptable use of eval. Just like the closure above saving the function definition for later, we’ll use eval just a tiny tiny bit here and save it’s results for later use, too. (This needs a couple of tweeks– I’m only handling + and * properly just yet…. This is just to show the idea…. Don’t have time to fix this, now….)

sub define_sub {
  my $text = shift;
  return eval "sub { $text }";
}

sub roll_expression_maker ($) {
    my($line, $dice_string, $sign, $offset, $sum, $roller, $exp);

    $line = shift;

    return undef unless $line =~ m{
                 ^              # beginning of line
                 (              # dice string in $1
                   (?:\d+)?     # optional count
                   [dD]         # 'd' for dice
                   (?:          # type of dice:
                      \d+       # either one or more digits
                    |           # or
                      %         # a percent sign for d% = d100
                   )
                 )
                 (?:            # grouping-only parens
                   ([-+xX*/bB]) # a + - * / b(est) in $2
                   (\d+)        # an offset in $3
                 )?             # both of those last are optional
              }x;               # whitespace allowed

    $dice_string = $1;
    $sign        = $2 || '';
    $offset      = $3 || 0;

    $sign        = lc $sign;

    $roller = roll_maker( $dice_string );
    return undef unless $roller;

    $exp = define_sub('my $arg = shift; return $arg ' . $sign . ' ' . $offset . ';');
    return undef unless $roller;
    
    return sub { $exp->($roller->()); };
}

my $funny = roll_expression_maker("3d6+20");
print "funny " . $funny->() . "\n";

If we’re calling these functions a lot with the same types of requests, then it would make sense to memoize them. That would cut back on the times we parse these regex’s and run the evil eval….

A Grab Bag of Intermediate Perl Regex Tricks

October 9, 2008

Below we begin exploring some of the finer points of Perl’s syntax. The rabbit hole goes much much further down than this, so don’t expect to get your mind blown. This is just a few tricks to help get started in breaking out of the bottom 30% of the language.

Below we count the number of occurrences of a character with the return value of a truncate command. (I’d been doing that the hard way up ’til now.) We demonstrate how to turn off case sensitivity for selected parts of a regex. We show how to comment complex regex’s with the /x option. Finally, we show a few pattern match variables and also how to use the /e option to replace patterns with bona fide perl expressions. (Just for fun we play around with the ‘gee’ option.)

### the translate and substitute commands have return values
### that can occasionally be useful.
my $string = "ABABBCCAA";
my $count = ($string =~ tr/A/A/);
print "The number of A's that appear in \"$string\" is $count.\n";

my $count2 = ($string =~ s/B/X/g);
print "The s changed it to \"$string\" and returned $count2.\n";

### The match command returns a number, too.
my $count3 = ($string =~ m/C/);
print "Matching C's on \"$string\" I get $count3.\n";

### You can turn off case sensitivity for pieces of your regex
### instead of ignoring it for the whole thing.
### (Also, a failed match does not return a zero.)
my $a = "John Jacob JiNgLeHeImEr Smith";
my $count4 = ($a =~ m/(?i:heimer) Smith/);
my $count5 = ($a =~ m/(?i:heimer) SMITH/);
print "The good one returned a $count4 and the bad one a $count5.\n";

### use the /x option to add whitespace and comments to your regex
my $count6 = ($a =~ m/(\w{5})   # a five letter word for \1
                      \s        # a space
                      (\w{12})  # a twelve letter word for \2
                     /x);
print "The count was $count6 and found \"$1 $2\".\n";

### The e option evaluates the right side of the substitution
### as an expression before doing the replacement.
my $text2 = "Hello world!";
$text2 =~ s/world/5 + 2 * 3/;
my $text3 = "Hello world!";
$text3 =~ s/world/5 + 2 * 3/e;
my $value = 3;
my $text4 = "Hello world!";
$text4 =~ s/world/5 + 2 * $value/e;
print "No e: '$text2' ...\nWith e: '$text3' ...\nWith e and variable: '$text4'\n";

### If our expression is stored in a scalar, we can use the
### ee option to force its evaluation after the interpolation.
my $text6= "Hello world!";
my $expression = "5 + 2 * 3";
$text6 =~ s/world/$expression/ee;
print "This is what happened: '$text5.\n";

### You can look at matching information with $`, $&, and $'
### The ee option will actually execute code as well...
### and the pos function will tell you where you've left off.
### By combining these three features we can 'step through' exactly
### what a substitute command is doing:
my $text = "one two three four seventeen";
$text =~ s/\w{4}/print "before[$`] matched[$&] after[$'] position " . pos($text) . ".\n"/gee;

### Each e option after the first is equivalent to calling eval.
### A single e option by itself is a standard perl expression
### and not necessarily evil.

Perl source filters: evil or not?

October 8, 2008

I showed my program to a Perl hacker and got a lot of good feedback on it. He didn’t like my tedious table parsing and general reinventing of core Perl features with mediocre code. He suggested I look at Filter::Simple.

I have to say that Active State’s package manager program for CPAN is a pleasure to use. It’s exactly the sort of painless no-hacking type of tool that Windows development practices breed addictions to in its developers. No hacking around in weird script files. No posting questions on forums. Yea! So getting Filter::Simple is not a problem… and dashing out a quick test project is a piece of cake thanks to the good documentation on CPAN:

#!/usr/bin/perl
#squig.pm
package SQUIG;
use Filter::Simple;

FILTER {
    s/(\w+)~(\w+)~(\w+)/try('\1', '\2', '\3')/g;
};

1;
#!/usr/bin/perl
#test.pl
use SQUIG;

sub try {
    my ($a, $b, $c) = @_;
    print "$a...$b...$c...\n";
}

Abba~Babba~Dabba;

I think this easy-to-use tool can solve about 80% of my syntactic sugar issues. The only hitch I see is that I’d like to go beyond a simple sed-like command and call subroutines or functions on the replacement side so I can get different results depending on what turns up in the regexp match. For instance, I’d want to adapt the above “squiggle” filter to put single quotes around text, but leave scalars plain. I might want to transform Foo~Bar~$baz into $self->a_function_call(‘Foo’, ‘Bar’, $baz). (I’m not sure I’d want to see a regex that could do that….) This could help me clean up my object code and eliminate some of the ugliness in the method routines. (Although I may be using Moose in a hamfisted way to begin with….) Turning this technique to my data file parsing of table data… I could create simple functions that build up my ‘environment’ objects. Instead of parsing text and ‘manually’ loading up Moose objects, I could use the sourcefilter transform my table definitions directly into perl code wherever that makes sense.

This also brings me back to my original ‘dream’ project. I could create my own shorthand for a certain class of objects. I could create a set of source filters that get rid of the boiler plate. Instead of hacking up my own evalutator or abusing eval, I could rearrange functions however I like based on the keywords I tag with them.

My spider sense is tingling, though. I suspect this is only marginally less evil than my original inclination. This technique is not covered in any of my Perl books. Larry mentions it in passing in the Camel book, the Perl Cookbook mentions it only in the context of a switch command hack, and Mastering Perl explicitly avoids it. It’s strange to me that Perl literature is so far removed from how I actually use Perl day-to-day. Without word-of-mouth type tips from ‘real’ Perl hackers, I would never have thought to try either Moose or source filters… but that’s what I’m leaning on the most in my architecture. Is there really a gap or do I want bizarre things from my programming environment?

Programmer: new to the area… seeks support

October 6, 2008

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			

Looks like we’re rolling with Moose…

September 26, 2008

After the nth person telling me to try Moose, I finally gave in.

The first thing I wanted to know was how to handle private variables, hash table properties, and object type properties. The Moose Quick-Ref Card lists the built-in Data Type constraints. I think Randal L. Schwartz has written the definitive introduction, though. (His follow up goes into more detail about custom types….)

We can see below that the read-only field on the Example object needed to have a writer defined for it. Even though the method is named private_set_x, it can still be called from the outside world. Also, we can set the “read only” member via the constructor hash! Hash and object property types seem to work just fine. The only real trick there was to use an in-line sub to initialize them.

#!/usr/bin/perl
package Example;
use Moose;

has 'x' => (isa => 'Int', is => 'ro', writer => 'private_set_x', default => 21);

sub test {
    my $self = shift;
    my $x = $self->x();
    print "My x is currently a $x\n";
}

sub setit {
    my $self = shift;
    $self->private_set_x(42);
}

package Another;
use Moose;
extends 'Example';

has 'hashtest' => (isa => 'HashRef', is => 'rw', default => sub { my %hash; return \%hash; } );
has 'exampletest' => (isa => 'Example', is => 'rw', default => sub { Example->new(); } );

after 'setit' => sub {
    my $self = shift;
    print "The after method is getting called now.\n";
};



my $thing = Example->new();
$thing->test();  #My x is currently a 21
$thing->setit();
$thing->test();  #My x is currently a 42
$thing->private_set_x(84);
$thing->test();  #My x is currently a 84

my $otherthing = Example->new(x => 168);
$otherthing->test();  # My x is currently a 168

my $another = Another->new();
$another->setit();  # The after method is getting called now.

my $h = $another->hashtest();
$h->{"One"} = "Hello";
my $v = $another->hashtest()->{"One"};
print "The hash value is $v\n";  # The hash value is Hello

my $e = $another->exampletest();
$e->test();  # My x is currently a 21

Roll-your-own OO system with Closures and a Dispatch Table

September 25, 2008

Okay… this isn’t an article or an essay… just more rambling notes from a random guy working on learning Perl. This is not a plea for help, so don’t feel like you have to jump in and rescue me or anything. I should develop my ideas further before posting, but I figure I’ll quit working on this if I “go dark” too soon.

I write these little programs and then I try to turn them into classes and try to instantiate them. Somehow, I don’t understand references, variable scope, and packages well enough to grok why I’m falling on my face here. (I remember a few years ago trying to read an early edition of Learning Perl and giving up pretty fast. Programming Perl was just plain frightening then. I can understand a lot more of it now, but I still get lost when I try to apply it.) I’m mad enough at the OO system that I’m willing to roll my own just to avoid the issue: I’d rather have a system that I understand completely than use one that’s much more robust but that does things that seem weird or wrong to me. Of course, I’d sacrifice some much-needed compiler help in the process, by there you go…. I have played with Moose, but my standard brain-dead OO use case that I want to roll with isn’t in their recipe list. It’s probably there somewhere, but I’ve used it enough that I know I need to understand more about regular Perl OO to use it—just so I can pick up the syntax and know what’s going on under the hood.

In any case… my view of objects may be shifting. I don’t know. I think an object should be completely malleable at runtime. I want to be able to add and remove properties and methods at will. Reflection should be drop-dead easy. Maybe I want to reinvent Smalltalk or something, I don’t know…. For some reason this just seems too hard to me in most OO systems. There’s probably some technical reason for this– or maybe I’m just lazy. Who cares. Meh.

In my last bit of Perl code, I had a table object glommed in with the rest of my code—it’s just crying to be abstracted out. I use dispatch tables all the time now, so a dispatch table class seems like a good idea. How many times do I need to cut and paste that code before I roll it into a module file?? And finally, we have the beginnings of the widget that I’m sketching out below. (Yep… totally done with closures—fun, fun, fun! For some reason I couldn’t figure out how to pass arguments to the dispatch table subs. I spent hours messing with it and I just don’t understand why I couldn’t. That’s why it’s using lame global variables in there for that….) At any rate, if I thought I could just pick up the Perl OO system and just run with it, I was wrong.

Time to sit down and RTFM– back to Programming Perl and Intermediate Perl for the time being…. Then we can revisit class definitions for data tables, widgets, dispatch tables, and my parser if I don’t come to my senses by then….

#!/usr/bin/perl
use warnings;
use strict;
my $show_debug = 0;

my @current_arguments;
my $current_stuff;

my %dispatch_data = (

    'Create Field'  => {
        code    => sub {  my ($field, $regex, $default) = @current_arguments;
                          $current_stuff->{$field} = create_field($regex, $default);
                          return $current_stuff->{$field};
                       },
        debug   => sub { print "Create Field called\n" },
    }

    );

my $dispatch_table = {};
while ( my ( $command, $dispatch ) = each %dispatch_data ) {
    $dispatch_table->{ $command } = sub {
        $dispatch->{ code  }->()  if exists $dispatch->{ code };
        $dispatch->{ debug }->()  if $show_debug;
    } if exists $dispatch->{ code } or ($show_debug and exists $dispatch->{ debug });
}

### return a closure that handles get and set methods for the field
sub create_field {
    my ($regex, $default) = @_;
    my $value;
    $value = $default if $default;
    return sub { my ($v) = @_;
                 if ($v) {
		     if ($regex) {
			 die "Value $v does not match |$regex|." unless ($v =~ /^$regex$/);
		     }
		     $value = $v;
                     return $value;
		 } else {
		     return $value;
		 }
               };
}

sub create_widget {
    my %stuff;
    return sub { my $command = shift;
                 if ($dispatch_table->{$command}) {
                     @current_arguments = @_;
                     $current_stuff = \%stuff;
                     return $dispatch_table->{$command}->();
                 } else {
                     my $thing = $stuff{$command};
                     die "No such thing '$command' in our stuff!" unless $thing;
                     my ($field, $value) = @_;
                     return $thing->($field, $value);
                 }
               };
}

my $f = create_field('\d+');
my $x = $f->(42);
$f->(77);
my $y = $f->();
print "x is $x and y is $y\n";

my $w = create_widget();
$w->('Create Field', 'Prop', '\d+', 43);
my $z = $w->('Prop');
$w->('Prop', 78);
my $a = $w->('Prop');
print "z is $z and a is $a";

using the sphincter-sigil to abuse Perl

September 23, 2008

(Sorry about the title. Don’t you hate it when you’ve got a syntax question and you don’t even know what to google to find out what it means…?)

draegtun dropped by recently to offer suggestions for tuning up some of my Perl code… and some of his code appeared to do some strange things. (Thanks for the help, as always….) Maybe it was something to do with closures and maybe it was operating directly on the internal function table of Perl. So I decided to mess with it some before rolling it out to my mini-project. I’m sure draegtun ‘s a nice guy and all, but I remember all to well the poor wannabe lisp hacker that picked up code for formatting his hard drive via some random use-group advice…. You just can’t be too careful…. 😉 Yeah, this is silly… but this is what passes for understanding code snippets before plugging them in….

Anyways, flipping through the Camel book I quickly came across a similar example in the section on closures. I couldn’t find out what the weird * sigil meant even after flipping around in the index. Logically, Perl is a postmodern language. Therefore the * sigil means the same thing as it did in Kurt Vonnegut’s Breakfast of Champions. Obviously, applying the * to a scalar shoves its associated reference up Perl’s hind end. Perl’s DWIM features should cause it to psychically intuit which internal table you meant it to go to based on the type of reference you’re passing….  (Well, I figure if I can think like Larry, then learning Perl will be a lot easier.  That’s my theory, anyway.  Let’s see if this is right….)

#/usr/bin/perl
use strict;
use warnings;

sub hotwire {
  my $number = 42;
  my $string = "foo";
  my $subname = "blarney";
  no strict 'refs';
  *$subname = sub { print "Yes, it's $number and $string.\n"; };
}

hotwire();
my $number = 12;
my $string = "bar";
blarney();

Okay, this is fun…. Now, we know from the opening chapter of Intermediate Perl that you can use eval as a substitute for the type of error-catching try/catch block activity you might have seen in other languages. Of course, as in other languages, using eval for what it’s supposed to be used is generally stupid and a form of language abuse. However we feel it is our divine right to abuse whatever language we have at our disposal, so let’s just check to see that we can load evaluated text into our environment as a function:

sub loadme {
  my ($name, $code) = @_;
  no strict 'refs';
  *$name = eval $code;
}

loadme("noway", 'sub { print "yadda yadda yadda\n"; }');
noway();

Wow… it works! Woo-hoo! Okay…. Let’s try adding in our own syntactic sugar. We’ll create a function and we’ll search for a pattern and replace it with our function call:

sub check {
  my ($a, $b, $c) = @_;
  return "$a...$b...$c...";
}

sub loadme2 {
  my ($name, $code) = @_;
  $code =~ s/(\w+)~(\w+)~(\w+)/check('$1','$2','$3')/g;
  #print "$code\n";
  no strict 'refs';
  *$name = eval $code;
}

loadme2("yesway", 'sub { my $a = 99; print try~this~out, "\n", $a, "\n"; }');
yesway();

Dumb dumb dumb! There are surely better ways to accomplish this! But yeah, it’s nice to know that (in a pinch) we can do evil nasty things like this…. Let’s try one more variation that loads the text in from a file. Also, let’s store our reference in a scalar variable instead of hotwiring the package’s table of functions….

open TEXTFILE, "< loadthis";
my $file;
while (<TEXTFILE>) {
  $file .= $_;
}
close TEXTFILE;

loadme2("crazy", $file);
crazy();

sub loadme3 {
  my ($code) = @_;
  $code =~ s/(\w+)~(\w+)~(\w+)/check('$1','$2','$3')/g;
  return eval $code;
}

my $C = loadme3($file);
print "Now we'll try running the code from a scalar...\n";
$C->();

There we go!

Now… this is evil… this is wrong… this is bogus and brain dead. But but by marrying this to our table parsing code, we can create our own Frankenstein style scripting language. We already can create specialized data structures can initialize them with data parsed from a pseudo-DSL. We can customize these structures with perl code tacked on however we like. This can be basic event and override code like you see in GUI frameworks. I figure that the code is already interpreted for us into compiled-ish code when the references are read in, so you won’t see any real performance hit when you call these things– they should be indistinguishable from any other sub. Just look for things to slow down at startup as you add more and more of these to the script files. (Yeah, I know. I need to learn about hardware and assembly language– and I need to go pick up a comp sci degree, too– I’ll get around to it sometime. Right now I just want something that works….)

Back in Lisp we made the mistake of trying to create an all-new language that ran on top of Lisp. This was bad because we couldn’t take advantage of Lisp’s language features in our hacked/custom dsl-thing. (We should have gone with the grain of the language and modified Lisp slightly so that it became our lisp-ish DSL by itself.) In Blub, we hacked someone’s custom evaluator to go even further to craft our own language from scratch. This proved to be an unsustainable amount of work beyond a certain level of complexity. With Perl, we are compromising by creating special language-interfaces for initializing data structures… and then switching over to (maybe) slightly-abused Perl code where it suits. There’s better ways to do this, but this may be sufficient for a certain class of problems….

Probably what we’re doing is rolling our own Meta-object protocol. (After a fashion, anyway.) That’s not necessarily a complete waste of time: now maybe if we study it, we’ll have a use for it….

A little experimentation with dispatch tables…

September 16, 2008

The basic model of development that’s been my hobby for the past year has been to use a custom scripting language to configure an object model which is then consumed by a GUI or something– eliminating large amounts of maintenance and opening up a form of tool-oriented development that allows for an order of magnitude increase in code reuse. That was my big thing after getting halfway through SICP– and the trojan horse by which I could sneak in some of the benefits of Lisp into a more Blubby environment. Doing that sort of thing got me into some serious parsing, which made me realize I really needed to bone up on regular expressions. I messed around with sed and awk enough that I finally broke down and decided to learn Perl. Now I’m working through O’Reilly’s Intermediate Perl book so I can understand and use more stuff from Dominus’s book Higher Order Perl.

The code below was mainly done so that I could get a better handle on references in Perl. I’m having a hard time getting up to speed with it, but hopefully after a few more projects like this I’ll get the hang of it. I also wanted to try to improve on the parser design that I thrashed out for Blub a while back. Finally, I wanted to play around with the concept of a dispatch table before rereading Dominus’s chapter on the subject.

Anyways… what I’ve done is constructed my first complex data structure in Perl: a set of nested hash tables and arrays that describe a table of data. We’re loading up the tables by parsing a text file. I’m tired of parsing beginning and ending brackets, so I’m trying maybe a more Python style approach of just using whitespace to indicate the end of a section. Here’s an example table.

Table Stuff:
	Key/[A-Z]/,     Description
	A,              Fooie
	B,              Barrie

The dispatch table (and Perl’s core features) allow us to treat code as data. With just a few language features built in to our parser, we can allow the users of our scripting language to extend and redefine the parser from within their scripts. Pretty cool…. (Dominus goes much further into this than I do, of course. And I’m crazy, so don’t judge his book by my bad code– I’m just learning, here, with my lame “3rd grade” level of Perl fluency.)

As I go further into the book Intermediate Perl, I can maybe come back and revisit this by turning it into an object. Also, I’m not using the regex’s I’ve tacked onto the table columns, so maybe I could write a validation routine that checks that the column data matches the expression. Another change might be to have a second dispatch table to handle the different state changes… but that may be overcomplicating it. [Actually, after refactoring a bit, it seems okay.] I’m sure I might come up with a different architecture if I read some chapters on compiler-like code….

#/bin/perl
use strict;
use warnings;
my %tables;
my $read_type = 0;
my $current_table = "None";
my $show_debug = 0;

sub cell {
    my ($table, $key, $column) = @_;
    my $rs = rows($table);
    my $r = $rs->{$key};
    return $r->{$column};
}

### returns an array of column names
sub columns {
    my ($table) = @_;
    my $t = $tables{$table};
    return  $t->{"Columns"};
}

### returns a hash of row hashes
sub rows {
    my ($table) = @_;
    my $t = $tables{$table};
    return $t->{"Rows"}
}

### returns an array of column regex's for validating cells
sub column_regexes {
    my ($table) = @_;
    my $t = $tables{$table};
    return $t->{"ColumnRegexes"}
}

sub add_table {
    my ($key, $table) = @_;
    $tables{$key} = $table;
}

sub add_row {
    my ($table, $key, $row) = @_;
    rows($table)->{$key} = $row;
}

### pass an array of columns and an array of column regex's
### and get a table hash back
sub initialize_table {
    my ($columns, $regexes) = @_;
    my %table;
    $table{"Columns"} = $columns;
    $table{"ColumnRegexes"} = $regexes;
    my %empty_rows;
    $table{"Rows"} = \%empty_rows;
    return \%table;
}

### 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 $current_table: $line\n" if $show_debug;
    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 get the row's key and a hash of detail data
sub parse_row_detail {
    my ($table, $line) = @_;
    my @fields = split /,/, $line;
    print "reading rows to table $current_table: $line\n" if $show_debug;
    my %row;
    my $column_number = 0;
    my $rowkey;
    foreach(@fields){
        my $field = $_;
        $field =~ s/^\s+|\s+$//g; # trim field
        if ($rowkey){
            $row{columns($current_table)->[$column_number]} = $field;
        } else {
            $rowkey = $field;
        }
        $column_number++;
    }
    return ($rowkey, \%row);
}

sub reading_table_header {
    my ($line) = @_;
    my ($columns, $regexes) = parse_column_header($line);
    add_table($current_table, initialize_table($columns,$regexes));
    $read_type = 2;
}

sub reading_table_detail {
    my ($line) = @_;
    my ($rowkey, $row) = parse_row_detail($current_table, $line);
    add_row($current_table, $rowkey, $row);
}

my $dispatch_table =
    { '^Table ([A-Za-z]+):'     => sub { $current_table = $1; $read_type = 1; print "(reading table $1)\n" if $show_debug; },
      '^\#(.*)'                 => sub { print "found a comment: $1\n" if $show_debug; },
      '^[\w]*$'                 => sub { print "(Whitespace line)\n" if $show_debug; $read_type = 0; }
    };

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

while(<>){
    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);
    }
}

my $a = cell("Stuff", "B", "Description");
print "a is $a\n";
my $cols = columns("Junk");
print "Look at this: $cols->[0], $cols->[1], $cols->[2]\n";

Random Notes on Intermediate Perl/Emacs Stuff

August 5, 2008

The learning curve is steep. It’s hard to know what to prioritize. Perl makes life easier, though, in that the bottom 30% of the language is so all around useful, you can get all kinds of things done even though you “speak Perl like a three year old.” For the rest of it, I just stop every few weeks and take an hour to focus on the two or three things that bug me the most. My theory has been, that as long as the combination of Unix-like shell, Emacs editor, and Perl scripting is applied to my daily work, there’ll always be enough payoff that it’s worth my while to learn the things I’ve been putting off– so that in 6 to 8 months I’ll actually start to gain some genuine skill.

Here’s a few things like that that I finally took the time to address:

(global-font-lock-mode 1)

Put this in your .emacs file to enjoy the wonders of syntax highlighting. Yea. (I wondered why the Windows version was in color where the Cygwin version wasn’t….)

There’s also two Perl modes, for some reason. I actually kind of liked the default one better than the M-x cperl-mode that you’re supposed to use instead. In color, your hashes look atrocious… and your useless spaces show of as abrasive underscore lines…. I use those lines to mark my place in my project– to sort of delineate where I’m working. Cperl-mode seems a little more sluggish to me when it has to place your braces where they belong, but I like the way it spaces things better. (And people talk about how hard it is to parse Perl… it wasn’t long before I broke the syntax highlighting with a line that had a mess of single and double quotes on it. Maybe switching color mode on was not a good idea.)

Perl has anonymous functions and also functions that operate in list context. As much as Larry hates parentheses, it’s clear that he doesn’t hate Lisp concepts….

If you’ve got an array of strings, you can grep them with an anonymous function. Map can be used in a similar way:

my @array = qw/ apple bus cat dog elephant/;
my @things = grep {length($_) > 3} @array;
print "*$_*\n" for @things;
my @stuff = map {"--$_--"} @things;
print "test: $_\n" for @stuff;

# Altogether now:
print map {"!!!$_!!!\n"} grep {length($_) == 3} @array;

Now here’s the cool thing. I’m thinking to myself… wouldn’t it be great if you could refer to files streams in list context? And sure enough…

print map {“!!!$_!!!\n”} grep {length($_) == 3} <>;

This works! All of that accidental complexity in my Perl scripts due to excessive looping and if-then-else blocks… this one idea puts a huge dent in it.

I have to admit, this gave me flashbacks to my college Calculus class. We’d been working through a huge number of problem sets for a few weeks… and the professor comes in and teaches us a trick that showed us we were really doing things the hard way. The “regular” kids were disgusted. Why did he waste all our time? My theory was, that for most of us, we would not have appreciated the trick (and maybe not even understood it) if we hadn’t done the work first. Back at the code bench, this translates to… write bad Perl scripts to do practical things at work. Then clean them up with map and grep. Now you *really* know what they were trying to tell you back in chapter 3 of SICP! You know it down in your fingernails….

Okay, one last note. A few weeks ago, we saw that to really get functions to work with accepting arrays as arguments and returning groups of them for their return values, you had make the mental and semantic leap to begin thinking in terms of references. This seems to be a little tricky, because it doesn’t appear to be a “reference” like what I’ve seen in other languages– maybe it is, but if I “my” the sucker in a subroutine, it looks like that’s copying it, at the very least. Anyways, I’ll gradually assimilate that in time. We don’t really care what a reference really is yet– we just want stuff to work! Especially with hashes!!

my ($foo, $bar) = test2();
my $value = ${$bar}{2};
print "The value of foo is $foo and the value is $value\n";
print "We could have just said, '${$bar}{2}', too.\n";

sub test2 {
  my $foo = "hello";
  my %bar;
  $bar{2} = "world!";
  return ($foo, \%bar);
}

So, to cast the reference (stored in a scalar) into a hash so that we can ‘talk’ to it, we have to ‘fancy’ it in two places. I was thinking that the curly braces around the key would tip Perl off as to what we were trying to do…. And when that didn’t work, I was thinking that some sort of casting with a % sign somewhere would be the ticket. Thanks to Intermediate Perl, though, we know what we need to keep rolling….