infocom/compilers/inform6/utilities/log2inf.pl

#!/usr/bin/perl

use strict;
use Getopt::Long;
use Pod::Usage;

Usage() unless @ARGV;

# help options
my ($help, $man);

# debugging options
my ($animate, $verbose, $srand);

# run-time configuration
my $room_class = 'Room';
my $prop_class = 'Prop';

# map generation
my $dt = 0.25;

GetOptions('help|?' => \$help, 'man' => \$man,
	'animate' => \$animate,
	'verbose+' => \$verbose, 'srand=i' => \$srand,
	'room=s' => \$room_class, 'prop=s' => \$prop_class,
	'dt=f' => \$dt,
	) or pod2usage(2);
pod2usage(1) if $help;
pod2usage(-verbose => 2) if $man;

# run-time configuration
my $room = { };
my $prop = { };

my $input = shift;
$input .= '.log' unless -f $input;
(my $base = $input) =~ s/(\.\w+)?$//;
my $output = $base . '.inf';
die "Input file $input is the same as output file $output\n"
	if $input eq $output;
my $plotter = $base . '.png';
die "Input file $input is the same as plotter file $plotter\n"
	if $input eq $plotter;
open(INPUT, $input)
	or die "Unable to open input file $input\n";

warn "input=$input, output=$output, plotter=$plotter\n" if $verbose;

my (%opposite, %sort_by, %xoff, %yoff);
{
	my @d1 = qw/n ne e se u in/;
	my @d2 = qw/s sw w nw d out/;
	@opposite{@d1, @d2} = (@d2, @d1);
	@sort_by{@d1, @d2} = qw/a e c f i k b g d h j l/;
	splice @d1, 4, 2;
	splice @d2, 4, 2;
	my $s2 = sqrt(.5);
	@xoff{@d1, @d2} = ( .0, $s2, 1.0,  $s2,   .0, -$s2, -1.0, -$s2, );
	@yoff{@d1, @d2} = (1.0, $s2,  .0, -$s2, -1.0, -$s2,   .0,  $s2, );
}

my $expecting = $room_class;

sub trace {
	warn sprintf "%d) %s x=%8.5f y=%8.5f fx=%8.5f fy=%8.5f\n", @_,
		if $_[1] =~ /^V/;
}

sub gd {
	my $hash = shift;
	return grep { defined $hash->{$_} } @_;
}

sub cart2rad {
	my ($dx, $dy) = @_;
	my $d = sqrt($dx*$dx + $dy*$dy);
	if (wantarray) {
		return ($d, atan2($dy, $dx));
	} else {
		return $d;
	}
}

sub Usage {
	die <<"__USAGE__";
Usage: $0 <logfile>
__USAGE__
}

sub move {
	my ($prop, $room) = @_;
	return if $prop->{parent} == $room;
	$prop->{parent} = $room;
	$prop->{sibling} = $room->{child};
	$room->{child} = $prop;
}

my $next_line;
sub get_description {
	my @descr;
	while (<INPUT>) {
		s/[\n\r]+//;
		last if /^>/ or eof(INPUT);
		push @descr, $_;
	}
	$next_line = $_;
	return join(' ', @descr);
}

sub fix_description {
	my ($property, $descr) = @_;
	$descr =~ s/"/~/g;  # clean up embedded double-quotes
	$descr =~ s/^/\n    $property "/;  # add header... "\n" is required
	$descr =~ s/ *$/"/;  # clean up trailing spaces
	$descr =~ s/(.*\n[^\n]{1,72}) ([^\n]+)$/$1\n        $2/s
		while $descr =~ /[^\n]{73,}/;  # word-wrap the text
	$descr =~ s/\n        /\n\t/g;  # clean up indentations
	return $descr;
}

{
my ($prev, @dir, $title, $property);
do {
	if ($expecting eq $room_class) {
		my ($label, @descr);
		$title = <INPUT>;
		$title =~ s/[\n\r]+//;
		($label = $title) =~ s/\W+/_/g;
		$label = '_'.$label if $label =~ /^\d/;
		warn "Processing room '$label'\n" if $verbose > 1;
		my $obj = (defined $room->{$label}) ? $room->{$label} : { };
		$obj->{title} ||= $title;
		my $d = get_description();
		$obj->{description} ||= $d;
		$room->{$label} ||= $obj;
		if ($prev) {
			foreach my $d (gd \%opposite, @dir) {
				$prev->{$d} ||= $label;
			}
		}
		$prev = $obj;
	} elsif ($expecting eq $prop_class) {
		warn "Prop found outside room!\n" unless $prev;
		my $label;
		($label = $title) =~ s/\W+/_/g;
		my $suffix = "00";
		(++ $suffix) while (defined $prop->{$label.'_'.$suffix}) &&
			($prop->{$label.'_'.$suffix}->{parent} != $prev);
		$label .= '_'.$suffix;
		warn "Processing prop '$label'\n" if $verbose > 1;
		$prop->{$label} = {
			label => $label,
			title => $title,
			name => join(' ', map {"'$_'"} split /\s+/, $title),
		} if ! defined $prop->{$label};
		$prop->{$label}->{$property} = get_description(),
		move($prop->{$label}, $prev);
	} else {
		warn "Don't know how to expect $expecting\n";
	}
	($_, $next_line) = ($next_line, '');
	s/> *//;
	$_ = lc $_;
	if (/^(x|examine)\s+(.*)/) {
		$title = $2;
		$expecting = $prop_class;
		$property = 'description';
	} elsif (/^(listen\s+to|hear)\s+(.*)/) {
		$title = $2;
		$expecting = $prop_class;
		$property = 'sound';
	} elsif (/^(smell|sniff)\s+(.*)/) {
		$title = $2;
		$expecting = $prop_class;
		$property = 'aroma';
	} elsif (/^(taste)\s+(.*)/) {
		$title = $2;
		$expecting = $prop_class;
		$property = 'flavor';
	} elsif (/^(touch|feel)\s+(.*)/) {
		$title = $2;
		$expecting = $prop_class;
		$property = 'texture';
	} elsif (/^(\w+)/ && (defined($sort_by{$1}) || $1 eq 'back')) {
		@dir = split(/\s*,\s*/);
		$expecting = $room_class;
	} else {
		warn "Ignoring unrecognized command, '$_'\n";
	}
} until eof(INPUT);
}
close(INPUT);

warn "Cleaning up directions\n" if $verbose;
foreach my $label (keys %$room) {
	my $obj = $room->{$label};
	POSSIBLE_EXIT:
	foreach my $dir (gd \%sort_by, keys %$obj) {
		my $label2 = $obj->{$dir};
		my $obj2 = $room->{$label2};
		foreach my $dir2 (gd \%sort_by, keys %$obj2) {
			if ($obj2->{$dir2} eq $label) {
				$obj->{$dir.' '} = $dir2;
				$obj2->{$dir2.' '} = $dir;
				next POSSIBLE_EXIT;
			}
		}
		my $dir2 = $opposite{$dir};
		$obj2->{$dir2} ||= $label;
		$obj->{$dir.' '} = $dir2;
		$obj2->{$dir2.' '} = $dir;
	}
}

open(OUTPUT, ">$output")
	or die "Unable to open output file $output\n";
my @senses = qw/description aroma sound taste texture/;
foreach my $label (sort keys %$room) {
	my $obj = $room->{$label};
	my ($title, $descr) = ($obj->{title}, $obj->{description});
	next unless $descr;
	warn "printing room $label\n" if $verbose > 1;
	my @d =( fix_description('description', $descr) );
	foreach my $dir (sort { $sort_by{$a} cmp $sort_by{$b} } 
			gd \%sort_by, keys %$obj) {
		my $label2 = $obj->{$dir};
		push @d, qq/    ${dir}_to ${label2}/;
	}
	print OUTPUT qq/$room_class $label "$title"\n  with/,
		join(",\n", @d), ";\n\n";

	for ($obj = $obj->{child}; $obj; $obj = $obj->{sibling}) {
		my ($label, $title) = ($obj->{label}, $obj->{title});
		warn "  printing prop $label\n" if $verbose > 2;
		my @d;
		foreach my $sense (gd $obj, @senses) {
			warn "    printing $sense\n" if $verbose > 3;
			push @d, fix_description($sense, $obj->{$sense});
		}
		#next unless @d;
		print OUTPUT qq/$prop_class -> $label "$title"\n  with/,
			join(",", qq/\n    name $obj->{name}/, @d),
			";\n\n";
	}
}
close(OUTPUT);

warn "Calculating path lengths\n" if $verbose;
my %cost; # cost matrix used by Floyd's algorithm
foreach my $label (keys %$room) {
	my $obj = $room->{$label};
	foreach my $label2 (keys %$room) {
		$cost{$label}->{$label2} = 9999;
	}
	foreach my $dir (grep {$sort_by{$_}} keys %$obj) {
		my $label2 = $obj->{$dir};
		$cost{$label}->{$label2} = 1;
	}
	$cost{$label}->{$label} = 0;
}

warn "Applying Floyd's algorithm\n" if $verbose;
foreach my $k (keys %$room) {
  my $cost_k = $cost{$k};
  foreach my $i (keys %$room) {
    my $cost_i = $cost{$i};
    foreach my $j (keys %$room) {
      if ($cost_i->{$j} > ($cost_i->{$k} + $cost_k->{$j})) {
        $cost_i->{$j} = $cost_i->{$k} + $cost_k->{$j};
      }
    }
  }
}

warn "Calculating map locations\n" if $verbose; 
(my $nbr_rooms = scalar %$room) =~ s=/.*==;
$nbr_rooms = 0 + $nbr_rooms;
$srand = int(10000 * rand) unless defined $srand;
srand $srand;
foreach my $label (keys %$room) {
	$room->{$label}->{x} = 24*rand;
	$room->{$label}->{y} = 24*rand;
}
my (%min, %max);
my ($pass, $prev_f, $iteration) = (1, 9999, '000');
while ($pass != 3) {
	%min = (x=>+1e9, y=>+1e9, f=>+1e9);
	%max = (x=>-1e9, y=>-1e9, f=>-1e9);
	foreach my $label (keys %$room) {
		my $obj = $room->{$label};
		my ($x, $y, $fx, $fy) = ($obj->{x}, $obj->{y}, 0, 0);
		#trace 1, $label, $x, $y, $fx, $fy;
		# links between rooms exert attractive force
		foreach my $dir (gd \%xoff, keys %$obj) {
			my $label2 = $obj->{$dir} or next;
			my $obj2 = $room->{$label2}
				or die "obj2: label=$label, dir=$dir, label2=$label2";
			my $dir2 = $obj->{$dir.' '}
				or die "dir2: label=$label, dir=$dir, label2=$label2";
			my ($d, $r) = cart2rad(
				($x + $xoff{$dir}) - ($obj2->{x} + $xoff{$dir2}),
				($y + $yoff{$dir}) - ($obj2->{y} + $yoff{$dir2}),
				);
			my $f = $d;
			$fx += $f * cos($r);
			$fy += $f * sin($r);
		}
		# all rooms exert repulsive force
		unless ($pass == 1) {
		my $costs = $cost{$label};
		foreach my $label2 (keys %$room) {
			next if $label2 eq $label;
			my $obj2 = $room->{$label2};
			my ($d, $r) = cart2rad(
				$x - $obj2->{x}, $y - $obj2->{y});
			$d /= 3;
			my $f = $costs->{$label2} /
				(($d < 1) ? $d : ($d*$d));
			$f = 10 if $f > 10;
			$fx -= $f * cos($r);
			$fy -= $f * sin($r);
		}
		}
		$obj->{fx} = $fx;
		$obj->{fy} = $fy;
		my $f = cart2rad($fx, $fy);
		$max{f} = $f if $max{f} < $f;
		$min{f} = $f if $min{f} > $f;
	}
	foreach my $label (keys %$room) {
		my $obj = $room->{$label};
		#trace 3, $label, $obj->{x}, $obj->{y}, $obj->{fx}, $obj->{fy};
		$obj->{x} -= $obj->{fx} * $dt;
		$obj->{y} -= $obj->{fy} * $dt;
		foreach my $v (qw/x y fx fy/) {
			if ($min{$v} > $obj->{$v}) {
				$min{$v} = $obj->{$v};
				$min{$v.' who'} = $label;
			}
			if ($max{$v} < $obj->{$v}) {
				$max{$v} = $obj->{$v};
				$max{$v.' who'} = $label;
			}
		}
	}
	#warn sprintf "sqrt((%8.5f-%8.5f)/(%8.5f-%8.5f+%8.5f-%8.5f))\n",
	#	$max{f}, $min{f}, $max{x}, $min{x}, $max{y}, $min{y};
	$dt = 0.1*sqrt(($max{x}-$min{x}+$max{y}-$min{y}) / ($max{f}-$min{f}));
} continue {
	warn sprintf "pass $pass, dt = %8.5f, prev. f = %8.5f\n",
		$dt, $prev_f if $verbose > 1;
	foreach my $v (qw/x y fx fy/) {
		warn sprintf "\t$v min=%8.5f @ %-8s max=%8.5f @ %-8s\n",
			$min{$v}, $min{$v.' who'}, $max{$v}, $max{$v.' who'}
			if $verbose > 2;
	}
	if ((($prev_f - $max{f}) < 0.01) && ($max{f} < 2)) {
		++ $pass;
		$prev_f = 9999;
	} elsif ($max{x}-$min{x} > 1000) {
		++ $pass;
	} elsif ($max{y}-$min{y} > 1000) {
		++ $pass;
	} elsif ($max{f} > 9999) {
		++ $pass;
	} else {
		$prev_f = $max{f};
	}
	plot($base.'.'.($iteration++).'.png') if $animate;
}
plot($base.'.png');

sub plot {
	my $plotter = shift;

my $diam = 1;
foreach my $v (qw/x y/) {
	$min{$v} -= $diam + 1;
	$max{$v} += $diam + 1;
}

use Graphics::Plotter;
open(PLOTTER, ">$plotter")
	or die "Unable to open plotter file $plotter\n";
my $p = Graphics::Plotter::PNG->new(*PLOTTER);
$p->openpl();

my ($dx, $dy) = ($max{x}-$min{x}, $max{y}-$min{y});
if ($dx > $dy) {
	$p->fspace($min{x}, $min{y}-($dx-$dy)/2, $max{x}, $max{y}+($dx-$dy)/2);
	$p->fmove($min{x}, $min{y}-($dx-$dy)/2);
} else {
	$p->fspace($min{x}-($dy-$dx)/2, $min{y}, $max{x}+($dy-$dx)/2, $max{y});
	$p->fmove($min{x}-($dy-$dx)/2, $min{y});
}
$p->alabel('l','b',"srand=$srand");

foreach my $label (keys %$room) {
	my $obj = $room->{$label};

	my ($x, $y) = ($obj->{x}, $obj->{y});
	$p->fmove($x,$y);
	$p->fcirclerel(0,0,$diam);

	my ($title, $descr) = ($obj->{title}, $obj->{description});
	if (length($title) > 5) {
		$title = substr($title,0,5);
	}
	$p->pencolorname($descr?"blue":"red");
	$p->alabel('c','c',$title);
	$p->pencolorname("black");

	foreach my $dir (gd \%xoff, keys %$obj) {
		my $label2 = $obj->{$dir} or next;
		my $obj2 = $room->{$label2}
			or die "obj2: label=$label, dir=$dir, label2=$label2";
		my $dir2 = $obj->{$dir.' '}
			or die "dir2: label=$label, dir=$dir, label2=$label2";
			$x + $xoff{$dir}, $y + $yoff{$dir},
			$obj2->{x} + $xoff{$dir2}, $obj2->{y} + $yoff{$dir2};
		#$p->fline($x + $xoff{$dir}, $y + $yoff{$dir},
		#	$obj2->{x} + $xoff{$dir2}, $obj2->{y} + $yoff{$dir2});
		$p->fbezier3($x + $xoff{$dir}, $y + $yoff{$dir},
			$x + 2 * $xoff{$dir}, $y + 2 * $yoff{$dir},
			$obj2->{x} + 2 * $xoff{$dir2},
					$obj2->{y} + 2 * $yoff{$dir2},
			$obj2->{x} + $xoff{$dir2}, $obj2->{y} + $yoff{$dir2});
	}
}
$p->closepl();

}

__END__

=head1 NAME

log2inf - Reverse-engineer an IF transcript into an Inform source file.

=head1 SYNOPSIS

sample [options] [file]

 Options:
   -room <string>   name of Class to use for rooms (default 'Room')
   -prop <string>   name of Class to use for props (default 'Prop')
   -dt <float>      see below
   -animate         produce an image after each pass
   -verbose         increment verbosity level
   -srand <int>     initialize random number generator
   -help            brief help message
   -man             full documentation

=head1 OPTIONS

=over 8

=item B<-room> -I<name>

Name of Class to use for rooms (default 'Room').

=item B<-prop> -I<name>

Name of Class to use for props (default 'Prop').

=item B<-dt> -I<float>

Sets increment amount for map generation.

=item B<-animate>

Graphs are produced by seeding the rooms to random locations, then moving
them around to minimize the forces produced by elastic links between them.
This option causes a graph to be produced after each iteration.

=item B<-verbose>

Increment verbosity level.  Use it once to produce a little output,
use it multiple times to produce a lot.

=item B<-srand> -I<int>

Initialize random number generator.

=item B<-help>

Print a brief help message and exits.

=item B<-man>

Prints the manual page and exits.

=back

=head1 DESCRIPTION

In "The Inform Designer's Manual, 4th edition, Graham Nelson says,
"Gareth Rees persuasively advocates writing this sort of
transcript, of an ideal sequence of play, first, and worrying about
how to code up the design afterwards. Other designers prefer to build
from the bottom up, crafting the objects one at a time and finally
bringing them together into the narrative."

I've gone with Rees' idea.  First, I wrote a transcript, then I wrote
a Perl script that turns transcripts into Inform source code.  So,
something like this:

  >n
  West Wing
  You are in the West Wing of the White House. You see a desk and, on
it, a red telephone.
  >x large wooden desk
  It has a heavy paperweight on it.
  >x paperweight
  It says "The buck stops here."
  >x red telephone
  It's red, without a dial.
  >w
  Rose Garden

generates something like this:

  Room West_Wing "West Wing"
    with
      description "You are in the West Wing of the White House. You
see a desk and, on it, a red telephone.",
      w_to Rose_Garden;
  Prop -> large_wooden_desk_00 "large wooden desk"
    with
      name 'large' 'wooden' 'desk'
      description "It has a paperweight on it."
  Prop -> paperweight_00 "paperweight"
    with
      name 'paperweight'
      description "It says ~The buck stops here.~"
  Prop -> red_telephone_00 "red telephone"
    with
      name 'red' 'telephone'
      description "It's red, without a dial."

Props are numbered, so multiple rooms could contain, for example,
large wooden desks. Note that anything described is assumed to be a
child of the room, so you still have a bit of fixing up to do (both
the paperweight and the telephone, in this instance).  Also, note that
I assume the existance of classes named Room and Prop.  Right now, I
use the script to generate a file that I then include in my main
Inform source, as both the transcript and the Perl script are still in
a bit of flux.

My next goal is to add a mapping component, which will likely spit out
gnuplot instructions to draw a crude map of just the rooms.  You just
pretend that the eight "primary" links between rooms are elastic, and
figure out a layout that keeps the links at their minimal lengths.
Simple iterative physics-based modeling.

I think I can also divide a map into layers by using some coloring
algorithms.  It's easy if the only connections between layers are 'up'
and 'down', but I think that by using weighted averaging, I can decide
which connections are important and which just lead to sunken living
rooms and the like.

=head1 AUTHOR

Sam Denton, samwyse (at) email (dot) com

=head1 BUGS

=head1 SEE ALSO

"The Inform Designer's Manual", 4th edition, Graham Nelson.

=head1 COPYRIGHT

Copyright 2004, Sam Denton.  All rights reserved.  
This program is free software.  You may copy or
redistribute it under the same license as Perl itself.

=cut