#!/bin/perl

my $debug = 0;

=pod

OBJECT ::= GOAL DONE PLAN_LIST ';' ;

GOAL ::= 'goal' IDENT '(' IDENT ',' IDENT ',' IDENT ')' ;

DONE ::= 'done' WHEN ',' ;

WHEN ::= 'always' | 'never' | 'unless' EXPR | 'when' EXPR ;

PLAN_LIST ::= 'plan' 'is' STEP_LIST { 'or' 'else' STEP_LIST } ;

STEP_LIST ::= [ 'multiple' EXPR ',' ] STEP { ',' STEP } ;

STEP ::= 'if' WHAT | 'be' WHAT | 'do' WHAT ;

WHAT ::= IDENT '(' EXPR ',' EXPR ')'

=cut

use strict;
use subs qw/OBJECT GOAL DONE PLAN_LIST OR_ELSE WHEN STEP_LIST STEP WHAT
	lit IDENT EXPR FAIL/;

print "System_file;\n";

my @routines;
while (<>) {
	push @routines, $1 if /\[\s*(\w+)\s+.*\;/;  # capture routine names
	last if /\%\%/;  # section seperator
	print;
}

print "[ routinename x ;\n  switch (x) {\n";
if ($debug) {
	print "  $_: print \"$_\";\n" foreach @routines;
}
print "  default: print \"<routine \",x,\">\";\n  }\n];\n";

get_next_line();  # prime the pump
OBJECT until eof();
print "! All done\n";

my ($name, $actor, $p1, $p2);

sub OBJECT {
	GOAL and DONE and PLAN_LIST and lit ';'
	or FAIL;
}

sub GOAL {
	lit 'goal' and ($name = IDENT) and lit '('
		and ($actor = IDENT) and lit ','
		and ($p1 = IDENT) and lit ','
		and ($p2 = IDENT) and lit ')'
	or FAIL;
	#print qq(\nrapGoal $name ").($debug?$name:'').qq("\n  with\n);
	print qq(\nrapGoal $name "$name"\n  with\n);
}

sub DONE {
	lit 'done' and (my $when = WHEN) and lit ','
	or FAIL;
	print "    istrue [ $actor $p1 $p2;\n";
	print debug('istrue', $actor, $p1, $p2) if $debug;
	print "\t$when\n\t],\n";
}

sub WHEN {
	my $expr;
	lit 'always' and ($expr = 'rtrue;') or
	lit 'never' and ($expr = 'rfalse;') or
	lit 'unless' and ($expr = 'return ~~('.EXPR.');') or
	lit 'when' and ($expr = 'return '.EXPR.';')
	or FAIL;
	return $expr;
}

sub sum {
	my @nbrs = map {$_->[0]} @_;
	my $total = 0;
	$total = $total + $_ foreach (grep /^\d+$/, @nbrs);
	return join('+', ($total, grep !/^\d+$/, @nbrs));
}

my $no_more_steps;
sub PLAN_LIST {
#warn "in PLAN_LIST()\n";
	my @list;
	lit 'plan' and lit 'is' and push @list, STEP_LIST or FAIL;
	$no_more_steps = 0;
	while (lit 'or') {
		lit 'else' and push @list, STEP_LIST or FAIL;
		last if $no_more_steps;
	};

	print "    get_nbr_plans [ $actor $p1 $p2 ;\n";
	print debug('get_nbr_plans ', $actor, $p1, $p2) if $debug;
	print "\treturn ", sum(@list), ";\n";
	print "    ],\n";

	print "    get_nbr_steps [ $actor $p1 $p2 plan ;\n";
	print debug('get_nbr_steps ', $actor, $p1, $p2, 'plan') if $debug;
	print "\tswitch (plan) {\n";
	my $plan_nbr;
	foreach my $pair (@list) {
		my ($count, $plan) = @$pair;
		$plan_nbr++;
		if ($count == 1) {
			print "\t${plan_nbr}:\t";
		} else {
			print "\tdefault: ";
		}
		print "return ", scalar @$plan, ";\n";
	}
	print "\t}\n";
	print "    ],\n";

	print "    get_plan [ $actor $p1 $p2 plan step;\n";
	print debug('get_plan', $actor, $p1, $p2, 'plan', 'step') if $debug;
	print "\tswitch (plan) {\n";
	my $plan_nbr;
	foreach my $pair (@list) {
		my ($count, $plan) = @$pair;
		$plan_nbr++;
		if ($count == 1) {
			print "\t${plan_nbr}:\tswitch (step) {\n";
		} else {
			print "\tdefault:\n";
			print "\t\tplan = plan - $plan_nbr;\n";
			print "\t\tswitch (step) {\n";
		}
		my $step_nbr;
		foreach my $step (@$plan) {
			$step_nbr++;
			print "\t\t${step_nbr}:\trap_set_step(",
				join(',', @$step), ");\n";
		}
		print "\t\t}\n";
	}
	print "\t}\n";
	print "    ];\n";

}

sub STEP_LIST {
#warn "in STEP_LIST()\n";
	my $expr = 1;
	my @list;
	if (lit 'multiple') {
		$no_more_steps = 1;
		($expr = EXPR) and lit ',' or FAIL;
	}
	push @list, STEP or FAIL;
	while (lit ',') {
		push @list, STEP or FAIL;
	}
	return [ $expr, \@list ];
}

sub STEP {
#warn "in STEP()\n";
	my $step;
	lit 'if' and ($step = ['RAP_IF', WHAT])
	or lit 'be' and ($step = ['RAP_BE', WHAT])
	or lit 'do' and ($step = ['RAP_DO', WHAT])
	or FAIL;
	return $step;
}

sub WHAT {
	my ($ident, $expr1, $expr2);
	($ident = IDENT) and lit '('
		and ($expr1 = EXPR)
		and lit ','
		and ($expr2 = EXPR)
		and lit ')'
	or FAIL;
	return ( $ident, $expr1, $expr2 );
}

##### Lexical scanner

sub get_next_line {
	$_ = <>;
	pos = 0;
}

sub EXPR {
	my $expr = '';
	my $depth = 0;
	/\G\s*/gc;
	while(1) {
		get_next_line while /\G\s*(!.*)?$/gc;
		($depth ? /\G./gc : /\G[^,)]/gc) or return " $expr";
		$expr .= $&;
		$depth++ if $expr =~ /\($/;
		$depth-- if $expr =~ /\)$/;
		FAIL if /\G\Z/gc;
	}
}

sub lit {
	my $what = quotemeta shift;
	get_next_line while /\G\s*(!.*)?$/gc;
	if ($what =~ /^\w+$/) {
		$what .= '\b';
	}
	#warn "looking for <$what>\n";
	/\G\s*$what/gc;
}

sub IDENT {
	get_next_line while /\G\s*(!.*)?$/gc;
	/\G\s*(\w+)/gc;
	return $1;
}

##### Utility routines

sub debug {
	my $method = shift;
	my $s = qq(\tprint "^in $name.$method);
	while (my $name = shift) {
		my $fmt = ($name eq 'plan' || $name eq 'step') ? '' : '(name)';
		$s .= qq(, $name=", $fmt$name, ");
	}
	$s .= qq(^";\n);
	return $s;
}

sub FAIL {
	my ($from) = (caller(1))[3] =~ /(\w+)$/;
	my $line = $.;
	warn "*** $line: ", $_;
	$line =~ s/./ /g;
	/\G\s*/gc;  # advance past whitespace
	warn "*** $line  ", ' ' x (pos()+3), "^\n";
	die <<__DIE__;
failed in $from
__DIE__
}
