#!/usr/bin/perl -w
### pragmas and modules
use strict;
use DB_File;
### configuration
my $db_file_prefix = '/var/www/vweb/howtired/docs/storytree/db';
my $URL = 'http://www.howtired.com/storytree/';
### data structures, defaults-for-zero replaced with tied arrayref at init time
my %db = (
nw => '-', # node => word at that node
np => 0, # node => parent node
nv => 0, # node => total votes; default 0; may be negative)
ns => 0, # node => node's votes + parent's score
nd => 0, # node => parent's depth + 1
nc => '', # node => child,child,child,
rn => 0, # rank => node, 0 = top, resort at Score change
);
### start output
print <<'EOF';
Content-type: text/html
StoryTree
StoryTree
EOF
### go!
eval {
### initialization
### get world data
my $args = &get_args;
### tie databases
my $init_db = 0;
if ($args->{'init_db'} eq 'foo') {
$init_db = 1; # clean up and set default in each database
print 'Initializing databases.
';
$args->{'node'} = 0;
}
for my $db (keys %db) {
my @db = (); # new array
tie (@db, 'DB_File', "$db_file_prefix.$db",
O_CREAT|O_RDWR, 0640, $DB_RECNO)
or die "trying to tie to '$db' database";
if ($init_db) { # initalizing databases too
@db = (); # clear database
$db[0] = $db{$db}; # set default for 0
}
$db{$db} = \@db;
}
### process input
### add new word
my $node = $args->{'node'} || int($db{'np'}[0]);
if ($args->{'new'} =~ /^[A-Za-z0-9\.\-!\? ]+$/) {
my $words = $args->{'new'};
$words =~ s/^\s+//;
$words =~ s/\s+$//;
my (@words) = split /\s+/, $words, 10;
my $parent = $node;
my $new;
for my $word (@words) {
# allocate new node
$new = int($db{'np'}[0]) + 1;
$db{'np'}[0] = $new;
# fill in data
$db{'nw'}[$new] = $word;
$db{'np'}[$new] = $parent;
$db{'nv'}[$new] = 0;
$db{'ns'}[$new] = $db{'ns'}[$parent];
$db{'nd'}[$new] = $db{'nd'}[$parent] + 1;
$db{'nc'}[$parent] .= "$new,";
$db{'rn'}[$new] = $new;
# FIXME - bubblesort $db{'rn'}[$new] into place
$parent = $new;
}
print qq(Added "$words".
);
$node = $new; # display this position now
}
### handle UP and DOWN
if ($args->{'move'} eq 'UP' or $args->{'move'} eq 'DOWN') {
my $change = $args->{'move'} eq 'UP' ? 1 : -1;
# recursively increment score
my @children = $node;
while (@children) {
my $nptr = pop @children;
$db{'ns'}[$nptr] += $change; # increment score
# FIXME - re-sort ... how to find rn node?
push @children, map { int($_) } split (/,/, $db{'nc'}[$nptr]);
}
}
### collect story data
### read current story
my @words = (); # all the words in the story
my $nptr = $node;
while ($nptr != 0) {
push @words, [$nptr, $db{'nw'}[$nptr]]; # retrieve word
$nptr = $db{'np'}[$nptr]; # follow parent pointer
}
@words = reverse @words;
### get children
my @children = map {[int($_), $db{'nw'}[$_]]} # store node, word
sort {$db{'ns'}[$a] <=> $db{'ns'}[$b]} # sort by score
split (/,/, $db{'nc'}[$node]); # split data
# FIXME - find _all_ children recursively, sorted by score
### display story
### time for more output!
print ''
# the story so far
. join (' ', map (qq($_->[1]), @words))
# the child-picker
. (@children ? (' ... [ '
. join (' | ', map(qq($_->[1]), @children))
. ' ]'
) : '')
. <<""
# . qq( [UP])
# . qq( [DOWN])
. '';
### finish up
### print statistics
print <<"";
Node $node. $db{'np'}[0] word${\($db{'np'}[0]==1?'':'s')}
in the whole tree.
};
### report errors
if (my $error = $@) {
$error =~ s/at $0 line (\d+)\.$/on line $1/g;
print qq(
Error $error);
}
### clean up
for my $db (keys %db) {
untie @{$db{$db}};
}
### end output
print <<'';
storytree@aceldama.com
exit;
### subroutines
sub get_args { # reads GET or POST data, parses into hashref
my $args = $ENV{'QUERY_STRING'} || '';
if ($ENV{'REQUEST_METHOD'} eq 'POST') {
read (STDIN, my $input, $ENV{'CONTENT_LENGTH'});
$args .= '&' if length($args);
$args .= $input;
}
my @args = split (/&/, $args);
my %args;
foreach my $kv (@args) {
$kv =~ tr/+/ /;
my ($key, $val) = split (/=/, $kv, 2);
$key =~ s/%([0-9A-F][0-9A-F])/pack('c', hex($1))/igeo;
$val =~ s/%([0-9A-F][0-9A-F])/pack('c', hex($1))/igeo;
$args{$key} = $val;
}
return \%args;
}
### EOF