#!/usr/local/bin/perl
# atopojo.pl - Generate MUD inter-area topology as JSON
#
# Copyright 2015 David Meyer <[email protected]> +JMJ
# (License and documentation at bottom of file.)


use strict;
use warnings;
use Getopt::Std;
use JSON;


our (@AREA, %RMAREA, @RMLINK, %ALINK, @ALINK);
## @AREA: {ID, FILE, NAME}
## %RMAREA: {rmnum}, areaid
## @RMLINK: {ORIGIN, DEST}
## %ALINK: {aorigin}{adest}, type (0: 1-way; 1: 2-way (indirect);
##                                 2: 2-way (same rooms))
## @ALINK: {AREAO, AREAD, TYPE}


our %OPTIONS = ();
getopts('df:', \%OPTIONS);


%FSM::STATE = (SKIP => 0,
              AREA => 1,
              ROOMS => 2,
              PENDRNAME => 3,
              PENDRDESC => 4,
              WAITDOOR => 5,
              PENDDDESC => 6,
              PENDDKW => 7,
              PENDDLKD => 8);
$FSM::state = $FSM::STATE{SKIP};

sub parse_are_fsm {
   my($afile, $aline) = @_;

   if ($FSM::state == $FSM::STATE{SKIP}) {
       if ($aline =~ /^#AREA\s+({.*}\s+\w+\s+)?(.*)~/) {
           $FSM::areaname = $2;
           $FSM::areaid = $#AREA + 1;
           push @AREA, {ID => $FSM::areaid, FILE => $afile, NAME => $FSM::areaname};
           $FSM::state = $FSM::STATE{AREA};
       }
   }

   elsif ($FSM::state == $FSM::STATE{AREA}) {
       if ($aline =~ /^#ROOMS$/) {
           $FSM::state = $FSM::STATE{ROOMS};
       }
       elsif ($aline =~ /^#\$$/) {
           $FSM::state = $FSM::STATE{SKIP};
       }
   }

   elsif ($FSM::state == $FSM::STATE{ROOMS}) {
       if ($aline =~ /^#0$/) {
           $FSM::state = $FSM::STATE{AREA};
       }
       elsif ($aline =~ /^#(\d+)$/) {
           $FSM::room = $1;
           $RMAREA{$FSM::room} = $FSM::areaid;
           $FSM::state = $FSM::STATE{PENDRNAME};
#           if (defined $OPTIONS{d}) {print STDERR "$afile\t#$1:\t";}
       }
   }

   elsif ($FSM::state == $FSM::STATE{PENDRNAME}) {
       if ($aline =~ /~$/) {
           $FSM::state = $FSM::STATE{PENDRDESC};
       }
   }

   elsif ($FSM::state == $FSM::STATE{PENDRDESC}) {
       if ($aline =~ /~$/) {
           $FSM::state = $FSM::STATE{WAITDOOR};
       }
   }

   elsif ($FSM::state == $FSM::STATE{WAITDOOR}) {
       if ($aline =~ /^D(\d+)$/) {
#           $FSM::exdir = $1;
           $FSM::state = $FSM::STATE{PENDDDESC};
       }
       elsif ($aline =~ /^S$/) {
           $FSM::state = $FSM::STATE{ROOMS};
#           if (defined($OPTIONS{d})) {print STDERR "\n";}
       }
   }

   elsif ($FSM::state == $FSM::STATE{PENDDDESC}) {
       if ($aline =~ /~$/) {
           $FSM::state = $FSM::STATE{PENDDKW};
       }
   }

   elsif ($FSM::state == $FSM::STATE{PENDDKW}) {
       if ($aline =~ /~$/) {
           $FSM::state = $FSM::STATE{PENDDLKD};
       }
   }

   elsif ($FSM::state == $FSM::STATE{PENDDLKD}) {
       if ($aline =~ /^\S+\s+\S+\s+(\d+)$/) {
           $FSM::exdest = $1;
           push @RMLINK, {ORIGIN => $FSM::room, DEST => $FSM::exdest};
           $FSM::state = $FSM::STATE{WAITDOOR};
#           if (defined $OPTIONS{d}) {print STDERR "$FSM::exdest ";}
       }
   }

   else {
       die "Invalid state processing file $afile line $.";
   }

}


## Read and parse area files
if (defined($OPTIONS{f})) {
   open(my $FLIST, "<", $OPTIONS{f}) or die "Can't open file $OPTIONS{f}: $!";
   my @afiles;
   while (<$FLIST>) {
       chop $_;
       if ($_ eq '$') {last;}
       push @afiles, $_;
   }
   foreach my $afile (@afiles) {
       open(my $AF, "<", $afile) or die "Can't open file $afile: $!";
       while (<$AF>) {
           parse_are_fsm($afile, $_);
       }
       close $AF;
   }
}
else {
   while (<>) {
       parse_are_fsm($ARGV, $_);
   }
}


## Select links between different areas
our %arlink;
foreach my $link (@RMLINK) {
   my $rorigin = $link->{ORIGIN};
   my $rdest = $link->{DEST};
   if (defined($RMAREA{$rdest})) {
       my $aorigin = $RMAREA{$rorigin};
       my $adest = $RMAREA{$rdest};
       if ($aorigin != $adest) {
           $arlink{$rorigin}{$rdest} = 1;
           if (defined $OPTIONS{d}) {print STDERR "$rorigin\t-> $rdest";}
           if (defined $OPTIONS{d}) {if (defined($arlink{$rdest}{$rorigin})) {print STDERR "\nD>O\n";} else {print STDERR "\t--\n";}}

           if (defined($arlink{$rdest}{$rorigin})) {
               $ALINK{$adest}{$aorigin} = 2;
           }
           elsif (defined($ALINK{$adest}{$aorigin})) {
               if ($ALINK{$adest}{$aorigin} == 0) {
                   $ALINK{$adest}{$aorigin} = 1;
               }
           }
           else {
               $ALINK{$aorigin}{$adest} = 0;
           }
#           if (defined $OPTIONS{d}) {print STDERR "$rorigin\t-> $rdest";}
#           if (defined $OPTIONS{d}) {if (defined $ALINK{$aorigin}{$adest}) {print STDERR " >$ALINK{$aorigin}{$adest}\n";} if (defined $ALINK{$adest}{$aorigin}) {print STDERR " <$ALINK{$adest}{$aorigin}\n";}}
       }
   }
}


foreach my $area (0 .. $#AREA) {
   if (defined $ALINK{$area}) {
       foreach my $adest (keys %{$ALINK{$area}}) {
           push @ALINK, {AREAO => $AREA[$area]->{NAME},
                         AREAD => $AREA[$adest]->{NAME},
                         TYPE => $ALINK{$area}{$adest}};
#           print "test: $ALINK[-1]->{TYPE}\t$ALINK[-1]->{AREAO}\t-> $ALINK[-1]->{AREAD}\n";
       }
   }
}


print encode_json {links => [@ALINK]};


exit 0

__END__

# Documentation #####################################################
=head1 NAME

template.pl - Perl script template (command line)

=head1 SYNOPSIS/USAGE

=head1 DESCRIPTION

Mark up code elements with C<>, file names with F<> (or C<> for
readability), command names with B<>. Also I<> for italics, U<> for
underline. Entities: E<lt> ('<'), E<gt> ('>').

=head1 OPTIONS

=item B<-o> I<value>, B<--option>=I<value>

=head1 RETURN VALUE

=head1 ERRORS

=head1 DIAGNOSTICS

=head1 EXAMPLES

=head1 ENVIRONMENT

=over 6

=item VARIABLE

Description of usage of environment variable C<VARIABLE>.

=back

=head1 FILES

=head1 BUGS, LIMITATIONS, AND CAVEATS

=head1 NOTES

=head1 AUTHOR

David Meyer <[email protected]>

=head1 HISTORY

=head1 COPYRIGHT AND LICENSE

Copyright 201x David Meyer

=head1 SEE ALSO



# Emacs control #####################################################
#Local variables:
#mode: perl
#End:

You are viewing proxied material from sdf.org. The copyright of proxied material belongs to its original authors. Any comments or complaints in relation to proxied material should be directed to the original authors of the content concerned. Please see the disclaimer for more details.