#!/local/bin/perl

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

# This perl script generates meta files for binary image operations.
# The operations may be commutative (-c) or noncommutative (-nc).
# The operations may be Image - Image (-ii), Image - scalar (-is),
#	or scalar - Image (-si).
# Arguments are required.



# $Id: gen-bo.perl,v 1.6.1.3 1995/01/13 19:37:42 thoth Exp thoth $

#
# $Log: gen-bo.perl,v $
# Revision 1.6.1.3  1995/01/13  19:37:42  thoth
# CoreImage has been re-merged with Image.  All special stuff should be
# friends of FBI now.
#
# Revision 1.6.1.2  1995/01/09  18:21:10  thoth
# removed duplicate log traces.
#
# Revision 1.6.1.1  1994/12/28  17:27:06  thoth
# conversion from Image-friendliness to FBI friendliness.
# conversion from switch statement to operator table.
#
# Revision 1.6  1994/07/25  17:26:39  thoth
# Name sanitization
#
# Revision 1.5  1994/07/08  16:15:07  thoth
# fixed segv caused by errant constructor/destructor.
#
# Revision 1.4  1994/01/07  15:15:14  thoth
# Image class is now CoreImage and named image types are
# Image<P,T>.
#
# Revision 1.3  1993/12/29  17:33:18  thoth
# New operator scheme that prevents the need for trivial Image conversions.
#
# Revision 1.2  1993/11/17  18:39:50  thoth
# short-circuiting pointwise logical operations were failing to increment
# the pointer.  We now increment outside the expression.
# reductions are now static functions.
#
# Revision 1.1  1993/09/15  13:03:56  thoth
# Initial revision
#




# variety is a number from 0..2 meaning
# VectorDI
# ConstDI
# other (but we can iterate over it!)

# Here is a vector with shorthand for each variety
@names = ("vec", "scalar", "iter");

# Given the variety of the image and its type:
# how will it be DECLARED as an argument to the static support procedure?
# $variety is 0..2.  $type may be either "LTYPE" or "RTYPE".
sub argtype {
	local($variety, $type) = @_;

	return "IA_BaseImage<IA_Point<int>, $type> &";

	if ($variety == 0) {
		return "const IA_VectorI<IA_Point<int>, $type> *";
	} elsif ($variety == 1) {
		return "$type ";
	} else {
		return "IA_Image<IA_Point<int>, $type> ";
	}
}

# Given the variety of the image and its type:
# how will it be PASSED as an argument to the static support procedure?
# $variety is 0..2.  $side may be either "l" or "r".
sub I_argexpr {
	local($variety, $side) = @_;
	local($uside, $type);

	($uside = $side) =~ y/a-z/A-Z/;
	$type = $uside . "TYPE";

	local($bip);
	#$bip = "${side}hs.bip";
	$bip = "IA_FBI<IA_Point<int>, IA_Point<int>, $type, $type, $type>::extract_baseptr(${side}hs)";

	return "$bip";

	if ($variety == 0) {
		return "(IA_VectorI<IA_Point<int>, $type> *)$bip";
	} elsif ($variety == 1) {
		return "((IA_ConstI<IA_Point<int>, $type> *)$bip)->value";
	} else {
		return "${side}hs";
	}
}

# When we're checking the type of an argument against the static types
# of all but the last variety, what is the class to check against?
# $variety is 0..1.  $type may be either "LTYPE" or "RTYPE".
sub arg_s_type {
    local($variety, $type) = @_;

    if ($variety == 0) {
	return "IA_VectorI<IA_Point<int>, $type>";
    } elsif ($variety == 1) {
	return "IA_ConstI<IA_Point<int>, $type>";
    } else {
	return "0";
	die "Class 2 is everything else.";
    }
}
sub arg_s_type_ {
    local($variety, $type) = @_;
    local ($suffix);
    if ($variety<2) {
	$suffix = "::s_type()";
    } else {
	$suffix = "";
    }
    return &arg_s_type($variety, $type).$suffix;
}

# Emit variable declarations necessary for the central loop which
# actually calculates a result.  Vec needs a properly initialized
# pointer.  Const doesn't need an iterator.  Others just use a DIVIter
# of the appropriate type and a temporary of the appropriate type.
# $variety is 0..2.  $side may be either "l" or "r".
sub emititer {
	local($variety, $side) = @_;
	local($uside, $type);

	($uside = $side) =~ y/a-z/A-Z/;
	$type = $uside . "TYPE";
	if ($variety == 0) {
	    print "\tIA_VectorI<IA_Point<int>, ${type}> *${side}hs\n",
	    "\t\t= (IA_VectorI<IA_Point<int>, ${type}> *)&${side}hs_;\n";

		print "\tconst ${type} *${side}s = ${side}hs->vec;\n";
	} elsif ($variety == 1) {
	    print "\tIA_ConstI<IA_Point<int>, ${type}> *${side}hs\n",
	    "\t\t= (IA_ConstI<IA_Point<int>, ${type}> *)&${side}hs_;\n";
	} elsif ($variety == 2) {
		print "\t${type} ${side}tmp;\n",
		    "\tIA_BaseIVIter<IA_Point<int>, ${type}>\t*${side}iter = ${side}hs_.value_iterator();\n";
	}
}

# When inside the loop and doing work, how do we use the iterator to
# calculate the result value?
# $variety is 0..2.  $side may be either "l" or "r".
sub inloop_val {
	($variety, $side) = @_;

	if ($variety == 0) {
		return "*${side}s";
	} elsif ($variety == 1) {
		return "${side}hs->value";
	} else {
		return "${side}tmp";
	}
}

# Emit the code for a support procedure.
# $i is the variety of the lhs image
# $j is the variety of the rhs image
sub generate_binary_op {
	local($i,$lside,$j,$rside) = @_;
	local($ltype, $rtype) = ($lside,$rside);
	local($sym);	
	$ltype =~ tr/a-z/A-Z/;
	$ltype .= "TYPE";
	$rtype =~ tr/a-z/A-Z/;
	$rtype .= "TYPE";

# Make sure that we don't duplicate the work of
# an image-scalar operation.
	if ($i==1 || $j==1) {
		$sym = $names[$i]."_".$names[$j]."_ATYPE_LTYPE_RTYPE_OPNAME";
		print "#ifndef ",$sym,"\n",
			"#define ",$sym,"\n";
	}

# function header and argument types
	if ($pwise) {
		print "static IA_BaseImage<IA_Point<int>, ATYPE> *\n";
	} else {
		print "static ATYPE ";
	}
	print $names[$i],"_",$names[$j],"_bo_OPNAME(";
	print &argtype($i,$ltype),"lhs_,\n\t",&argtype($j,$rtype),"rhs_)\n";
# the IntPointSet domain we are iterating over.
	print "{\n    const IA_Set<IA_Point<int> > domain = lhs_.domain();\n";
	if ($i==1 && $j==1) {
	    &emititer($i,"l");
	    &emititer($j,"r");
	    print "    ATYPE	aval = ";
	    if ($infix) {
		print "( lhs->value SUBOP rhs->value )";
	    } else {
		print "SUBOP( lhs->value, rhs->value )";
	    }
	    print ";\n    return ";
	    if ($pwise) {
		print "new IA_ConstI<IA_Point<int>, ATYPE>(domain, aval)";
	    } else {
		print "aval";
	    }
	    print ";\n";
	} else {
# how long the result vector will be
	    print "    const unsigned sz = domain.card();\n",
# declare the result vec
	    "    ATYPE *const vec = new ATYPE[sz];\n\n    {\n",
# declare a scanning pointer for the inner loop
	    "	ATYPE *ds = vec;\n";
# emit iterator declarations for the left and right hand sides of the operation
	    &emititer($i,"l");
	    &emititer($j,"r");
# begin the loop
	    print "\tfor (unsigned i=0; i<sz; i++) {\n";
# do we need to get values from the IVIter?
	    ($i==2) && print "\t    liter->next(ltmp);\n";
	    ($j==2) && print "\t    riter->next(rtmp);\n";

# perform the operation for one pixel, Yaay!

	    if ($pwise) {
		print "\t    *(ds++) = ";
	    } else {
		# strictrel
		print "\t    if (!";
	    }
	    if ($infix) {
		print "( (", &inloop_val($i,"l"), ") SUBOP (",
		&inloop_val($j,"r"), ") )";
	    } else {
		print "SUBOP(", &inloop_val($i,"l"), ", ",
		&inloop_val($j,"r"), ")";
	    }
	    if ($pwise) {
		print ";\n";
	    } else {
		print ")\n\t\treturn 0;\n";
	    }
	    ($i==0) && print "\t    ls++;\n";
	    ($j==0) && print "\t    rs++;\n";
	    print "\t}\n";
	    ($i==2) && print "\tdelete liter;\n";
	    ($j==2) && print "\tdelete riter;\n";
	    print "    }\n";
	    if ($pwise) {
# loop finished.  Result vector is filled.  Give the value vec away.
		print "    return new IA_VectorI<IA_Point<int>, ATYPE>(domain, vec, sz, 1);\n";
	    } else {
		print "    return 1;\n";
	    }
	}
	print "}\n";
	if ($i==1 || $j==1) {
		print "#endif // $sym\n";
	}
	print "\n";
}

sub generate_binary_swap
{
	local($i,$lside,$j,$rside) = @_;
	local($ltype, $rtype) = ($lside,$rside);
	local($sym);	
	$ltype =~ tr/a-z/A-Z/;
	$ltype .= "TYPE";
	$rtype =~ tr/a-z/A-Z/;
	$rtype .= "TYPE";

# Make sure that we don't duplicate the work of
# an image-scalar operation.
	if ($i==1 || $j==1) {
		$sym = $names[$i]."_".$names[$j]."_ATYPE_LTYPE_RTYPE_OPNAME";
		print "#ifndef ",$sym,"\n",
			"#define ",$sym,"\n";
	}

# function header and argument types
	if ($pwise) {
		print "static IA_BaseImage<IA_Point<int>, ATYPE> *\n";
	} else {
		print "static ATYPE ";
	}
	print $names[$i],"_",$names[$j],"_bo_OPNAME(";
	print &argtype($i,$ltype),"lhs_,\n\t",&argtype($j,$rtype),"rhs_)\n{\n";

	print "    return ", $names[$j], "_", $names[$i], "_bo_OPNAME(rhs_, lhs_);\n";
#	print "// NYI \n\n";

	print "}\n";
	if ($i==1 || $j==1) {
		print "#endif // $sym\n";
	}
	print "\n";
}

# Emit code for the beginning of an image variety case
# $variety is 0..2.  $side is "l" or "r".
sub emit_begin_imagecase {
	local($variety,$side) = @_;
	local($uside, $type);

	($uside = $side) =~ y/a-z/A-Z/;
	$type = $uside . "TYPE";

	if ($variety+1 < @names) {
		print "if (${side}hs.type() == ", &arg_s_type($variety,$type), "::s_type()) ";
	}
	print "{\n";
}

# Emit the call to a support procedure for a particular variety combination.
# This is where the ConstDI - ConstDI case is optimized.
# $i and $j are the varieties of the left- and right-hand side image arguments.
# If one of the varieties is negative, that means the corresponding
# argument to the enclosing procedure was a scalar argument instead of
# an image argument.
sub emit_support_call {
    local($i,$j) = @_;
    local($lexpr,$rexpr);
    $domain = "lhs.domain()";
    if ($i<0) {
	$i=1;
	$lexpr = "lhs";
	$domain = "rhs.domain()";
    } else {
        $lexpr = &I_argexpr($i,"l");
    }
    if ($j<0) {
	$j=1;
	$rexpr = "rhs";
    } else {
	$rexpr = &I_argexpr($j,"r");
    }
    if ($i==1 && $j==1) {
	$pwise && print "IA_Image<IA_Point<int>, ATYPE> ($domain, ";
	if ($infix) {
		print "($lexpr) SUBOP ($rexpr)";
	} else {
		print "SUBOP($lexpr, $rexpr)";
	}
	$pwise && print ")";
    } elsif ($comm && $j < $i) {
	print $names[$j],"_",$names[$i],"_bo_OPNAME(",
		$rexpr,",",$lexpr,")";
    } else {
	print $names[$i],"_",$names[$j],"_bo_OPNAME(",
		$lexpr,",",$rexpr,")";
    }
}

# Emit code for the end of an image variety case.
sub emit_end_imagecase {
	local($variety,$indent) = @_;
	print $indent,"}";
	if ($variety+1 < @names) {
		print " else ";
	}
}

#
# begin the main code
#


# parse arguments
$comm = 2;
$arity = 3;
$optype = 2;
$pwise = 2;
while (@ARGV) {
	$_ = shift(@ARGV);
	if ($_ eq "-nc") {
		$comm = 0;
	} elsif ($_ eq "-c") {
		$comm = 1;

	} elsif ($_ eq "-II") {
		$arity = 0;
	} elsif ($_ eq "-Is") {
		$arity = 1;
	} elsif ($_ eq "-sI") {
		$arity = 2;

	} elsif ($_ eq "-fn") {
		$optype = 0;
	} elsif ($_ eq "-op") {
		$optype = 1;
#	} elsif ($_ eq "-sr") {
#		$optype = 2;

	} elsif ($_ eq "-sr") {
		$pwise = 0;
	} elsif ($_ eq "-pw") {
		$pwise = 1;
	} else {
		die "unrecognized flag: $_\n";
	}
}
die "No value selected for commutativity.  Choose -c or -nc\n" if ($comm>1);
die "Must select -II, -Is, or -sI.\n" if ($arity>2);
die "Must select -op or -fn.\n" if ($optype>1);
die "Must select -sr or -pw.\n" if ($pwise>1);

#

$infix = ($optype==1);

# emit the operations table declaration

$curr_tbl  = "IA_Image_IP_ATYPE_LTYPE_RTYPE_OPNAME_tbl";
print "#ifndef BOT_ATYPE_LTYPE_RTYPE_OPNAME\n",
    "#define BOT_ATYPE_LTYPE_RTYPE_OPNAME\n",
    "IA_BinaryOperationsTable<",
    ($pwise ? "IA_BaseImage<IA_Point<int>, ATYPE>*" : "ATYPE"),
    ",\n\tIA_BaseImage<IA_Point<int>, LTYPE>,\n",
    "\tIA_BaseImage<IA_Point<int>, RTYPE> >\n",
    "\t*IA_Image_IP_ATYPE_LTYPE_RTYPE_OPNAME_tbl;\n\n";
#print    "static IA_BinaryOperationsTable<",
#    ($pwise ? "IA_BaseImage<IA_Point<int>, ATYPE>*" : "ATYPE"),
#    ",\n\tIA_BaseImage<IA_Point<int>, LTYPE>,\n",
#    "\tIA_BaseImage<IA_Point<int>, RTYPE> > *&curr_tbl",
#    " = IA_Image_IP_ATYPE_LTYPE_RTYPE_OPNAME_tbl;\n\n";
print    "void IA_fill_Image_IP_ATYPE_LTYPE_RTYPE_OPNAME_tbl();\n\n",
    "#endif // BOT_ATYPE_LTYPE_RTYPE_OPNAME\n";

# emit operation wrapper 

if (0 && $infix) {
	$funcname = "operator OP";
} else {
	$funcname = "OP";
}

if ($pwise) {
	print "IA_Image<IA_Point<int>, ATYPE>\n";
} else {
	print "ATYPE ";
}

print "$funcname (";
if ($arity==2) {
    print " LTYPE lhs";
} else {
    print " const IA_Image<IA_Point<int>, LTYPE> &lhs";
}
print ",\n";
if ($arity==1) {
    print "\t\tRTYPE rhs";
} else {
    print "\t\tconst IA_Image<IA_Point<int>, RTYPE> &rhs";
}
print ")\n{\n";
if ($arity==0) {
    print "    if (lhs.domain() != rhs.domain()) {\n",
    "\t ",
    $pwise?"IA_Image<IA_Point<int>, ATYPE>":"ATYPE", "\trval;\n",
    "\tia_throw(Image_DomainMismatch_Exception(__FILE__,__LINE__));\n",
    "\treturn rval;\n",
    "    }\n\n";
}
print "    if (!$curr_tbl)\n",
    "	IA_fill_Image_IP_ATYPE_LTYPE_RTYPE_OPNAME_tbl();\n\n",
    "    ",($pwise ? "IA_BaseImage<IA_Point<int>, ATYPE>*" : "ATYPE"), "(*f)( IA_BaseImage<IA_Point<int>, LTYPE> &,\n",
    "\t\tIA_BaseImage<IA_Point<int>, RTYPE> &);\n",
    "    f = $curr_tbl->lookup_operation\n",
    "	(";
if ($arity==2) {
    print "IA_ConstI<IA_Point<int>, LTYPE>::s_type()";
} else {
    print "lhs.type()";
}
print ", ";
if ($arity==1) {
    print "IA_ConstI<IA_Point<int>, RTYPE>::s_type()";
} else {
    print "rhs.type()";
}
print ");\n";
if ($arity==2) {
    print "    IA_ConstI<IA_Point<int>,LTYPE>	basel(rhs.domain(), lhs);\n"
} else {
    print "    IA_BaseImage<IA_Point<int>,LTYPE>	&basel =",
    " *IA_FBI<IA_Point<int>,IA_Point<int>, LTYPE,LTYPE,LTYPE>\n",
    "	    ::extract_baseptr(lhs);\n";
}
if ($arity==1) {
    print "    IA_ConstI<IA_Point<int>,LTYPE>	baser(lhs.domain(), rhs);\n"
} else {
    print "    IA_BaseImage<IA_Point<int>,LTYPE>	&baser =",
    " *IA_FBI<IA_Point<int>,IA_Point<int>, LTYPE,LTYPE,LTYPE>\n",
    "	    ::extract_baseptr(rhs);\n";
}
print "    return ";
if ($pwise) {
    print "IA_Image<IA_Point<int>,ATYPE>\n",
    "	(IA_FBI<IA_Point<int>,IA_Point<int>, ATYPE,ATYPE,ATYPE>\n",
    "	 ::make_Image(";
}
print "	 f(basel,baser)";
if ($pwise) {
    print "))";
}
print ";\n",
    "}\n\n//\n//\n//\n\n";


# emit the code for support procedures

if ($arity == 0) {
# emit support procedures for an image-image operation
    for ($i=0; $i<@names; $i++) {
	for ($j=0; $j<@names; $j++) {
	    # If the operation is commutative, we don\'t need to generate
	    # the mirror image of an asymmetric support procedure.
	    # We merely have to swap the order of the arguments in
	    # the call.
	    if ($comm && $j<$i) {
		&generate_binary_swap($i,"l",$j,"r"); 
	    } else {
		&generate_binary_op($i,"l",$j,"r"); 
	    }
	}
    }
} elsif ($arity == 1) {
# emit support procedures for an image-scalar operation
    for ($i=0; $i<@names; $i++) {
	if ($i>1 && $comm) {
	    &generate_binary_op(1,"r",$i,"l");
	    &generate_binary_swap($i,"l",1,"r");
	} else {
	    &generate_binary_op($i,"l",1,"r");
	}
    }
} else {
# emit support procedures for an scalar-image operation
    for ($i=0; $i<@names; $i++) {
	if ($i<1 && $comm) {
	    &generate_binary_op($i,"r",1,"l");
	    &generate_binary_swap(1,"l",$i,"r");
	} else {
	    &generate_binary_op(1,"l",$i,"r");
	}
    }
}

{
    print "#ifndef FILL_BOT_ATYPE_LTYPE_RTYPE_OPNAME\n",
    "#define FILL_BOT_ATYPE_LTYPE_RTYPE_OPNAME\n";
    local ($bop) = "IA_BinaryOperationsTable<".
        ($pwise ? "IA_BaseImage<IA_Point<int>, ATYPE>*" : "ATYPE").
	    ",\n\tIA_BaseImage<IA_Point<int>, LTYPE>,\n".
		"\tIA_BaseImage<IA_Point<int>, RTYPE> >";
    print "void IA_fill_Image_IP_ATYPE_LTYPE_RTYPE_OPNAME_tbl()\n",
    "{\n",
    "    if ($curr_tbl)\n",
    "\treturn;\n\n",
    
    "    $bop::function f;\n",
    "    f = ",$names[@names-1],"_",$names[@names-1],"_bo_OPNAME;\n\n",
    "    $curr_tbl = new $bop(iter_iter_bo_OPNAME);\n";

    for ($i=0; $i<@names; $i++) {
	for ($j=0; $j<@names; $j++) {
	    next if (($i+1)==@names && ($j+1)==@names);

	    print "    $curr_tbl->add_operation\n",
	    "\t(", &arg_s_type_($i, "LTYPE"), ",\n",
	    "\t ", &arg_s_type_($j, "RTYPE"), ",\n",
	    "\t ", $names[$i],"_",$names[$j],"_bo_OPNAME);\n";
	}
	print "\n";
    }

    print "}\n";
    print "#endif // BOT_ATYPE_LTYPE_RTYPE_OPNAME\n";
}

exit 0;
