#!/local/bin/perl

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

#
# $Log: h-gen-conv.perl,v $
# Revision 1.11.1.1  1995/01/13  19:58:04  thoth
# CoreImage has been re-merged with Image.  All special stuff should be
# friends of FBI now.
#
# Revision 1.11  1994/07/25  17:26:39  thoth
# Name sanitization
#
# Revision 1.10  1994/03/30  14:00:50  thoth
# Ability to emit friend or normal declarations for convolutions.
#
# Revision 1.9  1994/03/14  15:52:54  thoth
# inline versions of convolutions can now be turned off.
#
# Revision 1.8  1994/02/22  18:49:29  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:56:13  thoth
# removed cruft.
#
# 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:39:17  thoth
# template reductions are now supported.
# forward convolutions are now supported.
#
# Revision 1.2  1993/09/21  11:44:15  thoth
# the convolution description files can now have arbitrary
# white space in the operation specifications.
#
# Revision 1.1  93/09/15  13:03:41  thoth
# Initial revision
# 
# Revision 1.2  93/05/27  11:46:09  thoth
# Copyright Notices
# 
# Revision 1.1  93/03/18  11:22:28  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 param_code_of {
    local($_) = @_;
    if (/^T\((.*)\)$/) {
	return "IA_DDTemplate<IA_Image<IA_Point<int>,$1> >";
    } elsif (/^I\((.*)\)$/) {
	return "IA_Image<IA_Point<int>,$1>";
    } else {
	return $_;
    }
}

sub return_code_of {
    local($_) = @_;
    if (/^T\((.*)\)$/) {
	return "IA_DDTemplate<IA_Image<IA_Point<int>,$1> >";
    } elsif (/^I\((.*)\)$/) {
	return "IA_Image<IA_Point<int>,$1>";
    } else {
	return $_;
    }
}

#
#
#

$friendly = 0;
# if 1, emit friend declarations suitable for use inside a class definition.
# if 0 emit declarations suitable for use anywhere else.

# parse flags

while (@ARGV) {
    local ($_) = shift(@ARGV);
    if ($_ eq "-friends") {
	$friendly=1;
    } else {
	unshift(@ARGV, $_);
	last;
    }
}

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

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

    print "// $_";

    @_ = split;

    $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);

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

	    die "unknown convolution field: $_\n"
		unless (/^(init|accum|accvar|final):\s*/);
	}

	if (&is_image($rval) && &is_image($lhs) && &is_template($rhs)) {
	    # backward template convolution

	    local ($baserval, $baselhs, $baserhs) =
		(&base_type($rval),&base_type($lhs),&base_type($rhs));
	    print "friend " if $friendly;
	    print &return_code_of($rval), " $name(",
	    "const ", &param_code_of($lhs), " &img,\n",
	    "\t\tconst ", &param_code_of($rhs), " &templ,\n",
	    "\t\tIA_Set<IA_Point<int> > dest_ps);\n";
	    print "\n";

	    if (!$friendly) {
		print "#ifndef NO_INLINE_CONVS\n";
		print "inline ";
		print &return_code_of($rval), " $name(",
		"const ", &param_code_of($lhs), " &img,\n",
		"\t\tconst ", &param_code_of($rhs), " &templ) {\n",
		"    return $name(img, templ, img.domain());\n",
		"}\n";
		print "#endif // NO_INLINE_CONVS\n\n";
	    }
	} elsif (&is_image($rval) && &is_template($lhs) && &is_image($rhs)) {
	    # forward template convolution

	    local ($baserval, $baselhs, $baserhs) =
		(&base_type($rval),&base_type($lhs),&base_type($rhs));
	    print "friend " if $friendly;
	    print &return_code_of($rval), " $name(",
	    "const ", &param_code_of($lhs), " &templ,\n",
	    "\t\tconst ", &param_code_of($rhs), " &img,\n",
	    "\t\tIA_Set<IA_Point<int> > dest_ps);\n";
	    print "\n";

	    if (!$friendly) {
		print "#ifndef NO_INLINE_CONVS\n";
		print "inline ";
		print &return_code_of($rval), " $name(",
		"const ", &param_code_of($lhs), " &templ,\n",
		"\t\tconst ", &param_code_of($rhs), " &img) {\n",
		"    return $name(templ, img, img.domain());\n",
		"}\n";
		print "#endif // NO_INLINE_CONVS\n\n";
	    }
	} elsif (&is_template($rval)
		 && &is_template($lhs)
		 && &is_template($rhs)) {
	    local ($baserval, $baselhs, $baserhs) =
		(&base_type($rval),&base_type($lhs),&base_type($rhs));
	    print "friend " if $friendly;
	    print &return_code_of($rval), " $name(",
	    "const ", &param_code_of($lhs), " &templ,\n",
	    "\t\tconst ", &param_code_of($rhs), " &img);\n";
	    print "\n";

	} else {
	    die "Unknown argument configuration to convolution: $rval $lhs $rhs";
	}

    } 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);

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

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

	if (&is_image($rval) && &is_template($arg)) {
	    print "friend " if $friendly;
	    print &return_code_of($rval), " $name(\n",
	    "\tIA_Set<IA_Point<int> > domain,\n",
	    "\t", &param_code_of($arg), " templ,\n",
	    "\tIA_Set<IA_Point<int> > dest_domain);\n\n";
	} else {
	    die "Unknown argument configuration to reduction: $rval $arg\n";
	}
    } elsif  ($sort eq "binary") {

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

	local ($_);

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

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

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

	if (&is_template($rval) && &is_template($lhs) && &is_template($rhs)) {
	    print "friend " if $friendly;
	    print &return_code_of($rval), " $name(\n",
	    "\tconst ", &param_code_of($lhs), " &t1,\n",
	    "\tconst ", &param_code_of($rhs), " &t2);\n\n";
	} else {
	    die "Unknown argument configuration to binary: $rval $lhs $rhs";
	}
    } else {
	die "Unknown template operation $sort\n";
    }
}
