#!/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;
	}
    }
}