#!/local/bin/perl

#
#	Copyright 1993, Center for Computer Vision and Visualization,
#	University of Florida.  All rights reserved.
#

#
# $Log: c-gen-conv.perl,v $
# Revision 1.10  1994/09/16  14:57:11  thoth
# more DOS-inspired renaming.
#
# Revision 1.9  1994/07/25  17:26:39  thoth
# Name sanitization
#
# Revision 1.8  1994/02/22  18:49:07  thoth
# New template-template convolutions.
#
# Revision 1.7  1994/02/12  19:44:25  thoth
# Rehack of template operation specifications.
#
# Revision 1.6  1994/01/31  15:55:37  thoth
# prevented leakage of old values into new convolution specs.
#
# Revision 1.5  1994/01/07  15:24:40  thoth
# Image class is now CoreImage and named image types are
# Image<P,T>.
#
# Revision 1.4  1993/12/29  17:33:18  thoth
# New operator scheme that prevents the need for trivial Image conversions.
#
# Revision 1.3  1993/11/17  18:38:34  thoth
# template reductions are now supported.
# forward convolutions are now supported.
#
# Revision 1.2  1993/09/21  11:43:46  thoth
# the convolution description files can now have arbitrary
# white space in the operation specifications.
#
# Revision 1.1  93/09/15  13:03:22  thoth
# Initial revision
# 
# Revision 1.3  93/05/27  11:46:04  thoth
# Copyright Notices
# 
# Revision 1.2  93/04/29  11:21:43  thoth
# IBTYPE is now used in a #define symbol.
# 
# Revision 1.1  93/03/18  11:22:02  thoth
# Initial revision
# 

sub is_image {
    return $_[0] =~ /^I\(.*\)$/;
}

sub is_template {
    return $_[0] =~ /^T\(.*\)$/;
}

sub is_basic {
    return !&is_image(@_) && !&is_template(@_);
}

sub base_type {
    local($_) = @_;
    if (/^[TI]\((.*)\)$/) {
	return $1;
    } else {
	return $_;
    }
}

sub TT_product_subst {
	local ($fname,
	       $name, $rval, $litype, $ritype) = @_;
	local ($abtype, $lbtype, $rbtype) =
	    (&base_type($rval), &base_type($litype), &base_type($ritype));

	local ($aitype, $litype, $ritype) =
	    ("IA_Image<IA_Point<int>,$abtype>",
	     "IA_Image<IA_Point<int>,$lbtype>",
	     "IA_Image<IA_Point<int>,$rbtype>");

	local($_);
	local($/) = -1;

	open(FILE, "<$fname") ||
		die "couldn't open $fname";

	$_ = <FILE>;


	s/CONV/$name/g;
	s/ABTYPE/$abtype/g;
	s/AITYPE/$aitype/g;
	s/LBTYPE/$lbtype/g;
	s/LITYPE/$litype/g;
	s/RBTYPE/$rbtype/g;
	s/RITYPE/$ritype/g;

	print "$_\n";

	close(FILE);
}

sub TI_product_subst {
	local ($fname,
	       $init, $accum, $accvar, $final,
	       $name, $rval, $itype, $ttype, $zero) = @_;
	local ($rbtype, $ibtype, $tbtype) =
	    (&base_type($rval), &base_type($itype), &base_type($ttype));
	local ($titype) = "IA_Image<IA_Point<int>,$tbtype>";

	local ($ival, $tval, $rval) = ("#undef#","#undef#","#undef#");
	local($_);
	local($/) = -1;

	open(FILE, "<$fname") ||
		die "couldn't open $fname";

	$_ = <FILE>;

	s/\bINITIALIZE\b/$init/g;

	s/\bACCUMULATE\b/$accum/g;
	s/\bACCUMULATEVAR\b/$accvar/g;
	s/\bRESULT\b/$final/g;

	s/RTYPE/$rbtype/g;
	s/CONV/$name/g;
	s/IBTYPE\b/$ibtype/g;
	s/\bTBTYPE\b/$tbtype/g;
	s/\bTITYPE\b/$titype/g;
	s/\bZERO\b/$zero/g;

	local(@_) = split("\n");
	foreach (@_) {
		if (m:^\s*//\s*_IVAL_=:)    { $ival = $'; next; }
		if (m:^\s*//\s*_TVAL_=:)    { $tval = $'; next; }
		if (m:^\s*//\s*_IRESULT_=:) { $rval = $'; next; }
		s/\bIVAL\b/$ival/g;
		s/\bTVAL\b/$tval/g;
		s/\bIRESULT\b/$rval/g;
	}

	print join("\n", @_);
	print "\n";

	$/ = '\n';

	close(FILE);
}

sub reduction_subst {
	local ($fname, $accum, $name,
		$rval, $arg, $zero) = @_;
	local($rbtype, $tbtype) = (&base_type($rval), &base_type($arg));
	local($titype) = "IA_Image<IA_Point<int>,$tbtype>";
	local ($ival, $tval, $rval) = ("#undef#","#undef#","#undef#");
	local($_);
	local($/) = -1;

	open(FILE, "<$fname") ||
		die "couldn't open $fname";

	$_ = <FILE>;

	if (m-^// _IVAL_=-) {
		print STDERR "IVAL: ", $';
	}

	s/\bACCUMULATE\b/$accum/g;

	s/\bRTYPE\b/$rbtype/g;
	s/REDUCT/$name/g;
	s/\bTBTYPE\b/$tbtype/g;
	s/\bTITYPE\b/$titype/g;
	s/\bZERO\b/$zero/g;

	local(@_) = split("\n");
	foreach (@_) {
		if (m:^\s*//\s*_TVAL_=:)    { $tval = $'; next; }
		if (m:^\s*//\s*_IRESULT_=:) { $rval = $'; next; }
		s/\bTVAL\b/$tval/g;
		s/\bIRESULT\b/$rval/g;
	}

	print join("\n", @_);
	print "\n";

	$/ = '\n';

	close(FILE);
}


sub make_opname {
	local($_) = @_;
	s/\+/IAOPpl/g;
	s/-/IAOPmn/g;
	s/\*/IAOPmu/g;
	s:/:IAOPdv:g;

	s/%/IAOPmd/g;
	s/&&/IAOPla/g;
	s/\|\|/IAOPlo/g;
	s/!/IAOPno/g;

	s/&/IAOPba/g;
	s/\|/IAOPbo/g;
	s/\^/IAOPbx/g;
	s/~/IAOPbn/g;

	s/<</IAOPls/g;
	s/>>/IAOPrs/g;

	s/<=/IAOPle/g;
	s/</IAOPlt/g;
	s/==/IAOPeq/g;
	s/!=/IAOPne/g;
	s/>=/IAOPge/g;
	s/>/IAOPgt/g;
	return $_;
}

sub binary_templ_subst
{
    local($fname, $op, $subop, $zero, $rval, $lhs, $rhs) = @_;

    open(FILE, "<$fname") ||
			die "couldn't open opgen-templs/$fname, stopped";

    local ($baserval, $baselhs, $baserhs) = 
	(&base_type($rval), &base_type($lhs), &base_type($rhs));

    local($_);
    local($/) = -1;
    $_ = <FILE>;
    close(FILE);
    local($opname) = &make_opname($op);
    if ($opname eq "") {
	$opname = $op;
    }
    s/\bOP\b/$op/g;
    s/\bSUBOP\b/$subop/g;
    s/OPNAME/$opname/g;
    s/ATYPE/$baserval/g;
    s/LTYPE/$baselhs/g;
    s/RTYPE/$baserhs/g;
    s/ZERO/$zero/g;
    print;
}

#
#
#


while (<>) {
    next if /^\s*$/;

    if (/^#/) {
	print "//", $';
	next;
    }

    print "// $_";

    @_ = split;

    local($sort) = shift(@_);

    if ($sort eq "convolution") {

	local ($name) = shift(@_);

	local ($_);

	local($zero);
	while (@_) {
	    $_ = $_[0];
	    if (/^zero=/) {
		$zero = $';
	    } else {
		last;
	    }
	    shift(@_);
	}

	local($rval, $lhs, $rhs, @blah) = @_;

	die "extra arguments on convolution line: ", join(" ", @blah)
	    if (@blah);

	local($init,$accum,$accvar,$final);

	while ($_ = <>) {
	    chop;
	    last if $_ eq "end";

	    if (/^init:\s*/) {
		$init = $';
	    } elsif (/^accum:\s*/) {
		$accum = $';
	    } elsif (/^accvar:\s*/) {
		$accvar = $';
	    } elsif (/^final:\s*/) {
		$final = $';
	    } else {
		die "unknown convolution field: $_\n";
	    }
	}

	if (&is_template($rval)
	    && &is_template($lhs)
	    && &is_template($rhs)) {
	    # template-template convolution
	    &TT_product_subst("templ-templ-product",
			      $name, $rval, $lhs, $rhs);
	} elsif ($zero ne "") {
	    if (&is_image($rval) && &is_template($lhs) && &is_image($rhs)) {
		# forward image-template convolution
		defined $init || die "no initiazlier for convolution $name\n";
		defined $accum || die "no accumulator for convolution $name\n";
		defined $final || die "no final for convolution $name\n";
		defined $accvar || die "no variant accumulator for convolution $name\n";
		&TI_product_subst("templ-img-product", $init,
				  $accum, $accvar, $final,
				  $name, $rval, $rhs, $lhs, $zero);
	    } elsif (&is_image($rval)&& &is_image($lhs)&& &is_template($rhs)) {
		# backward image-template convolution
		defined $init || die "no initiazlier for convolution $name\n";
		defined $accum || die "no accumulator for convolution $name\n";
		defined $final || die "no final for convolution $name\n";
		$accvar = $accum unless defined $accvar;
		&TI_product_subst("img-templ-product", $init,
				  $accum, $accvar, $final,
				  $name, $rval, $lhs, $rhs, $zero);
	    } else {
		die "Unknown argument configuration to convolution: $rval $lhs $rhs\n";
	    }
	} else {
	    print "// non-absorbers not handled yet\n";
	}

	print "\n";
    } elsif ($sort eq "reduction") {

	local ($name) = shift(@_);

	local ($_);

	local($zero);
	while (@_) {
	    $_ = $_[0];
	    if (/^zero=/) {
		$zero = $';
	    } else {
		last;
	    }
	    shift(@_);
	}

	local($rval, $arg, @blah) = @_;

	die "extra arguments on convolution line: ", join(" ", @blah)
	    if (@blah);

	local ($accum);
	while ($_ = <>) {
	    chop;
	    last if $_ eq "end";

	    if (/^accum:\s*/) {
		$accum = $';
	    } else {
		die "unknown convolution field: $_\n";
	    }
	}
	($accum ne "") || die "no accumulator for convolution $name\n";

	if ($zero ne "") {
	    if (&is_image($rval) && &is_template($arg)) {
		&reduction_subst("template-reduction", $accum, $name, 
				 $rval, $arg, $zero);
	    } else {
		die "Unknown argument configuration to reduction: $rval $arg\n";
	    }
	} else {
	    print "// template reductions without an identity are not implemented\n";
	}
    } elsif  ($sort eq "binary") {

	local ($name) = shift(@_);

	local ($_);

	local($subop, $zero, $gamma) = ($name);
	while (@_) {
	    $_ = $_[0];
	    if (/^zero=/) {
		$zero = $';
	    } elsif (/^gamma=/) {
		$gamma = $';
	    } elsif (/^subop=/) {
		$subop = $';
	    } else {
		last;
	    }
	    shift(@_);
	}

	local($rval, $lhs, $rhs, @blah) = @_;

	die "extra arguments on convolution line: ", join(" ", @blah)
	    if (@blah);

	local($infix) = ($subop=~s/^operator//);

	if (&is_template($rval) && &is_template($lhs) && &is_template($rhs)) {
	    &binary_templ_subst("bin-T".($infix?"O":"F"),
				$name, $subop, $zero, $rval, $lhs, $rhs);
	} else {
	    die "Unknown argument configuration to binary: $rval $lhs $rhs\n";
	}
    } else {
	die "Unknown template operation $sort at";
    }
}
