#!/usr/bin/perl -w
# $Id: sad,v 1.8 2006/11/04 11:30:12 mike Exp $
#
# To test:
# cd /usr/local/src/mike/scott/Games-ScottAdams/bin && perl -I ../lib sad /usr/local/src/mike/games/adams/adv01.dat > advland.sac && perl -I ../lib sac advland.sac > advland.sao && xterm -e scottfree advland.sao
=head1 NAME
sad - the Scott Adams Decompiler
=head1 SYNOPSIS
scottfree advland.sao
sad advland.sao > advland.sac
=head1 DESCRIPTION
C<sad> decompiles the TRS-80 format Scott Adams game file named on the
command-line, writing the resulting source code on standard output in
a format suitable for subsequent recompilation with C<sac>.
=head1 SEE ALSO
C<sac>, the Scott Adams Compiler.
C<Games::ScottAdams>, the CPAN distribution containing this program.
=head1 AUTHOR
Mike Taylor E<lt>mike@miketaylor.org.ukE<gt>
First version Friday 3rd November 2006.
=cut
# In fact, since decompilation so much simpler a process than
# compilation, there's no need to use the library at all. Building
# the Games::ScottAdams::Game data-structure so that we could call a
# decompile() method would be much more difficult that just playing
# out the decompilation.
use strict;
use warnings;
use Games::ScottAdams::File;
# Borrow data-registeres from the compiler
use Games::ScottAdams::Action;
my $cond = \%Games::ScottAdams::Action::_cond;
my %condByIndex = map { $cond->{$_}->[0] =>
[ $_, $cond->{$_}->[1] ] } keys %$cond;
my $res = \%Games::ScottAdams::Action::_res;
my %resByIndex = map { $res->{$_}->[0] =>
[ $_, $res->{$_}->[1] ] } keys %$res;
#use Data::Dumper; print Dumper(\%resByIndex);
if (@ARGV != 1) {
print STDERR "Usage: $0 <sa-game-file>\n";
exit 1;
}
my($name) = @ARGV;
my $f = new Games::ScottAdams::File("$name")
or die "$0: can't open Scott Adams game file '$name': $@\n";
# --- Parse ------------------------------------------------------------------
my($unknown1,
$nitems,
$nactions,
$nvocab,
$nrooms,
$maxload,
$start,
$ntreasures,
$wordlen,
$lighttime,
$nmessages,
$treasury) = map { $f->getint() } 1..12;
my @actions;
foreach (0..$nactions) {
push @actions, {
verbnoun => $f->getint(),
conds => [ map { $f->getint() } 1..5 ],
results => [ map { $f->getint() } 1..2 ],
};
}
my(@verbs, @nouns);
foreach (0..$nvocab) {
push @verbs, $f->getstring();
push @nouns, $f->getstring();
}
my @rooms;
foreach my $id (0..$nrooms) {
push @rooms, {
id => $id,
exits => [ map { $f->getint() } 1..6 ],
desc => $f->getstring(),
};
}
my @messages = ( map { $f->getstring() } 0..$nmessages );
my @items;
foreach my $id (0..$nitems) {
push @items, {
id => $id,
desc => $f->getstring(),
pos => $f->getint(),
};
}
foreach (0..$nactions) {
$actions[$_]->{comment} = $f->getstring();
}
my($version,
$ident,
$unknown2) = map { $f->getint() } 1..3;
$f->close();
# --- Resolve ----------------------------------------------------------------
foreach my $item (@items) {
if ($item->{desc} =~ s/\/(.*)\/$//) {
$item->{getdrop} = $1;
}
if ($item->{desc} eq "") {
$item->{desc} = "UNDESCRIBED";
}
}
my %room2id = resolve_names(\@rooms, 1);
my %item2id = resolve_names(\@items, 0);
sub resolve_names {
my($list, $skipstars) = @_;
my %map;
foreach my $object (@$list) {
my $name = lc($object->{desc});
if ($skipstars && $name =~ /^\*/) {
# A room, probably of the form "*I'm in a" or "*I'm on a"
$name =~ s/.*?\s.*?\s.*?\s//;
}
$name =~ s/\s.*//s;
$name = "UNNAMED" if $name eq "";
if (exists $map{$name}) {
my $i = 1;
while (exists $map{"$name$i"}) {
$i++;
}
$name .= $i;
}
$map{$name} = $object->{id};
$object->{name} = $name;
}
return %map;
}
# --- Emit -------------------------------------------------------------------
print "# THIS IS A GENERATED FILE.\n";
print "# DO NOT EDIT IT UNLESS YOU KNOW WHAT YOU'RE DOING.\n";
print "# Made by $0 from $name\n";
print "# ", `date`;
print "\n";
print "%ident $ident\n";
print "%version $version\n";
print "%wordlen $wordlen\n";
print "%maxload $maxload\n";
print "%lighttime $lighttime\n";
print "%treasury ", $rooms[$treasury]->{name}, "\n";
print "%start ", $rooms[$start]->{name}, "\n";
print "\n";
print "# $nvocab verbs and nouns\n";
print "# $ntreasures treasures\n";
print "# $nmessages messages\n";
print "# unknown header value 1: $unknown1";
print " (generated by 'sac')" if $unknown1 == (76<<8)+84;
print "\n";
print "# unknown header value 2: $unknown2\n";
print "\n";
print "# $nrooms rooms\n";
foreach my $room (@rooms) {
next if $room->{id} == 0;
print "%room ", $room->{name}, "\n";
print $room->{desc}, "\n";
my @dir = qw(north south east west up down);
foreach my $i (0..5) {
my $dest = $room->{exits}->[$i];
print "%exit ", $dir[$i], " ", $rooms[$dest]->{name}, "\n" if $dest;
}
if (0) {
# Cheating
print "%action teleport ", $room->{name}, "\n";
print "%result\n";
print "moveto ", $room->{name}, "\n";
}
print "\n";
}
print "# $nitems items\n";
foreach my $item (@items) {
print "%item ", $item->{name}, "\n";
print $item->{desc}, "\n";
print "%getdrop ", $item->{getdrop}, "\n" if defined $item->{getdrop};
my $pos = $item->{pos};
if ($pos == 0) {
print "%nowhere\n";
} else {
print "%at ", $rooms[$pos]->{name}, "\n";
}
print "%lightsource ", $item->{name}, "\n"
if $item->{id} == 9;
print "\n";
}
print "# $nactions actions\n";
foreach my $action (@actions) {
my $verb = int($action->{verbnoun} / 150);
my $noun = $action->{verbnoun} % 150;
print "\n";
if ($verb == 0) {
print "%occur";
print " $noun" if $noun != 100;
} else {
print "%action ", $verbs[$verb];
print " ", $nouns[$noun] if $noun != 0;
}
print "\n";
my @args;
foreach my $cond (@{ $action->{conds} }) {
my $op = $cond % 20;
my $val = int($cond / 20);
if ($op == 0) {
push @args, $val;
} else {
my $ref = $condByIndex{$op};
my($name, $argType) = @$ref;
print $name;
if ($argType == Games::ScottAdams::Action::ARG_ITEM) {
print " ", $items[$val]->{name};
} elsif ($argType == Games::ScottAdams::Action::ARG_ROOM) {
print " ", $rooms[$val]->{name};
} elsif ($argType == Games::ScottAdams::Action::ARG_NUM) {
print " $val";
} elsif ($argType != Games::ScottAdams::Action::ARG_NONE) {
die "unknown condition arg type '$argType'";
}
print "\n";
}
}
print "%result\n";
my $arg = 0;
foreach my $num (@{ $action->{results} }) {
foreach my $op (int($num/150), $num%150) {
if ($op == 0) {
# Do nothing
} elsif ($op <= 51) {
msg($messages[$op]);
} elsif ($op >= 102) {
msg($messages[$op-50]);
} else {
my $ref = $resByIndex{$op};
my($name, $argType) = @$ref;
print $name;
if ($argType == Games::ScottAdams::Action::ARG_ITEM) {
print " ", $items[$args[$arg++]]->{name};
} elsif ($argType == Games::ScottAdams::Action::ARG_ROOM) {
print " ", $rooms[$args[$arg++]]->{name};
} elsif ($argType == Games::ScottAdams::Action::ARG_NUM) {
print " ", $args[$arg++];
} elsif ($argType == Games::ScottAdams::Action::ARG_ITEMROOM) {
print " ", $items[$args[$arg++]]->{name};
print " ", $rooms[$args[$arg++]]->{name};
} elsif ($argType == Games::ScottAdams::Action::ARG_ITEMITEM) {
print " ", $items[$args[$arg++]]->{name};
print " ", $items[$args[$arg++]]->{name};
} elsif ($argType != Games::ScottAdams::Action::ARG_NONE) {
die "unknown action arg type '$argType'";
}
print "\n";
}
}
}
print "%comment ", $action->{comment}, "\n"
if $action->{comment} ne "";
}
sub msg {
my($msg) = @_;
foreach my $line (split /\n/, $msg) {
if ($line eq "") {
print "nl\n";
} else {
print "msg $line\n";
}
}
}
print_aliases(\@verbs, "v");
print_aliases(\@nouns, "n");
sub print_aliases {
my($list, $prefix) = @_;
my $lastWord;
print "\n";
foreach my $word (@$list) {
if ($word =~ s/^\*//) {
print "%${prefix}alias $word $lastWord\n";
} else {
$lastWord = $word;
}
}
}