Status push_operator(const Operator *operator, Stack **operands, Stack **operators)
{
if (!operator)
{
return ERROR_SYNTAX;
}
Status status = OK;
while (*operators && status == OK)
{
const Operator *stack_operator = stack_top(*operators);
if (operator->arity == OPERATOR_UNARY ||
operator->precedence < stack_operator->precedence ||
(operator->associativity == OPERATOR_RIGHT &&
operator->precedence == stack_operator->precedence))
{
break;
}
status = apply_operator(stack_pop(operators), operands);
}
stack_push(operators, operator);
return status;
}
object *eval(object *exp, object *env) {
object *procedure;
object *arguments;
object *result;
bool tailcall = false;
do {
if (is_self_evaluating(exp))
return exp;
if (is_variable(exp))
return lookup_variable_value(exp, env);
if (is_quoted(exp))
return text_of_quotation(exp);
if (is_assignment(exp))
return eval_assignment(exp, env);
if (is_definition(exp))
return eval_definition(exp, env);
if (is_if(exp)) {
exp = is_true(eval(if_predicate(exp), env)) ? if_consequent(exp) : if_alternative(exp);
tailcall = true;
continue;
}
if (is_lambda(exp))
return make_compound_proc(lambda_parameters(exp), lambda_body(exp), env);
if (is_begin(exp)) {
exp = begin_actions(exp);
while (!is_last_exp(exp)) {
eval(first_exp(exp), env);
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_cond(exp)) {
exp = cond_to_if(exp);
tailcall = true;
continue;
}
if (is_let(exp)) {
exp = let_to_application(exp);
tailcall = true;
continue;
}
if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty(exp))
return make_boolean(true);
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_false(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty(exp)) {
return make_boolean(false);
}
while (!is_last_exp(exp)) {
result = eval(first_exp(exp), env);
if (is_true(result))
return result;
exp = rest_exps(exp);
}
exp = first_exp(exp);
tailcall = true;
continue;
}
if (is_application(exp)) {
procedure = eval(operator(exp), env);
arguments = list_of_values(operands(exp), env);
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == eval_proc) {
exp = eval_expression(arguments);
env = eval_environment(arguments);
tailcall = true;
continue;
}
if (is_primitive_proc(procedure) && procedure->data.primitive_proc.fn == apply_proc) {
procedure = apply_operator(arguments);
arguments = apply_operands(arguments);
}
if (is_primitive_proc(procedure))
return (procedure->data.primitive_proc.fn)(arguments);
if (is_compound_proc(procedure)) {
env = extend_environment(procedure->data.compound_proc.parameters, arguments, procedure->data.compound_proc.env);
exp = make_begin(procedure->data.compound_proc.body);
tailcall = true;
continue;
}
return make_error(342, "unknown procedure type");
} // is_application()
} while (tailcall);
fprintf(stderr, "cannot eval unknown expression type\n");
exit(EXIT_FAILURE);
}
object *bs_eval(object *exp, object *env)
{
tailcall:
if (is_empty_list(exp)) {
error("unable to evaluate empty list");
} else if (is_self_evaluating(exp)) {
return exp;
} else if (is_variable(exp)) {
return lookup_variable_value(exp, env);
} else if (is_quoted(exp)) {
return quoted_expression(exp);
} else if (is_assignment(exp)) {
return eval_assignment(exp, env);
} else if (is_definition(exp)) {
return eval_definition(exp, env);
} else if (is_if(exp)) {
if (is_true(bs_eval(if_predicate(exp), env))) {
exp = if_consequent(exp);
} else {
exp = if_alternate(exp);
}
goto tailcall;
} else if (is_lambda(exp)) {
return make_compound_proc(lambda_parameters(exp),
lambda_body(exp),
env);
} else if (is_begin(exp)) {
exp = begin_actions(exp);
if (is_empty_list(exp)) {
error("empty begin block");
}
while (!is_empty_list(cdr(exp))) {
bs_eval(car(exp), env);
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_cond(exp)) {
exp = cond_to_if(exp);
goto tailcall;
} else if (is_let(exp)) {
exp = let_to_application(exp);
goto tailcall;
} else if (is_and(exp)) {
exp = and_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(1);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_false(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_or(exp)) {
exp = or_tests(exp);
if (is_empty_list(exp)) {
return get_boolean(0);
}
object *result;
while (!is_empty_list(cdr(exp))) {
result = bs_eval(car(exp), env);
if (is_true(result)) {
return result;
}
exp = cdr(exp);
}
exp = car(exp);
goto tailcall;
} else if (is_application(exp)) {
object *procedure = bs_eval(application_operator(exp), env);
object *parameters = eval_parameters(application_operands(exp), env);
// handle eval specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == eval_proc) {
exp = eval_expression(parameters);
env = eval_environment(parameters);
goto tailcall;
}
// handle apply specially for tailcall requirement.
if (is_primitive_proc(procedure) &&
procedure->value.primitive_proc == apply_proc) {
procedure = apply_operator(parameters);
parameters = apply_operands(parameters);
}
if (is_primitive_proc(procedure)) {
return (procedure->value.primitive_proc)(parameters);
} else if (is_compound_proc(procedure)) {
env = extend_environment(
procedure->value.compound_proc.parameters,
parameters,
procedure->value.compound_proc.env);
exp = make_begin(procedure->value.compound_proc.body);
goto tailcall;
} else {
error("unable to apply unknown procedure type");
}
} else {
error("unable to evaluate expression");
}
}
int terrain_filter(
float *data, // input/output: array of data to process (row-major order)
double detail, // input: "detail" exponent to be applied
int nrows, // input: number of rows in data array
int ncols, // input: number of columns in data array
double xdim, // input: spacing between pixel columns (in degrees or meters)
double ydim, // input: spacing between pixel rows (in degrees or meters)
enum Terrain_Coord_Type
coord_type, // input: coordinate type for xdim & ydim (degrees or meters)
double center_lat, // input: latitude in degrees at center of data array
// (ignored if coord_type == TERRAIN_METERS)
const struct Terrain_Progress_Callback
*progress // optional callback functor for status; NULL for none
// enum Terrain_Reg registration // feature not yet implemented
)
// Computes operator (-Laplacian)^(detail/2) applied to data array.
// Returns 0 on success, nonzero if an error occurred (see enum Terrain_Filter_Errors).
// Mean of data array is always (approximately) zero on output.
// On input, vertical units (data array values) should be in meters.
{
enum Terrain_Reg registration = TERRAIN_REG_CELL;
int num_threads = 1; // number of threads used to parallelize the three DCT loops
// approximate relative amount of time spent in each step
// (actual times vary with data array size, memory size, and DCT algorithms chosen):
const float step_times[6] =
{ 0.5, 2.0/num_threads, 1.0, 4.0/num_threads, 1.0, 2.0/num_threads };
const int total_steps = sizeof( step_times ) / sizeof( *step_times );
struct Terrain_Progress_Info
progress_info = init_progress( progress, step_times, total_steps );
struct Transpose_Progress_Callback
sub_progress = { relay_progress, &progress_info };
const double steepness = 2.0;
int error;
int type_fwd, type_bwd;
int i, j;
float *ptr;
float data_min, data_max;
double normalizer;
double xres, yres;
double xscale, yscale;
double xsize, ysize;
struct Terrain_Operator_Info info;
// Determine pixel dimensions:
if (coord_type == TERRAIN_DEGREES) {
geographic_scale( center_lat, &xsize, &ysize );
// convert degrees to meters (approximately)
xres = xdim * xsize;
yres = ydim * ysize;
} else {
xres = xdim;
yres = ydim;
}
xscale = fabs( 1.0 / xres );
yscale = fabs( 1.0 / yres );
switch (registration) {
case TERRAIN_REG_GRID:
type_fwd = 1;
type_bwd = 1;
break;
case TERRAIN_REG_CELL:
type_fwd = 2;
type_bwd = 3;
break;
default:
return TERRAIN_FILTER_INVALID_PARAM;
}
if (progress && report_progress( &progress_info )) {
return TERRAIN_FILTER_CANCELED;
}
data_min = data[0];
data_max = data[0];
for (i=0, ptr=data; i<nrows; ++i, ptr+=ncols) {
//float *ptr = data + (LONG)i * (LONG)ncols;
for (j=0; j<ncols; ++j) {
if (ptr[j] < data_min) {
data_min = ptr[j];
} else if (ptr[j] > data_max) {
data_max = ptr[j];
}
}
}
normalizer = pow( 2.0 / (data_max - data_min), 1.0 - detail );
normalizer *= pow( steepness, -detail );
for (i=0, ptr=data; i<nrows; ++i, ptr+=ncols) {
//float *ptr = data + (LONG)i * (LONG)ncols;
for (j=0; j<ncols; ++j) {
ptr[j] *= normalizer;
}
}
error = setup_operator( detail, ncols, nrows, xscale, yscale, registration, &info );
if (error) {
return error;
}
set_progress( &progress_info, 1 );
if (progress && report_progress( &progress_info )) {
return TERRAIN_FILTER_CANCELED;
}
// CONCURRENCY NOTE: The iterations of the loop below will be
// independent and can be executed in parallel, if each thread has
// its own dct_plan with separate calls to setup_dcts() and cleanup_dcts().
{
struct Dct_Plan dct_plan = setup_dcts( type_fwd, ncols );
if (!dct_plan.dct_buffer) {
return TERRAIN_FILTER_MALLOC_ERROR;
}
for (i=0; i<nrows-1; i+=2) {
float *ptr = data + (LONG)i * (LONG)ncols;
two_dcts( ptr, ncols, &dct_plan );
if (progress && update_progress( &progress_info, i+2, nrows ))
{
return TERRAIN_FILTER_CANCELED;
}
}
if (nrows & 1) {
float *ptr = data + (LONG)(nrows - 1) * (LONG)ncols;
single_dct( ptr, ncols, &dct_plan );
}
cleanup_dcts( &dct_plan );
}
set_progress( &progress_info, 2 );
if (progress && report_progress( &progress_info )) {
return TERRAIN_FILTER_CANCELED;
}
error = transpose_inplace( data, nrows, ncols, progress ? &sub_progress : NULL );
if (error) {
if (error > 0) {
return TERRAIN_FILTER_MALLOC_ERROR;
} else {
return TERRAIN_FILTER_CANCELED;
}
}
set_progress( &progress_info, 3 );
if (progress && report_progress( &progress_info )) {
return TERRAIN_FILTER_CANCELED;
}
// CONCURRENCY NOTE: The iterations of the loop below will be
// independent and can be executed in parallel, if each thread has
// its own fwd_plan and bwd_plan with separate calls to setup_dcts()
// and cleanup_dcts().
{
struct Dct_Plan fwd_plan = setup_dcts( type_fwd, nrows );
struct Dct_Plan bwd_plan = setup_dcts( type_bwd, nrows );
if (!fwd_plan.dct_buffer || !bwd_plan.dct_buffer) {
return TERRAIN_FILTER_MALLOC_ERROR;
}
for (i=0; i<ncols-1; i+=2) {
float *ptr = data + (LONG)i * (LONG)nrows;
two_dcts( ptr, nrows, &fwd_plan );
apply_operator( data, i, nrows, info );
apply_operator( data, i+1, nrows, info );
two_dcts( ptr, nrows, &bwd_plan );
if (progress && update_progress( &progress_info, i+2, ncols ))
{
return TERRAIN_FILTER_CANCELED;
}
}
if (ncols & 1) {
float *ptr = data + (LONG)(ncols - 1) * (LONG)nrows;
single_dct( ptr, nrows, &fwd_plan );
apply_operator( data, ncols-1, nrows, info );
single_dct( ptr, nrows, &bwd_plan );
}
cleanup_dcts( &bwd_plan );
cleanup_dcts( &fwd_plan );
}
if (flt_isnan( data[0] )) {
return TERRAIN_FILTER_NULL_VALUES;
}
set_progress( &progress_info, 4 );
if (progress && report_progress( &progress_info )) {
return TERRAIN_FILTER_CANCELED;
}
error = transpose_inplace( data, ncols, nrows, progress ? &sub_progress : NULL );
if (error) {
if (error > 0) {
return TERRAIN_FILTER_MALLOC_ERROR;
} else {
return TERRAIN_FILTER_CANCELED;
}
}
set_progress( &progress_info, 5 );
if (progress && report_progress( &progress_info )) {
return TERRAIN_FILTER_CANCELED;
}
// CONCURRENCY NOTE: The iterations of the loop below will be
// independent and can be executed in parallel, if each thread has
// its own dct_plan with separate calls to setup_dcts() and cleanup_dcts().
{
struct Dct_Plan dct_plan = setup_dcts( type_bwd, ncols );
if (!dct_plan.dct_buffer) {
return TERRAIN_FILTER_MALLOC_ERROR;
}
for (i=0; i<nrows-1; i+=2) {
float *ptr = data + (LONG)i * (LONG)ncols;
two_dcts( ptr, ncols, &dct_plan );
if (progress && update_progress( &progress_info, i+2, nrows ))
{
return TERRAIN_FILTER_CANCELED;
}
}
if (nrows & 1) {
float *ptr = data + (LONG)(nrows - 1) * (LONG)ncols;
single_dct( ptr, ncols, &dct_plan );
}
cleanup_dcts( &dct_plan );
}
cleanup_operator( info );
set_progress( &progress_info, 6 );
if (progress) {
// report final progress; ignore any cancel request at this point
report_progress( &progress_info );
}
return TERRAIN_FILTER_SUCCESS;
}
Status parse(const Token *tokens, Stack **operands, Stack **operators, Stack **functions)
{
Status status = OK;
const Token *token, *previous, *next;
for (token = tokens, previous = &NO_TOKEN, next = token + 1;
token->type != TOKEN_NONE; previous = token, token = next++)
{
switch (token->type)
{
case TOKEN_OPEN_PARENTHESIS:
{
// Implicit multiplication: "(2)(2)".
if (previous->type == TOKEN_CLOSE_PARENTHESIS)
{
status = push_multiplication(operands, operators);
}
stack_push(operators, get_operator('(', OPERATOR_OTHER));
break;
}
case TOKEN_CLOSE_PARENTHESIS:
{
// Apply operators until the previous open parenthesis is found.
bool found_parenthesis = false;
while (*operators && status == OK && !found_parenthesis)
{
const Operator *operator = stack_pop(operators);
if (operator->symbol == '(')
{
found_parenthesis = true;
}
else
{
status = apply_operator(operator, operands);
}
}
if (!found_parenthesis)
{
status = ERROR_CLOSE_PARENTHESIS;
}
else if (*functions)
{
status = apply_function(stack_pop(functions), operands);
}
break;
}
case TOKEN_OPERATOR:
{
status = push_operator(
get_operator(*token->value, get_arity(*token->value, previous)),
operands, operators);
break;
}
case TOKEN_NUMBER:
{
if (previous->type == TOKEN_CLOSE_PARENTHESIS ||
previous->type == TOKEN_NUMBER ||
previous->type == TOKEN_IDENTIFIER)
{
status = ERROR_SYNTAX;
}
else
{
status = push_number(token->value, operands);
// Implicit multiplication: "2(2)" or "2a".
if (next->type == TOKEN_OPEN_PARENTHESIS ||
next->type == TOKEN_IDENTIFIER)
{
status = push_multiplication(operands, operators);
}
}
break;
}
case TOKEN_IDENTIFIER:
{
// The identifier could be either a constant or function.
status = push_constant(token->value, operands);
if (status == ERROR_UNDEFINED_CONSTANT &&
next->type == TOKEN_OPEN_PARENTHESIS)
{
stack_push(functions, token->value);
status = OK;
}
else if (next->type == TOKEN_OPEN_PARENTHESIS ||
next->type == TOKEN_IDENTIFIER)
{
// Implicit multiplication: "a(2)" or "a b".
status = push_multiplication(operands, operators);
}
break;
}
default:
{
status = ERROR_UNRECOGNIZED;
}
}
if (status != OK)
{
return status;
}
}
// Apply all remaining operators.
while (*operators && status == OK)
{
const Operator *operator = stack_pop(operators);
if (operator->symbol == '(')
{
status = ERROR_OPEN_PARENTHESIS;
}
else
{
status = apply_operator(operator, operands);
}
}
return status;
}
int terrain_filter(
float *data, // input/output: array of data to process (row-major order)
double gain, // input: "gain exponent" to be applied
int nrows, // input: number of rows in data array
int ncols, // input: number of columns in data array
double xres, // input: linear units (e.g., meters, not degrees) per column
double yres, // input: linear units (e.g., meters, not degrees) per row
const struct Terrain_Progress_Callback
*progress // optional callback functor for status; NULL for none
// enum Terrain_Reg registration
)
// Computes operator (-Laplacian)^(gain/2) applied to data array.
// Returns 0 on success, nonzero if an error occurred (see Terrain_Filter_Errors).
// Mean of data array is always (approximately) zero on output.
{
enum Terrain_Reg registration = TERRAIN_REG_CELL;
int error;
int type_fwd, type_bwd;
double xscale = 1.0 / xres;
double yscale = 1.0 / yres;
double dscale;
xscale = fabs( xscale );
yscale = fabs( yscale );
// check for yscale > xscale, but allow a little slack (< 1/4 pixel relative error)
dscale = yscale - xscale;
if (dscale * ncols >= 0.25 * xscale || dscale * nrows >= 0.25 * yscale) {
fprintf( stderr, "*** WARNING: " );
fprintf( stderr, "Unusual pixel aspect ratio (> 1.0). Is this correct?\n" );
}
switch (registration) {
case TERRAIN_REG_GRID:
type_fwd = 1;
type_bwd = 1;
break;
case TERRAIN_REG_CELL:
type_fwd = 2;
type_bwd = 3;
break;
default:
return TERRAIN_FILTER_INVALID_PARAM;
}
// Perform 2-D DCT (and transpose matrix):
if (progress && progress->callback( progress->state, 0, 3 )) {
return TERRAIN_FILTER_CANCELED;
}
error = dct_2d_and_transpose( nrows, ncols, data, type_fwd );
if (error) {
return TERRAIN_FILTER_MALLOC_ERROR;
}
if (flt_isnan( data[0] )) {
return TERRAIN_FILTER_NULL_VALUES;
}
if (progress && progress->callback( progress->state, 1, 3 )) {
return TERRAIN_FILTER_CANCELED;
}
// Apply fractional Laplacian operator as Fourier multiplier
error = apply_operator( data, gain, ncols, nrows, xscale, yscale, registration );
if (error) {
return error;
}
// Perform 2-D DCT (and transpose matrix):
if (progress && progress->callback( progress->state, 2, 3 )) {
return TERRAIN_FILTER_CANCELED;
}
error = dct_2d_and_transpose( ncols, nrows, data, type_bwd );
if (error) {
return TERRAIN_FILTER_MALLOC_ERROR;
}
if (progress && progress->callback( progress->state, 3, 3 )) {
return TERRAIN_FILTER_CANCELED;
}
return TERRAIN_FILTER_SUCCESS;
}