alpar@9: /* glpmpl03.c */ alpar@9: alpar@9: /*********************************************************************** alpar@9: * This code is part of GLPK (GNU Linear Programming Kit). alpar@9: * alpar@9: * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, alpar@9: * 2009, 2010, 2011 Andrew Makhorin, Department for Applied Informatics, alpar@9: * Moscow Aviation Institute, Moscow, Russia. All rights reserved. alpar@9: * E-mail: . alpar@9: * alpar@9: * GLPK is free software: you can redistribute it and/or modify it alpar@9: * under the terms of the GNU General Public License as published by alpar@9: * the Free Software Foundation, either version 3 of the License, or alpar@9: * (at your option) any later version. alpar@9: * alpar@9: * GLPK is distributed in the hope that it will be useful, but WITHOUT alpar@9: * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY alpar@9: * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public alpar@9: * License for more details. alpar@9: * alpar@9: * You should have received a copy of the GNU General Public License alpar@9: * along with GLPK. If not, see . alpar@9: ***********************************************************************/ alpar@9: alpar@9: #define _GLPSTD_ERRNO alpar@9: #define _GLPSTD_STDIO alpar@9: #include "glpenv.h" alpar@9: #include "glpmpl.h" alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * FLOATING-POINT NUMBERS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_add - floating-point addition. alpar@9: -- alpar@9: -- This routine computes the sum x + y. */ alpar@9: alpar@9: double fp_add(MPL *mpl, double x, double y) alpar@9: { if (x > 0.0 && y > 0.0 && x > + 0.999 * DBL_MAX - y || alpar@9: x < 0.0 && y < 0.0 && x < - 0.999 * DBL_MAX - y) alpar@9: error(mpl, "%.*g + %.*g; floating-point overflow", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: return x + y; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_sub - floating-point subtraction. alpar@9: -- alpar@9: -- This routine computes the difference x - y. */ alpar@9: alpar@9: double fp_sub(MPL *mpl, double x, double y) alpar@9: { if (x > 0.0 && y < 0.0 && x > + 0.999 * DBL_MAX + y || alpar@9: x < 0.0 && y > 0.0 && x < - 0.999 * DBL_MAX + y) alpar@9: error(mpl, "%.*g - %.*g; floating-point overflow", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: return x - y; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_less - floating-point non-negative subtraction. alpar@9: -- alpar@9: -- This routine computes the non-negative difference max(0, x - y). */ alpar@9: alpar@9: double fp_less(MPL *mpl, double x, double y) alpar@9: { if (x < y) return 0.0; alpar@9: if (x > 0.0 && y < 0.0 && x > + 0.999 * DBL_MAX + y) alpar@9: error(mpl, "%.*g less %.*g; floating-point overflow", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: return x - y; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_mul - floating-point multiplication. alpar@9: -- alpar@9: -- This routine computes the product x * y. */ alpar@9: alpar@9: double fp_mul(MPL *mpl, double x, double y) alpar@9: { if (fabs(y) > 1.0 && fabs(x) > (0.999 * DBL_MAX) / fabs(y)) alpar@9: error(mpl, "%.*g * %.*g; floating-point overflow", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: return x * y; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_div - floating-point division. alpar@9: -- alpar@9: -- This routine computes the quotient x / y. */ alpar@9: alpar@9: double fp_div(MPL *mpl, double x, double y) alpar@9: { if (fabs(y) < DBL_MIN) alpar@9: error(mpl, "%.*g / %.*g; floating-point zero divide", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: if (fabs(y) < 1.0 && fabs(x) > (0.999 * DBL_MAX) * fabs(y)) alpar@9: error(mpl, "%.*g / %.*g; floating-point overflow", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: return x / y; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_idiv - floating-point quotient of exact division. alpar@9: -- alpar@9: -- This routine computes the quotient of exact division x div y. */ alpar@9: alpar@9: double fp_idiv(MPL *mpl, double x, double y) alpar@9: { if (fabs(y) < DBL_MIN) alpar@9: error(mpl, "%.*g div %.*g; floating-point zero divide", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: if (fabs(y) < 1.0 && fabs(x) > (0.999 * DBL_MAX) * fabs(y)) alpar@9: error(mpl, "%.*g div %.*g; floating-point overflow", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: x /= y; alpar@9: return x > 0.0 ? floor(x) : x < 0.0 ? ceil(x) : 0.0; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_mod - floating-point remainder of exact division. alpar@9: -- alpar@9: -- This routine computes the remainder of exact division x mod y. alpar@9: -- alpar@9: -- NOTE: By definition x mod y = x - y * floor(x / y). */ alpar@9: alpar@9: double fp_mod(MPL *mpl, double x, double y) alpar@9: { double r; alpar@9: xassert(mpl == mpl); alpar@9: if (x == 0.0) alpar@9: r = 0.0; alpar@9: else if (y == 0.0) alpar@9: r = x; alpar@9: else alpar@9: { r = fmod(fabs(x), fabs(y)); alpar@9: if (r != 0.0) alpar@9: { if (x < 0.0) r = - r; alpar@9: if (x > 0.0 && y < 0.0 || x < 0.0 && y > 0.0) r += y; alpar@9: } alpar@9: } alpar@9: return r; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_power - floating-point exponentiation (raise to power). alpar@9: -- alpar@9: -- This routine computes the exponentiation x ** y. */ alpar@9: alpar@9: double fp_power(MPL *mpl, double x, double y) alpar@9: { double r; alpar@9: if (x == 0.0 && y <= 0.0 || x < 0.0 && y != floor(y)) alpar@9: error(mpl, "%.*g ** %.*g; result undefined", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: if (x == 0.0) goto eval; alpar@9: if (fabs(x) > 1.0 && y > +1.0 && alpar@9: +log(fabs(x)) > (0.999 * log(DBL_MAX)) / y || alpar@9: fabs(x) < 1.0 && y < -1.0 && alpar@9: +log(fabs(x)) < (0.999 * log(DBL_MAX)) / y) alpar@9: error(mpl, "%.*g ** %.*g; floating-point overflow", alpar@9: DBL_DIG, x, DBL_DIG, y); alpar@9: if (fabs(x) > 1.0 && y < -1.0 && alpar@9: -log(fabs(x)) < (0.999 * log(DBL_MAX)) / y || alpar@9: fabs(x) < 1.0 && y > +1.0 && alpar@9: -log(fabs(x)) > (0.999 * log(DBL_MAX)) / y) alpar@9: r = 0.0; alpar@9: else alpar@9: eval: r = pow(x, y); alpar@9: return r; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_exp - floating-point base-e exponential. alpar@9: -- alpar@9: -- This routine computes the base-e exponential e ** x. */ alpar@9: alpar@9: double fp_exp(MPL *mpl, double x) alpar@9: { if (x > 0.999 * log(DBL_MAX)) alpar@9: error(mpl, "exp(%.*g); floating-point overflow", DBL_DIG, x); alpar@9: return exp(x); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_log - floating-point natural logarithm. alpar@9: -- alpar@9: -- This routine computes the natural logarithm log x. */ alpar@9: alpar@9: double fp_log(MPL *mpl, double x) alpar@9: { if (x <= 0.0) alpar@9: error(mpl, "log(%.*g); non-positive argument", DBL_DIG, x); alpar@9: return log(x); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_log10 - floating-point common (decimal) logarithm. alpar@9: -- alpar@9: -- This routine computes the common (decimal) logarithm lg x. */ alpar@9: alpar@9: double fp_log10(MPL *mpl, double x) alpar@9: { if (x <= 0.0) alpar@9: error(mpl, "log10(%.*g); non-positive argument", DBL_DIG, x); alpar@9: return log10(x); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_sqrt - floating-point square root. alpar@9: -- alpar@9: -- This routine computes the square root x ** 0.5. */ alpar@9: alpar@9: double fp_sqrt(MPL *mpl, double x) alpar@9: { if (x < 0.0) alpar@9: error(mpl, "sqrt(%.*g); negative argument", DBL_DIG, x); alpar@9: return sqrt(x); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_sin - floating-point trigonometric sine. alpar@9: -- alpar@9: -- This routine computes the trigonometric sine sin(x). */ alpar@9: alpar@9: double fp_sin(MPL *mpl, double x) alpar@9: { if (!(-1e6 <= x && x <= +1e6)) alpar@9: error(mpl, "sin(%.*g); argument too large", DBL_DIG, x); alpar@9: return sin(x); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_cos - floating-point trigonometric cosine. alpar@9: -- alpar@9: -- This routine computes the trigonometric cosine cos(x). */ alpar@9: alpar@9: double fp_cos(MPL *mpl, double x) alpar@9: { if (!(-1e6 <= x && x <= +1e6)) alpar@9: error(mpl, "cos(%.*g); argument too large", DBL_DIG, x); alpar@9: return cos(x); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_atan - floating-point trigonometric arctangent. alpar@9: -- alpar@9: -- This routine computes the trigonometric arctangent atan(x). */ alpar@9: alpar@9: double fp_atan(MPL *mpl, double x) alpar@9: { xassert(mpl == mpl); alpar@9: return atan(x); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_atan2 - floating-point trigonometric arctangent. alpar@9: -- alpar@9: -- This routine computes the trigonometric arctangent atan(y / x). */ alpar@9: alpar@9: double fp_atan2(MPL *mpl, double y, double x) alpar@9: { xassert(mpl == mpl); alpar@9: return atan2(y, x); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_round - round floating-point value to n fractional digits. alpar@9: -- alpar@9: -- This routine rounds given floating-point value x to n fractional alpar@9: -- digits with the formula: alpar@9: -- alpar@9: -- round(x, n) = floor(x * 10^n + 0.5) / 10^n. alpar@9: -- alpar@9: -- The parameter n is assumed to be integer. */ alpar@9: alpar@9: double fp_round(MPL *mpl, double x, double n) alpar@9: { double ten_to_n; alpar@9: if (n != floor(n)) alpar@9: error(mpl, "round(%.*g, %.*g); non-integer second argument", alpar@9: DBL_DIG, x, DBL_DIG, n); alpar@9: if (n <= DBL_DIG + 2) alpar@9: { ten_to_n = pow(10.0, n); alpar@9: if (fabs(x) < (0.999 * DBL_MAX) / ten_to_n) alpar@9: { x = floor(x * ten_to_n + 0.5); alpar@9: if (x != 0.0) x /= ten_to_n; alpar@9: } alpar@9: } alpar@9: return x; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_trunc - truncate floating-point value to n fractional digits. alpar@9: -- alpar@9: -- This routine truncates given floating-point value x to n fractional alpar@9: -- digits with the formula: alpar@9: -- alpar@9: -- ( floor(x * 10^n) / 10^n, if x >= 0 alpar@9: -- trunc(x, n) = < alpar@9: -- ( ceil(x * 10^n) / 10^n, if x < 0 alpar@9: -- alpar@9: -- The parameter n is assumed to be integer. */ alpar@9: alpar@9: double fp_trunc(MPL *mpl, double x, double n) alpar@9: { double ten_to_n; alpar@9: if (n != floor(n)) alpar@9: error(mpl, "trunc(%.*g, %.*g); non-integer second argument", alpar@9: DBL_DIG, x, DBL_DIG, n); alpar@9: if (n <= DBL_DIG + 2) alpar@9: { ten_to_n = pow(10.0, n); alpar@9: if (fabs(x) < (0.999 * DBL_MAX) / ten_to_n) alpar@9: { x = (x >= 0.0 ? floor(x * ten_to_n) : ceil(x * ten_to_n)); alpar@9: if (x != 0.0) x /= ten_to_n; alpar@9: } alpar@9: } alpar@9: return x; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * PSEUDO-RANDOM NUMBER GENERATORS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_irand224 - pseudo-random integer in the range [0, 2^24). alpar@9: -- alpar@9: -- This routine returns a next pseudo-random integer (converted to alpar@9: -- floating-point) which is uniformly distributed between 0 and 2^24-1, alpar@9: -- inclusive. */ alpar@9: alpar@9: #define two_to_the_24 0x1000000 alpar@9: alpar@9: double fp_irand224(MPL *mpl) alpar@9: { return alpar@9: (double)rng_unif_rand(mpl->rand, two_to_the_24); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_uniform01 - pseudo-random number in the range [0, 1). alpar@9: -- alpar@9: -- This routine returns a next pseudo-random number which is uniformly alpar@9: -- distributed in the range [0, 1). */ alpar@9: alpar@9: #define two_to_the_31 ((unsigned int)0x80000000) alpar@9: alpar@9: double fp_uniform01(MPL *mpl) alpar@9: { return alpar@9: (double)rng_next_rand(mpl->rand) / (double)two_to_the_31; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_uniform - pseudo-random number in the range [a, b). alpar@9: -- alpar@9: -- This routine returns a next pseudo-random number which is uniformly alpar@9: -- distributed in the range [a, b). */ alpar@9: alpar@9: double fp_uniform(MPL *mpl, double a, double b) alpar@9: { double x; alpar@9: if (a >= b) alpar@9: error(mpl, "Uniform(%.*g, %.*g); invalid range", alpar@9: DBL_DIG, a, DBL_DIG, b); alpar@9: x = fp_uniform01(mpl); alpar@9: #if 0 alpar@9: x = a * (1.0 - x) + b * x; alpar@9: #else alpar@9: x = fp_add(mpl, a * (1.0 - x), b * x); alpar@9: #endif alpar@9: return x; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_normal01 - Gaussian random variate with mu = 0 and sigma = 1. alpar@9: -- alpar@9: -- This routine returns a Gaussian random variate with zero mean and alpar@9: -- unit standard deviation. The polar (Box-Mueller) method is used. alpar@9: -- alpar@9: -- This code is a modified version of the routine gsl_ran_gaussian from alpar@9: -- the GNU Scientific Library Version 1.0. */ alpar@9: alpar@9: double fp_normal01(MPL *mpl) alpar@9: { double x, y, r2; alpar@9: do alpar@9: { /* choose x, y in uniform square (-1,-1) to (+1,+1) */ alpar@9: x = -1.0 + 2.0 * fp_uniform01(mpl); alpar@9: y = -1.0 + 2.0 * fp_uniform01(mpl); alpar@9: /* see if it is in the unit circle */ alpar@9: r2 = x * x + y * y; alpar@9: } while (r2 > 1.0 || r2 == 0.0); alpar@9: /* Box-Muller transform */ alpar@9: return y * sqrt(-2.0 * log (r2) / r2); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fp_normal - Gaussian random variate with specified mu and sigma. alpar@9: -- alpar@9: -- This routine returns a Gaussian random variate with mean mu and alpar@9: -- standard deviation sigma. */ alpar@9: alpar@9: double fp_normal(MPL *mpl, double mu, double sigma) alpar@9: { double x; alpar@9: #if 0 alpar@9: x = mu + sigma * fp_normal01(mpl); alpar@9: #else alpar@9: x = fp_add(mpl, mu, fp_mul(mpl, sigma, fp_normal01(mpl))); alpar@9: #endif alpar@9: return x; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * SEGMENTED CHARACTER STRINGS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- create_string - create character string. alpar@9: -- alpar@9: -- This routine creates a segmented character string, which is exactly alpar@9: -- equivalent to specified character string. */ alpar@9: alpar@9: STRING *create_string alpar@9: ( MPL *mpl, alpar@9: char buf[MAX_LENGTH+1] /* not changed */ alpar@9: ) alpar@9: #if 0 alpar@9: { STRING *head, *tail; alpar@9: int i, j; alpar@9: xassert(buf != NULL); alpar@9: xassert(strlen(buf) <= MAX_LENGTH); alpar@9: head = tail = dmp_get_atom(mpl->strings, sizeof(STRING)); alpar@9: for (i = j = 0; ; i++) alpar@9: { if ((tail->seg[j++] = buf[i]) == '\0') break; alpar@9: if (j == STRSEG_SIZE) alpar@9: tail = (tail->next = dmp_get_atom(mpl->strings, sizeof(STRING))), j = 0; alpar@9: } alpar@9: tail->next = NULL; alpar@9: return head; alpar@9: } alpar@9: #else alpar@9: { STRING *str; alpar@9: xassert(strlen(buf) <= MAX_LENGTH); alpar@9: str = dmp_get_atom(mpl->strings, strlen(buf)+1); alpar@9: strcpy(str, buf); alpar@9: return str; alpar@9: } alpar@9: #endif alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- copy_string - make copy of character string. alpar@9: -- alpar@9: -- This routine returns an exact copy of segmented character string. */ alpar@9: alpar@9: STRING *copy_string alpar@9: ( MPL *mpl, alpar@9: STRING *str /* not changed */ alpar@9: ) alpar@9: #if 0 alpar@9: { STRING *head, *tail; alpar@9: xassert(str != NULL); alpar@9: head = tail = dmp_get_atom(mpl->strings, sizeof(STRING)); alpar@9: for (; str != NULL; str = str->next) alpar@9: { memcpy(tail->seg, str->seg, STRSEG_SIZE); alpar@9: if (str->next != NULL) alpar@9: tail = (tail->next = dmp_get_atom(mpl->strings, sizeof(STRING))); alpar@9: } alpar@9: tail->next = NULL; alpar@9: return head; alpar@9: } alpar@9: #else alpar@9: { xassert(mpl == mpl); alpar@9: return create_string(mpl, str); alpar@9: } alpar@9: #endif alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- compare_strings - compare one character string with another. alpar@9: -- alpar@9: -- This routine compares one segmented character strings with another alpar@9: -- and returns the result of comparison as follows: alpar@9: -- alpar@9: -- = 0 - both strings are identical; alpar@9: -- < 0 - the first string precedes the second one; alpar@9: -- > 0 - the first string follows the second one. */ alpar@9: alpar@9: int compare_strings alpar@9: ( MPL *mpl, alpar@9: STRING *str1, /* not changed */ alpar@9: STRING *str2 /* not changed */ alpar@9: ) alpar@9: #if 0 alpar@9: { int j, c1, c2; alpar@9: xassert(mpl == mpl); alpar@9: for (;; str1 = str1->next, str2 = str2->next) alpar@9: { xassert(str1 != NULL); alpar@9: xassert(str2 != NULL); alpar@9: for (j = 0; j < STRSEG_SIZE; j++) alpar@9: { c1 = (unsigned char)str1->seg[j]; alpar@9: c2 = (unsigned char)str2->seg[j]; alpar@9: if (c1 < c2) return -1; alpar@9: if (c1 > c2) return +1; alpar@9: if (c1 == '\0') goto done; alpar@9: } alpar@9: } alpar@9: done: return 0; alpar@9: } alpar@9: #else alpar@9: { xassert(mpl == mpl); alpar@9: return strcmp(str1, str2); alpar@9: } alpar@9: #endif alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- fetch_string - extract content of character string. alpar@9: -- alpar@9: -- This routine returns a character string, which is exactly equivalent alpar@9: -- to specified segmented character string. */ alpar@9: alpar@9: char *fetch_string alpar@9: ( MPL *mpl, alpar@9: STRING *str, /* not changed */ alpar@9: char buf[MAX_LENGTH+1] /* modified */ alpar@9: ) alpar@9: #if 0 alpar@9: { int i, j; alpar@9: xassert(mpl == mpl); alpar@9: xassert(buf != NULL); alpar@9: for (i = 0; ; str = str->next) alpar@9: { xassert(str != NULL); alpar@9: for (j = 0; j < STRSEG_SIZE; j++) alpar@9: if ((buf[i++] = str->seg[j]) == '\0') goto done; alpar@9: } alpar@9: done: xassert(strlen(buf) <= MAX_LENGTH); alpar@9: return buf; alpar@9: } alpar@9: #else alpar@9: { xassert(mpl == mpl); alpar@9: return strcpy(buf, str); alpar@9: } alpar@9: #endif alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- delete_string - delete character string. alpar@9: -- alpar@9: -- This routine deletes specified segmented character string. */ alpar@9: alpar@9: void delete_string alpar@9: ( MPL *mpl, alpar@9: STRING *str /* destroyed */ alpar@9: ) alpar@9: #if 0 alpar@9: { STRING *temp; alpar@9: xassert(str != NULL); alpar@9: while (str != NULL) alpar@9: { temp = str; alpar@9: str = str->next; alpar@9: dmp_free_atom(mpl->strings, temp, sizeof(STRING)); alpar@9: } alpar@9: return; alpar@9: } alpar@9: #else alpar@9: { dmp_free_atom(mpl->strings, str, strlen(str)+1); alpar@9: return; alpar@9: } alpar@9: #endif alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * SYMBOLS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- create_symbol_num - create symbol of numeric type. alpar@9: -- alpar@9: -- This routine creates a symbol, which has a numeric value specified alpar@9: -- as floating-point number. */ alpar@9: alpar@9: SYMBOL *create_symbol_num(MPL *mpl, double num) alpar@9: { SYMBOL *sym; alpar@9: sym = dmp_get_atom(mpl->symbols, sizeof(SYMBOL)); alpar@9: sym->num = num; alpar@9: sym->str = NULL; alpar@9: return sym; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- create_symbol_str - create symbol of abstract type. alpar@9: -- alpar@9: -- This routine creates a symbol, which has an abstract value specified alpar@9: -- as segmented character string. */ alpar@9: alpar@9: SYMBOL *create_symbol_str alpar@9: ( MPL *mpl, alpar@9: STRING *str /* destroyed */ alpar@9: ) alpar@9: { SYMBOL *sym; alpar@9: xassert(str != NULL); alpar@9: sym = dmp_get_atom(mpl->symbols, sizeof(SYMBOL)); alpar@9: sym->num = 0.0; alpar@9: sym->str = str; alpar@9: return sym; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- copy_symbol - make copy of symbol. alpar@9: -- alpar@9: -- This routine returns an exact copy of symbol. */ alpar@9: alpar@9: SYMBOL *copy_symbol alpar@9: ( MPL *mpl, alpar@9: SYMBOL *sym /* not changed */ alpar@9: ) alpar@9: { SYMBOL *copy; alpar@9: xassert(sym != NULL); alpar@9: copy = dmp_get_atom(mpl->symbols, sizeof(SYMBOL)); alpar@9: if (sym->str == NULL) alpar@9: { copy->num = sym->num; alpar@9: copy->str = NULL; alpar@9: } alpar@9: else alpar@9: { copy->num = 0.0; alpar@9: copy->str = copy_string(mpl, sym->str); alpar@9: } alpar@9: return copy; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- compare_symbols - compare one symbol with another. alpar@9: -- alpar@9: -- This routine compares one symbol with another and returns the result alpar@9: -- of comparison as follows: alpar@9: -- alpar@9: -- = 0 - both symbols are identical; alpar@9: -- < 0 - the first symbol precedes the second one; alpar@9: -- > 0 - the first symbol follows the second one. alpar@9: -- alpar@9: -- Note that the linear order, in which symbols follow each other, is alpar@9: -- implementation-dependent. It may be not an alphabetical order. */ alpar@9: alpar@9: int compare_symbols alpar@9: ( MPL *mpl, alpar@9: SYMBOL *sym1, /* not changed */ alpar@9: SYMBOL *sym2 /* not changed */ alpar@9: ) alpar@9: { xassert(sym1 != NULL); alpar@9: xassert(sym2 != NULL); alpar@9: /* let all numeric quantities precede all symbolic quantities */ alpar@9: if (sym1->str == NULL && sym2->str == NULL) alpar@9: { if (sym1->num < sym2->num) return -1; alpar@9: if (sym1->num > sym2->num) return +1; alpar@9: return 0; alpar@9: } alpar@9: if (sym1->str == NULL) return -1; alpar@9: if (sym2->str == NULL) return +1; alpar@9: return compare_strings(mpl, sym1->str, sym2->str); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- delete_symbol - delete symbol. alpar@9: -- alpar@9: -- This routine deletes specified symbol. */ alpar@9: alpar@9: void delete_symbol alpar@9: ( MPL *mpl, alpar@9: SYMBOL *sym /* destroyed */ alpar@9: ) alpar@9: { xassert(sym != NULL); alpar@9: if (sym->str != NULL) delete_string(mpl, sym->str); alpar@9: dmp_free_atom(mpl->symbols, sym, sizeof(SYMBOL)); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- format_symbol - format symbol for displaying or printing. alpar@9: -- alpar@9: -- This routine converts specified symbol to a charater string, which alpar@9: -- is suitable for displaying or printing. alpar@9: -- alpar@9: -- The resultant string is never longer than 255 characters. If it gets alpar@9: -- longer, it is truncated from the right and appended by dots. */ alpar@9: alpar@9: char *format_symbol alpar@9: ( MPL *mpl, alpar@9: SYMBOL *sym /* not changed */ alpar@9: ) alpar@9: { char *buf = mpl->sym_buf; alpar@9: xassert(sym != NULL); alpar@9: if (sym->str == NULL) alpar@9: sprintf(buf, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: { char str[MAX_LENGTH+1]; alpar@9: int quoted, j, len; alpar@9: fetch_string(mpl, sym->str, str); alpar@9: if (!(isalpha((unsigned char)str[0]) || str[0] == '_')) alpar@9: quoted = 1; alpar@9: else alpar@9: { quoted = 0; alpar@9: for (j = 1; str[j] != '\0'; j++) alpar@9: { if (!(isalnum((unsigned char)str[j]) || alpar@9: strchr("+-._", (unsigned char)str[j]) != NULL)) alpar@9: { quoted = 1; alpar@9: break; alpar@9: } alpar@9: } alpar@9: } alpar@9: # define safe_append(c) \ alpar@9: (void)(len < 255 ? (buf[len++] = (char)(c)) : 0) alpar@9: buf[0] = '\0', len = 0; alpar@9: if (quoted) safe_append('\''); alpar@9: for (j = 0; str[j] != '\0'; j++) alpar@9: { if (quoted && str[j] == '\'') safe_append('\''); alpar@9: safe_append(str[j]); alpar@9: } alpar@9: if (quoted) safe_append('\''); alpar@9: # undef safe_append alpar@9: buf[len] = '\0'; alpar@9: if (len == 255) strcpy(buf+252, "..."); alpar@9: } alpar@9: xassert(strlen(buf) <= 255); alpar@9: return buf; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- concat_symbols - concatenate one symbol with another. alpar@9: -- alpar@9: -- This routine concatenates values of two given symbols and assigns alpar@9: -- the resultant character string to a new symbol, which is returned on alpar@9: -- exit. Both original symbols are destroyed. */ alpar@9: alpar@9: SYMBOL *concat_symbols alpar@9: ( MPL *mpl, alpar@9: SYMBOL *sym1, /* destroyed */ alpar@9: SYMBOL *sym2 /* destroyed */ alpar@9: ) alpar@9: { char str1[MAX_LENGTH+1], str2[MAX_LENGTH+1]; alpar@9: xassert(MAX_LENGTH >= DBL_DIG + DBL_DIG); alpar@9: if (sym1->str == NULL) alpar@9: sprintf(str1, "%.*g", DBL_DIG, sym1->num); alpar@9: else alpar@9: fetch_string(mpl, sym1->str, str1); alpar@9: if (sym2->str == NULL) alpar@9: sprintf(str2, "%.*g", DBL_DIG, sym2->num); alpar@9: else alpar@9: fetch_string(mpl, sym2->str, str2); alpar@9: if (strlen(str1) + strlen(str2) > MAX_LENGTH) alpar@9: { char buf[255+1]; alpar@9: strcpy(buf, format_symbol(mpl, sym1)); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: error(mpl, "%s & %s; resultant symbol exceeds %d characters", alpar@9: buf, format_symbol(mpl, sym2), MAX_LENGTH); alpar@9: } alpar@9: delete_symbol(mpl, sym1); alpar@9: delete_symbol(mpl, sym2); alpar@9: return create_symbol_str(mpl, create_string(mpl, strcat(str1, alpar@9: str2))); alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * N-TUPLES * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- create_tuple - create n-tuple. alpar@9: -- alpar@9: -- This routine creates a n-tuple, which initially has no components, alpar@9: -- i.e. which is 0-tuple. */ alpar@9: alpar@9: TUPLE *create_tuple(MPL *mpl) alpar@9: { TUPLE *tuple; alpar@9: xassert(mpl == mpl); alpar@9: tuple = NULL; alpar@9: return tuple; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- expand_tuple - append symbol to n-tuple. alpar@9: -- alpar@9: -- This routine expands n-tuple appending to it a given symbol, which alpar@9: -- becomes its new last component. */ alpar@9: alpar@9: TUPLE *expand_tuple alpar@9: ( MPL *mpl, alpar@9: TUPLE *tuple, /* destroyed */ alpar@9: SYMBOL *sym /* destroyed */ alpar@9: ) alpar@9: { TUPLE *tail, *temp; alpar@9: xassert(sym != NULL); alpar@9: /* create a new component */ alpar@9: tail = dmp_get_atom(mpl->tuples, sizeof(TUPLE)); alpar@9: tail->sym = sym; alpar@9: tail->next = NULL; alpar@9: /* and append it to the component list */ alpar@9: if (tuple == NULL) alpar@9: tuple = tail; alpar@9: else alpar@9: { for (temp = tuple; temp->next != NULL; temp = temp->next); alpar@9: temp->next = tail; alpar@9: } alpar@9: return tuple; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- tuple_dimen - determine dimension of n-tuple. alpar@9: -- alpar@9: -- This routine returns dimension of n-tuple, i.e. number of components alpar@9: -- in the n-tuple. */ alpar@9: alpar@9: int tuple_dimen alpar@9: ( MPL *mpl, alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { TUPLE *temp; alpar@9: int dim = 0; alpar@9: xassert(mpl == mpl); alpar@9: for (temp = tuple; temp != NULL; temp = temp->next) dim++; alpar@9: return dim; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- copy_tuple - make copy of n-tuple. alpar@9: -- alpar@9: -- This routine returns an exact copy of n-tuple. */ alpar@9: alpar@9: TUPLE *copy_tuple alpar@9: ( MPL *mpl, alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { TUPLE *head, *tail; alpar@9: if (tuple == NULL) alpar@9: head = NULL; alpar@9: else alpar@9: { head = tail = dmp_get_atom(mpl->tuples, sizeof(TUPLE)); alpar@9: for (; tuple != NULL; tuple = tuple->next) alpar@9: { xassert(tuple->sym != NULL); alpar@9: tail->sym = copy_symbol(mpl, tuple->sym); alpar@9: if (tuple->next != NULL) alpar@9: tail = (tail->next = dmp_get_atom(mpl->tuples, sizeof(TUPLE))); alpar@9: } alpar@9: tail->next = NULL; alpar@9: } alpar@9: return head; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- compare_tuples - compare one n-tuple with another. alpar@9: -- alpar@9: -- This routine compares two given n-tuples, which must have the same alpar@9: -- dimension (not checked for the sake of efficiency), and returns one alpar@9: -- of the following codes: alpar@9: -- alpar@9: -- = 0 - both n-tuples are identical; alpar@9: -- < 0 - the first n-tuple precedes the second one; alpar@9: -- > 0 - the first n-tuple follows the second one. alpar@9: -- alpar@9: -- Note that the linear order, in which n-tuples follow each other, is alpar@9: -- implementation-dependent. It may be not an alphabetical order. */ alpar@9: alpar@9: int compare_tuples alpar@9: ( MPL *mpl, alpar@9: TUPLE *tuple1, /* not changed */ alpar@9: TUPLE *tuple2 /* not changed */ alpar@9: ) alpar@9: { TUPLE *item1, *item2; alpar@9: int ret; alpar@9: xassert(mpl == mpl); alpar@9: for (item1 = tuple1, item2 = tuple2; item1 != NULL; alpar@9: item1 = item1->next, item2 = item2->next) alpar@9: { xassert(item2 != NULL); alpar@9: xassert(item1->sym != NULL); alpar@9: xassert(item2->sym != NULL); alpar@9: ret = compare_symbols(mpl, item1->sym, item2->sym); alpar@9: if (ret != 0) return ret; alpar@9: } alpar@9: xassert(item2 == NULL); alpar@9: return 0; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- build_subtuple - build subtuple of given n-tuple. alpar@9: -- alpar@9: -- This routine builds subtuple, which consists of first dim components alpar@9: -- of given n-tuple. */ alpar@9: alpar@9: TUPLE *build_subtuple alpar@9: ( MPL *mpl, alpar@9: TUPLE *tuple, /* not changed */ alpar@9: int dim alpar@9: ) alpar@9: { TUPLE *head, *temp; alpar@9: int j; alpar@9: head = create_tuple(mpl); alpar@9: for (j = 1, temp = tuple; j <= dim; j++, temp = temp->next) alpar@9: { xassert(temp != NULL); alpar@9: head = expand_tuple(mpl, head, copy_symbol(mpl, temp->sym)); alpar@9: } alpar@9: return head; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- delete_tuple - delete n-tuple. alpar@9: -- alpar@9: -- This routine deletes specified n-tuple. */ alpar@9: alpar@9: void delete_tuple alpar@9: ( MPL *mpl, alpar@9: TUPLE *tuple /* destroyed */ alpar@9: ) alpar@9: { TUPLE *temp; alpar@9: while (tuple != NULL) alpar@9: { temp = tuple; alpar@9: tuple = temp->next; alpar@9: xassert(temp->sym != NULL); alpar@9: delete_symbol(mpl, temp->sym); alpar@9: dmp_free_atom(mpl->tuples, temp, sizeof(TUPLE)); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- format_tuple - format n-tuple for displaying or printing. alpar@9: -- alpar@9: -- This routine converts specified n-tuple to a character string, which alpar@9: -- is suitable for displaying or printing. alpar@9: -- alpar@9: -- The resultant string is never longer than 255 characters. If it gets alpar@9: -- longer, it is truncated from the right and appended by dots. */ alpar@9: alpar@9: char *format_tuple alpar@9: ( MPL *mpl, alpar@9: int c, alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { TUPLE *temp; alpar@9: int dim, j, len; alpar@9: char *buf = mpl->tup_buf, str[255+1], *save; alpar@9: # define safe_append(c) \ alpar@9: (void)(len < 255 ? (buf[len++] = (char)(c)) : 0) alpar@9: buf[0] = '\0', len = 0; alpar@9: dim = tuple_dimen(mpl, tuple); alpar@9: if (c == '[' && dim > 0) safe_append('['); alpar@9: if (c == '(' && dim > 1) safe_append('('); alpar@9: for (temp = tuple; temp != NULL; temp = temp->next) alpar@9: { if (temp != tuple) safe_append(','); alpar@9: xassert(temp->sym != NULL); alpar@9: save = mpl->sym_buf; alpar@9: mpl->sym_buf = str; alpar@9: format_symbol(mpl, temp->sym); alpar@9: mpl->sym_buf = save; alpar@9: xassert(strlen(str) < sizeof(str)); alpar@9: for (j = 0; str[j] != '\0'; j++) safe_append(str[j]); alpar@9: } alpar@9: if (c == '[' && dim > 0) safe_append(']'); alpar@9: if (c == '(' && dim > 1) safe_append(')'); alpar@9: # undef safe_append alpar@9: buf[len] = '\0'; alpar@9: if (len == 255) strcpy(buf+252, "..."); alpar@9: xassert(strlen(buf) <= 255); alpar@9: return buf; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * ELEMENTAL SETS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- create_elemset - create elemental set. alpar@9: -- alpar@9: -- This routine creates an elemental set, whose members are n-tuples of alpar@9: -- specified dimension. Being created the set is initially empty. */ alpar@9: alpar@9: ELEMSET *create_elemset(MPL *mpl, int dim) alpar@9: { ELEMSET *set; alpar@9: xassert(dim > 0); alpar@9: set = create_array(mpl, A_NONE, dim); alpar@9: return set; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- find_tuple - check if elemental set contains given n-tuple. alpar@9: -- alpar@9: -- This routine finds given n-tuple in specified elemental set in order alpar@9: -- to check if the set contains that n-tuple. If the n-tuple is found, alpar@9: -- the routine returns pointer to corresponding array member. Otherwise alpar@9: -- null pointer is returned. */ alpar@9: alpar@9: MEMBER *find_tuple alpar@9: ( MPL *mpl, alpar@9: ELEMSET *set, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { xassert(set != NULL); alpar@9: xassert(set->type == A_NONE); alpar@9: xassert(set->dim == tuple_dimen(mpl, tuple)); alpar@9: return find_member(mpl, set, tuple); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- add_tuple - add new n-tuple to elemental set. alpar@9: -- alpar@9: -- This routine adds given n-tuple to specified elemental set. alpar@9: -- alpar@9: -- For the sake of efficiency this routine doesn't check whether the alpar@9: -- set already contains the same n-tuple or not. Therefore the calling alpar@9: -- program should use the routine find_tuple (if necessary) in order to alpar@9: -- make sure that the given n-tuple is not contained in the set, since alpar@9: -- duplicate n-tuples within the same set are not allowed. */ alpar@9: alpar@9: MEMBER *add_tuple alpar@9: ( MPL *mpl, alpar@9: ELEMSET *set, /* modified */ alpar@9: TUPLE *tuple /* destroyed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: xassert(set != NULL); alpar@9: xassert(set->type == A_NONE); alpar@9: xassert(set->dim == tuple_dimen(mpl, tuple)); alpar@9: memb = add_member(mpl, set, tuple); alpar@9: memb->value.none = NULL; alpar@9: return memb; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- check_then_add - check and add new n-tuple to elemental set. alpar@9: -- alpar@9: -- This routine is equivalent to the routine add_tuple except that it alpar@9: -- does check for duplicate n-tuples. */ alpar@9: alpar@9: MEMBER *check_then_add alpar@9: ( MPL *mpl, alpar@9: ELEMSET *set, /* modified */ alpar@9: TUPLE *tuple /* destroyed */ alpar@9: ) alpar@9: { if (find_tuple(mpl, set, tuple) != NULL) alpar@9: error(mpl, "duplicate tuple %s detected", format_tuple(mpl, alpar@9: '(', tuple)); alpar@9: return add_tuple(mpl, set, tuple); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- copy_elemset - make copy of elemental set. alpar@9: -- alpar@9: -- This routine makes an exact copy of elemental set. */ alpar@9: alpar@9: ELEMSET *copy_elemset alpar@9: ( MPL *mpl, alpar@9: ELEMSET *set /* not changed */ alpar@9: ) alpar@9: { ELEMSET *copy; alpar@9: MEMBER *memb; alpar@9: xassert(set != NULL); alpar@9: xassert(set->type == A_NONE); alpar@9: xassert(set->dim > 0); alpar@9: copy = create_elemset(mpl, set->dim); alpar@9: for (memb = set->head; memb != NULL; memb = memb->next) alpar@9: add_tuple(mpl, copy, copy_tuple(mpl, memb->tuple)); alpar@9: return copy; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- delete_elemset - delete elemental set. alpar@9: -- alpar@9: -- This routine deletes specified elemental set. */ alpar@9: alpar@9: void delete_elemset alpar@9: ( MPL *mpl, alpar@9: ELEMSET *set /* destroyed */ alpar@9: ) alpar@9: { xassert(set != NULL); alpar@9: xassert(set->type == A_NONE); alpar@9: delete_array(mpl, set); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- arelset_size - compute size of "arithmetic" elemental set. alpar@9: -- alpar@9: -- This routine computes the size of "arithmetic" elemental set, which alpar@9: -- is specified in the form of arithmetic progression: alpar@9: -- alpar@9: -- { t0 .. tf by dt }. alpar@9: -- alpar@9: -- The size is computed using the formula: alpar@9: -- alpar@9: -- n = max(0, floor((tf - t0) / dt) + 1). */ alpar@9: alpar@9: int arelset_size(MPL *mpl, double t0, double tf, double dt) alpar@9: { double temp; alpar@9: if (dt == 0.0) alpar@9: error(mpl, "%.*g .. %.*g by %.*g; zero stride not allowed", alpar@9: DBL_DIG, t0, DBL_DIG, tf, DBL_DIG, dt); alpar@9: if (tf > 0.0 && t0 < 0.0 && tf > + 0.999 * DBL_MAX + t0) alpar@9: temp = +DBL_MAX; alpar@9: else if (tf < 0.0 && t0 > 0.0 && tf < - 0.999 * DBL_MAX + t0) alpar@9: temp = -DBL_MAX; alpar@9: else alpar@9: temp = tf - t0; alpar@9: if (fabs(dt) < 1.0 && fabs(temp) > (0.999 * DBL_MAX) * fabs(dt)) alpar@9: { if (temp > 0.0 && dt > 0.0 || temp < 0.0 && dt < 0.0) alpar@9: temp = +DBL_MAX; alpar@9: else alpar@9: temp = 0.0; alpar@9: } alpar@9: else alpar@9: { temp = floor(temp / dt) + 1.0; alpar@9: if (temp < 0.0) temp = 0.0; alpar@9: } alpar@9: xassert(temp >= 0.0); alpar@9: if (temp > (double)(INT_MAX - 1)) alpar@9: error(mpl, "%.*g .. %.*g by %.*g; set too large", alpar@9: DBL_DIG, t0, DBL_DIG, tf, DBL_DIG, dt); alpar@9: return (int)(temp + 0.5); alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- arelset_member - compute member of "arithmetic" elemental set. alpar@9: -- alpar@9: -- This routine returns a numeric value of symbol, which is equivalent alpar@9: -- to j-th member of given "arithmetic" elemental set specified in the alpar@9: -- form of arithmetic progression: alpar@9: -- alpar@9: -- { t0 .. tf by dt }. alpar@9: -- alpar@9: -- The symbol value is computed with the formula: alpar@9: -- alpar@9: -- j-th member = t0 + (j - 1) * dt, alpar@9: -- alpar@9: -- The number j must satisfy to the restriction 1 <= j <= n, where n is alpar@9: -- the set size computed by the routine arelset_size. */ alpar@9: alpar@9: double arelset_member(MPL *mpl, double t0, double tf, double dt, int j) alpar@9: { xassert(1 <= j && j <= arelset_size(mpl, t0, tf, dt)); alpar@9: return t0 + (double)(j - 1) * dt; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- create_arelset - create "arithmetic" elemental set. alpar@9: -- alpar@9: -- This routine creates "arithmetic" elemental set, which is specified alpar@9: -- in the form of arithmetic progression: alpar@9: -- alpar@9: -- { t0 .. tf by dt }. alpar@9: -- alpar@9: -- Components of this set are 1-tuples. */ alpar@9: alpar@9: ELEMSET *create_arelset(MPL *mpl, double t0, double tf, double dt) alpar@9: { ELEMSET *set; alpar@9: int j, n; alpar@9: set = create_elemset(mpl, 1); alpar@9: n = arelset_size(mpl, t0, tf, dt); alpar@9: for (j = 1; j <= n; j++) alpar@9: { add_tuple alpar@9: ( mpl, alpar@9: set, alpar@9: expand_tuple alpar@9: ( mpl, alpar@9: create_tuple(mpl), alpar@9: create_symbol_num alpar@9: ( mpl, alpar@9: arelset_member(mpl, t0, tf, dt, j) alpar@9: ) alpar@9: ) alpar@9: ); alpar@9: } alpar@9: return set; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- set_union - union of two elemental sets. alpar@9: -- alpar@9: -- This routine computes the union: alpar@9: -- alpar@9: -- X U Y = { j | (j in X) or (j in Y) }, alpar@9: -- alpar@9: -- where X and Y are given elemental sets (destroyed on exit). */ alpar@9: alpar@9: ELEMSET *set_union alpar@9: ( MPL *mpl, alpar@9: ELEMSET *X, /* destroyed */ alpar@9: ELEMSET *Y /* destroyed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: xassert(X != NULL); alpar@9: xassert(X->type == A_NONE); alpar@9: xassert(X->dim > 0); alpar@9: xassert(Y != NULL); alpar@9: xassert(Y->type == A_NONE); alpar@9: xassert(Y->dim > 0); alpar@9: xassert(X->dim == Y->dim); alpar@9: for (memb = Y->head; memb != NULL; memb = memb->next) alpar@9: { if (find_tuple(mpl, X, memb->tuple) == NULL) alpar@9: add_tuple(mpl, X, copy_tuple(mpl, memb->tuple)); alpar@9: } alpar@9: delete_elemset(mpl, Y); alpar@9: return X; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- set_diff - difference between two elemental sets. alpar@9: -- alpar@9: -- This routine computes the difference: alpar@9: -- alpar@9: -- X \ Y = { j | (j in X) and (j not in Y) }, alpar@9: -- alpar@9: -- where X and Y are given elemental sets (destroyed on exit). */ alpar@9: alpar@9: ELEMSET *set_diff alpar@9: ( MPL *mpl, alpar@9: ELEMSET *X, /* destroyed */ alpar@9: ELEMSET *Y /* destroyed */ alpar@9: ) alpar@9: { ELEMSET *Z; alpar@9: MEMBER *memb; alpar@9: xassert(X != NULL); alpar@9: xassert(X->type == A_NONE); alpar@9: xassert(X->dim > 0); alpar@9: xassert(Y != NULL); alpar@9: xassert(Y->type == A_NONE); alpar@9: xassert(Y->dim > 0); alpar@9: xassert(X->dim == Y->dim); alpar@9: Z = create_elemset(mpl, X->dim); alpar@9: for (memb = X->head; memb != NULL; memb = memb->next) alpar@9: { if (find_tuple(mpl, Y, memb->tuple) == NULL) alpar@9: add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple)); alpar@9: } alpar@9: delete_elemset(mpl, X); alpar@9: delete_elemset(mpl, Y); alpar@9: return Z; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- set_symdiff - symmetric difference between two elemental sets. alpar@9: -- alpar@9: -- This routine computes the symmetric difference: alpar@9: -- alpar@9: -- X (+) Y = (X \ Y) U (Y \ X), alpar@9: -- alpar@9: -- where X and Y are given elemental sets (destroyed on exit). */ alpar@9: alpar@9: ELEMSET *set_symdiff alpar@9: ( MPL *mpl, alpar@9: ELEMSET *X, /* destroyed */ alpar@9: ELEMSET *Y /* destroyed */ alpar@9: ) alpar@9: { ELEMSET *Z; alpar@9: MEMBER *memb; alpar@9: xassert(X != NULL); alpar@9: xassert(X->type == A_NONE); alpar@9: xassert(X->dim > 0); alpar@9: xassert(Y != NULL); alpar@9: xassert(Y->type == A_NONE); alpar@9: xassert(Y->dim > 0); alpar@9: xassert(X->dim == Y->dim); alpar@9: /* Z := X \ Y */ alpar@9: Z = create_elemset(mpl, X->dim); alpar@9: for (memb = X->head; memb != NULL; memb = memb->next) alpar@9: { if (find_tuple(mpl, Y, memb->tuple) == NULL) alpar@9: add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple)); alpar@9: } alpar@9: /* Z := Z U (Y \ X) */ alpar@9: for (memb = Y->head; memb != NULL; memb = memb->next) alpar@9: { if (find_tuple(mpl, X, memb->tuple) == NULL) alpar@9: add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple)); alpar@9: } alpar@9: delete_elemset(mpl, X); alpar@9: delete_elemset(mpl, Y); alpar@9: return Z; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- set_inter - intersection of two elemental sets. alpar@9: -- alpar@9: -- This routine computes the intersection: alpar@9: -- alpar@9: -- X ^ Y = { j | (j in X) and (j in Y) }, alpar@9: -- alpar@9: -- where X and Y are given elemental sets (destroyed on exit). */ alpar@9: alpar@9: ELEMSET *set_inter alpar@9: ( MPL *mpl, alpar@9: ELEMSET *X, /* destroyed */ alpar@9: ELEMSET *Y /* destroyed */ alpar@9: ) alpar@9: { ELEMSET *Z; alpar@9: MEMBER *memb; alpar@9: xassert(X != NULL); alpar@9: xassert(X->type == A_NONE); alpar@9: xassert(X->dim > 0); alpar@9: xassert(Y != NULL); alpar@9: xassert(Y->type == A_NONE); alpar@9: xassert(Y->dim > 0); alpar@9: xassert(X->dim == Y->dim); alpar@9: Z = create_elemset(mpl, X->dim); alpar@9: for (memb = X->head; memb != NULL; memb = memb->next) alpar@9: { if (find_tuple(mpl, Y, memb->tuple) != NULL) alpar@9: add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple)); alpar@9: } alpar@9: delete_elemset(mpl, X); alpar@9: delete_elemset(mpl, Y); alpar@9: return Z; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- set_cross - cross (Cartesian) product of two elemental sets. alpar@9: -- alpar@9: -- This routine computes the cross (Cartesian) product: alpar@9: -- alpar@9: -- X x Y = { (i,j) | (i in X) and (j in Y) }, alpar@9: -- alpar@9: -- where X and Y are given elemental sets (destroyed on exit). */ alpar@9: alpar@9: ELEMSET *set_cross alpar@9: ( MPL *mpl, alpar@9: ELEMSET *X, /* destroyed */ alpar@9: ELEMSET *Y /* destroyed */ alpar@9: ) alpar@9: { ELEMSET *Z; alpar@9: MEMBER *memx, *memy; alpar@9: TUPLE *tuple, *temp; alpar@9: xassert(X != NULL); alpar@9: xassert(X->type == A_NONE); alpar@9: xassert(X->dim > 0); alpar@9: xassert(Y != NULL); alpar@9: xassert(Y->type == A_NONE); alpar@9: xassert(Y->dim > 0); alpar@9: Z = create_elemset(mpl, X->dim + Y->dim); alpar@9: for (memx = X->head; memx != NULL; memx = memx->next) alpar@9: { for (memy = Y->head; memy != NULL; memy = memy->next) alpar@9: { tuple = copy_tuple(mpl, memx->tuple); alpar@9: for (temp = memy->tuple; temp != NULL; temp = temp->next) alpar@9: tuple = expand_tuple(mpl, tuple, copy_symbol(mpl, alpar@9: temp->sym)); alpar@9: add_tuple(mpl, Z, tuple); alpar@9: } alpar@9: } alpar@9: delete_elemset(mpl, X); alpar@9: delete_elemset(mpl, Y); alpar@9: return Z; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * ELEMENTAL VARIABLES * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /* (there are no specific routines for elemental variables) */ alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * LINEAR FORMS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- constant_term - create constant term. alpar@9: -- alpar@9: -- This routine creates the linear form, which is a constant term. */ alpar@9: alpar@9: FORMULA *constant_term(MPL *mpl, double coef) alpar@9: { FORMULA *form; alpar@9: if (coef == 0.0) alpar@9: form = NULL; alpar@9: else alpar@9: { form = dmp_get_atom(mpl->formulae, sizeof(FORMULA)); alpar@9: form->coef = coef; alpar@9: form->var = NULL; alpar@9: form->next = NULL; alpar@9: } alpar@9: return form; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- single_variable - create single variable. alpar@9: -- alpar@9: -- This routine creates the linear form, which is a single elemental alpar@9: -- variable. */ alpar@9: alpar@9: FORMULA *single_variable alpar@9: ( MPL *mpl, alpar@9: ELEMVAR *var /* referenced */ alpar@9: ) alpar@9: { FORMULA *form; alpar@9: xassert(var != NULL); alpar@9: form = dmp_get_atom(mpl->formulae, sizeof(FORMULA)); alpar@9: form->coef = 1.0; alpar@9: form->var = var; alpar@9: form->next = NULL; alpar@9: return form; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- copy_formula - make copy of linear form. alpar@9: -- alpar@9: -- This routine returns an exact copy of linear form. */ alpar@9: alpar@9: FORMULA *copy_formula alpar@9: ( MPL *mpl, alpar@9: FORMULA *form /* not changed */ alpar@9: ) alpar@9: { FORMULA *head, *tail; alpar@9: if (form == NULL) alpar@9: head = NULL; alpar@9: else alpar@9: { head = tail = dmp_get_atom(mpl->formulae, sizeof(FORMULA)); alpar@9: for (; form != NULL; form = form->next) alpar@9: { tail->coef = form->coef; alpar@9: tail->var = form->var; alpar@9: if (form->next != NULL) alpar@9: tail = (tail->next = dmp_get_atom(mpl->formulae, sizeof(FORMULA))); alpar@9: } alpar@9: tail->next = NULL; alpar@9: } alpar@9: return head; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- delete_formula - delete linear form. alpar@9: -- alpar@9: -- This routine deletes specified linear form. */ alpar@9: alpar@9: void delete_formula alpar@9: ( MPL *mpl, alpar@9: FORMULA *form /* destroyed */ alpar@9: ) alpar@9: { FORMULA *temp; alpar@9: while (form != NULL) alpar@9: { temp = form; alpar@9: form = form->next; alpar@9: dmp_free_atom(mpl->formulae, temp, sizeof(FORMULA)); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- linear_comb - linear combination of two linear forms. alpar@9: -- alpar@9: -- This routine computes the linear combination: alpar@9: -- alpar@9: -- a * fx + b * fy, alpar@9: -- alpar@9: -- where a and b are numeric coefficients, fx and fy are linear forms alpar@9: -- (destroyed on exit). */ alpar@9: alpar@9: FORMULA *linear_comb alpar@9: ( MPL *mpl, alpar@9: double a, FORMULA *fx, /* destroyed */ alpar@9: double b, FORMULA *fy /* destroyed */ alpar@9: ) alpar@9: { FORMULA *form = NULL, *term, *temp; alpar@9: double c0 = 0.0; alpar@9: for (term = fx; term != NULL; term = term->next) alpar@9: { if (term->var == NULL) alpar@9: c0 = fp_add(mpl, c0, fp_mul(mpl, a, term->coef)); alpar@9: else alpar@9: term->var->temp = alpar@9: fp_add(mpl, term->var->temp, fp_mul(mpl, a, term->coef)); alpar@9: } alpar@9: for (term = fy; term != NULL; term = term->next) alpar@9: { if (term->var == NULL) alpar@9: c0 = fp_add(mpl, c0, fp_mul(mpl, b, term->coef)); alpar@9: else alpar@9: term->var->temp = alpar@9: fp_add(mpl, term->var->temp, fp_mul(mpl, b, term->coef)); alpar@9: } alpar@9: for (term = fx; term != NULL; term = term->next) alpar@9: { if (term->var != NULL && term->var->temp != 0.0) alpar@9: { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA)); alpar@9: temp->coef = term->var->temp, temp->var = term->var; alpar@9: temp->next = form, form = temp; alpar@9: term->var->temp = 0.0; alpar@9: } alpar@9: } alpar@9: for (term = fy; term != NULL; term = term->next) alpar@9: { if (term->var != NULL && term->var->temp != 0.0) alpar@9: { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA)); alpar@9: temp->coef = term->var->temp, temp->var = term->var; alpar@9: temp->next = form, form = temp; alpar@9: term->var->temp = 0.0; alpar@9: } alpar@9: } alpar@9: if (c0 != 0.0) alpar@9: { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA)); alpar@9: temp->coef = c0, temp->var = NULL; alpar@9: temp->next = form, form = temp; alpar@9: } alpar@9: delete_formula(mpl, fx); alpar@9: delete_formula(mpl, fy); alpar@9: return form; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- remove_constant - remove constant term from linear form. alpar@9: -- alpar@9: -- This routine removes constant term from linear form and stores its alpar@9: -- value to given location. */ alpar@9: alpar@9: FORMULA *remove_constant alpar@9: ( MPL *mpl, alpar@9: FORMULA *form, /* destroyed */ alpar@9: double *coef /* modified */ alpar@9: ) alpar@9: { FORMULA *head = NULL, *temp; alpar@9: *coef = 0.0; alpar@9: while (form != NULL) alpar@9: { temp = form; alpar@9: form = form->next; alpar@9: if (temp->var == NULL) alpar@9: { /* constant term */ alpar@9: *coef = fp_add(mpl, *coef, temp->coef); alpar@9: dmp_free_atom(mpl->formulae, temp, sizeof(FORMULA)); alpar@9: } alpar@9: else alpar@9: { /* linear term */ alpar@9: temp->next = head; alpar@9: head = temp; alpar@9: } alpar@9: } alpar@9: return head; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- reduce_terms - reduce identical terms in linear form. alpar@9: -- alpar@9: -- This routine reduces identical terms in specified linear form. */ alpar@9: alpar@9: FORMULA *reduce_terms alpar@9: ( MPL *mpl, alpar@9: FORMULA *form /* destroyed */ alpar@9: ) alpar@9: { FORMULA *term, *next_term; alpar@9: double c0 = 0.0; alpar@9: for (term = form; term != NULL; term = term->next) alpar@9: { if (term->var == NULL) alpar@9: c0 = fp_add(mpl, c0, term->coef); alpar@9: else alpar@9: term->var->temp = fp_add(mpl, term->var->temp, term->coef); alpar@9: } alpar@9: next_term = form, form = NULL; alpar@9: for (term = next_term; term != NULL; term = next_term) alpar@9: { next_term = term->next; alpar@9: if (term->var == NULL && c0 != 0.0) alpar@9: { term->coef = c0, c0 = 0.0; alpar@9: term->next = form, form = term; alpar@9: } alpar@9: else if (term->var != NULL && term->var->temp != 0.0) alpar@9: { term->coef = term->var->temp, term->var->temp = 0.0; alpar@9: term->next = form, form = term; alpar@9: } alpar@9: else alpar@9: dmp_free_atom(mpl->formulae, term, sizeof(FORMULA)); alpar@9: } alpar@9: return form; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * ELEMENTAL CONSTRAINTS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /* (there are no specific routines for elemental constraints) */ alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * GENERIC VALUES * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- delete_value - delete generic value. alpar@9: -- alpar@9: -- This routine deletes specified generic value. alpar@9: -- alpar@9: -- NOTE: The generic value to be deleted must be valid. */ alpar@9: alpar@9: void delete_value alpar@9: ( MPL *mpl, alpar@9: int type, alpar@9: VALUE *value /* content destroyed */ alpar@9: ) alpar@9: { xassert(value != NULL); alpar@9: switch (type) alpar@9: { case A_NONE: alpar@9: value->none = NULL; alpar@9: break; alpar@9: case A_NUMERIC: alpar@9: value->num = 0.0; alpar@9: break; alpar@9: case A_SYMBOLIC: alpar@9: delete_symbol(mpl, value->sym), value->sym = NULL; alpar@9: break; alpar@9: case A_LOGICAL: alpar@9: value->bit = 0; alpar@9: break; alpar@9: case A_TUPLE: alpar@9: delete_tuple(mpl, value->tuple), value->tuple = NULL; alpar@9: break; alpar@9: case A_ELEMSET: alpar@9: delete_elemset(mpl, value->set), value->set = NULL; alpar@9: break; alpar@9: case A_ELEMVAR: alpar@9: value->var = NULL; alpar@9: break; alpar@9: case A_FORMULA: alpar@9: delete_formula(mpl, value->form), value->form = NULL; alpar@9: break; alpar@9: case A_ELEMCON: alpar@9: value->con = NULL; alpar@9: break; alpar@9: default: alpar@9: xassert(type != type); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * SYMBOLICALLY INDEXED ARRAYS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- create_array - create array. alpar@9: -- alpar@9: -- This routine creates an array of specified type and dimension. Being alpar@9: -- created the array is initially empty. alpar@9: -- alpar@9: -- The type indicator determines generic values, which can be assigned alpar@9: -- to the array members: alpar@9: -- alpar@9: -- A_NONE - none (members have no assigned values) alpar@9: -- A_NUMERIC - floating-point numbers alpar@9: -- A_SYMBOLIC - symbols alpar@9: -- A_ELEMSET - elemental sets alpar@9: -- A_ELEMVAR - elemental variables alpar@9: -- A_ELEMCON - elemental constraints alpar@9: -- alpar@9: -- The dimension may be 0, in which case the array consists of the only alpar@9: -- member (such arrays represent 0-dimensional objects). */ alpar@9: alpar@9: ARRAY *create_array(MPL *mpl, int type, int dim) alpar@9: { ARRAY *array; alpar@9: xassert(type == A_NONE || type == A_NUMERIC || alpar@9: type == A_SYMBOLIC || type == A_ELEMSET || alpar@9: type == A_ELEMVAR || type == A_ELEMCON); alpar@9: xassert(dim >= 0); alpar@9: array = dmp_get_atom(mpl->arrays, sizeof(ARRAY)); alpar@9: array->type = type; alpar@9: array->dim = dim; alpar@9: array->size = 0; alpar@9: array->head = NULL; alpar@9: array->tail = NULL; alpar@9: array->tree = NULL; alpar@9: array->prev = NULL; alpar@9: array->next = mpl->a_list; alpar@9: /* include the array in the global array list */ alpar@9: if (array->next != NULL) array->next->prev = array; alpar@9: mpl->a_list = array; alpar@9: return array; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- find_member - find array member with given n-tuple. alpar@9: -- alpar@9: -- This routine finds an array member, which has given n-tuple. If the alpar@9: -- array is short, the linear search is used. Otherwise the routine alpar@9: -- autimatically creates the search tree (i.e. the array index) to find alpar@9: -- members for logarithmic time. */ alpar@9: alpar@9: static int compare_member_tuples(void *info, const void *key1, alpar@9: const void *key2) alpar@9: { /* this is an auxiliary routine used to compare keys, which are alpar@9: n-tuples assigned to array members */ alpar@9: return compare_tuples((MPL *)info, (TUPLE *)key1, (TUPLE *)key2); alpar@9: } alpar@9: alpar@9: MEMBER *find_member alpar@9: ( MPL *mpl, alpar@9: ARRAY *array, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: xassert(array != NULL); alpar@9: /* the n-tuple must have the same dimension as the array */ alpar@9: xassert(tuple_dimen(mpl, tuple) == array->dim); alpar@9: /* if the array is large enough, create the search tree and index alpar@9: all existing members of the array */ alpar@9: if (array->size > 30 && array->tree == NULL) alpar@9: { array->tree = avl_create_tree(compare_member_tuples, mpl); alpar@9: for (memb = array->head; memb != NULL; memb = memb->next) alpar@9: avl_set_node_link(avl_insert_node(array->tree, memb->tuple), alpar@9: (void *)memb); alpar@9: } alpar@9: /* find a member, which has the given tuple */ alpar@9: if (array->tree == NULL) alpar@9: { /* the search tree doesn't exist; use the linear search */ alpar@9: for (memb = array->head; memb != NULL; memb = memb->next) alpar@9: if (compare_tuples(mpl, memb->tuple, tuple) == 0) break; alpar@9: } alpar@9: else alpar@9: { /* the search tree exists; use the binary search */ alpar@9: AVLNODE *node; alpar@9: node = avl_find_node(array->tree, tuple); alpar@9: memb = (MEMBER *)(node == NULL ? NULL : avl_get_node_link(node)); alpar@9: } alpar@9: return memb; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- add_member - add new member to array. alpar@9: -- alpar@9: -- This routine creates a new member with given n-tuple and adds it to alpar@9: -- specified array. alpar@9: -- alpar@9: -- For the sake of efficiency this routine doesn't check whether the alpar@9: -- array already contains a member with the given n-tuple or not. Thus, alpar@9: -- if necessary, the calling program should use the routine find_member alpar@9: -- in order to be sure that the array contains no member with the same alpar@9: -- n-tuple, because members with duplicate n-tuples are not allowed. alpar@9: -- alpar@9: -- This routine assigns no generic value to the new member, because the alpar@9: -- calling program must do that. */ alpar@9: alpar@9: MEMBER *add_member alpar@9: ( MPL *mpl, alpar@9: ARRAY *array, /* modified */ alpar@9: TUPLE *tuple /* destroyed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: xassert(array != NULL); alpar@9: /* the n-tuple must have the same dimension as the array */ alpar@9: xassert(tuple_dimen(mpl, tuple) == array->dim); alpar@9: /* create new member */ alpar@9: memb = dmp_get_atom(mpl->members, sizeof(MEMBER)); alpar@9: memb->tuple = tuple; alpar@9: memb->next = NULL; alpar@9: memset(&memb->value, '?', sizeof(VALUE)); alpar@9: /* and append it to the member list */ alpar@9: array->size++; alpar@9: if (array->head == NULL) alpar@9: array->head = memb; alpar@9: else alpar@9: array->tail->next = memb; alpar@9: array->tail = memb; alpar@9: /* if the search tree exists, index the new member */ alpar@9: if (array->tree != NULL) alpar@9: avl_set_node_link(avl_insert_node(array->tree, memb->tuple), alpar@9: (void *)memb); alpar@9: return memb; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- delete_array - delete array. alpar@9: -- alpar@9: -- This routine deletes specified array. alpar@9: -- alpar@9: -- Generic values assigned to the array members are not deleted by this alpar@9: -- routine. The calling program itself must delete all assigned generic alpar@9: -- values before deleting the array. */ alpar@9: alpar@9: void delete_array alpar@9: ( MPL *mpl, alpar@9: ARRAY *array /* destroyed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: xassert(array != NULL); alpar@9: /* delete all existing array members */ alpar@9: while (array->head != NULL) alpar@9: { memb = array->head; alpar@9: array->head = memb->next; alpar@9: delete_tuple(mpl, memb->tuple); alpar@9: dmp_free_atom(mpl->members, memb, sizeof(MEMBER)); alpar@9: } alpar@9: /* if the search tree exists, also delete it */ alpar@9: if (array->tree != NULL) avl_delete_tree(array->tree); alpar@9: /* remove the array from the global array list */ alpar@9: if (array->prev == NULL) alpar@9: mpl->a_list = array->next; alpar@9: else alpar@9: array->prev->next = array->next; alpar@9: if (array->next == NULL) alpar@9: ; alpar@9: else alpar@9: array->next->prev = array->prev; alpar@9: /* delete the array descriptor */ alpar@9: dmp_free_atom(mpl->arrays, array, sizeof(ARRAY)); alpar@9: return; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * DOMAINS AND DUMMY INDICES * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- assign_dummy_index - assign new value to dummy index. alpar@9: -- alpar@9: -- This routine assigns new value to specified dummy index and, that is alpar@9: -- important, invalidates all temporary resultant values, which depends alpar@9: -- on that dummy index. */ alpar@9: alpar@9: void assign_dummy_index alpar@9: ( MPL *mpl, alpar@9: DOMAIN_SLOT *slot, /* modified */ alpar@9: SYMBOL *value /* not changed */ alpar@9: ) alpar@9: { CODE *leaf, *code; alpar@9: xassert(slot != NULL); alpar@9: xassert(value != NULL); alpar@9: /* delete the current value assigned to the dummy index */ alpar@9: if (slot->value != NULL) alpar@9: { /* if the current value and the new one are identical, actual alpar@9: assignment is not needed */ alpar@9: if (compare_symbols(mpl, slot->value, value) == 0) goto done; alpar@9: /* delete a symbol, which is the current value */ alpar@9: delete_symbol(mpl, slot->value), slot->value = NULL; alpar@9: } alpar@9: /* now walk through all the pseudo-codes with op = O_INDEX, which alpar@9: refer to the dummy index to be changed (these pseudo-codes are alpar@9: leaves in the forest of *all* expressions in the database) */ alpar@9: for (leaf = slot->list; leaf != NULL; leaf = leaf->arg.index. alpar@9: next) alpar@9: { xassert(leaf->op == O_INDEX); alpar@9: /* invalidate all resultant values, which depend on the dummy alpar@9: index, walking from the current leaf toward the root of the alpar@9: corresponding expression tree */ alpar@9: for (code = leaf; code != NULL; code = code->up) alpar@9: { if (code->valid) alpar@9: { /* invalidate and delete resultant value */ alpar@9: code->valid = 0; alpar@9: delete_value(mpl, code->type, &code->value); alpar@9: } alpar@9: } alpar@9: } alpar@9: /* assign new value to the dummy index */ alpar@9: slot->value = copy_symbol(mpl, value); alpar@9: done: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- update_dummy_indices - update current values of dummy indices. alpar@9: -- alpar@9: -- This routine assigns components of "backup" n-tuple to dummy indices alpar@9: -- of specified domain block. If no "backup" n-tuple is defined for the alpar@9: -- domain block, values of the dummy indices remain untouched. */ alpar@9: alpar@9: void update_dummy_indices alpar@9: ( MPL *mpl, alpar@9: DOMAIN_BLOCK *block /* not changed */ alpar@9: ) alpar@9: { DOMAIN_SLOT *slot; alpar@9: TUPLE *temp; alpar@9: if (block->backup != NULL) alpar@9: { for (slot = block->list, temp = block->backup; slot != NULL; alpar@9: slot = slot->next, temp = temp->next) alpar@9: { xassert(temp != NULL); alpar@9: xassert(temp->sym != NULL); alpar@9: assign_dummy_index(mpl, slot, temp->sym); alpar@9: } alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- enter_domain_block - enter domain block. alpar@9: -- alpar@9: -- Let specified domain block have the form: alpar@9: -- alpar@9: -- { ..., (j1, j2, ..., jn) in J, ... } alpar@9: -- alpar@9: -- where j1, j2, ..., jn are dummy indices, J is a basic set. alpar@9: -- alpar@9: -- This routine does the following: alpar@9: -- alpar@9: -- 1. Checks if the given n-tuple is a member of the basic set J. Note alpar@9: -- that J being *out of the scope* of the domain block cannot depend alpar@9: -- on the dummy indices in the same and inner domain blocks, so it alpar@9: -- can be computed before the dummy indices are assigned new values. alpar@9: -- If this check fails, the routine returns with non-zero code. alpar@9: -- alpar@9: -- 2. Saves current values of the dummy indices j1, j2, ..., jn. alpar@9: -- alpar@9: -- 3. Assigns new values, which are components of the given n-tuple, to alpar@9: -- the dummy indices j1, j2, ..., jn. If dimension of the n-tuple is alpar@9: -- larger than n, its extra components n+1, n+2, ... are not used. alpar@9: -- alpar@9: -- 4. Calls the formal routine func which either enters the next domain alpar@9: -- block or evaluates some code within the domain scope. alpar@9: -- alpar@9: -- 5. Restores former values of the dummy indices j1, j2, ..., jn. alpar@9: -- alpar@9: -- Since current values assigned to the dummy indices on entry to this alpar@9: -- routine are restored on exit, the formal routine func is allowed to alpar@9: -- call this routine recursively. */ alpar@9: alpar@9: int enter_domain_block alpar@9: ( MPL *mpl, alpar@9: DOMAIN_BLOCK *block, /* not changed */ alpar@9: TUPLE *tuple, /* not changed */ alpar@9: void *info, void (*func)(MPL *mpl, void *info) alpar@9: ) alpar@9: { TUPLE *backup; alpar@9: int ret = 0; alpar@9: /* check if the given n-tuple is a member of the basic set */ alpar@9: xassert(block->code != NULL); alpar@9: if (!is_member(mpl, block->code, tuple)) alpar@9: { ret = 1; alpar@9: goto done; alpar@9: } alpar@9: /* save reference to "backup" n-tuple, which was used to assign alpar@9: current values of the dummy indices (it is sufficient to save alpar@9: reference, not value, because that n-tuple is defined in some alpar@9: outer level of recursion and therefore cannot be changed on alpar@9: this and deeper recursive calls) */ alpar@9: backup = block->backup; alpar@9: /* set up new "backup" n-tuple, which defines new values of the alpar@9: dummy indices */ alpar@9: block->backup = tuple; alpar@9: /* assign new values to the dummy indices */ alpar@9: update_dummy_indices(mpl, block); alpar@9: /* call the formal routine that does the rest part of the job */ alpar@9: func(mpl, info); alpar@9: /* restore reference to the former "backup" n-tuple */ alpar@9: block->backup = backup; alpar@9: /* restore former values of the dummy indices; note that if the alpar@9: domain block just escaped has no other active instances which alpar@9: may exist due to recursion (it is indicated by a null pointer alpar@9: to the former n-tuple), former values of the dummy indices are alpar@9: undefined; therefore in this case the routine keeps currently alpar@9: assigned values of the dummy indices that involves keeping all alpar@9: dependent temporary results and thereby, if this domain block alpar@9: is not used recursively, allows improving efficiency */ alpar@9: update_dummy_indices(mpl, block); alpar@9: done: return ret; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_within_domain - perform evaluation within domain scope. alpar@9: -- alpar@9: -- This routine assigns new values (symbols) to all dummy indices of alpar@9: -- specified domain and calls the formal routine func, which is used to alpar@9: -- evaluate some code in the domain scope. Each free dummy index in the alpar@9: -- domain is assigned a value specified in the corresponding component alpar@9: -- of given n-tuple. Non-free dummy indices are assigned values, which alpar@9: -- are computed by this routine. alpar@9: -- alpar@9: -- Number of components in the given n-tuple must be the same as number alpar@9: -- of free indices in the domain. alpar@9: -- alpar@9: -- If the given n-tuple is not a member of the domain set, the routine alpar@9: -- func is not called, and non-zero code is returned. alpar@9: -- alpar@9: -- For the sake of convenience it is allowed to specify domain as NULL alpar@9: -- (then n-tuple also must be 0-tuple, i.e. empty), in which case this alpar@9: -- routine just calls the routine func and returns zero. alpar@9: -- alpar@9: -- This routine allows recursive calls from the routine func providing alpar@9: -- correct values of dummy indices for each instance. alpar@9: -- alpar@9: -- NOTE: The n-tuple passed to this routine must not be changed by any alpar@9: -- other routines called from the formal routine func until this alpar@9: -- routine has returned. */ alpar@9: alpar@9: struct eval_domain_info alpar@9: { /* working info used by the routine eval_within_domain */ alpar@9: DOMAIN *domain; alpar@9: /* domain, which has to be entered */ alpar@9: DOMAIN_BLOCK *block; alpar@9: /* domain block, which is currently processed */ alpar@9: TUPLE *tuple; alpar@9: /* tail of original n-tuple, whose components have to be assigned alpar@9: to free dummy indices in the current domain block */ alpar@9: void *info; alpar@9: /* transit pointer passed to the formal routine func */ alpar@9: void (*func)(MPL *mpl, void *info); alpar@9: /* routine, which has to be executed in the domain scope */ alpar@9: int failure; alpar@9: /* this flag indicates that given n-tuple is not a member of the alpar@9: domain set */ alpar@9: }; alpar@9: alpar@9: static void eval_domain_func(MPL *mpl, void *_my_info) alpar@9: { /* this routine recursively enters into the domain scope and then alpar@9: calls the routine func */ alpar@9: struct eval_domain_info *my_info = _my_info; alpar@9: if (my_info->block != NULL) alpar@9: { /* the current domain block to be entered exists */ alpar@9: DOMAIN_BLOCK *block; alpar@9: DOMAIN_SLOT *slot; alpar@9: TUPLE *tuple = NULL, *temp = NULL; alpar@9: /* save pointer to the current domain block */ alpar@9: block = my_info->block; alpar@9: /* and get ready to enter the next block (if it exists) */ alpar@9: my_info->block = block->next; alpar@9: /* construct temporary n-tuple, whose components correspond to alpar@9: dummy indices (slots) of the current domain; components of alpar@9: the temporary n-tuple that correspond to free dummy indices alpar@9: are assigned references (not values!) to symbols specified alpar@9: in the corresponding components of the given n-tuple, while alpar@9: other components that correspond to non-free dummy indices alpar@9: are assigned symbolic values computed here */ alpar@9: for (slot = block->list; slot != NULL; slot = slot->next) alpar@9: { /* create component that corresponds to the current slot */ alpar@9: if (tuple == NULL) alpar@9: tuple = temp = dmp_get_atom(mpl->tuples, sizeof(TUPLE)); alpar@9: else alpar@9: temp = (temp->next = dmp_get_atom(mpl->tuples, sizeof(TUPLE))); alpar@9: if (slot->code == NULL) alpar@9: { /* dummy index is free; take reference to symbol, which alpar@9: is specified in the corresponding component of given alpar@9: n-tuple */ alpar@9: xassert(my_info->tuple != NULL); alpar@9: temp->sym = my_info->tuple->sym; alpar@9: xassert(temp->sym != NULL); alpar@9: my_info->tuple = my_info->tuple->next; alpar@9: } alpar@9: else alpar@9: { /* dummy index is non-free; compute symbolic value to be alpar@9: temporarily assigned to the dummy index */ alpar@9: temp->sym = eval_symbolic(mpl, slot->code); alpar@9: } alpar@9: } alpar@9: temp->next = NULL; alpar@9: /* enter the current domain block */ alpar@9: if (enter_domain_block(mpl, block, tuple, my_info, alpar@9: eval_domain_func)) my_info->failure = 1; alpar@9: /* delete temporary n-tuple as well as symbols that correspond alpar@9: to non-free dummy indices (they were computed here) */ alpar@9: for (slot = block->list; slot != NULL; slot = slot->next) alpar@9: { xassert(tuple != NULL); alpar@9: temp = tuple; alpar@9: tuple = tuple->next; alpar@9: if (slot->code != NULL) alpar@9: { /* dummy index is non-free; delete symbolic value */ alpar@9: delete_symbol(mpl, temp->sym); alpar@9: } alpar@9: /* delete component that corresponds to the current slot */ alpar@9: dmp_free_atom(mpl->tuples, temp, sizeof(TUPLE)); alpar@9: } alpar@9: } alpar@9: else alpar@9: { /* there are no more domain blocks, i.e. we have reached the alpar@9: domain scope */ alpar@9: xassert(my_info->tuple == NULL); alpar@9: /* check optional predicate specified for the domain */ alpar@9: if (my_info->domain->code != NULL && !eval_logical(mpl, alpar@9: my_info->domain->code)) alpar@9: { /* the predicate is false */ alpar@9: my_info->failure = 2; alpar@9: } alpar@9: else alpar@9: { /* the predicate is true; do the job */ alpar@9: my_info->func(mpl, my_info->info); alpar@9: } alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: int eval_within_domain alpar@9: ( MPL *mpl, alpar@9: DOMAIN *domain, /* not changed */ alpar@9: TUPLE *tuple, /* not changed */ alpar@9: void *info, void (*func)(MPL *mpl, void *info) alpar@9: ) alpar@9: { /* this routine performs evaluation within domain scope */ alpar@9: struct eval_domain_info _my_info, *my_info = &_my_info; alpar@9: if (domain == NULL) alpar@9: { xassert(tuple == NULL); alpar@9: func(mpl, info); alpar@9: my_info->failure = 0; alpar@9: } alpar@9: else alpar@9: { xassert(tuple != NULL); alpar@9: my_info->domain = domain; alpar@9: my_info->block = domain->list; alpar@9: my_info->tuple = tuple; alpar@9: my_info->info = info; alpar@9: my_info->func = func; alpar@9: my_info->failure = 0; alpar@9: /* enter the very first domain block */ alpar@9: eval_domain_func(mpl, my_info); alpar@9: } alpar@9: return my_info->failure; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- loop_within_domain - perform iterations within domain scope. alpar@9: -- alpar@9: -- This routine iteratively assigns new values (symbols) to the dummy alpar@9: -- indices of specified domain by enumerating all n-tuples, which are alpar@9: -- members of the domain set, and for every n-tuple it calls the formal alpar@9: -- routine func to evaluate some code within the domain scope. alpar@9: -- alpar@9: -- If the routine func returns non-zero, enumeration within the domain alpar@9: -- is prematurely terminated. alpar@9: -- alpar@9: -- For the sake of convenience it is allowed to specify domain as NULL, alpar@9: -- in which case this routine just calls the routine func only once and alpar@9: -- returns zero. alpar@9: -- alpar@9: -- This routine allows recursive calls from the routine func providing alpar@9: -- correct values of dummy indices for each instance. */ alpar@9: alpar@9: struct loop_domain_info alpar@9: { /* working info used by the routine loop_within_domain */ alpar@9: DOMAIN *domain; alpar@9: /* domain, which has to be entered */ alpar@9: DOMAIN_BLOCK *block; alpar@9: /* domain block, which is currently processed */ alpar@9: int looping; alpar@9: /* clearing this flag leads to terminating enumeration */ alpar@9: void *info; alpar@9: /* transit pointer passed to the formal routine func */ alpar@9: int (*func)(MPL *mpl, void *info); alpar@9: /* routine, which needs to be executed in the domain scope */ alpar@9: }; alpar@9: alpar@9: static void loop_domain_func(MPL *mpl, void *_my_info) alpar@9: { /* this routine enumerates all n-tuples in the basic set of the alpar@9: current domain block, enters recursively into the domain scope alpar@9: for every n-tuple, and then calls the routine func */ alpar@9: struct loop_domain_info *my_info = _my_info; alpar@9: if (my_info->block != NULL) alpar@9: { /* the current domain block to be entered exists */ alpar@9: DOMAIN_BLOCK *block; alpar@9: DOMAIN_SLOT *slot; alpar@9: TUPLE *bound; alpar@9: /* save pointer to the current domain block */ alpar@9: block = my_info->block; alpar@9: /* and get ready to enter the next block (if it exists) */ alpar@9: my_info->block = block->next; alpar@9: /* compute symbolic values, at which non-free dummy indices of alpar@9: the current domain block are bound; since that values don't alpar@9: depend on free dummy indices of the current block, they can alpar@9: be computed once out of the enumeration loop */ alpar@9: bound = create_tuple(mpl); alpar@9: for (slot = block->list; slot != NULL; slot = slot->next) alpar@9: { if (slot->code != NULL) alpar@9: bound = expand_tuple(mpl, bound, eval_symbolic(mpl, alpar@9: slot->code)); alpar@9: } alpar@9: /* start enumeration */ alpar@9: xassert(block->code != NULL); alpar@9: if (block->code->op == O_DOTS) alpar@9: { /* the basic set is "arithmetic", in which case it doesn't alpar@9: need to be computed explicitly */ alpar@9: TUPLE *tuple; alpar@9: int n, j; alpar@9: double t0, tf, dt; alpar@9: /* compute "parameters" of the basic set */ alpar@9: t0 = eval_numeric(mpl, block->code->arg.arg.x); alpar@9: tf = eval_numeric(mpl, block->code->arg.arg.y); alpar@9: if (block->code->arg.arg.z == NULL) alpar@9: dt = 1.0; alpar@9: else alpar@9: dt = eval_numeric(mpl, block->code->arg.arg.z); alpar@9: /* determine cardinality of the basic set */ alpar@9: n = arelset_size(mpl, t0, tf, dt); alpar@9: /* create dummy 1-tuple for members of the basic set */ alpar@9: tuple = expand_tuple(mpl, create_tuple(mpl), alpar@9: create_symbol_num(mpl, 0.0)); alpar@9: /* in case of "arithmetic" set there is exactly one dummy alpar@9: index, which cannot be non-free */ alpar@9: xassert(bound == NULL); alpar@9: /* walk through 1-tuples of the basic set */ alpar@9: for (j = 1; j <= n && my_info->looping; j++) alpar@9: { /* construct dummy 1-tuple for the current member */ alpar@9: tuple->sym->num = arelset_member(mpl, t0, tf, dt, j); alpar@9: /* enter the current domain block */ alpar@9: enter_domain_block(mpl, block, tuple, my_info, alpar@9: loop_domain_func); alpar@9: } alpar@9: /* delete dummy 1-tuple */ alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: else alpar@9: { /* the basic set is of general kind, in which case it needs alpar@9: to be explicitly computed */ alpar@9: ELEMSET *set; alpar@9: MEMBER *memb; alpar@9: TUPLE *temp1, *temp2; alpar@9: /* compute the basic set */ alpar@9: set = eval_elemset(mpl, block->code); alpar@9: /* walk through all n-tuples of the basic set */ alpar@9: for (memb = set->head; memb != NULL && my_info->looping; alpar@9: memb = memb->next) alpar@9: { /* all components of the current n-tuple that correspond alpar@9: to non-free dummy indices must be feasible; otherwise alpar@9: the n-tuple is not in the basic set */ alpar@9: temp1 = memb->tuple; alpar@9: temp2 = bound; alpar@9: for (slot = block->list; slot != NULL; slot = slot->next) alpar@9: { xassert(temp1 != NULL); alpar@9: if (slot->code != NULL) alpar@9: { /* non-free dummy index */ alpar@9: xassert(temp2 != NULL); alpar@9: if (compare_symbols(mpl, temp1->sym, temp2->sym) alpar@9: != 0) alpar@9: { /* the n-tuple is not in the basic set */ alpar@9: goto skip; alpar@9: } alpar@9: temp2 = temp2->next; alpar@9: } alpar@9: temp1 = temp1->next; alpar@9: } alpar@9: xassert(temp1 == NULL); alpar@9: xassert(temp2 == NULL); alpar@9: /* enter the current domain block */ alpar@9: enter_domain_block(mpl, block, memb->tuple, my_info, alpar@9: loop_domain_func); alpar@9: skip: ; alpar@9: } alpar@9: /* delete the basic set */ alpar@9: delete_elemset(mpl, set); alpar@9: } alpar@9: /* delete symbolic values binding non-free dummy indices */ alpar@9: delete_tuple(mpl, bound); alpar@9: /* restore pointer to the current domain block */ alpar@9: my_info->block = block; alpar@9: } alpar@9: else alpar@9: { /* there are no more domain blocks, i.e. we have reached the alpar@9: domain scope */ alpar@9: /* check optional predicate specified for the domain */ alpar@9: if (my_info->domain->code != NULL && !eval_logical(mpl, alpar@9: my_info->domain->code)) alpar@9: { /* the predicate is false */ alpar@9: /* nop */; alpar@9: } alpar@9: else alpar@9: { /* the predicate is true; do the job */ alpar@9: my_info->looping = !my_info->func(mpl, my_info->info); alpar@9: } alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: void loop_within_domain alpar@9: ( MPL *mpl, alpar@9: DOMAIN *domain, /* not changed */ alpar@9: void *info, int (*func)(MPL *mpl, void *info) alpar@9: ) alpar@9: { /* this routine performs iterations within domain scope */ alpar@9: struct loop_domain_info _my_info, *my_info = &_my_info; alpar@9: if (domain == NULL) alpar@9: func(mpl, info); alpar@9: else alpar@9: { my_info->domain = domain; alpar@9: my_info->block = domain->list; alpar@9: my_info->looping = 1; alpar@9: my_info->info = info; alpar@9: my_info->func = func; alpar@9: /* enter the very first domain block */ alpar@9: loop_domain_func(mpl, my_info); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- out_of_domain - raise domain exception. alpar@9: -- alpar@9: -- This routine is called when a reference is made to a member of some alpar@9: -- model object, but its n-tuple is out of the object domain. */ alpar@9: alpar@9: void out_of_domain alpar@9: ( MPL *mpl, alpar@9: char *name, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { xassert(name != NULL); alpar@9: xassert(tuple != NULL); alpar@9: error(mpl, "%s%s out of domain", name, format_tuple(mpl, '[', alpar@9: tuple)); alpar@9: /* no return */ alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- get_domain_tuple - obtain current n-tuple from domain. alpar@9: -- alpar@9: -- This routine constructs n-tuple, whose components are current values alpar@9: -- assigned to *free* dummy indices of specified domain. alpar@9: -- alpar@9: -- For the sake of convenience it is allowed to specify domain as NULL, alpar@9: -- in which case this routine returns 0-tuple. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: TUPLE *get_domain_tuple alpar@9: ( MPL *mpl, alpar@9: DOMAIN *domain /* not changed */ alpar@9: ) alpar@9: { DOMAIN_BLOCK *block; alpar@9: DOMAIN_SLOT *slot; alpar@9: TUPLE *tuple; alpar@9: tuple = create_tuple(mpl); alpar@9: if (domain != NULL) alpar@9: { for (block = domain->list; block != NULL; block = block->next) alpar@9: { for (slot = block->list; slot != NULL; slot = slot->next) alpar@9: { if (slot->code == NULL) alpar@9: { xassert(slot->value != NULL); alpar@9: tuple = expand_tuple(mpl, tuple, copy_symbol(mpl, alpar@9: slot->value)); alpar@9: } alpar@9: } alpar@9: } alpar@9: } alpar@9: return tuple; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_domain - clean domain. alpar@9: -- alpar@9: -- This routine cleans specified domain that assumes deleting all stuff alpar@9: -- dynamically allocated during the generation phase. */ alpar@9: alpar@9: void clean_domain(MPL *mpl, DOMAIN *domain) alpar@9: { DOMAIN_BLOCK *block; alpar@9: DOMAIN_SLOT *slot; alpar@9: /* if no domain is specified, do nothing */ alpar@9: if (domain == NULL) goto done; alpar@9: /* clean all domain blocks */ alpar@9: for (block = domain->list; block != NULL; block = block->next) alpar@9: { /* clean all domain slots */ alpar@9: for (slot = block->list; slot != NULL; slot = slot->next) alpar@9: { /* clean pseudo-code for computing bound value */ alpar@9: clean_code(mpl, slot->code); alpar@9: /* delete symbolic value assigned to dummy index */ alpar@9: if (slot->value != NULL) alpar@9: delete_symbol(mpl, slot->value), slot->value = NULL; alpar@9: } alpar@9: /* clean pseudo-code for computing basic set */ alpar@9: clean_code(mpl, block->code); alpar@9: } alpar@9: /* clean pseudo-code for computing domain predicate */ alpar@9: clean_code(mpl, domain->code); alpar@9: done: return; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * MODEL SETS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- check_elem_set - check elemental set assigned to set member. alpar@9: -- alpar@9: -- This routine checks if given elemental set being assigned to member alpar@9: -- of specified model set satisfies to all restrictions. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: void check_elem_set alpar@9: ( MPL *mpl, alpar@9: SET *set, /* not changed */ alpar@9: TUPLE *tuple, /* not changed */ alpar@9: ELEMSET *refer /* not changed */ alpar@9: ) alpar@9: { WITHIN *within; alpar@9: MEMBER *memb; alpar@9: int eqno; alpar@9: /* elemental set must be within all specified supersets */ alpar@9: for (within = set->within, eqno = 1; within != NULL; within = alpar@9: within->next, eqno++) alpar@9: { xassert(within->code != NULL); alpar@9: for (memb = refer->head; memb != NULL; memb = memb->next) alpar@9: { if (!is_member(mpl, within->code, memb->tuple)) alpar@9: { char buf[255+1]; alpar@9: strcpy(buf, format_tuple(mpl, '(', memb->tuple)); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: error(mpl, "%s%s contains %s which not within specified " alpar@9: "set; see (%d)", set->name, format_tuple(mpl, '[', alpar@9: tuple), buf, eqno); alpar@9: } alpar@9: } alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- take_member_set - obtain elemental set assigned to set member. alpar@9: -- alpar@9: -- This routine obtains a reference to elemental set assigned to given alpar@9: -- member of specified model set and returns it on exit. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: ELEMSET *take_member_set /* returns reference, not value */ alpar@9: ( MPL *mpl, alpar@9: SET *set, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: ELEMSET *refer; alpar@9: /* find member in the set array */ alpar@9: memb = find_member(mpl, set->array, tuple); alpar@9: if (memb != NULL) alpar@9: { /* member exists, so just take the reference */ alpar@9: refer = memb->value.set; alpar@9: } alpar@9: else if (set->assign != NULL) alpar@9: { /* compute value using assignment expression */ alpar@9: refer = eval_elemset(mpl, set->assign); alpar@9: add: /* check that the elemental set satisfies to all restrictions, alpar@9: assign it to new member, and add the member to the array */ alpar@9: check_elem_set(mpl, set, tuple, refer); alpar@9: memb = add_member(mpl, set->array, copy_tuple(mpl, tuple)); alpar@9: memb->value.set = refer; alpar@9: } alpar@9: else if (set->option != NULL) alpar@9: { /* compute default elemental set */ alpar@9: refer = eval_elemset(mpl, set->option); alpar@9: goto add; alpar@9: } alpar@9: else alpar@9: { /* no value (elemental set) is provided */ alpar@9: error(mpl, "no value for %s%s", set->name, format_tuple(mpl, alpar@9: '[', tuple)); alpar@9: } alpar@9: return refer; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_member_set - evaluate elemental set assigned to set member. alpar@9: -- alpar@9: -- This routine evaluates a reference to elemental set assigned to given alpar@9: -- member of specified model set and returns it on exit. */ alpar@9: alpar@9: struct eval_set_info alpar@9: { /* working info used by the routine eval_member_set */ alpar@9: SET *set; alpar@9: /* model set */ alpar@9: TUPLE *tuple; alpar@9: /* n-tuple, which defines set member */ alpar@9: MEMBER *memb; alpar@9: /* normally this pointer is NULL; the routine uses this pointer alpar@9: to check data provided in the data section, in which case it alpar@9: points to a member currently checked; this check is performed alpar@9: automatically only once when a reference to any member occurs alpar@9: for the first time */ alpar@9: ELEMSET *refer; alpar@9: /* evaluated reference to elemental set */ alpar@9: }; alpar@9: alpar@9: static void eval_set_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: struct eval_set_info *info = _info; alpar@9: if (info->memb != NULL) alpar@9: { /* checking call; check elemental set being assigned */ alpar@9: check_elem_set(mpl, info->set, info->memb->tuple, alpar@9: info->memb->value.set); alpar@9: } alpar@9: else alpar@9: { /* normal call; evaluate member, which has given n-tuple */ alpar@9: info->refer = take_member_set(mpl, info->set, info->tuple); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: #if 1 /* 12/XII-2008 */ alpar@9: static void saturate_set(MPL *mpl, SET *set) alpar@9: { GADGET *gadget = set->gadget; alpar@9: ELEMSET *data; alpar@9: MEMBER *elem, *memb; alpar@9: TUPLE *tuple, *work[20]; alpar@9: int i; alpar@9: xprintf("Generating %s...\n", set->name); alpar@9: eval_whole_set(mpl, gadget->set); alpar@9: /* gadget set must have exactly one member */ alpar@9: xassert(gadget->set->array != NULL); alpar@9: xassert(gadget->set->array->head != NULL); alpar@9: xassert(gadget->set->array->head == gadget->set->array->tail); alpar@9: data = gadget->set->array->head->value.set; alpar@9: xassert(data->type == A_NONE); alpar@9: xassert(data->dim == gadget->set->dimen); alpar@9: /* walk thru all elements of the plain set */ alpar@9: for (elem = data->head; elem != NULL; elem = elem->next) alpar@9: { /* create a copy of n-tuple */ alpar@9: tuple = copy_tuple(mpl, elem->tuple); alpar@9: /* rearrange component of the n-tuple */ alpar@9: for (i = 0; i < gadget->set->dimen; i++) alpar@9: work[i] = NULL; alpar@9: for (i = 0; tuple != NULL; tuple = tuple->next) alpar@9: work[gadget->ind[i++]-1] = tuple; alpar@9: xassert(i == gadget->set->dimen); alpar@9: for (i = 0; i < gadget->set->dimen; i++) alpar@9: { xassert(work[i] != NULL); alpar@9: work[i]->next = work[i+1]; alpar@9: } alpar@9: /* construct subscript list from first set->dim components */ alpar@9: if (set->dim == 0) alpar@9: tuple = NULL; alpar@9: else alpar@9: tuple = work[0], work[set->dim-1]->next = NULL; alpar@9: /* find corresponding member of the set to be initialized */ alpar@9: memb = find_member(mpl, set->array, tuple); alpar@9: if (memb == NULL) alpar@9: { /* not found; add new member to the set and assign it empty alpar@9: elemental set */ alpar@9: memb = add_member(mpl, set->array, tuple); alpar@9: memb->value.set = create_elemset(mpl, set->dimen); alpar@9: } alpar@9: else alpar@9: { /* found; free subscript list */ alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: /* construct new n-tuple from rest set->dimen components */ alpar@9: tuple = work[set->dim]; alpar@9: xassert(set->dim + set->dimen == gadget->set->dimen); alpar@9: work[gadget->set->dimen-1]->next = NULL; alpar@9: /* and add it to the elemental set assigned to the member alpar@9: (no check for duplicates is needed) */ alpar@9: add_tuple(mpl, memb->value.set, tuple); alpar@9: } alpar@9: /* the set has been saturated with data */ alpar@9: set->data = 1; alpar@9: return; alpar@9: } alpar@9: #endif alpar@9: alpar@9: ELEMSET *eval_member_set /* returns reference, not value */ alpar@9: ( MPL *mpl, alpar@9: SET *set, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { /* this routine evaluates set member */ alpar@9: struct eval_set_info _info, *info = &_info; alpar@9: xassert(set->dim == tuple_dimen(mpl, tuple)); alpar@9: info->set = set; alpar@9: info->tuple = tuple; alpar@9: #if 1 /* 12/XII-2008 */ alpar@9: if (set->gadget != NULL && set->data == 0) alpar@9: { /* initialize the set with data from a plain set */ alpar@9: saturate_set(mpl, set); alpar@9: } alpar@9: #endif alpar@9: if (set->data == 1) alpar@9: { /* check data, which are provided in the data section, but not alpar@9: checked yet */ alpar@9: /* save pointer to the last array member; note that during the alpar@9: check new members may be added beyond the last member due to alpar@9: references to the same parameter from default expression as alpar@9: well as from expressions that define restricting supersets; alpar@9: however, values assigned to the new members will be checked alpar@9: by other routine, so we don't need to check them here */ alpar@9: MEMBER *tail = set->array->tail; alpar@9: /* change the data status to prevent infinite recursive loop alpar@9: due to references to the same set during the check */ alpar@9: set->data = 2; alpar@9: /* check elemental sets assigned to array members in the data alpar@9: section until the marked member has been reached */ alpar@9: for (info->memb = set->array->head; info->memb != NULL; alpar@9: info->memb = info->memb->next) alpar@9: { if (eval_within_domain(mpl, set->domain, info->memb->tuple, alpar@9: info, eval_set_func)) alpar@9: out_of_domain(mpl, set->name, info->memb->tuple); alpar@9: if (info->memb == tail) break; alpar@9: } alpar@9: /* the check has been finished */ alpar@9: } alpar@9: /* evaluate member, which has given n-tuple */ alpar@9: info->memb = NULL; alpar@9: if (eval_within_domain(mpl, info->set->domain, info->tuple, info, alpar@9: eval_set_func)) alpar@9: out_of_domain(mpl, set->name, info->tuple); alpar@9: /* bring evaluated reference to the calling program */ alpar@9: return info->refer; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_whole_set - evaluate model set over entire domain. alpar@9: -- alpar@9: -- This routine evaluates all members of specified model set over entire alpar@9: -- domain. */ alpar@9: alpar@9: static int whole_set_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: SET *set = (SET *)info; alpar@9: TUPLE *tuple = get_domain_tuple(mpl, set->domain); alpar@9: eval_member_set(mpl, set, tuple); alpar@9: delete_tuple(mpl, tuple); alpar@9: return 0; alpar@9: } alpar@9: alpar@9: void eval_whole_set(MPL *mpl, SET *set) alpar@9: { loop_within_domain(mpl, set->domain, set, whole_set_func); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean set - clean model set. alpar@9: -- alpar@9: -- This routine cleans specified model set that assumes deleting all alpar@9: -- stuff dynamically allocated during the generation phase. */ alpar@9: alpar@9: void clean_set(MPL *mpl, SET *set) alpar@9: { WITHIN *within; alpar@9: MEMBER *memb; alpar@9: /* clean subscript domain */ alpar@9: clean_domain(mpl, set->domain); alpar@9: /* clean pseudo-code for computing supersets */ alpar@9: for (within = set->within; within != NULL; within = within->next) alpar@9: clean_code(mpl, within->code); alpar@9: /* clean pseudo-code for computing assigned value */ alpar@9: clean_code(mpl, set->assign); alpar@9: /* clean pseudo-code for computing default value */ alpar@9: clean_code(mpl, set->option); alpar@9: /* reset data status flag */ alpar@9: set->data = 0; alpar@9: /* delete content array */ alpar@9: for (memb = set->array->head; memb != NULL; memb = memb->next) alpar@9: delete_value(mpl, set->array->type, &memb->value); alpar@9: delete_array(mpl, set->array), set->array = NULL; alpar@9: return; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * MODEL PARAMETERS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- check_value_num - check numeric value assigned to parameter member. alpar@9: -- alpar@9: -- This routine checks if numeric value being assigned to some member alpar@9: -- of specified numeric model parameter satisfies to all restrictions. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: void check_value_num alpar@9: ( MPL *mpl, alpar@9: PARAMETER *par, /* not changed */ alpar@9: TUPLE *tuple, /* not changed */ alpar@9: double value alpar@9: ) alpar@9: { CONDITION *cond; alpar@9: WITHIN *in; alpar@9: int eqno; alpar@9: /* the value must satisfy to the parameter type */ alpar@9: switch (par->type) alpar@9: { case A_NUMERIC: alpar@9: break; alpar@9: case A_INTEGER: alpar@9: if (value != floor(value)) alpar@9: error(mpl, "%s%s = %.*g not integer", par->name, alpar@9: format_tuple(mpl, '[', tuple), DBL_DIG, value); alpar@9: break; alpar@9: case A_BINARY: alpar@9: if (!(value == 0.0 || value == 1.0)) alpar@9: error(mpl, "%s%s = %.*g not binary", par->name, alpar@9: format_tuple(mpl, '[', tuple), DBL_DIG, value); alpar@9: break; alpar@9: default: alpar@9: xassert(par != par); alpar@9: } alpar@9: /* the value must satisfy to all specified conditions */ alpar@9: for (cond = par->cond, eqno = 1; cond != NULL; cond = cond->next, alpar@9: eqno++) alpar@9: { double bound; alpar@9: char *rho; alpar@9: xassert(cond->code != NULL); alpar@9: bound = eval_numeric(mpl, cond->code); alpar@9: switch (cond->rho) alpar@9: { case O_LT: alpar@9: if (!(value < bound)) alpar@9: { rho = "<"; alpar@9: err: error(mpl, "%s%s = %.*g not %s %.*g; see (%d)", alpar@9: par->name, format_tuple(mpl, '[', tuple), DBL_DIG, alpar@9: value, rho, DBL_DIG, bound, eqno); alpar@9: } alpar@9: break; alpar@9: case O_LE: alpar@9: if (!(value <= bound)) { rho = "<="; goto err; } alpar@9: break; alpar@9: case O_EQ: alpar@9: if (!(value == bound)) { rho = "="; goto err; } alpar@9: break; alpar@9: case O_GE: alpar@9: if (!(value >= bound)) { rho = ">="; goto err; } alpar@9: break; alpar@9: case O_GT: alpar@9: if (!(value > bound)) { rho = ">"; goto err; } alpar@9: break; alpar@9: case O_NE: alpar@9: if (!(value != bound)) { rho = "<>"; goto err; } alpar@9: break; alpar@9: default: alpar@9: xassert(cond != cond); alpar@9: } alpar@9: } alpar@9: /* the value must be in all specified supersets */ alpar@9: for (in = par->in, eqno = 1; in != NULL; in = in->next, eqno++) alpar@9: { TUPLE *dummy; alpar@9: xassert(in->code != NULL); alpar@9: xassert(in->code->dim == 1); alpar@9: dummy = expand_tuple(mpl, create_tuple(mpl), alpar@9: create_symbol_num(mpl, value)); alpar@9: if (!is_member(mpl, in->code, dummy)) alpar@9: error(mpl, "%s%s = %.*g not in specified set; see (%d)", alpar@9: par->name, format_tuple(mpl, '[', tuple), DBL_DIG, alpar@9: value, eqno); alpar@9: delete_tuple(mpl, dummy); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- take_member_num - obtain num. value assigned to parameter member. alpar@9: -- alpar@9: -- This routine obtains a numeric value assigned to member of specified alpar@9: -- numeric model parameter and returns it on exit. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: double take_member_num alpar@9: ( MPL *mpl, alpar@9: PARAMETER *par, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: double value; alpar@9: /* find member in the parameter array */ alpar@9: memb = find_member(mpl, par->array, tuple); alpar@9: if (memb != NULL) alpar@9: { /* member exists, so just take its value */ alpar@9: value = memb->value.num; alpar@9: } alpar@9: else if (par->assign != NULL) alpar@9: { /* compute value using assignment expression */ alpar@9: value = eval_numeric(mpl, par->assign); alpar@9: add: /* check that the value satisfies to all restrictions, assign alpar@9: it to new member, and add the member to the array */ alpar@9: check_value_num(mpl, par, tuple, value); alpar@9: memb = add_member(mpl, par->array, copy_tuple(mpl, tuple)); alpar@9: memb->value.num = value; alpar@9: } alpar@9: else if (par->option != NULL) alpar@9: { /* compute default value */ alpar@9: value = eval_numeric(mpl, par->option); alpar@9: goto add; alpar@9: } alpar@9: else if (par->defval != NULL) alpar@9: { /* take default value provided in the data section */ alpar@9: if (par->defval->str != NULL) alpar@9: error(mpl, "cannot convert %s to floating-point number", alpar@9: format_symbol(mpl, par->defval)); alpar@9: value = par->defval->num; alpar@9: goto add; alpar@9: } alpar@9: else alpar@9: { /* no value is provided */ alpar@9: error(mpl, "no value for %s%s", par->name, format_tuple(mpl, alpar@9: '[', tuple)); alpar@9: } alpar@9: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_member_num - evaluate num. value assigned to parameter member. alpar@9: -- alpar@9: -- This routine evaluates a numeric value assigned to given member of alpar@9: -- specified numeric model parameter and returns it on exit. */ alpar@9: alpar@9: struct eval_num_info alpar@9: { /* working info used by the routine eval_member_num */ alpar@9: PARAMETER *par; alpar@9: /* model parameter */ alpar@9: TUPLE *tuple; alpar@9: /* n-tuple, which defines parameter member */ alpar@9: MEMBER *memb; alpar@9: /* normally this pointer is NULL; the routine uses this pointer alpar@9: to check data provided in the data section, in which case it alpar@9: points to a member currently checked; this check is performed alpar@9: automatically only once when a reference to any member occurs alpar@9: for the first time */ alpar@9: double value; alpar@9: /* evaluated numeric value */ alpar@9: }; alpar@9: alpar@9: static void eval_num_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: struct eval_num_info *info = _info; alpar@9: if (info->memb != NULL) alpar@9: { /* checking call; check numeric value being assigned */ alpar@9: check_value_num(mpl, info->par, info->memb->tuple, alpar@9: info->memb->value.num); alpar@9: } alpar@9: else alpar@9: { /* normal call; evaluate member, which has given n-tuple */ alpar@9: info->value = take_member_num(mpl, info->par, info->tuple); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: double eval_member_num alpar@9: ( MPL *mpl, alpar@9: PARAMETER *par, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { /* this routine evaluates numeric parameter member */ alpar@9: struct eval_num_info _info, *info = &_info; alpar@9: xassert(par->type == A_NUMERIC || par->type == A_INTEGER || alpar@9: par->type == A_BINARY); alpar@9: xassert(par->dim == tuple_dimen(mpl, tuple)); alpar@9: info->par = par; alpar@9: info->tuple = tuple; alpar@9: if (par->data == 1) alpar@9: { /* check data, which are provided in the data section, but not alpar@9: checked yet */ alpar@9: /* save pointer to the last array member; note that during the alpar@9: check new members may be added beyond the last member due to alpar@9: references to the same parameter from default expression as alpar@9: well as from expressions that define restricting conditions; alpar@9: however, values assigned to the new members will be checked alpar@9: by other routine, so we don't need to check them here */ alpar@9: MEMBER *tail = par->array->tail; alpar@9: /* change the data status to prevent infinite recursive loop alpar@9: due to references to the same parameter during the check */ alpar@9: par->data = 2; alpar@9: /* check values assigned to array members in the data section alpar@9: until the marked member has been reached */ alpar@9: for (info->memb = par->array->head; info->memb != NULL; alpar@9: info->memb = info->memb->next) alpar@9: { if (eval_within_domain(mpl, par->domain, info->memb->tuple, alpar@9: info, eval_num_func)) alpar@9: out_of_domain(mpl, par->name, info->memb->tuple); alpar@9: if (info->memb == tail) break; alpar@9: } alpar@9: /* the check has been finished */ alpar@9: } alpar@9: /* evaluate member, which has given n-tuple */ alpar@9: info->memb = NULL; alpar@9: if (eval_within_domain(mpl, info->par->domain, info->tuple, info, alpar@9: eval_num_func)) alpar@9: out_of_domain(mpl, par->name, info->tuple); alpar@9: /* bring evaluated value to the calling program */ alpar@9: return info->value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- check_value_sym - check symbolic value assigned to parameter member. alpar@9: -- alpar@9: -- This routine checks if symbolic value being assigned to some member alpar@9: -- of specified symbolic model parameter satisfies to all restrictions. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: void check_value_sym alpar@9: ( MPL *mpl, alpar@9: PARAMETER *par, /* not changed */ alpar@9: TUPLE *tuple, /* not changed */ alpar@9: SYMBOL *value /* not changed */ alpar@9: ) alpar@9: { CONDITION *cond; alpar@9: WITHIN *in; alpar@9: int eqno; alpar@9: /* the value must satisfy to all specified conditions */ alpar@9: for (cond = par->cond, eqno = 1; cond != NULL; cond = cond->next, alpar@9: eqno++) alpar@9: { SYMBOL *bound; alpar@9: char buf[255+1]; alpar@9: xassert(cond->code != NULL); alpar@9: bound = eval_symbolic(mpl, cond->code); alpar@9: switch (cond->rho) alpar@9: { alpar@9: #if 1 /* 13/VIII-2008 */ alpar@9: case O_LT: alpar@9: if (!(compare_symbols(mpl, value, bound) < 0)) alpar@9: { strcpy(buf, format_symbol(mpl, bound)); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: error(mpl, "%s%s = %s not < %s", alpar@9: par->name, format_tuple(mpl, '[', tuple), alpar@9: format_symbol(mpl, value), buf, eqno); alpar@9: } alpar@9: break; alpar@9: case O_LE: alpar@9: if (!(compare_symbols(mpl, value, bound) <= 0)) alpar@9: { strcpy(buf, format_symbol(mpl, bound)); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: error(mpl, "%s%s = %s not <= %s", alpar@9: par->name, format_tuple(mpl, '[', tuple), alpar@9: format_symbol(mpl, value), buf, eqno); alpar@9: } alpar@9: break; alpar@9: #endif alpar@9: case O_EQ: alpar@9: if (!(compare_symbols(mpl, value, bound) == 0)) alpar@9: { strcpy(buf, format_symbol(mpl, bound)); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: error(mpl, "%s%s = %s not = %s", alpar@9: par->name, format_tuple(mpl, '[', tuple), alpar@9: format_symbol(mpl, value), buf, eqno); alpar@9: } alpar@9: break; alpar@9: #if 1 /* 13/VIII-2008 */ alpar@9: case O_GE: alpar@9: if (!(compare_symbols(mpl, value, bound) >= 0)) alpar@9: { strcpy(buf, format_symbol(mpl, bound)); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: error(mpl, "%s%s = %s not >= %s", alpar@9: par->name, format_tuple(mpl, '[', tuple), alpar@9: format_symbol(mpl, value), buf, eqno); alpar@9: } alpar@9: break; alpar@9: case O_GT: alpar@9: if (!(compare_symbols(mpl, value, bound) > 0)) alpar@9: { strcpy(buf, format_symbol(mpl, bound)); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: error(mpl, "%s%s = %s not > %s", alpar@9: par->name, format_tuple(mpl, '[', tuple), alpar@9: format_symbol(mpl, value), buf, eqno); alpar@9: } alpar@9: break; alpar@9: #endif alpar@9: case O_NE: alpar@9: if (!(compare_symbols(mpl, value, bound) != 0)) alpar@9: { strcpy(buf, format_symbol(mpl, bound)); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: error(mpl, "%s%s = %s not <> %s", alpar@9: par->name, format_tuple(mpl, '[', tuple), alpar@9: format_symbol(mpl, value), buf, eqno); alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(cond != cond); alpar@9: } alpar@9: delete_symbol(mpl, bound); alpar@9: } alpar@9: /* the value must be in all specified supersets */ alpar@9: for (in = par->in, eqno = 1; in != NULL; in = in->next, eqno++) alpar@9: { TUPLE *dummy; alpar@9: xassert(in->code != NULL); alpar@9: xassert(in->code->dim == 1); alpar@9: dummy = expand_tuple(mpl, create_tuple(mpl), copy_symbol(mpl, alpar@9: value)); alpar@9: if (!is_member(mpl, in->code, dummy)) alpar@9: error(mpl, "%s%s = %s not in specified set; see (%d)", alpar@9: par->name, format_tuple(mpl, '[', tuple), alpar@9: format_symbol(mpl, value), eqno); alpar@9: delete_tuple(mpl, dummy); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- take_member_sym - obtain symb. value assigned to parameter member. alpar@9: -- alpar@9: -- This routine obtains a symbolic value assigned to member of specified alpar@9: -- symbolic model parameter and returns it on exit. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: SYMBOL *take_member_sym /* returns value, not reference */ alpar@9: ( MPL *mpl, alpar@9: PARAMETER *par, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: SYMBOL *value; alpar@9: /* find member in the parameter array */ alpar@9: memb = find_member(mpl, par->array, tuple); alpar@9: if (memb != NULL) alpar@9: { /* member exists, so just take its value */ alpar@9: value = copy_symbol(mpl, memb->value.sym); alpar@9: } alpar@9: else if (par->assign != NULL) alpar@9: { /* compute value using assignment expression */ alpar@9: value = eval_symbolic(mpl, par->assign); alpar@9: add: /* check that the value satisfies to all restrictions, assign alpar@9: it to new member, and add the member to the array */ alpar@9: check_value_sym(mpl, par, tuple, value); alpar@9: memb = add_member(mpl, par->array, copy_tuple(mpl, tuple)); alpar@9: memb->value.sym = copy_symbol(mpl, value); alpar@9: } alpar@9: else if (par->option != NULL) alpar@9: { /* compute default value */ alpar@9: value = eval_symbolic(mpl, par->option); alpar@9: goto add; alpar@9: } alpar@9: else if (par->defval != NULL) alpar@9: { /* take default value provided in the data section */ alpar@9: value = copy_symbol(mpl, par->defval); alpar@9: goto add; alpar@9: } alpar@9: else alpar@9: { /* no value is provided */ alpar@9: error(mpl, "no value for %s%s", par->name, format_tuple(mpl, alpar@9: '[', tuple)); alpar@9: } alpar@9: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_member_sym - evaluate symb. value assigned to parameter member. alpar@9: -- alpar@9: -- This routine evaluates a symbolic value assigned to given member of alpar@9: -- specified symbolic model parameter and returns it on exit. */ alpar@9: alpar@9: struct eval_sym_info alpar@9: { /* working info used by the routine eval_member_sym */ alpar@9: PARAMETER *par; alpar@9: /* model parameter */ alpar@9: TUPLE *tuple; alpar@9: /* n-tuple, which defines parameter member */ alpar@9: MEMBER *memb; alpar@9: /* normally this pointer is NULL; the routine uses this pointer alpar@9: to check data provided in the data section, in which case it alpar@9: points to a member currently checked; this check is performed alpar@9: automatically only once when a reference to any member occurs alpar@9: for the first time */ alpar@9: SYMBOL *value; alpar@9: /* evaluated symbolic value */ alpar@9: }; alpar@9: alpar@9: static void eval_sym_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: struct eval_sym_info *info = _info; alpar@9: if (info->memb != NULL) alpar@9: { /* checking call; check symbolic value being assigned */ alpar@9: check_value_sym(mpl, info->par, info->memb->tuple, alpar@9: info->memb->value.sym); alpar@9: } alpar@9: else alpar@9: { /* normal call; evaluate member, which has given n-tuple */ alpar@9: info->value = take_member_sym(mpl, info->par, info->tuple); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: SYMBOL *eval_member_sym /* returns value, not reference */ alpar@9: ( MPL *mpl, alpar@9: PARAMETER *par, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { /* this routine evaluates symbolic parameter member */ alpar@9: struct eval_sym_info _info, *info = &_info; alpar@9: xassert(par->type == A_SYMBOLIC); alpar@9: xassert(par->dim == tuple_dimen(mpl, tuple)); alpar@9: info->par = par; alpar@9: info->tuple = tuple; alpar@9: if (par->data == 1) alpar@9: { /* check data, which are provided in the data section, but not alpar@9: checked yet */ alpar@9: /* save pointer to the last array member; note that during the alpar@9: check new members may be added beyond the last member due to alpar@9: references to the same parameter from default expression as alpar@9: well as from expressions that define restricting conditions; alpar@9: however, values assigned to the new members will be checked alpar@9: by other routine, so we don't need to check them here */ alpar@9: MEMBER *tail = par->array->tail; alpar@9: /* change the data status to prevent infinite recursive loop alpar@9: due to references to the same parameter during the check */ alpar@9: par->data = 2; alpar@9: /* check values assigned to array members in the data section alpar@9: until the marked member has been reached */ alpar@9: for (info->memb = par->array->head; info->memb != NULL; alpar@9: info->memb = info->memb->next) alpar@9: { if (eval_within_domain(mpl, par->domain, info->memb->tuple, alpar@9: info, eval_sym_func)) alpar@9: out_of_domain(mpl, par->name, info->memb->tuple); alpar@9: if (info->memb == tail) break; alpar@9: } alpar@9: /* the check has been finished */ alpar@9: } alpar@9: /* evaluate member, which has given n-tuple */ alpar@9: info->memb = NULL; alpar@9: if (eval_within_domain(mpl, info->par->domain, info->tuple, info, alpar@9: eval_sym_func)) alpar@9: out_of_domain(mpl, par->name, info->tuple); alpar@9: /* bring evaluated value to the calling program */ alpar@9: return info->value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_whole_par - evaluate model parameter over entire domain. alpar@9: -- alpar@9: -- This routine evaluates all members of specified model parameter over alpar@9: -- entire domain. */ alpar@9: alpar@9: static int whole_par_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: PARAMETER *par = (PARAMETER *)info; alpar@9: TUPLE *tuple = get_domain_tuple(mpl, par->domain); alpar@9: switch (par->type) alpar@9: { case A_NUMERIC: alpar@9: case A_INTEGER: alpar@9: case A_BINARY: alpar@9: eval_member_num(mpl, par, tuple); alpar@9: break; alpar@9: case A_SYMBOLIC: alpar@9: delete_symbol(mpl, eval_member_sym(mpl, par, tuple)); alpar@9: break; alpar@9: default: alpar@9: xassert(par != par); alpar@9: } alpar@9: delete_tuple(mpl, tuple); alpar@9: return 0; alpar@9: } alpar@9: alpar@9: void eval_whole_par(MPL *mpl, PARAMETER *par) alpar@9: { loop_within_domain(mpl, par->domain, par, whole_par_func); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_parameter - clean model parameter. alpar@9: -- alpar@9: -- This routine cleans specified model parameter that assumes deleting alpar@9: -- all stuff dynamically allocated during the generation phase. */ alpar@9: alpar@9: void clean_parameter(MPL *mpl, PARAMETER *par) alpar@9: { CONDITION *cond; alpar@9: WITHIN *in; alpar@9: MEMBER *memb; alpar@9: /* clean subscript domain */ alpar@9: clean_domain(mpl, par->domain); alpar@9: /* clean pseudo-code for computing restricting conditions */ alpar@9: for (cond = par->cond; cond != NULL; cond = cond->next) alpar@9: clean_code(mpl, cond->code); alpar@9: /* clean pseudo-code for computing restricting supersets */ alpar@9: for (in = par->in; in != NULL; in = in->next) alpar@9: clean_code(mpl, in->code); alpar@9: /* clean pseudo-code for computing assigned value */ alpar@9: clean_code(mpl, par->assign); alpar@9: /* clean pseudo-code for computing default value */ alpar@9: clean_code(mpl, par->option); alpar@9: /* reset data status flag */ alpar@9: par->data = 0; alpar@9: /* delete default symbolic value */ alpar@9: if (par->defval != NULL) alpar@9: delete_symbol(mpl, par->defval), par->defval = NULL; alpar@9: /* delete content array */ alpar@9: for (memb = par->array->head; memb != NULL; memb = memb->next) alpar@9: delete_value(mpl, par->array->type, &memb->value); alpar@9: delete_array(mpl, par->array), par->array = NULL; alpar@9: return; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * MODEL VARIABLES * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- take_member_var - obtain reference to elemental variable. alpar@9: -- alpar@9: -- This routine obtains a reference to elemental variable assigned to alpar@9: -- given member of specified model variable and returns it on exit. If alpar@9: -- necessary, new elemental variable is created. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: ELEMVAR *take_member_var /* returns reference */ alpar@9: ( MPL *mpl, alpar@9: VARIABLE *var, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: ELEMVAR *refer; alpar@9: /* find member in the variable array */ alpar@9: memb = find_member(mpl, var->array, tuple); alpar@9: if (memb != NULL) alpar@9: { /* member exists, so just take the reference */ alpar@9: refer = memb->value.var; alpar@9: } alpar@9: else alpar@9: { /* member is referenced for the first time and therefore does alpar@9: not exist; create new elemental variable, assign it to new alpar@9: member, and add the member to the variable array */ alpar@9: memb = add_member(mpl, var->array, copy_tuple(mpl, tuple)); alpar@9: refer = (memb->value.var = alpar@9: dmp_get_atom(mpl->elemvars, sizeof(ELEMVAR))); alpar@9: refer->j = 0; alpar@9: refer->var = var; alpar@9: refer->memb = memb; alpar@9: /* compute lower bound */ alpar@9: if (var->lbnd == NULL) alpar@9: refer->lbnd = 0.0; alpar@9: else alpar@9: refer->lbnd = eval_numeric(mpl, var->lbnd); alpar@9: /* compute upper bound */ alpar@9: if (var->ubnd == NULL) alpar@9: refer->ubnd = 0.0; alpar@9: else if (var->ubnd == var->lbnd) alpar@9: refer->ubnd = refer->lbnd; alpar@9: else alpar@9: refer->ubnd = eval_numeric(mpl, var->ubnd); alpar@9: /* nullify working quantity */ alpar@9: refer->temp = 0.0; alpar@9: #if 1 /* 15/V-2010 */ alpar@9: /* solution has not been obtained by the solver yet */ alpar@9: refer->stat = 0; alpar@9: refer->prim = refer->dual = 0.0; alpar@9: #endif alpar@9: } alpar@9: return refer; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_member_var - evaluate reference to elemental variable. alpar@9: -- alpar@9: -- This routine evaluates a reference to elemental variable assigned to alpar@9: -- member of specified model variable and returns it on exit. */ alpar@9: alpar@9: struct eval_var_info alpar@9: { /* working info used by the routine eval_member_var */ alpar@9: VARIABLE *var; alpar@9: /* model variable */ alpar@9: TUPLE *tuple; alpar@9: /* n-tuple, which defines variable member */ alpar@9: ELEMVAR *refer; alpar@9: /* evaluated reference to elemental variable */ alpar@9: }; alpar@9: alpar@9: static void eval_var_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: struct eval_var_info *info = _info; alpar@9: info->refer = take_member_var(mpl, info->var, info->tuple); alpar@9: return; alpar@9: } alpar@9: alpar@9: ELEMVAR *eval_member_var /* returns reference */ alpar@9: ( MPL *mpl, alpar@9: VARIABLE *var, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { /* this routine evaluates variable member */ alpar@9: struct eval_var_info _info, *info = &_info; alpar@9: xassert(var->dim == tuple_dimen(mpl, tuple)); alpar@9: info->var = var; alpar@9: info->tuple = tuple; alpar@9: /* evaluate member, which has given n-tuple */ alpar@9: if (eval_within_domain(mpl, info->var->domain, info->tuple, info, alpar@9: eval_var_func)) alpar@9: out_of_domain(mpl, var->name, info->tuple); alpar@9: /* bring evaluated reference to the calling program */ alpar@9: return info->refer; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_whole_var - evaluate model variable over entire domain. alpar@9: -- alpar@9: -- This routine evaluates all members of specified model variable over alpar@9: -- entire domain. */ alpar@9: alpar@9: static int whole_var_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: VARIABLE *var = (VARIABLE *)info; alpar@9: TUPLE *tuple = get_domain_tuple(mpl, var->domain); alpar@9: eval_member_var(mpl, var, tuple); alpar@9: delete_tuple(mpl, tuple); alpar@9: return 0; alpar@9: } alpar@9: alpar@9: void eval_whole_var(MPL *mpl, VARIABLE *var) alpar@9: { loop_within_domain(mpl, var->domain, var, whole_var_func); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_variable - clean model variable. alpar@9: -- alpar@9: -- This routine cleans specified model variable that assumes deleting alpar@9: -- all stuff dynamically allocated during the generation phase. */ alpar@9: alpar@9: void clean_variable(MPL *mpl, VARIABLE *var) alpar@9: { MEMBER *memb; alpar@9: /* clean subscript domain */ alpar@9: clean_domain(mpl, var->domain); alpar@9: /* clean code for computing lower bound */ alpar@9: clean_code(mpl, var->lbnd); alpar@9: /* clean code for computing upper bound */ alpar@9: if (var->ubnd != var->lbnd) clean_code(mpl, var->ubnd); alpar@9: /* delete content array */ alpar@9: for (memb = var->array->head; memb != NULL; memb = memb->next) alpar@9: dmp_free_atom(mpl->elemvars, memb->value.var, sizeof(ELEMVAR)); alpar@9: delete_array(mpl, var->array), var->array = NULL; alpar@9: return; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * MODEL CONSTRAINTS AND OBJECTIVES * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- take_member_con - obtain reference to elemental constraint. alpar@9: -- alpar@9: -- This routine obtains a reference to elemental constraint assigned alpar@9: -- to given member of specified model constraint and returns it on exit. alpar@9: -- If necessary, new elemental constraint is created. alpar@9: -- alpar@9: -- NOTE: This routine must not be called out of domain scope. */ alpar@9: alpar@9: ELEMCON *take_member_con /* returns reference */ alpar@9: ( MPL *mpl, alpar@9: CONSTRAINT *con, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { MEMBER *memb; alpar@9: ELEMCON *refer; alpar@9: /* find member in the constraint array */ alpar@9: memb = find_member(mpl, con->array, tuple); alpar@9: if (memb != NULL) alpar@9: { /* member exists, so just take the reference */ alpar@9: refer = memb->value.con; alpar@9: } alpar@9: else alpar@9: { /* member is referenced for the first time and therefore does alpar@9: not exist; create new elemental constraint, assign it to new alpar@9: member, and add the member to the constraint array */ alpar@9: memb = add_member(mpl, con->array, copy_tuple(mpl, tuple)); alpar@9: refer = (memb->value.con = alpar@9: dmp_get_atom(mpl->elemcons, sizeof(ELEMCON))); alpar@9: refer->i = 0; alpar@9: refer->con = con; alpar@9: refer->memb = memb; alpar@9: /* compute linear form */ alpar@9: xassert(con->code != NULL); alpar@9: refer->form = eval_formula(mpl, con->code); alpar@9: /* compute lower and upper bounds */ alpar@9: if (con->lbnd == NULL && con->ubnd == NULL) alpar@9: { /* objective has no bounds */ alpar@9: double temp; alpar@9: xassert(con->type == A_MINIMIZE || con->type == A_MAXIMIZE); alpar@9: /* carry the constant term to the right-hand side */ alpar@9: refer->form = remove_constant(mpl, refer->form, &temp); alpar@9: refer->lbnd = refer->ubnd = - temp; alpar@9: } alpar@9: else if (con->lbnd != NULL && con->ubnd == NULL) alpar@9: { /* constraint a * x + b >= c * y + d is transformed to the alpar@9: standard form a * x - c * y >= d - b */ alpar@9: double temp; alpar@9: xassert(con->type == A_CONSTRAINT); alpar@9: refer->form = linear_comb(mpl, alpar@9: +1.0, refer->form, alpar@9: -1.0, eval_formula(mpl, con->lbnd)); alpar@9: refer->form = remove_constant(mpl, refer->form, &temp); alpar@9: refer->lbnd = - temp; alpar@9: refer->ubnd = 0.0; alpar@9: } alpar@9: else if (con->lbnd == NULL && con->ubnd != NULL) alpar@9: { /* constraint a * x + b <= c * y + d is transformed to the alpar@9: standard form a * x - c * y <= d - b */ alpar@9: double temp; alpar@9: xassert(con->type == A_CONSTRAINT); alpar@9: refer->form = linear_comb(mpl, alpar@9: +1.0, refer->form, alpar@9: -1.0, eval_formula(mpl, con->ubnd)); alpar@9: refer->form = remove_constant(mpl, refer->form, &temp); alpar@9: refer->lbnd = 0.0; alpar@9: refer->ubnd = - temp; alpar@9: } alpar@9: else if (con->lbnd == con->ubnd) alpar@9: { /* constraint a * x + b = c * y + d is transformed to the alpar@9: standard form a * x - c * y = d - b */ alpar@9: double temp; alpar@9: xassert(con->type == A_CONSTRAINT); alpar@9: refer->form = linear_comb(mpl, alpar@9: +1.0, refer->form, alpar@9: -1.0, eval_formula(mpl, con->lbnd)); alpar@9: refer->form = remove_constant(mpl, refer->form, &temp); alpar@9: refer->lbnd = refer->ubnd = - temp; alpar@9: } alpar@9: else alpar@9: { /* ranged constraint c <= a * x + b <= d is transformed to alpar@9: the standard form c - b <= a * x <= d - b */ alpar@9: double temp, temp1, temp2; alpar@9: xassert(con->type == A_CONSTRAINT); alpar@9: refer->form = remove_constant(mpl, refer->form, &temp); alpar@9: xassert(remove_constant(mpl, eval_formula(mpl, con->lbnd), alpar@9: &temp1) == NULL); alpar@9: xassert(remove_constant(mpl, eval_formula(mpl, con->ubnd), alpar@9: &temp2) == NULL); alpar@9: refer->lbnd = fp_sub(mpl, temp1, temp); alpar@9: refer->ubnd = fp_sub(mpl, temp2, temp); alpar@9: } alpar@9: #if 1 /* 15/V-2010 */ alpar@9: /* solution has not been obtained by the solver yet */ alpar@9: refer->stat = 0; alpar@9: refer->prim = refer->dual = 0.0; alpar@9: #endif alpar@9: } alpar@9: return refer; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_member_con - evaluate reference to elemental constraint. alpar@9: -- alpar@9: -- This routine evaluates a reference to elemental constraint assigned alpar@9: -- to member of specified model constraint and returns it on exit. */ alpar@9: alpar@9: struct eval_con_info alpar@9: { /* working info used by the routine eval_member_con */ alpar@9: CONSTRAINT *con; alpar@9: /* model constraint */ alpar@9: TUPLE *tuple; alpar@9: /* n-tuple, which defines constraint member */ alpar@9: ELEMCON *refer; alpar@9: /* evaluated reference to elemental constraint */ alpar@9: }; alpar@9: alpar@9: static void eval_con_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: struct eval_con_info *info = _info; alpar@9: info->refer = take_member_con(mpl, info->con, info->tuple); alpar@9: return; alpar@9: } alpar@9: alpar@9: ELEMCON *eval_member_con /* returns reference */ alpar@9: ( MPL *mpl, alpar@9: CONSTRAINT *con, /* not changed */ alpar@9: TUPLE *tuple /* not changed */ alpar@9: ) alpar@9: { /* this routine evaluates constraint member */ alpar@9: struct eval_con_info _info, *info = &_info; alpar@9: xassert(con->dim == tuple_dimen(mpl, tuple)); alpar@9: info->con = con; alpar@9: info->tuple = tuple; alpar@9: /* evaluate member, which has given n-tuple */ alpar@9: if (eval_within_domain(mpl, info->con->domain, info->tuple, info, alpar@9: eval_con_func)) alpar@9: out_of_domain(mpl, con->name, info->tuple); alpar@9: /* bring evaluated reference to the calling program */ alpar@9: return info->refer; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_whole_con - evaluate model constraint over entire domain. alpar@9: -- alpar@9: -- This routine evaluates all members of specified model constraint over alpar@9: -- entire domain. */ alpar@9: alpar@9: static int whole_con_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: CONSTRAINT *con = (CONSTRAINT *)info; alpar@9: TUPLE *tuple = get_domain_tuple(mpl, con->domain); alpar@9: eval_member_con(mpl, con, tuple); alpar@9: delete_tuple(mpl, tuple); alpar@9: return 0; alpar@9: } alpar@9: alpar@9: void eval_whole_con(MPL *mpl, CONSTRAINT *con) alpar@9: { loop_within_domain(mpl, con->domain, con, whole_con_func); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_constraint - clean model constraint. alpar@9: -- alpar@9: -- This routine cleans specified model constraint that assumes deleting alpar@9: -- all stuff dynamically allocated during the generation phase. */ alpar@9: alpar@9: void clean_constraint(MPL *mpl, CONSTRAINT *con) alpar@9: { MEMBER *memb; alpar@9: /* clean subscript domain */ alpar@9: clean_domain(mpl, con->domain); alpar@9: /* clean code for computing main linear form */ alpar@9: clean_code(mpl, con->code); alpar@9: /* clean code for computing lower bound */ alpar@9: clean_code(mpl, con->lbnd); alpar@9: /* clean code for computing upper bound */ alpar@9: if (con->ubnd != con->lbnd) clean_code(mpl, con->ubnd); alpar@9: /* delete content array */ alpar@9: for (memb = con->array->head; memb != NULL; memb = memb->next) alpar@9: { delete_formula(mpl, memb->value.con->form); alpar@9: dmp_free_atom(mpl->elemcons, memb->value.con, sizeof(ELEMCON)); alpar@9: } alpar@9: delete_array(mpl, con->array), con->array = NULL; alpar@9: return; alpar@9: } alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * PSEUDO-CODE * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_numeric - evaluate pseudo-code to determine numeric value. alpar@9: -- alpar@9: -- This routine evaluates specified pseudo-code to determine resultant alpar@9: -- numeric value, which is returned on exit. */ alpar@9: alpar@9: struct iter_num_info alpar@9: { /* working info used by the routine iter_num_func */ alpar@9: CODE *code; alpar@9: /* pseudo-code for iterated operation to be performed */ alpar@9: double value; alpar@9: /* resultant value */ alpar@9: }; alpar@9: alpar@9: static int iter_num_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine used to perform iterated operation alpar@9: on numeric "integrand" within domain scope */ alpar@9: struct iter_num_info *info = _info; alpar@9: double temp; alpar@9: temp = eval_numeric(mpl, info->code->arg.loop.x); alpar@9: switch (info->code->op) alpar@9: { case O_SUM: alpar@9: /* summation over domain */ alpar@9: info->value = fp_add(mpl, info->value, temp); alpar@9: break; alpar@9: case O_PROD: alpar@9: /* multiplication over domain */ alpar@9: info->value = fp_mul(mpl, info->value, temp); alpar@9: break; alpar@9: case O_MINIMUM: alpar@9: /* minimum over domain */ alpar@9: if (info->value > temp) info->value = temp; alpar@9: break; alpar@9: case O_MAXIMUM: alpar@9: /* maximum over domain */ alpar@9: if (info->value < temp) info->value = temp; alpar@9: break; alpar@9: default: alpar@9: xassert(info != info); alpar@9: } alpar@9: return 0; alpar@9: } alpar@9: alpar@9: double eval_numeric(MPL *mpl, CODE *code) alpar@9: { double value; alpar@9: xassert(code != NULL); alpar@9: xassert(code->type == A_NUMERIC); alpar@9: xassert(code->dim == 0); alpar@9: /* if the operation has a side effect, invalidate and delete the alpar@9: resultant value */ alpar@9: if (code->vflag && code->valid) alpar@9: { code->valid = 0; alpar@9: delete_value(mpl, code->type, &code->value); alpar@9: } alpar@9: /* if resultant value is valid, no evaluation is needed */ alpar@9: if (code->valid) alpar@9: { value = code->value.num; alpar@9: goto done; alpar@9: } alpar@9: /* evaluate pseudo-code recursively */ alpar@9: switch (code->op) alpar@9: { case O_NUMBER: alpar@9: /* take floating-point number */ alpar@9: value = code->arg.num; alpar@9: break; alpar@9: case O_MEMNUM: alpar@9: /* take member of numeric parameter */ alpar@9: { TUPLE *tuple; alpar@9: ARG_LIST *e; alpar@9: tuple = create_tuple(mpl); alpar@9: for (e = code->arg.par.list; e != NULL; e = e->next) alpar@9: tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: value = eval_member_num(mpl, code->arg.par.par, tuple); alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: case O_MEMVAR: alpar@9: /* take computed value of elemental variable */ alpar@9: { TUPLE *tuple; alpar@9: ARG_LIST *e; alpar@9: #if 1 /* 15/V-2010 */ alpar@9: ELEMVAR *var; alpar@9: #endif alpar@9: tuple = create_tuple(mpl); alpar@9: for (e = code->arg.var.list; e != NULL; e = e->next) alpar@9: tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: #if 0 /* 15/V-2010 */ alpar@9: value = eval_member_var(mpl, code->arg.var.var, tuple) alpar@9: ->value; alpar@9: #else alpar@9: var = eval_member_var(mpl, code->arg.var.var, tuple); alpar@9: switch (code->arg.var.suff) alpar@9: { case DOT_LB: alpar@9: if (var->var->lbnd == NULL) alpar@9: value = -DBL_MAX; alpar@9: else alpar@9: value = var->lbnd; alpar@9: break; alpar@9: case DOT_UB: alpar@9: if (var->var->ubnd == NULL) alpar@9: value = +DBL_MAX; alpar@9: else alpar@9: value = var->ubnd; alpar@9: break; alpar@9: case DOT_STATUS: alpar@9: value = var->stat; alpar@9: break; alpar@9: case DOT_VAL: alpar@9: value = var->prim; alpar@9: break; alpar@9: case DOT_DUAL: alpar@9: value = var->dual; alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: #endif alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: #if 1 /* 15/V-2010 */ alpar@9: case O_MEMCON: alpar@9: /* take computed value of elemental constraint */ alpar@9: { TUPLE *tuple; alpar@9: ARG_LIST *e; alpar@9: ELEMCON *con; alpar@9: tuple = create_tuple(mpl); alpar@9: for (e = code->arg.con.list; e != NULL; e = e->next) alpar@9: tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: con = eval_member_con(mpl, code->arg.con.con, tuple); alpar@9: switch (code->arg.con.suff) alpar@9: { case DOT_LB: alpar@9: if (con->con->lbnd == NULL) alpar@9: value = -DBL_MAX; alpar@9: else alpar@9: value = con->lbnd; alpar@9: break; alpar@9: case DOT_UB: alpar@9: if (con->con->ubnd == NULL) alpar@9: value = +DBL_MAX; alpar@9: else alpar@9: value = con->ubnd; alpar@9: break; alpar@9: case DOT_STATUS: alpar@9: value = con->stat; alpar@9: break; alpar@9: case DOT_VAL: alpar@9: value = con->prim; alpar@9: break; alpar@9: case DOT_DUAL: alpar@9: value = con->dual; alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: #endif alpar@9: case O_IRAND224: alpar@9: /* pseudo-random in [0, 2^24-1] */ alpar@9: value = fp_irand224(mpl); alpar@9: break; alpar@9: case O_UNIFORM01: alpar@9: /* pseudo-random in [0, 1) */ alpar@9: value = fp_uniform01(mpl); alpar@9: break; alpar@9: case O_NORMAL01: alpar@9: /* gaussian random, mu = 0, sigma = 1 */ alpar@9: value = fp_normal01(mpl); alpar@9: break; alpar@9: case O_GMTIME: alpar@9: /* current calendar time */ alpar@9: value = fn_gmtime(mpl); alpar@9: break; alpar@9: case O_CVTNUM: alpar@9: /* conversion to numeric */ alpar@9: { SYMBOL *sym; alpar@9: sym = eval_symbolic(mpl, code->arg.arg.x); alpar@9: #if 0 /* 23/XI-2008 */ alpar@9: if (sym->str != NULL) alpar@9: error(mpl, "cannot convert %s to floating-point numbe" alpar@9: "r", format_symbol(mpl, sym)); alpar@9: value = sym->num; alpar@9: #else alpar@9: if (sym->str == NULL) alpar@9: value = sym->num; alpar@9: else alpar@9: { if (str2num(sym->str, &value)) alpar@9: error(mpl, "cannot convert %s to floating-point nu" alpar@9: "mber", format_symbol(mpl, sym)); alpar@9: } alpar@9: #endif alpar@9: delete_symbol(mpl, sym); alpar@9: } alpar@9: break; alpar@9: case O_PLUS: alpar@9: /* unary plus */ alpar@9: value = + eval_numeric(mpl, code->arg.arg.x); alpar@9: break; alpar@9: case O_MINUS: alpar@9: /* unary minus */ alpar@9: value = - eval_numeric(mpl, code->arg.arg.x); alpar@9: break; alpar@9: case O_ABS: alpar@9: /* absolute value */ alpar@9: value = fabs(eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_CEIL: alpar@9: /* round upward ("ceiling of x") */ alpar@9: value = ceil(eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_FLOOR: alpar@9: /* round downward ("floor of x") */ alpar@9: value = floor(eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_EXP: alpar@9: /* base-e exponential */ alpar@9: value = fp_exp(mpl, eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_LOG: alpar@9: /* natural logarithm */ alpar@9: value = fp_log(mpl, eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_LOG10: alpar@9: /* common (decimal) logarithm */ alpar@9: value = fp_log10(mpl, eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_SQRT: alpar@9: /* square root */ alpar@9: value = fp_sqrt(mpl, eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_SIN: alpar@9: /* trigonometric sine */ alpar@9: value = fp_sin(mpl, eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_COS: alpar@9: /* trigonometric cosine */ alpar@9: value = fp_cos(mpl, eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_ATAN: alpar@9: /* trigonometric arctangent (one argument) */ alpar@9: value = fp_atan(mpl, eval_numeric(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_ATAN2: alpar@9: /* trigonometric arctangent (two arguments) */ alpar@9: value = fp_atan2(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_ROUND: alpar@9: /* round to nearest integer */ alpar@9: value = fp_round(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), 0.0); alpar@9: break; alpar@9: case O_ROUND2: alpar@9: /* round to n fractional digits */ alpar@9: value = fp_round(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_TRUNC: alpar@9: /* truncate to nearest integer */ alpar@9: value = fp_trunc(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), 0.0); alpar@9: break; alpar@9: case O_TRUNC2: alpar@9: /* truncate to n fractional digits */ alpar@9: value = fp_trunc(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_ADD: alpar@9: /* addition */ alpar@9: value = fp_add(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_SUB: alpar@9: /* subtraction */ alpar@9: value = fp_sub(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_LESS: alpar@9: /* non-negative subtraction */ alpar@9: value = fp_less(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_MUL: alpar@9: /* multiplication */ alpar@9: value = fp_mul(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_DIV: alpar@9: /* division */ alpar@9: value = fp_div(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_IDIV: alpar@9: /* quotient of exact division */ alpar@9: value = fp_idiv(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_MOD: alpar@9: /* remainder of exact division */ alpar@9: value = fp_mod(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_POWER: alpar@9: /* exponentiation (raise to power) */ alpar@9: value = fp_power(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_UNIFORM: alpar@9: /* pseudo-random in [a, b) */ alpar@9: value = fp_uniform(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_NORMAL: alpar@9: /* gaussian random, given mu and sigma */ alpar@9: value = fp_normal(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_CARD: alpar@9: { ELEMSET *set; alpar@9: set = eval_elemset(mpl, code->arg.arg.x); alpar@9: value = set->size; alpar@9: delete_array(mpl, set); alpar@9: } alpar@9: break; alpar@9: case O_LENGTH: alpar@9: { SYMBOL *sym; alpar@9: char str[MAX_LENGTH+1]; alpar@9: sym = eval_symbolic(mpl, code->arg.arg.x); alpar@9: if (sym->str == NULL) alpar@9: sprintf(str, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: fetch_string(mpl, sym->str, str); alpar@9: delete_symbol(mpl, sym); alpar@9: value = strlen(str); alpar@9: } alpar@9: break; alpar@9: case O_STR2TIME: alpar@9: { SYMBOL *sym; alpar@9: char str[MAX_LENGTH+1], fmt[MAX_LENGTH+1]; alpar@9: sym = eval_symbolic(mpl, code->arg.arg.x); alpar@9: if (sym->str == NULL) alpar@9: sprintf(str, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: fetch_string(mpl, sym->str, str); alpar@9: delete_symbol(mpl, sym); alpar@9: sym = eval_symbolic(mpl, code->arg.arg.y); alpar@9: if (sym->str == NULL) alpar@9: sprintf(fmt, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: fetch_string(mpl, sym->str, fmt); alpar@9: delete_symbol(mpl, sym); alpar@9: value = fn_str2time(mpl, str, fmt); alpar@9: } alpar@9: break; alpar@9: case O_FORK: alpar@9: /* if-then-else */ alpar@9: if (eval_logical(mpl, code->arg.arg.x)) alpar@9: value = eval_numeric(mpl, code->arg.arg.y); alpar@9: else if (code->arg.arg.z == NULL) alpar@9: value = 0.0; alpar@9: else alpar@9: value = eval_numeric(mpl, code->arg.arg.z); alpar@9: break; alpar@9: case O_MIN: alpar@9: /* minimal value (n-ary) */ alpar@9: { ARG_LIST *e; alpar@9: double temp; alpar@9: value = +DBL_MAX; alpar@9: for (e = code->arg.list; e != NULL; e = e->next) alpar@9: { temp = eval_numeric(mpl, e->x); alpar@9: if (value > temp) value = temp; alpar@9: } alpar@9: } alpar@9: break; alpar@9: case O_MAX: alpar@9: /* maximal value (n-ary) */ alpar@9: { ARG_LIST *e; alpar@9: double temp; alpar@9: value = -DBL_MAX; alpar@9: for (e = code->arg.list; e != NULL; e = e->next) alpar@9: { temp = eval_numeric(mpl, e->x); alpar@9: if (value < temp) value = temp; alpar@9: } alpar@9: } alpar@9: break; alpar@9: case O_SUM: alpar@9: /* summation over domain */ alpar@9: { struct iter_num_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = 0.0; alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_num_func); alpar@9: value = info->value; alpar@9: } alpar@9: break; alpar@9: case O_PROD: alpar@9: /* multiplication over domain */ alpar@9: { struct iter_num_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = 1.0; alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_num_func); alpar@9: value = info->value; alpar@9: } alpar@9: break; alpar@9: case O_MINIMUM: alpar@9: /* minimum over domain */ alpar@9: { struct iter_num_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = +DBL_MAX; alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_num_func); alpar@9: if (info->value == +DBL_MAX) alpar@9: error(mpl, "min{} over empty set; result undefined"); alpar@9: value = info->value; alpar@9: } alpar@9: break; alpar@9: case O_MAXIMUM: alpar@9: /* maximum over domain */ alpar@9: { struct iter_num_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = -DBL_MAX; alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_num_func); alpar@9: if (info->value == -DBL_MAX) alpar@9: error(mpl, "max{} over empty set; result undefined"); alpar@9: value = info->value; alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: /* save resultant value */ alpar@9: xassert(!code->valid); alpar@9: code->valid = 1; alpar@9: code->value.num = value; alpar@9: done: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_symbolic - evaluate pseudo-code to determine symbolic value. alpar@9: -- alpar@9: -- This routine evaluates specified pseudo-code to determine resultant alpar@9: -- symbolic value, which is returned on exit. */ alpar@9: alpar@9: SYMBOL *eval_symbolic(MPL *mpl, CODE *code) alpar@9: { SYMBOL *value; alpar@9: xassert(code != NULL); alpar@9: xassert(code->type == A_SYMBOLIC); alpar@9: xassert(code->dim == 0); alpar@9: /* if the operation has a side effect, invalidate and delete the alpar@9: resultant value */ alpar@9: if (code->vflag && code->valid) alpar@9: { code->valid = 0; alpar@9: delete_value(mpl, code->type, &code->value); alpar@9: } alpar@9: /* if resultant value is valid, no evaluation is needed */ alpar@9: if (code->valid) alpar@9: { value = copy_symbol(mpl, code->value.sym); alpar@9: goto done; alpar@9: } alpar@9: /* evaluate pseudo-code recursively */ alpar@9: switch (code->op) alpar@9: { case O_STRING: alpar@9: /* take character string */ alpar@9: value = create_symbol_str(mpl, create_string(mpl, alpar@9: code->arg.str)); alpar@9: break; alpar@9: case O_INDEX: alpar@9: /* take dummy index */ alpar@9: xassert(code->arg.index.slot->value != NULL); alpar@9: value = copy_symbol(mpl, code->arg.index.slot->value); alpar@9: break; alpar@9: case O_MEMSYM: alpar@9: /* take member of symbolic parameter */ alpar@9: { TUPLE *tuple; alpar@9: ARG_LIST *e; alpar@9: tuple = create_tuple(mpl); alpar@9: for (e = code->arg.par.list; e != NULL; e = e->next) alpar@9: tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: value = eval_member_sym(mpl, code->arg.par.par, tuple); alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: case O_CVTSYM: alpar@9: /* conversion to symbolic */ alpar@9: value = create_symbol_num(mpl, eval_numeric(mpl, alpar@9: code->arg.arg.x)); alpar@9: break; alpar@9: case O_CONCAT: alpar@9: /* concatenation */ alpar@9: value = concat_symbols(mpl, alpar@9: eval_symbolic(mpl, code->arg.arg.x), alpar@9: eval_symbolic(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_FORK: alpar@9: /* if-then-else */ alpar@9: if (eval_logical(mpl, code->arg.arg.x)) alpar@9: value = eval_symbolic(mpl, code->arg.arg.y); alpar@9: else if (code->arg.arg.z == NULL) alpar@9: value = create_symbol_num(mpl, 0.0); alpar@9: else alpar@9: value = eval_symbolic(mpl, code->arg.arg.z); alpar@9: break; alpar@9: case O_SUBSTR: alpar@9: case O_SUBSTR3: alpar@9: { double pos, len; alpar@9: char str[MAX_LENGTH+1]; alpar@9: value = eval_symbolic(mpl, code->arg.arg.x); alpar@9: if (value->str == NULL) alpar@9: sprintf(str, "%.*g", DBL_DIG, value->num); alpar@9: else alpar@9: fetch_string(mpl, value->str, str); alpar@9: delete_symbol(mpl, value); alpar@9: if (code->op == O_SUBSTR) alpar@9: { pos = eval_numeric(mpl, code->arg.arg.y); alpar@9: if (pos != floor(pos)) alpar@9: error(mpl, "substr('...', %.*g); non-integer secon" alpar@9: "d argument", DBL_DIG, pos); alpar@9: if (pos < 1 || pos > strlen(str) + 1) alpar@9: error(mpl, "substr('...', %.*g); substring out of " alpar@9: "range", DBL_DIG, pos); alpar@9: } alpar@9: else alpar@9: { pos = eval_numeric(mpl, code->arg.arg.y); alpar@9: len = eval_numeric(mpl, code->arg.arg.z); alpar@9: if (pos != floor(pos) || len != floor(len)) alpar@9: error(mpl, "substr('...', %.*g, %.*g); non-integer" alpar@9: " second and/or third argument", DBL_DIG, pos, alpar@9: DBL_DIG, len); alpar@9: if (pos < 1 || len < 0 || pos + len > strlen(str) + 1) alpar@9: error(mpl, "substr('...', %.*g, %.*g); substring o" alpar@9: "ut of range", DBL_DIG, pos, DBL_DIG, len); alpar@9: str[(int)pos + (int)len - 1] = '\0'; alpar@9: } alpar@9: value = create_symbol_str(mpl, create_string(mpl, str + alpar@9: (int)pos - 1)); alpar@9: } alpar@9: break; alpar@9: case O_TIME2STR: alpar@9: { double num; alpar@9: SYMBOL *sym; alpar@9: char str[MAX_LENGTH+1], fmt[MAX_LENGTH+1]; alpar@9: num = eval_numeric(mpl, code->arg.arg.x); alpar@9: sym = eval_symbolic(mpl, code->arg.arg.y); alpar@9: if (sym->str == NULL) alpar@9: sprintf(fmt, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: fetch_string(mpl, sym->str, fmt); alpar@9: delete_symbol(mpl, sym); alpar@9: fn_time2str(mpl, str, num, fmt); alpar@9: value = create_symbol_str(mpl, create_string(mpl, str)); alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: /* save resultant value */ alpar@9: xassert(!code->valid); alpar@9: code->valid = 1; alpar@9: code->value.sym = copy_symbol(mpl, value); alpar@9: done: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_logical - evaluate pseudo-code to determine logical value. alpar@9: -- alpar@9: -- This routine evaluates specified pseudo-code to determine resultant alpar@9: -- logical value, which is returned on exit. */ alpar@9: alpar@9: struct iter_log_info alpar@9: { /* working info used by the routine iter_log_func */ alpar@9: CODE *code; alpar@9: /* pseudo-code for iterated operation to be performed */ alpar@9: int value; alpar@9: /* resultant value */ alpar@9: }; alpar@9: alpar@9: static int iter_log_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine used to perform iterated operation alpar@9: on logical "integrand" within domain scope */ alpar@9: struct iter_log_info *info = _info; alpar@9: int ret = 0; alpar@9: switch (info->code->op) alpar@9: { case O_FORALL: alpar@9: /* conjunction over domain */ alpar@9: info->value &= eval_logical(mpl, info->code->arg.loop.x); alpar@9: if (!info->value) ret = 1; alpar@9: break; alpar@9: case O_EXISTS: alpar@9: /* disjunction over domain */ alpar@9: info->value |= eval_logical(mpl, info->code->arg.loop.x); alpar@9: if (info->value) ret = 1; alpar@9: break; alpar@9: default: alpar@9: xassert(info != info); alpar@9: } alpar@9: return ret; alpar@9: } alpar@9: alpar@9: int eval_logical(MPL *mpl, CODE *code) alpar@9: { int value; alpar@9: xassert(code->type == A_LOGICAL); alpar@9: xassert(code->dim == 0); alpar@9: /* if the operation has a side effect, invalidate and delete the alpar@9: resultant value */ alpar@9: if (code->vflag && code->valid) alpar@9: { code->valid = 0; alpar@9: delete_value(mpl, code->type, &code->value); alpar@9: } alpar@9: /* if resultant value is valid, no evaluation is needed */ alpar@9: if (code->valid) alpar@9: { value = code->value.bit; alpar@9: goto done; alpar@9: } alpar@9: /* evaluate pseudo-code recursively */ alpar@9: switch (code->op) alpar@9: { case O_CVTLOG: alpar@9: /* conversion to logical */ alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) != 0.0); alpar@9: break; alpar@9: case O_NOT: alpar@9: /* negation (logical "not") */ alpar@9: value = !eval_logical(mpl, code->arg.arg.x); alpar@9: break; alpar@9: case O_LT: alpar@9: /* comparison on 'less than' */ alpar@9: #if 0 /* 02/VIII-2008 */ alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) < alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: #else alpar@9: xassert(code->arg.arg.x != NULL); alpar@9: if (code->arg.arg.x->type == A_NUMERIC) alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) < alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: else alpar@9: { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x); alpar@9: SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y); alpar@9: value = (compare_symbols(mpl, sym1, sym2) < 0); alpar@9: delete_symbol(mpl, sym1); alpar@9: delete_symbol(mpl, sym2); alpar@9: } alpar@9: #endif alpar@9: break; alpar@9: case O_LE: alpar@9: /* comparison on 'not greater than' */ alpar@9: #if 0 /* 02/VIII-2008 */ alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) <= alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: #else alpar@9: xassert(code->arg.arg.x != NULL); alpar@9: if (code->arg.arg.x->type == A_NUMERIC) alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) <= alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: else alpar@9: { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x); alpar@9: SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y); alpar@9: value = (compare_symbols(mpl, sym1, sym2) <= 0); alpar@9: delete_symbol(mpl, sym1); alpar@9: delete_symbol(mpl, sym2); alpar@9: } alpar@9: #endif alpar@9: break; alpar@9: case O_EQ: alpar@9: /* comparison on 'equal to' */ alpar@9: xassert(code->arg.arg.x != NULL); alpar@9: if (code->arg.arg.x->type == A_NUMERIC) alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) == alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: else alpar@9: { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x); alpar@9: SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y); alpar@9: value = (compare_symbols(mpl, sym1, sym2) == 0); alpar@9: delete_symbol(mpl, sym1); alpar@9: delete_symbol(mpl, sym2); alpar@9: } alpar@9: break; alpar@9: case O_GE: alpar@9: /* comparison on 'not less than' */ alpar@9: #if 0 /* 02/VIII-2008 */ alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) >= alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: #else alpar@9: xassert(code->arg.arg.x != NULL); alpar@9: if (code->arg.arg.x->type == A_NUMERIC) alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) >= alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: else alpar@9: { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x); alpar@9: SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y); alpar@9: value = (compare_symbols(mpl, sym1, sym2) >= 0); alpar@9: delete_symbol(mpl, sym1); alpar@9: delete_symbol(mpl, sym2); alpar@9: } alpar@9: #endif alpar@9: break; alpar@9: case O_GT: alpar@9: /* comparison on 'greater than' */ alpar@9: #if 0 /* 02/VIII-2008 */ alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) > alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: #else alpar@9: xassert(code->arg.arg.x != NULL); alpar@9: if (code->arg.arg.x->type == A_NUMERIC) alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) > alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: else alpar@9: { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x); alpar@9: SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y); alpar@9: value = (compare_symbols(mpl, sym1, sym2) > 0); alpar@9: delete_symbol(mpl, sym1); alpar@9: delete_symbol(mpl, sym2); alpar@9: } alpar@9: #endif alpar@9: break; alpar@9: case O_NE: alpar@9: /* comparison on 'not equal to' */ alpar@9: xassert(code->arg.arg.x != NULL); alpar@9: if (code->arg.arg.x->type == A_NUMERIC) alpar@9: value = (eval_numeric(mpl, code->arg.arg.x) != alpar@9: eval_numeric(mpl, code->arg.arg.y)); alpar@9: else alpar@9: { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x); alpar@9: SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y); alpar@9: value = (compare_symbols(mpl, sym1, sym2) != 0); alpar@9: delete_symbol(mpl, sym1); alpar@9: delete_symbol(mpl, sym2); alpar@9: } alpar@9: break; alpar@9: case O_AND: alpar@9: /* conjunction (logical "and") */ alpar@9: value = eval_logical(mpl, code->arg.arg.x) && alpar@9: eval_logical(mpl, code->arg.arg.y); alpar@9: break; alpar@9: case O_OR: alpar@9: /* disjunction (logical "or") */ alpar@9: value = eval_logical(mpl, code->arg.arg.x) || alpar@9: eval_logical(mpl, code->arg.arg.y); alpar@9: break; alpar@9: case O_IN: alpar@9: /* test on 'x in Y' */ alpar@9: { TUPLE *tuple; alpar@9: tuple = eval_tuple(mpl, code->arg.arg.x); alpar@9: value = is_member(mpl, code->arg.arg.y, tuple); alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: case O_NOTIN: alpar@9: /* test on 'x not in Y' */ alpar@9: { TUPLE *tuple; alpar@9: tuple = eval_tuple(mpl, code->arg.arg.x); alpar@9: value = !is_member(mpl, code->arg.arg.y, tuple); alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: case O_WITHIN: alpar@9: /* test on 'X within Y' */ alpar@9: { ELEMSET *set; alpar@9: MEMBER *memb; alpar@9: set = eval_elemset(mpl, code->arg.arg.x); alpar@9: value = 1; alpar@9: for (memb = set->head; memb != NULL; memb = memb->next) alpar@9: { if (!is_member(mpl, code->arg.arg.y, memb->tuple)) alpar@9: { value = 0; alpar@9: break; alpar@9: } alpar@9: } alpar@9: delete_elemset(mpl, set); alpar@9: } alpar@9: break; alpar@9: case O_NOTWITHIN: alpar@9: /* test on 'X not within Y' */ alpar@9: { ELEMSET *set; alpar@9: MEMBER *memb; alpar@9: set = eval_elemset(mpl, code->arg.arg.x); alpar@9: value = 1; alpar@9: for (memb = set->head; memb != NULL; memb = memb->next) alpar@9: { if (is_member(mpl, code->arg.arg.y, memb->tuple)) alpar@9: { value = 0; alpar@9: break; alpar@9: } alpar@9: } alpar@9: delete_elemset(mpl, set); alpar@9: } alpar@9: break; alpar@9: case O_FORALL: alpar@9: /* conjunction (A-quantification) */ alpar@9: { struct iter_log_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = 1; alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_log_func); alpar@9: value = info->value; alpar@9: } alpar@9: break; alpar@9: case O_EXISTS: alpar@9: /* disjunction (E-quantification) */ alpar@9: { struct iter_log_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = 0; alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_log_func); alpar@9: value = info->value; alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: /* save resultant value */ alpar@9: xassert(!code->valid); alpar@9: code->valid = 1; alpar@9: code->value.bit = value; alpar@9: done: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_tuple - evaluate pseudo-code to construct n-tuple. alpar@9: -- alpar@9: -- This routine evaluates specified pseudo-code to construct resultant alpar@9: -- n-tuple, which is returned on exit. */ alpar@9: alpar@9: TUPLE *eval_tuple(MPL *mpl, CODE *code) alpar@9: { TUPLE *value; alpar@9: xassert(code != NULL); alpar@9: xassert(code->type == A_TUPLE); alpar@9: xassert(code->dim > 0); alpar@9: /* if the operation has a side effect, invalidate and delete the alpar@9: resultant value */ alpar@9: if (code->vflag && code->valid) alpar@9: { code->valid = 0; alpar@9: delete_value(mpl, code->type, &code->value); alpar@9: } alpar@9: /* if resultant value is valid, no evaluation is needed */ alpar@9: if (code->valid) alpar@9: { value = copy_tuple(mpl, code->value.tuple); alpar@9: goto done; alpar@9: } alpar@9: /* evaluate pseudo-code recursively */ alpar@9: switch (code->op) alpar@9: { case O_TUPLE: alpar@9: /* make n-tuple */ alpar@9: { ARG_LIST *e; alpar@9: value = create_tuple(mpl); alpar@9: for (e = code->arg.list; e != NULL; e = e->next) alpar@9: value = expand_tuple(mpl, value, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: } alpar@9: break; alpar@9: case O_CVTTUP: alpar@9: /* convert to 1-tuple */ alpar@9: value = expand_tuple(mpl, create_tuple(mpl), alpar@9: eval_symbolic(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: /* save resultant value */ alpar@9: xassert(!code->valid); alpar@9: code->valid = 1; alpar@9: code->value.tuple = copy_tuple(mpl, value); alpar@9: done: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_elemset - evaluate pseudo-code to construct elemental set. alpar@9: -- alpar@9: -- This routine evaluates specified pseudo-code to construct resultant alpar@9: -- elemental set, which is returned on exit. */ alpar@9: alpar@9: struct iter_set_info alpar@9: { /* working info used by the routine iter_set_func */ alpar@9: CODE *code; alpar@9: /* pseudo-code for iterated operation to be performed */ alpar@9: ELEMSET *value; alpar@9: /* resultant value */ alpar@9: }; alpar@9: alpar@9: static int iter_set_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine used to perform iterated operation alpar@9: on n-tuple "integrand" within domain scope */ alpar@9: struct iter_set_info *info = _info; alpar@9: TUPLE *tuple; alpar@9: switch (info->code->op) alpar@9: { case O_SETOF: alpar@9: /* compute next n-tuple and add it to the set; in this case alpar@9: duplicate n-tuples are silently ignored */ alpar@9: tuple = eval_tuple(mpl, info->code->arg.loop.x); alpar@9: if (find_tuple(mpl, info->value, tuple) == NULL) alpar@9: add_tuple(mpl, info->value, tuple); alpar@9: else alpar@9: delete_tuple(mpl, tuple); alpar@9: break; alpar@9: case O_BUILD: alpar@9: /* construct next n-tuple using current values assigned to alpar@9: *free* dummy indices as its components and add it to the alpar@9: set; in this case duplicate n-tuples cannot appear */ alpar@9: add_tuple(mpl, info->value, get_domain_tuple(mpl, alpar@9: info->code->arg.loop.domain)); alpar@9: break; alpar@9: default: alpar@9: xassert(info != info); alpar@9: } alpar@9: return 0; alpar@9: } alpar@9: alpar@9: ELEMSET *eval_elemset(MPL *mpl, CODE *code) alpar@9: { ELEMSET *value; alpar@9: xassert(code != NULL); alpar@9: xassert(code->type == A_ELEMSET); alpar@9: xassert(code->dim > 0); alpar@9: /* if the operation has a side effect, invalidate and delete the alpar@9: resultant value */ alpar@9: if (code->vflag && code->valid) alpar@9: { code->valid = 0; alpar@9: delete_value(mpl, code->type, &code->value); alpar@9: } alpar@9: /* if resultant value is valid, no evaluation is needed */ alpar@9: if (code->valid) alpar@9: { value = copy_elemset(mpl, code->value.set); alpar@9: goto done; alpar@9: } alpar@9: /* evaluate pseudo-code recursively */ alpar@9: switch (code->op) alpar@9: { case O_MEMSET: alpar@9: /* take member of set */ alpar@9: { TUPLE *tuple; alpar@9: ARG_LIST *e; alpar@9: tuple = create_tuple(mpl); alpar@9: for (e = code->arg.set.list; e != NULL; e = e->next) alpar@9: tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: value = copy_elemset(mpl, alpar@9: eval_member_set(mpl, code->arg.set.set, tuple)); alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: case O_MAKE: alpar@9: /* make elemental set of n-tuples */ alpar@9: { ARG_LIST *e; alpar@9: value = create_elemset(mpl, code->dim); alpar@9: for (e = code->arg.list; e != NULL; e = e->next) alpar@9: check_then_add(mpl, value, eval_tuple(mpl, e->x)); alpar@9: } alpar@9: break; alpar@9: case O_UNION: alpar@9: /* union of two elemental sets */ alpar@9: value = set_union(mpl, alpar@9: eval_elemset(mpl, code->arg.arg.x), alpar@9: eval_elemset(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_DIFF: alpar@9: /* difference between two elemental sets */ alpar@9: value = set_diff(mpl, alpar@9: eval_elemset(mpl, code->arg.arg.x), alpar@9: eval_elemset(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_SYMDIFF: alpar@9: /* symmetric difference between two elemental sets */ alpar@9: value = set_symdiff(mpl, alpar@9: eval_elemset(mpl, code->arg.arg.x), alpar@9: eval_elemset(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_INTER: alpar@9: /* intersection of two elemental sets */ alpar@9: value = set_inter(mpl, alpar@9: eval_elemset(mpl, code->arg.arg.x), alpar@9: eval_elemset(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_CROSS: alpar@9: /* cross (Cartesian) product of two elemental sets */ alpar@9: value = set_cross(mpl, alpar@9: eval_elemset(mpl, code->arg.arg.x), alpar@9: eval_elemset(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_DOTS: alpar@9: /* build "arithmetic" elemental set */ alpar@9: value = create_arelset(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_numeric(mpl, code->arg.arg.y), alpar@9: code->arg.arg.z == NULL ? 1.0 : eval_numeric(mpl, alpar@9: code->arg.arg.z)); alpar@9: break; alpar@9: case O_FORK: alpar@9: /* if-then-else */ alpar@9: if (eval_logical(mpl, code->arg.arg.x)) alpar@9: value = eval_elemset(mpl, code->arg.arg.y); alpar@9: else alpar@9: value = eval_elemset(mpl, code->arg.arg.z); alpar@9: break; alpar@9: case O_SETOF: alpar@9: /* compute elemental set */ alpar@9: { struct iter_set_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = create_elemset(mpl, code->dim); alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_set_func); alpar@9: value = info->value; alpar@9: } alpar@9: break; alpar@9: case O_BUILD: alpar@9: /* build elemental set identical to domain set */ alpar@9: { struct iter_set_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = create_elemset(mpl, code->dim); alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_set_func); alpar@9: value = info->value; alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: /* save resultant value */ alpar@9: xassert(!code->valid); alpar@9: code->valid = 1; alpar@9: code->value.set = copy_elemset(mpl, value); alpar@9: done: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- is_member - check if n-tuple is in set specified by pseudo-code. alpar@9: -- alpar@9: -- This routine checks if given n-tuple is a member of elemental set alpar@9: -- specified in the form of pseudo-code (i.e. by expression). alpar@9: -- alpar@9: -- The n-tuple may have more components that dimension of the elemental alpar@9: -- set, in which case the extra components are ignored. */ alpar@9: alpar@9: static void null_func(MPL *mpl, void *info) alpar@9: { /* this is dummy routine used to enter the domain scope */ alpar@9: xassert(mpl == mpl); alpar@9: xassert(info == NULL); alpar@9: return; alpar@9: } alpar@9: alpar@9: int is_member(MPL *mpl, CODE *code, TUPLE *tuple) alpar@9: { int value; alpar@9: xassert(code != NULL); alpar@9: xassert(code->type == A_ELEMSET); alpar@9: xassert(code->dim > 0); alpar@9: xassert(tuple != NULL); alpar@9: switch (code->op) alpar@9: { case O_MEMSET: alpar@9: /* check if given n-tuple is member of elemental set, which alpar@9: is assigned to member of model set */ alpar@9: { ARG_LIST *e; alpar@9: TUPLE *temp; alpar@9: ELEMSET *set; alpar@9: /* evaluate reference to elemental set */ alpar@9: temp = create_tuple(mpl); alpar@9: for (e = code->arg.set.list; e != NULL; e = e->next) alpar@9: temp = expand_tuple(mpl, temp, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: set = eval_member_set(mpl, code->arg.set.set, temp); alpar@9: delete_tuple(mpl, temp); alpar@9: /* check if the n-tuple is contained in the set array */ alpar@9: temp = build_subtuple(mpl, tuple, set->dim); alpar@9: value = (find_tuple(mpl, set, temp) != NULL); alpar@9: delete_tuple(mpl, temp); alpar@9: } alpar@9: break; alpar@9: case O_MAKE: alpar@9: /* check if given n-tuple is member of literal set */ alpar@9: { ARG_LIST *e; alpar@9: TUPLE *temp, *that; alpar@9: value = 0; alpar@9: temp = build_subtuple(mpl, tuple, code->dim); alpar@9: for (e = code->arg.list; e != NULL; e = e->next) alpar@9: { that = eval_tuple(mpl, e->x); alpar@9: value = (compare_tuples(mpl, temp, that) == 0); alpar@9: delete_tuple(mpl, that); alpar@9: if (value) break; alpar@9: } alpar@9: delete_tuple(mpl, temp); alpar@9: } alpar@9: break; alpar@9: case O_UNION: alpar@9: value = is_member(mpl, code->arg.arg.x, tuple) || alpar@9: is_member(mpl, code->arg.arg.y, tuple); alpar@9: break; alpar@9: case O_DIFF: alpar@9: value = is_member(mpl, code->arg.arg.x, tuple) && alpar@9: !is_member(mpl, code->arg.arg.y, tuple); alpar@9: break; alpar@9: case O_SYMDIFF: alpar@9: { int in1 = is_member(mpl, code->arg.arg.x, tuple); alpar@9: int in2 = is_member(mpl, code->arg.arg.y, tuple); alpar@9: value = (in1 && !in2) || (!in1 && in2); alpar@9: } alpar@9: break; alpar@9: case O_INTER: alpar@9: value = is_member(mpl, code->arg.arg.x, tuple) && alpar@9: is_member(mpl, code->arg.arg.y, tuple); alpar@9: break; alpar@9: case O_CROSS: alpar@9: { int j; alpar@9: value = is_member(mpl, code->arg.arg.x, tuple); alpar@9: if (value) alpar@9: { for (j = 1; j <= code->arg.arg.x->dim; j++) alpar@9: { xassert(tuple != NULL); alpar@9: tuple = tuple->next; alpar@9: } alpar@9: value = is_member(mpl, code->arg.arg.y, tuple); alpar@9: } alpar@9: } alpar@9: break; alpar@9: case O_DOTS: alpar@9: /* check if given 1-tuple is member of "arithmetic" set */ alpar@9: { int j; alpar@9: double x, t0, tf, dt; alpar@9: xassert(code->dim == 1); alpar@9: /* compute "parameters" of the "arithmetic" set */ alpar@9: t0 = eval_numeric(mpl, code->arg.arg.x); alpar@9: tf = eval_numeric(mpl, code->arg.arg.y); alpar@9: if (code->arg.arg.z == NULL) alpar@9: dt = 1.0; alpar@9: else alpar@9: dt = eval_numeric(mpl, code->arg.arg.z); alpar@9: /* make sure the parameters are correct */ alpar@9: arelset_size(mpl, t0, tf, dt); alpar@9: /* if component of 1-tuple is symbolic, not numeric, the alpar@9: 1-tuple cannot be member of "arithmetic" set */ alpar@9: xassert(tuple->sym != NULL); alpar@9: if (tuple->sym->str != NULL) alpar@9: { value = 0; alpar@9: break; alpar@9: } alpar@9: /* determine numeric value of the component */ alpar@9: x = tuple->sym->num; alpar@9: /* if the component value is out of the set range, the alpar@9: 1-tuple is not in the set */ alpar@9: if (dt > 0.0 && !(t0 <= x && x <= tf) || alpar@9: dt < 0.0 && !(tf <= x && x <= t0)) alpar@9: { value = 0; alpar@9: break; alpar@9: } alpar@9: /* estimate ordinal number of the 1-tuple in the set */ alpar@9: j = (int)(((x - t0) / dt) + 0.5) + 1; alpar@9: /* perform the main check */ alpar@9: value = (arelset_member(mpl, t0, tf, dt, j) == x); alpar@9: } alpar@9: break; alpar@9: case O_FORK: alpar@9: /* check if given n-tuple is member of conditional set */ alpar@9: if (eval_logical(mpl, code->arg.arg.x)) alpar@9: value = is_member(mpl, code->arg.arg.y, tuple); alpar@9: else alpar@9: value = is_member(mpl, code->arg.arg.z, tuple); alpar@9: break; alpar@9: case O_SETOF: alpar@9: /* check if given n-tuple is member of computed set */ alpar@9: /* it is not clear how to efficiently perform the check not alpar@9: computing the entire elemental set :+( */ alpar@9: error(mpl, "implementation restriction; in/within setof{} n" alpar@9: "ot allowed"); alpar@9: break; alpar@9: case O_BUILD: alpar@9: /* check if given n-tuple is member of domain set */ alpar@9: { TUPLE *temp; alpar@9: temp = build_subtuple(mpl, tuple, code->dim); alpar@9: /* try to enter the domain scope; if it is successful, alpar@9: the n-tuple is in the domain set */ alpar@9: value = (eval_within_domain(mpl, code->arg.loop.domain, alpar@9: temp, NULL, null_func) == 0); alpar@9: delete_tuple(mpl, temp); alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- eval_formula - evaluate pseudo-code to construct linear form. alpar@9: -- alpar@9: -- This routine evaluates specified pseudo-code to construct resultant alpar@9: -- linear form, which is returned on exit. */ alpar@9: alpar@9: struct iter_form_info alpar@9: { /* working info used by the routine iter_form_func */ alpar@9: CODE *code; alpar@9: /* pseudo-code for iterated operation to be performed */ alpar@9: FORMULA *value; alpar@9: /* resultant value */ alpar@9: FORMULA *tail; alpar@9: /* pointer to the last term */ alpar@9: }; alpar@9: alpar@9: static int iter_form_func(MPL *mpl, void *_info) alpar@9: { /* this is auxiliary routine used to perform iterated operation alpar@9: on linear form "integrand" within domain scope */ alpar@9: struct iter_form_info *info = _info; alpar@9: switch (info->code->op) alpar@9: { case O_SUM: alpar@9: /* summation over domain */ alpar@9: #if 0 alpar@9: info->value = alpar@9: linear_comb(mpl, alpar@9: +1.0, info->value, alpar@9: +1.0, eval_formula(mpl, info->code->arg.loop.x)); alpar@9: #else alpar@9: /* the routine linear_comb needs to look through all terms alpar@9: of both linear forms to reduce identical terms, so using alpar@9: it here is not a good idea (for example, evaluation of alpar@9: sum{i in 1..n} x[i] required quadratic time); the better alpar@9: idea is to gather all terms of the integrand in one list alpar@9: and reduce identical terms only once after all terms of alpar@9: the resultant linear form have been evaluated */ alpar@9: { FORMULA *form, *term; alpar@9: form = eval_formula(mpl, info->code->arg.loop.x); alpar@9: if (info->value == NULL) alpar@9: { xassert(info->tail == NULL); alpar@9: info->value = form; alpar@9: } alpar@9: else alpar@9: { xassert(info->tail != NULL); alpar@9: info->tail->next = form; alpar@9: } alpar@9: for (term = form; term != NULL; term = term->next) alpar@9: info->tail = term; alpar@9: } alpar@9: #endif alpar@9: break; alpar@9: default: alpar@9: xassert(info != info); alpar@9: } alpar@9: return 0; alpar@9: } alpar@9: alpar@9: FORMULA *eval_formula(MPL *mpl, CODE *code) alpar@9: { FORMULA *value; alpar@9: xassert(code != NULL); alpar@9: xassert(code->type == A_FORMULA); alpar@9: xassert(code->dim == 0); alpar@9: /* if the operation has a side effect, invalidate and delete the alpar@9: resultant value */ alpar@9: if (code->vflag && code->valid) alpar@9: { code->valid = 0; alpar@9: delete_value(mpl, code->type, &code->value); alpar@9: } alpar@9: /* if resultant value is valid, no evaluation is needed */ alpar@9: if (code->valid) alpar@9: { value = copy_formula(mpl, code->value.form); alpar@9: goto done; alpar@9: } alpar@9: /* evaluate pseudo-code recursively */ alpar@9: switch (code->op) alpar@9: { case O_MEMVAR: alpar@9: /* take member of variable */ alpar@9: { TUPLE *tuple; alpar@9: ARG_LIST *e; alpar@9: tuple = create_tuple(mpl); alpar@9: for (e = code->arg.var.list; e != NULL; e = e->next) alpar@9: tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: #if 1 /* 15/V-2010 */ alpar@9: xassert(code->arg.var.suff == DOT_NONE); alpar@9: #endif alpar@9: value = single_variable(mpl, alpar@9: eval_member_var(mpl, code->arg.var.var, tuple)); alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: case O_CVTLFM: alpar@9: /* convert to linear form */ alpar@9: value = constant_term(mpl, eval_numeric(mpl, alpar@9: code->arg.arg.x)); alpar@9: break; alpar@9: case O_PLUS: alpar@9: /* unary plus */ alpar@9: value = linear_comb(mpl, alpar@9: 0.0, constant_term(mpl, 0.0), alpar@9: +1.0, eval_formula(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_MINUS: alpar@9: /* unary minus */ alpar@9: value = linear_comb(mpl, alpar@9: 0.0, constant_term(mpl, 0.0), alpar@9: -1.0, eval_formula(mpl, code->arg.arg.x)); alpar@9: break; alpar@9: case O_ADD: alpar@9: /* addition */ alpar@9: value = linear_comb(mpl, alpar@9: +1.0, eval_formula(mpl, code->arg.arg.x), alpar@9: +1.0, eval_formula(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_SUB: alpar@9: /* subtraction */ alpar@9: value = linear_comb(mpl, alpar@9: +1.0, eval_formula(mpl, code->arg.arg.x), alpar@9: -1.0, eval_formula(mpl, code->arg.arg.y)); alpar@9: break; alpar@9: case O_MUL: alpar@9: /* multiplication */ alpar@9: xassert(code->arg.arg.x != NULL); alpar@9: xassert(code->arg.arg.y != NULL); alpar@9: if (code->arg.arg.x->type == A_NUMERIC) alpar@9: { xassert(code->arg.arg.y->type == A_FORMULA); alpar@9: value = linear_comb(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.x), alpar@9: eval_formula(mpl, code->arg.arg.y), alpar@9: 0.0, constant_term(mpl, 0.0)); alpar@9: } alpar@9: else alpar@9: { xassert(code->arg.arg.x->type == A_FORMULA); alpar@9: xassert(code->arg.arg.y->type == A_NUMERIC); alpar@9: value = linear_comb(mpl, alpar@9: eval_numeric(mpl, code->arg.arg.y), alpar@9: eval_formula(mpl, code->arg.arg.x), alpar@9: 0.0, constant_term(mpl, 0.0)); alpar@9: } alpar@9: break; alpar@9: case O_DIV: alpar@9: /* division */ alpar@9: value = linear_comb(mpl, alpar@9: fp_div(mpl, 1.0, eval_numeric(mpl, code->arg.arg.y)), alpar@9: eval_formula(mpl, code->arg.arg.x), alpar@9: 0.0, constant_term(mpl, 0.0)); alpar@9: break; alpar@9: case O_FORK: alpar@9: /* if-then-else */ alpar@9: if (eval_logical(mpl, code->arg.arg.x)) alpar@9: value = eval_formula(mpl, code->arg.arg.y); alpar@9: else if (code->arg.arg.z == NULL) alpar@9: value = constant_term(mpl, 0.0); alpar@9: else alpar@9: value = eval_formula(mpl, code->arg.arg.z); alpar@9: break; alpar@9: case O_SUM: alpar@9: /* summation over domain */ alpar@9: { struct iter_form_info _info, *info = &_info; alpar@9: info->code = code; alpar@9: info->value = constant_term(mpl, 0.0); alpar@9: info->tail = NULL; alpar@9: loop_within_domain(mpl, code->arg.loop.domain, info, alpar@9: iter_form_func); alpar@9: value = reduce_terms(mpl, info->value); alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: /* save resultant value */ alpar@9: xassert(!code->valid); alpar@9: code->valid = 1; alpar@9: code->value.form = copy_formula(mpl, value); alpar@9: done: return value; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_code - clean pseudo-code. alpar@9: -- alpar@9: -- This routine recursively cleans specified pseudo-code that assumes alpar@9: -- deleting all temporary resultant values. */ alpar@9: alpar@9: void clean_code(MPL *mpl, CODE *code) alpar@9: { ARG_LIST *e; alpar@9: /* if no pseudo-code is specified, do nothing */ alpar@9: if (code == NULL) goto done; alpar@9: /* if resultant value is valid (exists), delete it */ alpar@9: if (code->valid) alpar@9: { code->valid = 0; alpar@9: delete_value(mpl, code->type, &code->value); alpar@9: } alpar@9: /* recursively clean pseudo-code for operands */ alpar@9: switch (code->op) alpar@9: { case O_NUMBER: alpar@9: case O_STRING: alpar@9: case O_INDEX: alpar@9: break; alpar@9: case O_MEMNUM: alpar@9: case O_MEMSYM: alpar@9: for (e = code->arg.par.list; e != NULL; e = e->next) alpar@9: clean_code(mpl, e->x); alpar@9: break; alpar@9: case O_MEMSET: alpar@9: for (e = code->arg.set.list; e != NULL; e = e->next) alpar@9: clean_code(mpl, e->x); alpar@9: break; alpar@9: case O_MEMVAR: alpar@9: for (e = code->arg.var.list; e != NULL; e = e->next) alpar@9: clean_code(mpl, e->x); alpar@9: break; alpar@9: #if 1 /* 15/V-2010 */ alpar@9: case O_MEMCON: alpar@9: for (e = code->arg.con.list; e != NULL; e = e->next) alpar@9: clean_code(mpl, e->x); alpar@9: break; alpar@9: #endif alpar@9: case O_TUPLE: alpar@9: case O_MAKE: alpar@9: for (e = code->arg.list; e != NULL; e = e->next) alpar@9: clean_code(mpl, e->x); alpar@9: break; alpar@9: case O_SLICE: alpar@9: xassert(code != code); alpar@9: case O_IRAND224: alpar@9: case O_UNIFORM01: alpar@9: case O_NORMAL01: alpar@9: case O_GMTIME: alpar@9: break; alpar@9: case O_CVTNUM: alpar@9: case O_CVTSYM: alpar@9: case O_CVTLOG: alpar@9: case O_CVTTUP: alpar@9: case O_CVTLFM: alpar@9: case O_PLUS: alpar@9: case O_MINUS: alpar@9: case O_NOT: alpar@9: case O_ABS: alpar@9: case O_CEIL: alpar@9: case O_FLOOR: alpar@9: case O_EXP: alpar@9: case O_LOG: alpar@9: case O_LOG10: alpar@9: case O_SQRT: alpar@9: case O_SIN: alpar@9: case O_COS: alpar@9: case O_ATAN: alpar@9: case O_ROUND: alpar@9: case O_TRUNC: alpar@9: case O_CARD: alpar@9: case O_LENGTH: alpar@9: /* unary operation */ alpar@9: clean_code(mpl, code->arg.arg.x); alpar@9: break; alpar@9: case O_ADD: alpar@9: case O_SUB: alpar@9: case O_LESS: alpar@9: case O_MUL: alpar@9: case O_DIV: alpar@9: case O_IDIV: alpar@9: case O_MOD: alpar@9: case O_POWER: alpar@9: case O_ATAN2: alpar@9: case O_ROUND2: alpar@9: case O_TRUNC2: alpar@9: case O_UNIFORM: alpar@9: case O_NORMAL: alpar@9: case O_CONCAT: alpar@9: case O_LT: alpar@9: case O_LE: alpar@9: case O_EQ: alpar@9: case O_GE: alpar@9: case O_GT: alpar@9: case O_NE: alpar@9: case O_AND: alpar@9: case O_OR: alpar@9: case O_UNION: alpar@9: case O_DIFF: alpar@9: case O_SYMDIFF: alpar@9: case O_INTER: alpar@9: case O_CROSS: alpar@9: case O_IN: alpar@9: case O_NOTIN: alpar@9: case O_WITHIN: alpar@9: case O_NOTWITHIN: alpar@9: case O_SUBSTR: alpar@9: case O_STR2TIME: alpar@9: case O_TIME2STR: alpar@9: /* binary operation */ alpar@9: clean_code(mpl, code->arg.arg.x); alpar@9: clean_code(mpl, code->arg.arg.y); alpar@9: break; alpar@9: case O_DOTS: alpar@9: case O_FORK: alpar@9: case O_SUBSTR3: alpar@9: /* ternary operation */ alpar@9: clean_code(mpl, code->arg.arg.x); alpar@9: clean_code(mpl, code->arg.arg.y); alpar@9: clean_code(mpl, code->arg.arg.z); alpar@9: break; alpar@9: case O_MIN: alpar@9: case O_MAX: alpar@9: /* n-ary operation */ alpar@9: for (e = code->arg.list; e != NULL; e = e->next) alpar@9: clean_code(mpl, e->x); alpar@9: break; alpar@9: case O_SUM: alpar@9: case O_PROD: alpar@9: case O_MINIMUM: alpar@9: case O_MAXIMUM: alpar@9: case O_FORALL: alpar@9: case O_EXISTS: alpar@9: case O_SETOF: alpar@9: case O_BUILD: alpar@9: /* iterated operation */ alpar@9: clean_domain(mpl, code->arg.loop.domain); alpar@9: clean_code(mpl, code->arg.loop.x); alpar@9: break; alpar@9: default: alpar@9: xassert(code->op != code->op); alpar@9: } alpar@9: done: return; alpar@9: } alpar@9: alpar@9: #if 1 /* 11/II-2008 */ alpar@9: /**********************************************************************/ alpar@9: /* * * DATA TABLES * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: int mpl_tab_num_args(TABDCA *dca) alpar@9: { /* returns the number of arguments */ alpar@9: return dca->na; alpar@9: } alpar@9: alpar@9: const char *mpl_tab_get_arg(TABDCA *dca, int k) alpar@9: { /* returns pointer to k-th argument */ alpar@9: xassert(1 <= k && k <= dca->na); alpar@9: return dca->arg[k]; alpar@9: } alpar@9: alpar@9: int mpl_tab_num_flds(TABDCA *dca) alpar@9: { /* returns the number of fields */ alpar@9: return dca->nf; alpar@9: } alpar@9: alpar@9: const char *mpl_tab_get_name(TABDCA *dca, int k) alpar@9: { /* returns pointer to name of k-th field */ alpar@9: xassert(1 <= k && k <= dca->nf); alpar@9: return dca->name[k]; alpar@9: } alpar@9: alpar@9: int mpl_tab_get_type(TABDCA *dca, int k) alpar@9: { /* returns type of k-th field */ alpar@9: xassert(1 <= k && k <= dca->nf); alpar@9: return dca->type[k]; alpar@9: } alpar@9: alpar@9: double mpl_tab_get_num(TABDCA *dca, int k) alpar@9: { /* returns numeric value of k-th field */ alpar@9: xassert(1 <= k && k <= dca->nf); alpar@9: xassert(dca->type[k] == 'N'); alpar@9: return dca->num[k]; alpar@9: } alpar@9: alpar@9: const char *mpl_tab_get_str(TABDCA *dca, int k) alpar@9: { /* returns pointer to string value of k-th field */ alpar@9: xassert(1 <= k && k <= dca->nf); alpar@9: xassert(dca->type[k] == 'S'); alpar@9: xassert(dca->str[k] != NULL); alpar@9: return dca->str[k]; alpar@9: } alpar@9: alpar@9: void mpl_tab_set_num(TABDCA *dca, int k, double num) alpar@9: { /* assign numeric value to k-th field */ alpar@9: xassert(1 <= k && k <= dca->nf); alpar@9: xassert(dca->type[k] == '?'); alpar@9: dca->type[k] = 'N'; alpar@9: dca->num[k] = num; alpar@9: return; alpar@9: } alpar@9: alpar@9: void mpl_tab_set_str(TABDCA *dca, int k, const char *str) alpar@9: { /* assign string value to k-th field */ alpar@9: xassert(1 <= k && k <= dca->nf); alpar@9: xassert(dca->type[k] == '?'); alpar@9: xassert(strlen(str) <= MAX_LENGTH); alpar@9: xassert(dca->str[k] != NULL); alpar@9: dca->type[k] = 'S'; alpar@9: strcpy(dca->str[k], str); alpar@9: return; alpar@9: } alpar@9: alpar@9: static int write_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: TABLE *tab = info; alpar@9: TABDCA *dca = mpl->dca; alpar@9: TABOUT *out; alpar@9: SYMBOL *sym; alpar@9: int k; alpar@9: char buf[MAX_LENGTH+1]; alpar@9: /* evaluate field values */ alpar@9: k = 0; alpar@9: for (out = tab->u.out.list; out != NULL; out = out->next) alpar@9: { k++; alpar@9: switch (out->code->type) alpar@9: { case A_NUMERIC: alpar@9: dca->type[k] = 'N'; alpar@9: dca->num[k] = eval_numeric(mpl, out->code); alpar@9: dca->str[k][0] = '\0'; alpar@9: break; alpar@9: case A_SYMBOLIC: alpar@9: sym = eval_symbolic(mpl, out->code); alpar@9: if (sym->str == NULL) alpar@9: { dca->type[k] = 'N'; alpar@9: dca->num[k] = sym->num; alpar@9: dca->str[k][0] = '\0'; alpar@9: } alpar@9: else alpar@9: { dca->type[k] = 'S'; alpar@9: dca->num[k] = 0.0; alpar@9: fetch_string(mpl, sym->str, buf); alpar@9: strcpy(dca->str[k], buf); alpar@9: } alpar@9: delete_symbol(mpl, sym); alpar@9: break; alpar@9: default: alpar@9: xassert(out != out); alpar@9: } alpar@9: } alpar@9: /* write record to output table */ alpar@9: mpl_tab_drv_write(mpl); alpar@9: return 0; alpar@9: } alpar@9: alpar@9: void execute_table(MPL *mpl, TABLE *tab) alpar@9: { /* execute table statement */ alpar@9: TABARG *arg; alpar@9: TABFLD *fld; alpar@9: TABIN *in; alpar@9: TABOUT *out; alpar@9: TABDCA *dca; alpar@9: SET *set; alpar@9: int k; alpar@9: char buf[MAX_LENGTH+1]; alpar@9: /* allocate table driver communication area */ alpar@9: xassert(mpl->dca == NULL); alpar@9: mpl->dca = dca = xmalloc(sizeof(TABDCA)); alpar@9: dca->id = 0; alpar@9: dca->link = NULL; alpar@9: dca->na = 0; alpar@9: dca->arg = NULL; alpar@9: dca->nf = 0; alpar@9: dca->name = NULL; alpar@9: dca->type = NULL; alpar@9: dca->num = NULL; alpar@9: dca->str = NULL; alpar@9: /* allocate arguments */ alpar@9: xassert(dca->na == 0); alpar@9: for (arg = tab->arg; arg != NULL; arg = arg->next) alpar@9: dca->na++; alpar@9: dca->arg = xcalloc(1+dca->na, sizeof(char *)); alpar@9: #if 1 /* 28/IX-2008 */ alpar@9: for (k = 1; k <= dca->na; k++) dca->arg[k] = NULL; alpar@9: #endif alpar@9: /* evaluate argument values */ alpar@9: k = 0; alpar@9: for (arg = tab->arg; arg != NULL; arg = arg->next) alpar@9: { SYMBOL *sym; alpar@9: k++; alpar@9: xassert(arg->code->type == A_SYMBOLIC); alpar@9: sym = eval_symbolic(mpl, arg->code); alpar@9: if (sym->str == NULL) alpar@9: sprintf(buf, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: fetch_string(mpl, sym->str, buf); alpar@9: delete_symbol(mpl, sym); alpar@9: dca->arg[k] = xmalloc(strlen(buf)+1); alpar@9: strcpy(dca->arg[k], buf); alpar@9: } alpar@9: /* perform table input/output */ alpar@9: switch (tab->type) alpar@9: { case A_INPUT: goto read_table; alpar@9: case A_OUTPUT: goto write_table; alpar@9: default: xassert(tab != tab); alpar@9: } alpar@9: read_table: alpar@9: /* read data from input table */ alpar@9: /* add the only member to the control set and assign it empty alpar@9: elemental set */ alpar@9: set = tab->u.in.set; alpar@9: if (set != NULL) alpar@9: { if (set->data) alpar@9: error(mpl, "%s already provided with data", set->name); alpar@9: xassert(set->array->head == NULL); alpar@9: add_member(mpl, set->array, NULL)->value.set = alpar@9: create_elemset(mpl, set->dimen); alpar@9: set->data = 1; alpar@9: } alpar@9: /* check parameters specified in the input list */ alpar@9: for (in = tab->u.in.list; in != NULL; in = in->next) alpar@9: { if (in->par->data) alpar@9: error(mpl, "%s already provided with data", in->par->name); alpar@9: in->par->data = 1; alpar@9: } alpar@9: /* allocate and initialize fields */ alpar@9: xassert(dca->nf == 0); alpar@9: for (fld = tab->u.in.fld; fld != NULL; fld = fld->next) alpar@9: dca->nf++; alpar@9: for (in = tab->u.in.list; in != NULL; in = in->next) alpar@9: dca->nf++; alpar@9: dca->name = xcalloc(1+dca->nf, sizeof(char *)); alpar@9: dca->type = xcalloc(1+dca->nf, sizeof(int)); alpar@9: dca->num = xcalloc(1+dca->nf, sizeof(double)); alpar@9: dca->str = xcalloc(1+dca->nf, sizeof(char *)); alpar@9: k = 0; alpar@9: for (fld = tab->u.in.fld; fld != NULL; fld = fld->next) alpar@9: { k++; alpar@9: dca->name[k] = fld->name; alpar@9: dca->type[k] = '?'; alpar@9: dca->num[k] = 0.0; alpar@9: dca->str[k] = xmalloc(MAX_LENGTH+1); alpar@9: dca->str[k][0] = '\0'; alpar@9: } alpar@9: for (in = tab->u.in.list; in != NULL; in = in->next) alpar@9: { k++; alpar@9: dca->name[k] = in->name; alpar@9: dca->type[k] = '?'; alpar@9: dca->num[k] = 0.0; alpar@9: dca->str[k] = xmalloc(MAX_LENGTH+1); alpar@9: dca->str[k][0] = '\0'; alpar@9: } alpar@9: /* open input table */ alpar@9: mpl_tab_drv_open(mpl, 'R'); alpar@9: /* read and process records */ alpar@9: for (;;) alpar@9: { TUPLE *tup; alpar@9: /* reset field types */ alpar@9: for (k = 1; k <= dca->nf; k++) alpar@9: dca->type[k] = '?'; alpar@9: /* read next record */ alpar@9: if (mpl_tab_drv_read(mpl)) break; alpar@9: /* all fields must be set by the driver */ alpar@9: for (k = 1; k <= dca->nf; k++) alpar@9: { if (dca->type[k] == '?') alpar@9: error(mpl, "field %s missing in input table", alpar@9: dca->name[k]); alpar@9: } alpar@9: /* construct n-tuple */ alpar@9: tup = create_tuple(mpl); alpar@9: k = 0; alpar@9: for (fld = tab->u.in.fld; fld != NULL; fld = fld->next) alpar@9: { k++; alpar@9: xassert(k <= dca->nf); alpar@9: switch (dca->type[k]) alpar@9: { case 'N': alpar@9: tup = expand_tuple(mpl, tup, create_symbol_num(mpl, alpar@9: dca->num[k])); alpar@9: break; alpar@9: case 'S': alpar@9: xassert(strlen(dca->str[k]) <= MAX_LENGTH); alpar@9: tup = expand_tuple(mpl, tup, create_symbol_str(mpl, alpar@9: create_string(mpl, dca->str[k]))); alpar@9: break; alpar@9: default: alpar@9: xassert(dca != dca); alpar@9: } alpar@9: } alpar@9: /* add n-tuple just read to the control set */ alpar@9: if (tab->u.in.set != NULL) alpar@9: check_then_add(mpl, tab->u.in.set->array->head->value.set, alpar@9: copy_tuple(mpl, tup)); alpar@9: /* assign values to the parameters in the input list */ alpar@9: for (in = tab->u.in.list; in != NULL; in = in->next) alpar@9: { MEMBER *memb; alpar@9: k++; alpar@9: xassert(k <= dca->nf); alpar@9: /* there must be no member with the same n-tuple */ alpar@9: if (find_member(mpl, in->par->array, tup) != NULL) alpar@9: error(mpl, "%s%s already defined", in->par->name, alpar@9: format_tuple(mpl, '[', tup)); alpar@9: /* create new parameter member with given n-tuple */ alpar@9: memb = add_member(mpl, in->par->array, copy_tuple(mpl, tup)) alpar@9: ; alpar@9: /* assign value to the parameter member */ alpar@9: switch (in->par->type) alpar@9: { case A_NUMERIC: alpar@9: case A_INTEGER: alpar@9: case A_BINARY: alpar@9: if (dca->type[k] != 'N') alpar@9: error(mpl, "%s requires numeric data", alpar@9: in->par->name); alpar@9: memb->value.num = dca->num[k]; alpar@9: break; alpar@9: case A_SYMBOLIC: alpar@9: switch (dca->type[k]) alpar@9: { case 'N': alpar@9: memb->value.sym = create_symbol_num(mpl, alpar@9: dca->num[k]); alpar@9: break; alpar@9: case 'S': alpar@9: xassert(strlen(dca->str[k]) <= MAX_LENGTH); alpar@9: memb->value.sym = create_symbol_str(mpl, alpar@9: create_string(mpl,dca->str[k])); alpar@9: break; alpar@9: default: alpar@9: xassert(dca != dca); alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(in != in); alpar@9: } alpar@9: } alpar@9: /* n-tuple is no more needed */ alpar@9: delete_tuple(mpl, tup); alpar@9: } alpar@9: /* close input table */ alpar@9: mpl_tab_drv_close(mpl); alpar@9: goto done; alpar@9: write_table: alpar@9: /* write data to output table */ alpar@9: /* allocate and initialize fields */ alpar@9: xassert(dca->nf == 0); alpar@9: for (out = tab->u.out.list; out != NULL; out = out->next) alpar@9: dca->nf++; alpar@9: dca->name = xcalloc(1+dca->nf, sizeof(char *)); alpar@9: dca->type = xcalloc(1+dca->nf, sizeof(int)); alpar@9: dca->num = xcalloc(1+dca->nf, sizeof(double)); alpar@9: dca->str = xcalloc(1+dca->nf, sizeof(char *)); alpar@9: k = 0; alpar@9: for (out = tab->u.out.list; out != NULL; out = out->next) alpar@9: { k++; alpar@9: dca->name[k] = out->name; alpar@9: dca->type[k] = '?'; alpar@9: dca->num[k] = 0.0; alpar@9: dca->str[k] = xmalloc(MAX_LENGTH+1); alpar@9: dca->str[k][0] = '\0'; alpar@9: } alpar@9: /* open output table */ alpar@9: mpl_tab_drv_open(mpl, 'W'); alpar@9: /* evaluate fields and write records */ alpar@9: loop_within_domain(mpl, tab->u.out.domain, tab, write_func); alpar@9: /* close output table */ alpar@9: mpl_tab_drv_close(mpl); alpar@9: done: /* free table driver communication area */ alpar@9: free_dca(mpl); alpar@9: return; alpar@9: } alpar@9: alpar@9: void free_dca(MPL *mpl) alpar@9: { /* free table driver communucation area */ alpar@9: TABDCA *dca = mpl->dca; alpar@9: int k; alpar@9: if (dca != NULL) alpar@9: { if (dca->link != NULL) alpar@9: mpl_tab_drv_close(mpl); alpar@9: if (dca->arg != NULL) alpar@9: { for (k = 1; k <= dca->na; k++) alpar@9: #if 1 /* 28/IX-2008 */ alpar@9: if (dca->arg[k] != NULL) alpar@9: #endif alpar@9: xfree(dca->arg[k]); alpar@9: xfree(dca->arg); alpar@9: } alpar@9: if (dca->name != NULL) xfree(dca->name); alpar@9: if (dca->type != NULL) xfree(dca->type); alpar@9: if (dca->num != NULL) xfree(dca->num); alpar@9: if (dca->str != NULL) alpar@9: { for (k = 1; k <= dca->nf; k++) alpar@9: xfree(dca->str[k]); alpar@9: xfree(dca->str); alpar@9: } alpar@9: xfree(dca), mpl->dca = NULL; alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: void clean_table(MPL *mpl, TABLE *tab) alpar@9: { /* clean table statement */ alpar@9: TABARG *arg; alpar@9: TABOUT *out; alpar@9: /* clean string list */ alpar@9: for (arg = tab->arg; arg != NULL; arg = arg->next) alpar@9: clean_code(mpl, arg->code); alpar@9: switch (tab->type) alpar@9: { case A_INPUT: alpar@9: break; alpar@9: case A_OUTPUT: alpar@9: /* clean subscript domain */ alpar@9: clean_domain(mpl, tab->u.out.domain); alpar@9: /* clean output list */ alpar@9: for (out = tab->u.out.list; out != NULL; out = out->next) alpar@9: clean_code(mpl, out->code); alpar@9: break; alpar@9: default: alpar@9: xassert(tab != tab); alpar@9: } alpar@9: return; alpar@9: } alpar@9: #endif alpar@9: alpar@9: /**********************************************************************/ alpar@9: /* * * MODEL STATEMENTS * * */ alpar@9: /**********************************************************************/ alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- execute_check - execute check statement. alpar@9: -- alpar@9: -- This routine executes specified check statement. */ alpar@9: alpar@9: static int check_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: CHECK *chk = (CHECK *)info; alpar@9: if (!eval_logical(mpl, chk->code)) alpar@9: error(mpl, "check%s failed", format_tuple(mpl, '[', alpar@9: get_domain_tuple(mpl, chk->domain))); alpar@9: return 0; alpar@9: } alpar@9: alpar@9: void execute_check(MPL *mpl, CHECK *chk) alpar@9: { loop_within_domain(mpl, chk->domain, chk, check_func); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_check - clean check statement. alpar@9: -- alpar@9: -- This routine cleans specified check statement that assumes deleting alpar@9: -- all stuff dynamically allocated on generating/postsolving phase. */ alpar@9: alpar@9: void clean_check(MPL *mpl, CHECK *chk) alpar@9: { /* clean subscript domain */ alpar@9: clean_domain(mpl, chk->domain); alpar@9: /* clean pseudo-code for computing predicate */ alpar@9: clean_code(mpl, chk->code); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- execute_display - execute display statement. alpar@9: -- alpar@9: -- This routine executes specified display statement. */ alpar@9: alpar@9: static void display_set(MPL *mpl, SET *set, MEMBER *memb) alpar@9: { /* display member of model set */ alpar@9: ELEMSET *s = memb->value.set; alpar@9: MEMBER *m; alpar@9: write_text(mpl, "%s%s%s\n", set->name, alpar@9: format_tuple(mpl, '[', memb->tuple), alpar@9: s->head == NULL ? " is empty" : ":"); alpar@9: for (m = s->head; m != NULL; m = m->next) alpar@9: write_text(mpl, " %s\n", format_tuple(mpl, '(', m->tuple)); alpar@9: return; alpar@9: } alpar@9: alpar@9: static void display_par(MPL *mpl, PARAMETER *par, MEMBER *memb) alpar@9: { /* display member of model parameter */ alpar@9: switch (par->type) alpar@9: { case A_NUMERIC: alpar@9: case A_INTEGER: alpar@9: case A_BINARY: alpar@9: write_text(mpl, "%s%s = %.*g\n", par->name, alpar@9: format_tuple(mpl, '[', memb->tuple), alpar@9: DBL_DIG, memb->value.num); alpar@9: break; alpar@9: case A_SYMBOLIC: alpar@9: write_text(mpl, "%s%s = %s\n", par->name, alpar@9: format_tuple(mpl, '[', memb->tuple), alpar@9: format_symbol(mpl, memb->value.sym)); alpar@9: break; alpar@9: default: alpar@9: xassert(par != par); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: #if 1 /* 15/V-2010 */ alpar@9: static void display_var(MPL *mpl, VARIABLE *var, MEMBER *memb, alpar@9: int suff) alpar@9: { /* display member of model variable */ alpar@9: if (suff == DOT_NONE || suff == DOT_VAL) alpar@9: write_text(mpl, "%s%s.val = %.*g\n", var->name, alpar@9: format_tuple(mpl, '[', memb->tuple), DBL_DIG, alpar@9: memb->value.var->prim); alpar@9: else if (suff == DOT_LB) alpar@9: write_text(mpl, "%s%s.lb = %.*g\n", var->name, alpar@9: format_tuple(mpl, '[', memb->tuple), DBL_DIG, alpar@9: memb->value.var->var->lbnd == NULL ? -DBL_MAX : alpar@9: memb->value.var->lbnd); alpar@9: else if (suff == DOT_UB) alpar@9: write_text(mpl, "%s%s.ub = %.*g\n", var->name, alpar@9: format_tuple(mpl, '[', memb->tuple), DBL_DIG, alpar@9: memb->value.var->var->ubnd == NULL ? +DBL_MAX : alpar@9: memb->value.var->ubnd); alpar@9: else if (suff == DOT_STATUS) alpar@9: write_text(mpl, "%s%s.status = %d\n", var->name, format_tuple alpar@9: (mpl, '[', memb->tuple), memb->value.var->stat); alpar@9: else if (suff == DOT_DUAL) alpar@9: write_text(mpl, "%s%s.dual = %.*g\n", var->name, alpar@9: format_tuple(mpl, '[', memb->tuple), DBL_DIG, alpar@9: memb->value.var->dual); alpar@9: else alpar@9: xassert(suff != suff); alpar@9: return; alpar@9: } alpar@9: #endif alpar@9: alpar@9: #if 1 /* 15/V-2010 */ alpar@9: static void display_con(MPL *mpl, CONSTRAINT *con, MEMBER *memb, alpar@9: int suff) alpar@9: { /* display member of model constraint */ alpar@9: if (suff == DOT_NONE || suff == DOT_VAL) alpar@9: write_text(mpl, "%s%s.val = %.*g\n", con->name, alpar@9: format_tuple(mpl, '[', memb->tuple), DBL_DIG, alpar@9: memb->value.con->prim); alpar@9: else if (suff == DOT_LB) alpar@9: write_text(mpl, "%s%s.lb = %.*g\n", con->name, alpar@9: format_tuple(mpl, '[', memb->tuple), DBL_DIG, alpar@9: memb->value.con->con->lbnd == NULL ? -DBL_MAX : alpar@9: memb->value.con->lbnd); alpar@9: else if (suff == DOT_UB) alpar@9: write_text(mpl, "%s%s.ub = %.*g\n", con->name, alpar@9: format_tuple(mpl, '[', memb->tuple), DBL_DIG, alpar@9: memb->value.con->con->ubnd == NULL ? +DBL_MAX : alpar@9: memb->value.con->ubnd); alpar@9: else if (suff == DOT_STATUS) alpar@9: write_text(mpl, "%s%s.status = %d\n", con->name, format_tuple alpar@9: (mpl, '[', memb->tuple), memb->value.con->stat); alpar@9: else if (suff == DOT_DUAL) alpar@9: write_text(mpl, "%s%s.dual = %.*g\n", con->name, alpar@9: format_tuple(mpl, '[', memb->tuple), DBL_DIG, alpar@9: memb->value.con->dual); alpar@9: else alpar@9: xassert(suff != suff); alpar@9: return; alpar@9: } alpar@9: #endif alpar@9: alpar@9: static void display_memb(MPL *mpl, CODE *code) alpar@9: { /* display member specified by pseudo-code */ alpar@9: MEMBER memb; alpar@9: ARG_LIST *e; alpar@9: xassert(code->op == O_MEMNUM || code->op == O_MEMSYM alpar@9: || code->op == O_MEMSET || code->op == O_MEMVAR alpar@9: || code->op == O_MEMCON); alpar@9: memb.tuple = create_tuple(mpl); alpar@9: for (e = code->arg.par.list; e != NULL; e = e->next) alpar@9: memb.tuple = expand_tuple(mpl, memb.tuple, eval_symbolic(mpl, alpar@9: e->x)); alpar@9: switch (code->op) alpar@9: { case O_MEMNUM: alpar@9: memb.value.num = eval_member_num(mpl, code->arg.par.par, alpar@9: memb.tuple); alpar@9: display_par(mpl, code->arg.par.par, &memb); alpar@9: break; alpar@9: case O_MEMSYM: alpar@9: memb.value.sym = eval_member_sym(mpl, code->arg.par.par, alpar@9: memb.tuple); alpar@9: display_par(mpl, code->arg.par.par, &memb); alpar@9: delete_symbol(mpl, memb.value.sym); alpar@9: break; alpar@9: case O_MEMSET: alpar@9: memb.value.set = eval_member_set(mpl, code->arg.set.set, alpar@9: memb.tuple); alpar@9: display_set(mpl, code->arg.set.set, &memb); alpar@9: break; alpar@9: case O_MEMVAR: alpar@9: memb.value.var = eval_member_var(mpl, code->arg.var.var, alpar@9: memb.tuple); alpar@9: display_var alpar@9: (mpl, code->arg.var.var, &memb, code->arg.var.suff); alpar@9: break; alpar@9: case O_MEMCON: alpar@9: memb.value.con = eval_member_con(mpl, code->arg.con.con, alpar@9: memb.tuple); alpar@9: display_con alpar@9: (mpl, code->arg.con.con, &memb, code->arg.con.suff); alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: delete_tuple(mpl, memb.tuple); alpar@9: return; alpar@9: } alpar@9: alpar@9: static void display_code(MPL *mpl, CODE *code) alpar@9: { /* display value of expression */ alpar@9: switch (code->type) alpar@9: { case A_NUMERIC: alpar@9: /* numeric value */ alpar@9: { double num; alpar@9: num = eval_numeric(mpl, code); alpar@9: write_text(mpl, "%.*g\n", DBL_DIG, num); alpar@9: } alpar@9: break; alpar@9: case A_SYMBOLIC: alpar@9: /* symbolic value */ alpar@9: { SYMBOL *sym; alpar@9: sym = eval_symbolic(mpl, code); alpar@9: write_text(mpl, "%s\n", format_symbol(mpl, sym)); alpar@9: delete_symbol(mpl, sym); alpar@9: } alpar@9: break; alpar@9: case A_LOGICAL: alpar@9: /* logical value */ alpar@9: { int bit; alpar@9: bit = eval_logical(mpl, code); alpar@9: write_text(mpl, "%s\n", bit ? "true" : "false"); alpar@9: } alpar@9: break; alpar@9: case A_TUPLE: alpar@9: /* n-tuple */ alpar@9: { TUPLE *tuple; alpar@9: tuple = eval_tuple(mpl, code); alpar@9: write_text(mpl, "%s\n", format_tuple(mpl, '(', tuple)); alpar@9: delete_tuple(mpl, tuple); alpar@9: } alpar@9: break; alpar@9: case A_ELEMSET: alpar@9: /* elemental set */ alpar@9: { ELEMSET *set; alpar@9: MEMBER *memb; alpar@9: set = eval_elemset(mpl, code); alpar@9: if (set->head == 0) alpar@9: write_text(mpl, "set is empty\n"); alpar@9: for (memb = set->head; memb != NULL; memb = memb->next) alpar@9: write_text(mpl, " %s\n", format_tuple(mpl, '(', alpar@9: memb->tuple)); alpar@9: delete_elemset(mpl, set); alpar@9: } alpar@9: break; alpar@9: case A_FORMULA: alpar@9: /* linear form */ alpar@9: { FORMULA *form, *term; alpar@9: form = eval_formula(mpl, code); alpar@9: if (form == NULL) alpar@9: write_text(mpl, "linear form is empty\n"); alpar@9: for (term = form; term != NULL; term = term->next) alpar@9: { if (term->var == NULL) alpar@9: write_text(mpl, " %.*g\n", term->coef); alpar@9: else alpar@9: write_text(mpl, " %.*g %s%s\n", DBL_DIG, alpar@9: term->coef, term->var->var->name, alpar@9: format_tuple(mpl, '[', term->var->memb->tuple)); alpar@9: } alpar@9: delete_formula(mpl, form); alpar@9: } alpar@9: break; alpar@9: default: alpar@9: xassert(code != code); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: static int display_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: DISPLAY *dpy = (DISPLAY *)info; alpar@9: DISPLAY1 *entry; alpar@9: for (entry = dpy->list; entry != NULL; entry = entry->next) alpar@9: { if (entry->type == A_INDEX) alpar@9: { /* dummy index */ alpar@9: DOMAIN_SLOT *slot = entry->u.slot; alpar@9: write_text(mpl, "%s = %s\n", slot->name, alpar@9: format_symbol(mpl, slot->value)); alpar@9: } alpar@9: else if (entry->type == A_SET) alpar@9: { /* model set */ alpar@9: SET *set = entry->u.set; alpar@9: MEMBER *memb; alpar@9: if (set->assign != NULL) alpar@9: { /* the set has assignment expression; evaluate all its alpar@9: members over entire domain */ alpar@9: eval_whole_set(mpl, set); alpar@9: } alpar@9: else alpar@9: { /* the set has no assignment expression; refer to its alpar@9: any existing member ignoring resultant value to check alpar@9: the data provided the data section */ alpar@9: #if 1 /* 12/XII-2008 */ alpar@9: if (set->gadget != NULL && set->data == 0) alpar@9: { /* initialize the set with data from a plain set */ alpar@9: saturate_set(mpl, set); alpar@9: } alpar@9: #endif alpar@9: if (set->array->head != NULL) alpar@9: eval_member_set(mpl, set, set->array->head->tuple); alpar@9: } alpar@9: /* display all members of the set array */ alpar@9: if (set->array->head == NULL) alpar@9: write_text(mpl, "%s has empty content\n", set->name); alpar@9: for (memb = set->array->head; memb != NULL; memb = alpar@9: memb->next) display_set(mpl, set, memb); alpar@9: } alpar@9: else if (entry->type == A_PARAMETER) alpar@9: { /* model parameter */ alpar@9: PARAMETER *par = entry->u.par; alpar@9: MEMBER *memb; alpar@9: if (par->assign != NULL) alpar@9: { /* the parameter has an assignment expression; evaluate alpar@9: all its member over entire domain */ alpar@9: eval_whole_par(mpl, par); alpar@9: } alpar@9: else alpar@9: { /* the parameter has no assignment expression; refer to alpar@9: its any existing member ignoring resultant value to alpar@9: check the data provided in the data section */ alpar@9: if (par->array->head != NULL) alpar@9: { if (par->type != A_SYMBOLIC) alpar@9: eval_member_num(mpl, par, par->array->head->tuple); alpar@9: else alpar@9: delete_symbol(mpl, eval_member_sym(mpl, par, alpar@9: par->array->head->tuple)); alpar@9: } alpar@9: } alpar@9: /* display all members of the parameter array */ alpar@9: if (par->array->head == NULL) alpar@9: write_text(mpl, "%s has empty content\n", par->name); alpar@9: for (memb = par->array->head; memb != NULL; memb = alpar@9: memb->next) display_par(mpl, par, memb); alpar@9: } alpar@9: else if (entry->type == A_VARIABLE) alpar@9: { /* model variable */ alpar@9: VARIABLE *var = entry->u.var; alpar@9: MEMBER *memb; alpar@9: xassert(mpl->flag_p); alpar@9: /* display all members of the variable array */ alpar@9: if (var->array->head == NULL) alpar@9: write_text(mpl, "%s has empty content\n", var->name); alpar@9: for (memb = var->array->head; memb != NULL; memb = alpar@9: memb->next) display_var(mpl, var, memb, DOT_NONE); alpar@9: } alpar@9: else if (entry->type == A_CONSTRAINT) alpar@9: { /* model constraint */ alpar@9: CONSTRAINT *con = entry->u.con; alpar@9: MEMBER *memb; alpar@9: xassert(mpl->flag_p); alpar@9: /* display all members of the constraint array */ alpar@9: if (con->array->head == NULL) alpar@9: write_text(mpl, "%s has empty content\n", con->name); alpar@9: for (memb = con->array->head; memb != NULL; memb = alpar@9: memb->next) display_con(mpl, con, memb, DOT_NONE); alpar@9: } alpar@9: else if (entry->type == A_EXPRESSION) alpar@9: { /* expression */ alpar@9: CODE *code = entry->u.code; alpar@9: if (code->op == O_MEMNUM || code->op == O_MEMSYM || alpar@9: code->op == O_MEMSET || code->op == O_MEMVAR || alpar@9: code->op == O_MEMCON) alpar@9: display_memb(mpl, code); alpar@9: else alpar@9: display_code(mpl, code); alpar@9: } alpar@9: else alpar@9: xassert(entry != entry); alpar@9: } alpar@9: return 0; alpar@9: } alpar@9: alpar@9: void execute_display(MPL *mpl, DISPLAY *dpy) alpar@9: { loop_within_domain(mpl, dpy->domain, dpy, display_func); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_display - clean display statement. alpar@9: -- alpar@9: -- This routine cleans specified display statement that assumes deleting alpar@9: -- all stuff dynamically allocated on generating/postsolving phase. */ alpar@9: alpar@9: void clean_display(MPL *mpl, DISPLAY *dpy) alpar@9: { DISPLAY1 *d; alpar@9: #if 0 /* 15/V-2010 */ alpar@9: ARG_LIST *e; alpar@9: #endif alpar@9: /* clean subscript domain */ alpar@9: clean_domain(mpl, dpy->domain); alpar@9: /* clean display list */ alpar@9: for (d = dpy->list; d != NULL; d = d->next) alpar@9: { /* clean pseudo-code for computing expression */ alpar@9: if (d->type == A_EXPRESSION) alpar@9: clean_code(mpl, d->u.code); alpar@9: #if 0 /* 15/V-2010 */ alpar@9: /* clean pseudo-code for computing subscripts */ alpar@9: for (e = d->list; e != NULL; e = e->next) alpar@9: clean_code(mpl, e->x); alpar@9: #endif alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- execute_printf - execute printf statement. alpar@9: -- alpar@9: -- This routine executes specified printf statement. */ alpar@9: alpar@9: #if 1 /* 14/VII-2006 */ alpar@9: static void print_char(MPL *mpl, int c) alpar@9: { if (mpl->prt_fp == NULL) alpar@9: write_char(mpl, c); alpar@9: else alpar@9: xfputc(c, mpl->prt_fp); alpar@9: return; alpar@9: } alpar@9: alpar@9: static void print_text(MPL *mpl, char *fmt, ...) alpar@9: { va_list arg; alpar@9: char buf[OUTBUF_SIZE], *c; alpar@9: va_start(arg, fmt); alpar@9: vsprintf(buf, fmt, arg); alpar@9: xassert(strlen(buf) < sizeof(buf)); alpar@9: va_end(arg); alpar@9: for (c = buf; *c != '\0'; c++) print_char(mpl, *c); alpar@9: return; alpar@9: } alpar@9: #endif alpar@9: alpar@9: static int printf_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: PRINTF *prt = (PRINTF *)info; alpar@9: PRINTF1 *entry; alpar@9: SYMBOL *sym; alpar@9: char fmt[MAX_LENGTH+1], *c, *from, save; alpar@9: /* evaluate format control string */ alpar@9: sym = eval_symbolic(mpl, prt->fmt); alpar@9: if (sym->str == NULL) alpar@9: sprintf(fmt, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: fetch_string(mpl, sym->str, fmt); alpar@9: delete_symbol(mpl, sym); alpar@9: /* scan format control string and perform formatting output */ alpar@9: entry = prt->list; alpar@9: for (c = fmt; *c != '\0'; c++) alpar@9: { if (*c == '%') alpar@9: { /* scan format specifier */ alpar@9: from = c++; alpar@9: if (*c == '%') alpar@9: { print_char(mpl, '%'); alpar@9: continue; alpar@9: } alpar@9: if (entry == NULL) break; alpar@9: /* scan optional flags */ alpar@9: while (*c == '-' || *c == '+' || *c == ' ' || *c == '#' || alpar@9: *c == '0') c++; alpar@9: /* scan optional minimum field width */ alpar@9: while (isdigit((unsigned char)*c)) c++; alpar@9: /* scan optional precision */ alpar@9: if (*c == '.') alpar@9: { c++; alpar@9: while (isdigit((unsigned char)*c)) c++; alpar@9: } alpar@9: /* scan conversion specifier and perform formatting */ alpar@9: save = *(c+1), *(c+1) = '\0'; alpar@9: if (*c == 'd' || *c == 'i' || *c == 'e' || *c == 'E' || alpar@9: *c == 'f' || *c == 'F' || *c == 'g' || *c == 'G') alpar@9: { /* the specifier requires numeric value */ alpar@9: double value; alpar@9: xassert(entry != NULL); alpar@9: switch (entry->code->type) alpar@9: { case A_NUMERIC: alpar@9: value = eval_numeric(mpl, entry->code); alpar@9: break; alpar@9: case A_SYMBOLIC: alpar@9: sym = eval_symbolic(mpl, entry->code); alpar@9: if (sym->str != NULL) alpar@9: error(mpl, "cannot convert %s to floating-point" alpar@9: " number", format_symbol(mpl, sym)); alpar@9: value = sym->num; alpar@9: delete_symbol(mpl, sym); alpar@9: break; alpar@9: case A_LOGICAL: alpar@9: if (eval_logical(mpl, entry->code)) alpar@9: value = 1.0; alpar@9: else alpar@9: value = 0.0; alpar@9: break; alpar@9: default: alpar@9: xassert(entry != entry); alpar@9: } alpar@9: if (*c == 'd' || *c == 'i') alpar@9: { double int_max = (double)INT_MAX; alpar@9: if (!(-int_max <= value && value <= +int_max)) alpar@9: error(mpl, "cannot convert %.*g to integer", alpar@9: DBL_DIG, value); alpar@9: print_text(mpl, from, (int)floor(value + 0.5)); alpar@9: } alpar@9: else alpar@9: print_text(mpl, from, value); alpar@9: } alpar@9: else if (*c == 's') alpar@9: { /* the specifier requires symbolic value */ alpar@9: char value[MAX_LENGTH+1]; alpar@9: switch (entry->code->type) alpar@9: { case A_NUMERIC: alpar@9: sprintf(value, "%.*g", DBL_DIG, eval_numeric(mpl, alpar@9: entry->code)); alpar@9: break; alpar@9: case A_LOGICAL: alpar@9: if (eval_logical(mpl, entry->code)) alpar@9: strcpy(value, "T"); alpar@9: else alpar@9: strcpy(value, "F"); alpar@9: break; alpar@9: case A_SYMBOLIC: alpar@9: sym = eval_symbolic(mpl, entry->code); alpar@9: if (sym->str == NULL) alpar@9: sprintf(value, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: fetch_string(mpl, sym->str, value); alpar@9: delete_symbol(mpl, sym); alpar@9: break; alpar@9: default: alpar@9: xassert(entry != entry); alpar@9: } alpar@9: print_text(mpl, from, value); alpar@9: } alpar@9: else alpar@9: error(mpl, "format specifier missing or invalid"); alpar@9: *(c+1) = save; alpar@9: entry = entry->next; alpar@9: } alpar@9: else if (*c == '\\') alpar@9: { /* write some control character */ alpar@9: c++; alpar@9: if (*c == 't') alpar@9: print_char(mpl, '\t'); alpar@9: else if (*c == 'n') alpar@9: print_char(mpl, '\n'); alpar@9: #if 1 /* 28/X-2010 */ alpar@9: else if (*c == '\0') alpar@9: { /* format string ends with backslash */ alpar@9: error(mpl, "invalid use of escape character \\ in format" alpar@9: " control string"); alpar@9: } alpar@9: #endif alpar@9: else alpar@9: print_char(mpl, *c); alpar@9: } alpar@9: else alpar@9: { /* write character without formatting */ alpar@9: print_char(mpl, *c); alpar@9: } alpar@9: } alpar@9: return 0; alpar@9: } alpar@9: alpar@9: #if 0 /* 14/VII-2006 */ alpar@9: void execute_printf(MPL *mpl, PRINTF *prt) alpar@9: { loop_within_domain(mpl, prt->domain, prt, printf_func); alpar@9: return; alpar@9: } alpar@9: #else alpar@9: void execute_printf(MPL *mpl, PRINTF *prt) alpar@9: { if (prt->fname == NULL) alpar@9: { /* switch to the standard output */ alpar@9: if (mpl->prt_fp != NULL) alpar@9: { xfclose(mpl->prt_fp), mpl->prt_fp = NULL; alpar@9: xfree(mpl->prt_file), mpl->prt_file = NULL; alpar@9: } alpar@9: } alpar@9: else alpar@9: { /* evaluate file name string */ alpar@9: SYMBOL *sym; alpar@9: char fname[MAX_LENGTH+1]; alpar@9: sym = eval_symbolic(mpl, prt->fname); alpar@9: if (sym->str == NULL) alpar@9: sprintf(fname, "%.*g", DBL_DIG, sym->num); alpar@9: else alpar@9: fetch_string(mpl, sym->str, fname); alpar@9: delete_symbol(mpl, sym); alpar@9: /* close the current print file, if necessary */ alpar@9: if (mpl->prt_fp != NULL && alpar@9: (!prt->app || strcmp(mpl->prt_file, fname) != 0)) alpar@9: { xfclose(mpl->prt_fp), mpl->prt_fp = NULL; alpar@9: xfree(mpl->prt_file), mpl->prt_file = NULL; alpar@9: } alpar@9: /* open the specified print file, if necessary */ alpar@9: if (mpl->prt_fp == NULL) alpar@9: { mpl->prt_fp = xfopen(fname, prt->app ? "a" : "w"); alpar@9: if (mpl->prt_fp == NULL) alpar@9: error(mpl, "unable to open `%s' for writing - %s", alpar@9: fname, xerrmsg()); alpar@9: mpl->prt_file = xmalloc(strlen(fname)+1); alpar@9: strcpy(mpl->prt_file, fname); alpar@9: } alpar@9: } alpar@9: loop_within_domain(mpl, prt->domain, prt, printf_func); alpar@9: if (mpl->prt_fp != NULL) alpar@9: { xfflush(mpl->prt_fp); alpar@9: if (xferror(mpl->prt_fp)) alpar@9: error(mpl, "writing error to `%s' - %s", mpl->prt_file, alpar@9: xerrmsg()); alpar@9: } alpar@9: return; alpar@9: } alpar@9: #endif alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_printf - clean printf statement. alpar@9: -- alpar@9: -- This routine cleans specified printf statement that assumes deleting alpar@9: -- all stuff dynamically allocated on generating/postsolving phase. */ alpar@9: alpar@9: void clean_printf(MPL *mpl, PRINTF *prt) alpar@9: { PRINTF1 *p; alpar@9: /* clean subscript domain */ alpar@9: clean_domain(mpl, prt->domain); alpar@9: /* clean pseudo-code for computing format string */ alpar@9: clean_code(mpl, prt->fmt); alpar@9: /* clean printf list */ alpar@9: for (p = prt->list; p != NULL; p = p->next) alpar@9: { /* clean pseudo-code for computing value to be printed */ alpar@9: clean_code(mpl, p->code); alpar@9: } alpar@9: #if 1 /* 14/VII-2006 */ alpar@9: /* clean pseudo-code for computing file name string */ alpar@9: clean_code(mpl, prt->fname); alpar@9: #endif alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- execute_for - execute for statement. alpar@9: -- alpar@9: -- This routine executes specified for statement. */ alpar@9: alpar@9: static int for_func(MPL *mpl, void *info) alpar@9: { /* this is auxiliary routine to work within domain scope */ alpar@9: FOR *fur = (FOR *)info; alpar@9: STATEMENT *stmt, *save; alpar@9: save = mpl->stmt; alpar@9: for (stmt = fur->list; stmt != NULL; stmt = stmt->next) alpar@9: execute_statement(mpl, stmt); alpar@9: mpl->stmt = save; alpar@9: return 0; alpar@9: } alpar@9: alpar@9: void execute_for(MPL *mpl, FOR *fur) alpar@9: { loop_within_domain(mpl, fur->domain, fur, for_func); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_for - clean for statement. alpar@9: -- alpar@9: -- This routine cleans specified for statement that assumes deleting all alpar@9: -- stuff dynamically allocated on generating/postsolving phase. */ alpar@9: alpar@9: void clean_for(MPL *mpl, FOR *fur) alpar@9: { STATEMENT *stmt; alpar@9: /* clean subscript domain */ alpar@9: clean_domain(mpl, fur->domain); alpar@9: /* clean all sub-statements */ alpar@9: for (stmt = fur->list; stmt != NULL; stmt = stmt->next) alpar@9: clean_statement(mpl, stmt); alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- execute_statement - execute specified model statement. alpar@9: -- alpar@9: -- This routine executes specified model statement. */ alpar@9: alpar@9: void execute_statement(MPL *mpl, STATEMENT *stmt) alpar@9: { mpl->stmt = stmt; alpar@9: switch (stmt->type) alpar@9: { case A_SET: alpar@9: case A_PARAMETER: alpar@9: case A_VARIABLE: alpar@9: break; alpar@9: case A_CONSTRAINT: alpar@9: xprintf("Generating %s...\n", stmt->u.con->name); alpar@9: eval_whole_con(mpl, stmt->u.con); alpar@9: break; alpar@9: case A_TABLE: alpar@9: switch (stmt->u.tab->type) alpar@9: { case A_INPUT: alpar@9: xprintf("Reading %s...\n", stmt->u.tab->name); alpar@9: break; alpar@9: case A_OUTPUT: alpar@9: xprintf("Writing %s...\n", stmt->u.tab->name); alpar@9: break; alpar@9: default: alpar@9: xassert(stmt != stmt); alpar@9: } alpar@9: execute_table(mpl, stmt->u.tab); alpar@9: break; alpar@9: case A_SOLVE: alpar@9: break; alpar@9: case A_CHECK: alpar@9: xprintf("Checking (line %d)...\n", stmt->line); alpar@9: execute_check(mpl, stmt->u.chk); alpar@9: break; alpar@9: case A_DISPLAY: alpar@9: write_text(mpl, "Display statement at line %d\n", alpar@9: stmt->line); alpar@9: execute_display(mpl, stmt->u.dpy); alpar@9: break; alpar@9: case A_PRINTF: alpar@9: execute_printf(mpl, stmt->u.prt); alpar@9: break; alpar@9: case A_FOR: alpar@9: execute_for(mpl, stmt->u.fur); alpar@9: break; alpar@9: default: alpar@9: xassert(stmt != stmt); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /*---------------------------------------------------------------------- alpar@9: -- clean_statement - clean specified model statement. alpar@9: -- alpar@9: -- This routine cleans specified model statement that assumes deleting alpar@9: -- all stuff dynamically allocated on generating/postsolving phase. */ alpar@9: alpar@9: void clean_statement(MPL *mpl, STATEMENT *stmt) alpar@9: { switch(stmt->type) alpar@9: { case A_SET: alpar@9: clean_set(mpl, stmt->u.set); break; alpar@9: case A_PARAMETER: alpar@9: clean_parameter(mpl, stmt->u.par); break; alpar@9: case A_VARIABLE: alpar@9: clean_variable(mpl, stmt->u.var); break; alpar@9: case A_CONSTRAINT: alpar@9: clean_constraint(mpl, stmt->u.con); break; alpar@9: #if 1 /* 11/II-2008 */ alpar@9: case A_TABLE: alpar@9: clean_table(mpl, stmt->u.tab); break; alpar@9: #endif alpar@9: case A_SOLVE: alpar@9: break; alpar@9: case A_CHECK: alpar@9: clean_check(mpl, stmt->u.chk); break; alpar@9: case A_DISPLAY: alpar@9: clean_display(mpl, stmt->u.dpy); break; alpar@9: case A_PRINTF: alpar@9: clean_printf(mpl, stmt->u.prt); break; alpar@9: case A_FOR: alpar@9: clean_for(mpl, stmt->u.fur); break; alpar@9: default: alpar@9: xassert(stmt != stmt); alpar@9: } alpar@9: return; alpar@9: } alpar@9: alpar@9: /* eof */