lemon-project-template-glpk: deps/glpk/src/glpmpl03.c annotate

lemon-project-template-glpk

annotate deps/glpk/src/glpmpl03.c @ 11:4fc6ad2fb8a6

Test GLPK in src/main.cc

author	Alpar Juttner <alpar@cs.elte.hu>
date	Sun, 06 Nov 2011 21:43:29 +0100
parents
children

rev	line source
alpar@9	1 /* glpmpl03.c */
alpar@9	2
alpar@9	3 /***********************************************************************
alpar@9	4 * This code is part of GLPK (GNU Linear Programming Kit).
alpar@9	5 *
alpar@9	6 * Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
alpar@9	7 * 2009, 2010, 2011 Andrew Makhorin, Department for Applied Informatics,
alpar@9	8 * Moscow Aviation Institute, Moscow, Russia. All rights reserved.
alpar@9	9 * E-mail: <mao@gnu.org>.
alpar@9	10 *
alpar@9	11 * GLPK is free software: you can redistribute it and/or modify it
alpar@9	12 * under the terms of the GNU General Public License as published by
alpar@9	13 * the Free Software Foundation, either version 3 of the License, or
alpar@9	14 * (at your option) any later version.
alpar@9	15 *
alpar@9	16 * GLPK is distributed in the hope that it will be useful, but WITHOUT
alpar@9	17 * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
alpar@9	18 * or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
alpar@9	19 * License for more details.
alpar@9	20 *
alpar@9	21 * You should have received a copy of the GNU General Public License
alpar@9	22 * along with GLPK. If not, see <http://www.gnu.org/licenses/>.
alpar@9	23 ***********************************************************************/
alpar@9	24
alpar@9	25 #define _GLPSTD_ERRNO
alpar@9	26 #define _GLPSTD_STDIO
alpar@9	27 #include "glpenv.h"
alpar@9	28 #include "glpmpl.h"
alpar@9	29
alpar@9	30 /**********************************************************************/
alpar@9	31 /* * * FLOATING-POINT NUMBERS * * */
alpar@9	32 /**********************************************************************/
alpar@9	33
alpar@9	34 /*----------------------------------------------------------------------
alpar@9	35 -- fp_add - floating-point addition.
alpar@9	36 --
alpar@9	37 -- This routine computes the sum x + y. */
alpar@9	38
alpar@9	39 double fp_add(MPL *mpl, double x, double y)
alpar@9	40 { if (x > 0.0 && y > 0.0 && x > + 0.999 * DBL_MAX - y \|\|
alpar@9	41 x < 0.0 && y < 0.0 && x < - 0.999 * DBL_MAX - y)
alpar@9	42 error(mpl, "%.g + %.g; floating-point overflow",
alpar@9	43 DBL_DIG, x, DBL_DIG, y);
alpar@9	44 return x + y;
alpar@9	45 }
alpar@9	46
alpar@9	47 /*----------------------------------------------------------------------
alpar@9	48 -- fp_sub - floating-point subtraction.
alpar@9	49 --
alpar@9	50 -- This routine computes the difference x - y. */
alpar@9	51
alpar@9	52 double fp_sub(MPL *mpl, double x, double y)
alpar@9	53 { if (x > 0.0 && y < 0.0 && x > + 0.999 * DBL_MAX + y \|\|
alpar@9	54 x < 0.0 && y > 0.0 && x < - 0.999 * DBL_MAX + y)
alpar@9	55 error(mpl, "%.g - %.g; floating-point overflow",
alpar@9	56 DBL_DIG, x, DBL_DIG, y);
alpar@9	57 return x - y;
alpar@9	58 }
alpar@9	59
alpar@9	60 /*----------------------------------------------------------------------
alpar@9	61 -- fp_less - floating-point non-negative subtraction.
alpar@9	62 --
alpar@9	63 -- This routine computes the non-negative difference max(0, x - y). */
alpar@9	64
alpar@9	65 double fp_less(MPL *mpl, double x, double y)
alpar@9	66 { if (x < y) return 0.0;
alpar@9	67 if (x > 0.0 && y < 0.0 && x > + 0.999 * DBL_MAX + y)
alpar@9	68 error(mpl, "%.g less %.g; floating-point overflow",
alpar@9	69 DBL_DIG, x, DBL_DIG, y);
alpar@9	70 return x - y;
alpar@9	71 }
alpar@9	72
alpar@9	73 /*----------------------------------------------------------------------
alpar@9	74 -- fp_mul - floating-point multiplication.
alpar@9	75 --
alpar@9	76 -- This routine computes the product x * y. */
alpar@9	77
alpar@9	78 double fp_mul(MPL *mpl, double x, double y)
alpar@9	79 { if (fabs(y) > 1.0 && fabs(x) > (0.999 * DBL_MAX) / fabs(y))
alpar@9	80 error(mpl, "%.g %.*g; floating-point overflow",
alpar@9	81 DBL_DIG, x, DBL_DIG, y);
alpar@9	82 return x * y;
alpar@9	83 }
alpar@9	84
alpar@9	85 /*----------------------------------------------------------------------
alpar@9	86 -- fp_div - floating-point division.
alpar@9	87 --
alpar@9	88 -- This routine computes the quotient x / y. */
alpar@9	89
alpar@9	90 double fp_div(MPL *mpl, double x, double y)
alpar@9	91 { if (fabs(y) < DBL_MIN)
alpar@9	92 error(mpl, "%.g / %.g; floating-point zero divide",
alpar@9	93 DBL_DIG, x, DBL_DIG, y);
alpar@9	94 if (fabs(y) < 1.0 && fabs(x) > (0.999 * DBL_MAX) * fabs(y))
alpar@9	95 error(mpl, "%.g / %.g; floating-point overflow",
alpar@9	96 DBL_DIG, x, DBL_DIG, y);
alpar@9	97 return x / y;
alpar@9	98 }
alpar@9	99
alpar@9	100 /*----------------------------------------------------------------------
alpar@9	101 -- fp_idiv - floating-point quotient of exact division.
alpar@9	102 --
alpar@9	103 -- This routine computes the quotient of exact division x div y. */
alpar@9	104
alpar@9	105 double fp_idiv(MPL *mpl, double x, double y)
alpar@9	106 { if (fabs(y) < DBL_MIN)
alpar@9	107 error(mpl, "%.g div %.g; floating-point zero divide",
alpar@9	108 DBL_DIG, x, DBL_DIG, y);
alpar@9	109 if (fabs(y) < 1.0 && fabs(x) > (0.999 * DBL_MAX) * fabs(y))
alpar@9	110 error(mpl, "%.g div %.g; floating-point overflow",
alpar@9	111 DBL_DIG, x, DBL_DIG, y);
alpar@9	112 x /= y;
alpar@9	113 return x > 0.0 ? floor(x) : x < 0.0 ? ceil(x) : 0.0;
alpar@9	114 }
alpar@9	115
alpar@9	116 /*----------------------------------------------------------------------
alpar@9	117 -- fp_mod - floating-point remainder of exact division.
alpar@9	118 --
alpar@9	119 -- This routine computes the remainder of exact division x mod y.
alpar@9	120 --
alpar@9	121 -- NOTE: By definition x mod y = x - y * floor(x / y). */
alpar@9	122
alpar@9	123 double fp_mod(MPL *mpl, double x, double y)
alpar@9	124 { double r;
alpar@9	125 xassert(mpl == mpl);
alpar@9	126 if (x == 0.0)
alpar@9	127 r = 0.0;
alpar@9	128 else if (y == 0.0)
alpar@9	129 r = x;
alpar@9	130 else
alpar@9	131 { r = fmod(fabs(x), fabs(y));
alpar@9	132 if (r != 0.0)
alpar@9	133 { if (x < 0.0) r = - r;
alpar@9	134 if (x > 0.0 && y < 0.0 \|\| x < 0.0 && y > 0.0) r += y;
alpar@9	135 }
alpar@9	136 }
alpar@9	137 return r;
alpar@9	138 }
alpar@9	139
alpar@9	140 /*----------------------------------------------------------------------
alpar@9	141 -- fp_power - floating-point exponentiation (raise to power).
alpar@9	142 --
alpar@9	143 -- This routine computes the exponentiation x ** y. */
alpar@9	144
alpar@9	145 double fp_power(MPL *mpl, double x, double y)
alpar@9	146 { double r;
alpar@9	147 if (x == 0.0 && y <= 0.0 \|\| x < 0.0 && y != floor(y))
alpar@9	148 error(mpl, "%.g * %.*g; result undefined",
alpar@9	149 DBL_DIG, x, DBL_DIG, y);
alpar@9	150 if (x == 0.0) goto eval;
alpar@9	151 if (fabs(x) > 1.0 && y > +1.0 &&
alpar@9	152 +log(fabs(x)) > (0.999 * log(DBL_MAX)) / y \|\|
alpar@9	153 fabs(x) < 1.0 && y < -1.0 &&
alpar@9	154 +log(fabs(x)) < (0.999 * log(DBL_MAX)) / y)
alpar@9	155 error(mpl, "%.g * %.*g; floating-point overflow",
alpar@9	156 DBL_DIG, x, DBL_DIG, y);
alpar@9	157 if (fabs(x) > 1.0 && y < -1.0 &&
alpar@9	158 -log(fabs(x)) < (0.999 * log(DBL_MAX)) / y \|\|
alpar@9	159 fabs(x) < 1.0 && y > +1.0 &&
alpar@9	160 -log(fabs(x)) > (0.999 * log(DBL_MAX)) / y)
alpar@9	161 r = 0.0;
alpar@9	162 else
alpar@9	163 eval: r = pow(x, y);
alpar@9	164 return r;
alpar@9	165 }
alpar@9	166
alpar@9	167 /*----------------------------------------------------------------------
alpar@9	168 -- fp_exp - floating-point base-e exponential.
alpar@9	169 --
alpar@9	170 -- This routine computes the base-e exponential e ** x. */
alpar@9	171
alpar@9	172 double fp_exp(MPL *mpl, double x)
alpar@9	173 { if (x > 0.999 * log(DBL_MAX))
alpar@9	174 error(mpl, "exp(%.*g); floating-point overflow", DBL_DIG, x);
alpar@9	175 return exp(x);
alpar@9	176 }
alpar@9	177
alpar@9	178 /*----------------------------------------------------------------------
alpar@9	179 -- fp_log - floating-point natural logarithm.
alpar@9	180 --
alpar@9	181 -- This routine computes the natural logarithm log x. */
alpar@9	182
alpar@9	183 double fp_log(MPL *mpl, double x)
alpar@9	184 { if (x <= 0.0)
alpar@9	185 error(mpl, "log(%.*g); non-positive argument", DBL_DIG, x);
alpar@9	186 return log(x);
alpar@9	187 }
alpar@9	188
alpar@9	189 /*----------------------------------------------------------------------
alpar@9	190 -- fp_log10 - floating-point common (decimal) logarithm.
alpar@9	191 --
alpar@9	192 -- This routine computes the common (decimal) logarithm lg x. */
alpar@9	193
alpar@9	194 double fp_log10(MPL *mpl, double x)
alpar@9	195 { if (x <= 0.0)
alpar@9	196 error(mpl, "log10(%.*g); non-positive argument", DBL_DIG, x);
alpar@9	197 return log10(x);
alpar@9	198 }
alpar@9	199
alpar@9	200 /*----------------------------------------------------------------------
alpar@9	201 -- fp_sqrt - floating-point square root.
alpar@9	202 --
alpar@9	203 -- This routine computes the square root x ** 0.5. */
alpar@9	204
alpar@9	205 double fp_sqrt(MPL *mpl, double x)
alpar@9	206 { if (x < 0.0)
alpar@9	207 error(mpl, "sqrt(%.*g); negative argument", DBL_DIG, x);
alpar@9	208 return sqrt(x);
alpar@9	209 }
alpar@9	210
alpar@9	211 /*----------------------------------------------------------------------
alpar@9	212 -- fp_sin - floating-point trigonometric sine.
alpar@9	213 --
alpar@9	214 -- This routine computes the trigonometric sine sin(x). */
alpar@9	215
alpar@9	216 double fp_sin(MPL *mpl, double x)
alpar@9	217 { if (!(-1e6 <= x && x <= +1e6))
alpar@9	218 error(mpl, "sin(%.*g); argument too large", DBL_DIG, x);
alpar@9	219 return sin(x);
alpar@9	220 }
alpar@9	221
alpar@9	222 /*----------------------------------------------------------------------
alpar@9	223 -- fp_cos - floating-point trigonometric cosine.
alpar@9	224 --
alpar@9	225 -- This routine computes the trigonometric cosine cos(x). */
alpar@9	226
alpar@9	227 double fp_cos(MPL *mpl, double x)
alpar@9	228 { if (!(-1e6 <= x && x <= +1e6))
alpar@9	229 error(mpl, "cos(%.*g); argument too large", DBL_DIG, x);
alpar@9	230 return cos(x);
alpar@9	231 }
alpar@9	232
alpar@9	233 /*----------------------------------------------------------------------
alpar@9	234 -- fp_atan - floating-point trigonometric arctangent.
alpar@9	235 --
alpar@9	236 -- This routine computes the trigonometric arctangent atan(x). */
alpar@9	237
alpar@9	238 double fp_atan(MPL *mpl, double x)
alpar@9	239 { xassert(mpl == mpl);
alpar@9	240 return atan(x);
alpar@9	241 }
alpar@9	242
alpar@9	243 /*----------------------------------------------------------------------
alpar@9	244 -- fp_atan2 - floating-point trigonometric arctangent.
alpar@9	245 --
alpar@9	246 -- This routine computes the trigonometric arctangent atan(y / x). */
alpar@9	247
alpar@9	248 double fp_atan2(MPL *mpl, double y, double x)
alpar@9	249 { xassert(mpl == mpl);
alpar@9	250 return atan2(y, x);
alpar@9	251 }
alpar@9	252
alpar@9	253 /*----------------------------------------------------------------------
alpar@9	254 -- fp_round - round floating-point value to n fractional digits.
alpar@9	255 --
alpar@9	256 -- This routine rounds given floating-point value x to n fractional
alpar@9	257 -- digits with the formula:
alpar@9	258 --
alpar@9	259 -- round(x, n) = floor(x * 10^n + 0.5) / 10^n.
alpar@9	260 --
alpar@9	261 -- The parameter n is assumed to be integer. */
alpar@9	262
alpar@9	263 double fp_round(MPL *mpl, double x, double n)
alpar@9	264 { double ten_to_n;
alpar@9	265 if (n != floor(n))
alpar@9	266 error(mpl, "round(%.g, %.g); non-integer second argument",
alpar@9	267 DBL_DIG, x, DBL_DIG, n);
alpar@9	268 if (n <= DBL_DIG + 2)
alpar@9	269 { ten_to_n = pow(10.0, n);
alpar@9	270 if (fabs(x) < (0.999 * DBL_MAX) / ten_to_n)
alpar@9	271 { x = floor(x * ten_to_n + 0.5);
alpar@9	272 if (x != 0.0) x /= ten_to_n;
alpar@9	273 }
alpar@9	274 }
alpar@9	275 return x;
alpar@9	276 }
alpar@9	277
alpar@9	278 /*----------------------------------------------------------------------
alpar@9	279 -- fp_trunc - truncate floating-point value to n fractional digits.
alpar@9	280 --
alpar@9	281 -- This routine truncates given floating-point value x to n fractional
alpar@9	282 -- digits with the formula:
alpar@9	283 --
alpar@9	284 -- ( floor(x * 10^n) / 10^n, if x >= 0
alpar@9	285 -- trunc(x, n) = <
alpar@9	286 -- ( ceil(x * 10^n) / 10^n, if x < 0
alpar@9	287 --
alpar@9	288 -- The parameter n is assumed to be integer. */
alpar@9	289
alpar@9	290 double fp_trunc(MPL *mpl, double x, double n)
alpar@9	291 { double ten_to_n;
alpar@9	292 if (n != floor(n))
alpar@9	293 error(mpl, "trunc(%.g, %.g); non-integer second argument",
alpar@9	294 DBL_DIG, x, DBL_DIG, n);
alpar@9	295 if (n <= DBL_DIG + 2)
alpar@9	296 { ten_to_n = pow(10.0, n);
alpar@9	297 if (fabs(x) < (0.999 * DBL_MAX) / ten_to_n)
alpar@9	298 { x = (x >= 0.0 ? floor(x * ten_to_n) : ceil(x * ten_to_n));
alpar@9	299 if (x != 0.0) x /= ten_to_n;
alpar@9	300 }
alpar@9	301 }
alpar@9	302 return x;
alpar@9	303 }
alpar@9	304
alpar@9	305 /**********************************************************************/
alpar@9	306 /* * * PSEUDO-RANDOM NUMBER GENERATORS * * */
alpar@9	307 /**********************************************************************/
alpar@9	308
alpar@9	309 /*----------------------------------------------------------------------
alpar@9	310 -- fp_irand224 - pseudo-random integer in the range [0, 2^24).
alpar@9	311 --
alpar@9	312 -- This routine returns a next pseudo-random integer (converted to
alpar@9	313 -- floating-point) which is uniformly distributed between 0 and 2^24-1,
alpar@9	314 -- inclusive. */
alpar@9	315
alpar@9	316 #define two_to_the_24 0x1000000
alpar@9	317
alpar@9	318 double fp_irand224(MPL *mpl)
alpar@9	319 { return
alpar@9	320 (double)rng_unif_rand(mpl->rand, two_to_the_24);
alpar@9	321 }
alpar@9	322
alpar@9	323 /*----------------------------------------------------------------------
alpar@9	324 -- fp_uniform01 - pseudo-random number in the range [0, 1).
alpar@9	325 --
alpar@9	326 -- This routine returns a next pseudo-random number which is uniformly
alpar@9	327 -- distributed in the range [0, 1). */
alpar@9	328
alpar@9	329 #define two_to_the_31 ((unsigned int)0x80000000)
alpar@9	330
alpar@9	331 double fp_uniform01(MPL *mpl)
alpar@9	332 { return
alpar@9	333 (double)rng_next_rand(mpl->rand) / (double)two_to_the_31;
alpar@9	334 }
alpar@9	335
alpar@9	336 /*----------------------------------------------------------------------
alpar@9	337 -- fp_uniform - pseudo-random number in the range [a, b).
alpar@9	338 --
alpar@9	339 -- This routine returns a next pseudo-random number which is uniformly
alpar@9	340 -- distributed in the range [a, b). */
alpar@9	341
alpar@9	342 double fp_uniform(MPL *mpl, double a, double b)
alpar@9	343 { double x;
alpar@9	344 if (a >= b)
alpar@9	345 error(mpl, "Uniform(%.g, %.g); invalid range",
alpar@9	346 DBL_DIG, a, DBL_DIG, b);
alpar@9	347 x = fp_uniform01(mpl);
alpar@9	348 #if 0
alpar@9	349 x = a * (1.0 - x) + b * x;
alpar@9	350 #else
alpar@9	351 x = fp_add(mpl, a * (1.0 - x), b * x);
alpar@9	352 #endif
alpar@9	353 return x;
alpar@9	354 }
alpar@9	355
alpar@9	356 /*----------------------------------------------------------------------
alpar@9	357 -- fp_normal01 - Gaussian random variate with mu = 0 and sigma = 1.
alpar@9	358 --
alpar@9	359 -- This routine returns a Gaussian random variate with zero mean and
alpar@9	360 -- unit standard deviation. The polar (Box-Mueller) method is used.
alpar@9	361 --
alpar@9	362 -- This code is a modified version of the routine gsl_ran_gaussian from
alpar@9	363 -- the GNU Scientific Library Version 1.0. */
alpar@9	364
alpar@9	365 double fp_normal01(MPL *mpl)
alpar@9	366 { double x, y, r2;
alpar@9	367 do
alpar@9	368 { /* choose x, y in uniform square (-1,-1) to (+1,+1) */
alpar@9	369 x = -1.0 + 2.0 * fp_uniform01(mpl);
alpar@9	370 y = -1.0 + 2.0 * fp_uniform01(mpl);
alpar@9	371 /* see if it is in the unit circle */
alpar@9	372 r2 = x * x + y * y;
alpar@9	373 } while (r2 > 1.0 \|\| r2 == 0.0);
alpar@9	374 /* Box-Muller transform */
alpar@9	375 return y * sqrt(-2.0 * log (r2) / r2);
alpar@9	376 }
alpar@9	377
alpar@9	378 /*----------------------------------------------------------------------
alpar@9	379 -- fp_normal - Gaussian random variate with specified mu and sigma.
alpar@9	380 --
alpar@9	381 -- This routine returns a Gaussian random variate with mean mu and
alpar@9	382 -- standard deviation sigma. */
alpar@9	383
alpar@9	384 double fp_normal(MPL *mpl, double mu, double sigma)
alpar@9	385 { double x;
alpar@9	386 #if 0
alpar@9	387 x = mu + sigma * fp_normal01(mpl);
alpar@9	388 #else
alpar@9	389 x = fp_add(mpl, mu, fp_mul(mpl, sigma, fp_normal01(mpl)));
alpar@9	390 #endif
alpar@9	391 return x;
alpar@9	392 }
alpar@9	393
alpar@9	394 /**********************************************************************/
alpar@9	395 /* * * SEGMENTED CHARACTER STRINGS * * */
alpar@9	396 /**********************************************************************/
alpar@9	397
alpar@9	398 /*----------------------------------------------------------------------
alpar@9	399 -- create_string - create character string.
alpar@9	400 --
alpar@9	401 -- This routine creates a segmented character string, which is exactly
alpar@9	402 -- equivalent to specified character string. */
alpar@9	403
alpar@9	404 STRING *create_string
alpar@9	405 ( MPL *mpl,
alpar@9	406 char buf[MAX_LENGTH+1] /* not changed */
alpar@9	407 )
alpar@9	408 #if 0
alpar@9	409 { STRING head, tail;
alpar@9	410 int i, j;
alpar@9	411 xassert(buf != NULL);
alpar@9	412 xassert(strlen(buf) <= MAX_LENGTH);
alpar@9	413 head = tail = dmp_get_atom(mpl->strings, sizeof(STRING));
alpar@9	414 for (i = j = 0; ; i++)
alpar@9	415 { if ((tail->seg[j++] = buf[i]) == '\0') break;
alpar@9	416 if (j == STRSEG_SIZE)
alpar@9	417 tail = (tail->next = dmp_get_atom(mpl->strings, sizeof(STRING))), j = 0;
alpar@9	418 }
alpar@9	419 tail->next = NULL;
alpar@9	420 return head;
alpar@9	421 }
alpar@9	422 #else
alpar@9	423 { STRING *str;
alpar@9	424 xassert(strlen(buf) <= MAX_LENGTH);
alpar@9	425 str = dmp_get_atom(mpl->strings, strlen(buf)+1);
alpar@9	426 strcpy(str, buf);
alpar@9	427 return str;
alpar@9	428 }
alpar@9	429 #endif
alpar@9	430
alpar@9	431 /*----------------------------------------------------------------------
alpar@9	432 -- copy_string - make copy of character string.
alpar@9	433 --
alpar@9	434 -- This routine returns an exact copy of segmented character string. */
alpar@9	435
alpar@9	436 STRING *copy_string
alpar@9	437 ( MPL *mpl,
alpar@9	438 STRING str / not changed */
alpar@9	439 )
alpar@9	440 #if 0
alpar@9	441 { STRING head, tail;
alpar@9	442 xassert(str != NULL);
alpar@9	443 head = tail = dmp_get_atom(mpl->strings, sizeof(STRING));
alpar@9	444 for (; str != NULL; str = str->next)
alpar@9	445 { memcpy(tail->seg, str->seg, STRSEG_SIZE);
alpar@9	446 if (str->next != NULL)
alpar@9	447 tail = (tail->next = dmp_get_atom(mpl->strings, sizeof(STRING)));
alpar@9	448 }
alpar@9	449 tail->next = NULL;
alpar@9	450 return head;
alpar@9	451 }
alpar@9	452 #else
alpar@9	453 { xassert(mpl == mpl);
alpar@9	454 return create_string(mpl, str);
alpar@9	455 }
alpar@9	456 #endif
alpar@9	457
alpar@9	458 /*----------------------------------------------------------------------
alpar@9	459 -- compare_strings - compare one character string with another.
alpar@9	460 --
alpar@9	461 -- This routine compares one segmented character strings with another
alpar@9	462 -- and returns the result of comparison as follows:
alpar@9	463 --
alpar@9	464 -- = 0 - both strings are identical;
alpar@9	465 -- < 0 - the first string precedes the second one;
alpar@9	466 -- > 0 - the first string follows the second one. */
alpar@9	467
alpar@9	468 int compare_strings
alpar@9	469 ( MPL *mpl,
alpar@9	470 STRING str1, / not changed */
alpar@9	471 STRING str2 / not changed */
alpar@9	472 )
alpar@9	473 #if 0
alpar@9	474 { int j, c1, c2;
alpar@9	475 xassert(mpl == mpl);
alpar@9	476 for (;; str1 = str1->next, str2 = str2->next)
alpar@9	477 { xassert(str1 != NULL);
alpar@9	478 xassert(str2 != NULL);
alpar@9	479 for (j = 0; j < STRSEG_SIZE; j++)
alpar@9	480 { c1 = (unsigned char)str1->seg[j];
alpar@9	481 c2 = (unsigned char)str2->seg[j];
alpar@9	482 if (c1 < c2) return -1;
alpar@9	483 if (c1 > c2) return +1;
alpar@9	484 if (c1 == '\0') goto done;
alpar@9	485 }
alpar@9	486 }
alpar@9	487 done: return 0;
alpar@9	488 }
alpar@9	489 #else
alpar@9	490 { xassert(mpl == mpl);
alpar@9	491 return strcmp(str1, str2);
alpar@9	492 }
alpar@9	493 #endif
alpar@9	494
alpar@9	495 /*----------------------------------------------------------------------
alpar@9	496 -- fetch_string - extract content of character string.
alpar@9	497 --
alpar@9	498 -- This routine returns a character string, which is exactly equivalent
alpar@9	499 -- to specified segmented character string. */
alpar@9	500
alpar@9	501 char *fetch_string
alpar@9	502 ( MPL *mpl,
alpar@9	503 STRING str, / not changed */
alpar@9	504 char buf[MAX_LENGTH+1] /* modified */
alpar@9	505 )
alpar@9	506 #if 0
alpar@9	507 { int i, j;
alpar@9	508 xassert(mpl == mpl);
alpar@9	509 xassert(buf != NULL);
alpar@9	510 for (i = 0; ; str = str->next)
alpar@9	511 { xassert(str != NULL);
alpar@9	512 for (j = 0; j < STRSEG_SIZE; j++)
alpar@9	513 if ((buf[i++] = str->seg[j]) == '\0') goto done;
alpar@9	514 }
alpar@9	515 done: xassert(strlen(buf) <= MAX_LENGTH);
alpar@9	516 return buf;
alpar@9	517 }
alpar@9	518 #else
alpar@9	519 { xassert(mpl == mpl);
alpar@9	520 return strcpy(buf, str);
alpar@9	521 }
alpar@9	522 #endif
alpar@9	523
alpar@9	524 /*----------------------------------------------------------------------
alpar@9	525 -- delete_string - delete character string.
alpar@9	526 --
alpar@9	527 -- This routine deletes specified segmented character string. */
alpar@9	528
alpar@9	529 void delete_string
alpar@9	530 ( MPL *mpl,
alpar@9	531 STRING str / destroyed */
alpar@9	532 )
alpar@9	533 #if 0
alpar@9	534 { STRING *temp;
alpar@9	535 xassert(str != NULL);
alpar@9	536 while (str != NULL)
alpar@9	537 { temp = str;
alpar@9	538 str = str->next;
alpar@9	539 dmp_free_atom(mpl->strings, temp, sizeof(STRING));
alpar@9	540 }
alpar@9	541 return;
alpar@9	542 }
alpar@9	543 #else
alpar@9	544 { dmp_free_atom(mpl->strings, str, strlen(str)+1);
alpar@9	545 return;
alpar@9	546 }
alpar@9	547 #endif
alpar@9	548
alpar@9	549 /**********************************************************************/
alpar@9	550 /* * * SYMBOLS * * */
alpar@9	551 /**********************************************************************/
alpar@9	552
alpar@9	553 /*----------------------------------------------------------------------
alpar@9	554 -- create_symbol_num - create symbol of numeric type.
alpar@9	555 --
alpar@9	556 -- This routine creates a symbol, which has a numeric value specified
alpar@9	557 -- as floating-point number. */
alpar@9	558
alpar@9	559 SYMBOL create_symbol_num(MPL mpl, double num)
alpar@9	560 { SYMBOL *sym;
alpar@9	561 sym = dmp_get_atom(mpl->symbols, sizeof(SYMBOL));
alpar@9	562 sym->num = num;
alpar@9	563 sym->str = NULL;
alpar@9	564 return sym;
alpar@9	565 }
alpar@9	566
alpar@9	567 /*----------------------------------------------------------------------
alpar@9	568 -- create_symbol_str - create symbol of abstract type.
alpar@9	569 --
alpar@9	570 -- This routine creates a symbol, which has an abstract value specified
alpar@9	571 -- as segmented character string. */
alpar@9	572
alpar@9	573 SYMBOL *create_symbol_str
alpar@9	574 ( MPL *mpl,
alpar@9	575 STRING str / destroyed */
alpar@9	576 )
alpar@9	577 { SYMBOL *sym;
alpar@9	578 xassert(str != NULL);
alpar@9	579 sym = dmp_get_atom(mpl->symbols, sizeof(SYMBOL));
alpar@9	580 sym->num = 0.0;
alpar@9	581 sym->str = str;
alpar@9	582 return sym;
alpar@9	583 }
alpar@9	584
alpar@9	585 /*----------------------------------------------------------------------
alpar@9	586 -- copy_symbol - make copy of symbol.
alpar@9	587 --
alpar@9	588 -- This routine returns an exact copy of symbol. */
alpar@9	589
alpar@9	590 SYMBOL *copy_symbol
alpar@9	591 ( MPL *mpl,
alpar@9	592 SYMBOL sym / not changed */
alpar@9	593 )
alpar@9	594 { SYMBOL *copy;
alpar@9	595 xassert(sym != NULL);
alpar@9	596 copy = dmp_get_atom(mpl->symbols, sizeof(SYMBOL));
alpar@9	597 if (sym->str == NULL)
alpar@9	598 { copy->num = sym->num;
alpar@9	599 copy->str = NULL;
alpar@9	600 }
alpar@9	601 else
alpar@9	602 { copy->num = 0.0;
alpar@9	603 copy->str = copy_string(mpl, sym->str);
alpar@9	604 }
alpar@9	605 return copy;
alpar@9	606 }
alpar@9	607
alpar@9	608 /*----------------------------------------------------------------------
alpar@9	609 -- compare_symbols - compare one symbol with another.
alpar@9	610 --
alpar@9	611 -- This routine compares one symbol with another and returns the result
alpar@9	612 -- of comparison as follows:
alpar@9	613 --
alpar@9	614 -- = 0 - both symbols are identical;
alpar@9	615 -- < 0 - the first symbol precedes the second one;
alpar@9	616 -- > 0 - the first symbol follows the second one.
alpar@9	617 --
alpar@9	618 -- Note that the linear order, in which symbols follow each other, is
alpar@9	619 -- implementation-dependent. It may be not an alphabetical order. */
alpar@9	620
alpar@9	621 int compare_symbols
alpar@9	622 ( MPL *mpl,
alpar@9	623 SYMBOL sym1, / not changed */
alpar@9	624 SYMBOL sym2 / not changed */
alpar@9	625 )
alpar@9	626 { xassert(sym1 != NULL);
alpar@9	627 xassert(sym2 != NULL);
alpar@9	628 /* let all numeric quantities precede all symbolic quantities */
alpar@9	629 if (sym1->str == NULL && sym2->str == NULL)
alpar@9	630 { if (sym1->num < sym2->num) return -1;
alpar@9	631 if (sym1->num > sym2->num) return +1;
alpar@9	632 return 0;
alpar@9	633 }
alpar@9	634 if (sym1->str == NULL) return -1;
alpar@9	635 if (sym2->str == NULL) return +1;
alpar@9	636 return compare_strings(mpl, sym1->str, sym2->str);
alpar@9	637 }
alpar@9	638
alpar@9	639 /*----------------------------------------------------------------------
alpar@9	640 -- delete_symbol - delete symbol.
alpar@9	641 --
alpar@9	642 -- This routine deletes specified symbol. */
alpar@9	643
alpar@9	644 void delete_symbol
alpar@9	645 ( MPL *mpl,
alpar@9	646 SYMBOL sym / destroyed */
alpar@9	647 )
alpar@9	648 { xassert(sym != NULL);
alpar@9	649 if (sym->str != NULL) delete_string(mpl, sym->str);
alpar@9	650 dmp_free_atom(mpl->symbols, sym, sizeof(SYMBOL));
alpar@9	651 return;
alpar@9	652 }
alpar@9	653
alpar@9	654 /*----------------------------------------------------------------------
alpar@9	655 -- format_symbol - format symbol for displaying or printing.
alpar@9	656 --
alpar@9	657 -- This routine converts specified symbol to a charater string, which
alpar@9	658 -- is suitable for displaying or printing.
alpar@9	659 --
alpar@9	660 -- The resultant string is never longer than 255 characters. If it gets
alpar@9	661 -- longer, it is truncated from the right and appended by dots. */
alpar@9	662
alpar@9	663 char *format_symbol
alpar@9	664 ( MPL *mpl,
alpar@9	665 SYMBOL sym / not changed */
alpar@9	666 )
alpar@9	667 { char *buf = mpl->sym_buf;
alpar@9	668 xassert(sym != NULL);
alpar@9	669 if (sym->str == NULL)
alpar@9	670 sprintf(buf, "%.*g", DBL_DIG, sym->num);
alpar@9	671 else
alpar@9	672 { char str[MAX_LENGTH+1];
alpar@9	673 int quoted, j, len;
alpar@9	674 fetch_string(mpl, sym->str, str);
alpar@9	675 if (!(isalpha((unsigned char)str[0]) \|\| str[0] == '_'))
alpar@9	676 quoted = 1;
alpar@9	677 else
alpar@9	678 { quoted = 0;
alpar@9	679 for (j = 1; str[j] != '\0'; j++)
alpar@9	680 { if (!(isalnum((unsigned char)str[j]) \|\|
alpar@9	681 strchr("+-._", (unsigned char)str[j]) != NULL))
alpar@9	682 { quoted = 1;
alpar@9	683 break;
alpar@9	684 }
alpar@9	685 }
alpar@9	686 }
alpar@9	687 # define safe_append(c) \
alpar@9	688 (void)(len < 255 ? (buf[len++] = (char)(c)) : 0)
alpar@9	689 buf[0] = '\0', len = 0;
alpar@9	690 if (quoted) safe_append('\'');
alpar@9	691 for (j = 0; str[j] != '\0'; j++)
alpar@9	692 { if (quoted && str[j] == '\'') safe_append('\'');
alpar@9	693 safe_append(str[j]);
alpar@9	694 }
alpar@9	695 if (quoted) safe_append('\'');
alpar@9	696 # undef safe_append
alpar@9	697 buf[len] = '\0';
alpar@9	698 if (len == 255) strcpy(buf+252, "...");
alpar@9	699 }
alpar@9	700 xassert(strlen(buf) <= 255);
alpar@9	701 return buf;
alpar@9	702 }
alpar@9	703
alpar@9	704 /*----------------------------------------------------------------------
alpar@9	705 -- concat_symbols - concatenate one symbol with another.
alpar@9	706 --
alpar@9	707 -- This routine concatenates values of two given symbols and assigns
alpar@9	708 -- the resultant character string to a new symbol, which is returned on
alpar@9	709 -- exit. Both original symbols are destroyed. */
alpar@9	710
alpar@9	711 SYMBOL *concat_symbols
alpar@9	712 ( MPL *mpl,
alpar@9	713 SYMBOL sym1, / destroyed */
alpar@9	714 SYMBOL sym2 / destroyed */
alpar@9	715 )
alpar@9	716 { char str1[MAX_LENGTH+1], str2[MAX_LENGTH+1];
alpar@9	717 xassert(MAX_LENGTH >= DBL_DIG + DBL_DIG);
alpar@9	718 if (sym1->str == NULL)
alpar@9	719 sprintf(str1, "%.*g", DBL_DIG, sym1->num);
alpar@9	720 else
alpar@9	721 fetch_string(mpl, sym1->str, str1);
alpar@9	722 if (sym2->str == NULL)
alpar@9	723 sprintf(str2, "%.*g", DBL_DIG, sym2->num);
alpar@9	724 else
alpar@9	725 fetch_string(mpl, sym2->str, str2);
alpar@9	726 if (strlen(str1) + strlen(str2) > MAX_LENGTH)
alpar@9	727 { char buf[255+1];
alpar@9	728 strcpy(buf, format_symbol(mpl, sym1));
alpar@9	729 xassert(strlen(buf) < sizeof(buf));
alpar@9	730 error(mpl, "%s & %s; resultant symbol exceeds %d characters",
alpar@9	731 buf, format_symbol(mpl, sym2), MAX_LENGTH);
alpar@9	732 }
alpar@9	733 delete_symbol(mpl, sym1);
alpar@9	734 delete_symbol(mpl, sym2);
alpar@9	735 return create_symbol_str(mpl, create_string(mpl, strcat(str1,
alpar@9	736 str2)));
alpar@9	737 }
alpar@9	738
alpar@9	739 /**********************************************************************/
alpar@9	740 /* * * N-TUPLES * * */
alpar@9	741 /**********************************************************************/
alpar@9	742
alpar@9	743 /*----------------------------------------------------------------------
alpar@9	744 -- create_tuple - create n-tuple.
alpar@9	745 --
alpar@9	746 -- This routine creates a n-tuple, which initially has no components,
alpar@9	747 -- i.e. which is 0-tuple. */
alpar@9	748
alpar@9	749 TUPLE create_tuple(MPL mpl)
alpar@9	750 { TUPLE *tuple;
alpar@9	751 xassert(mpl == mpl);
alpar@9	752 tuple = NULL;
alpar@9	753 return tuple;
alpar@9	754 }
alpar@9	755
alpar@9	756 /*----------------------------------------------------------------------
alpar@9	757 -- expand_tuple - append symbol to n-tuple.
alpar@9	758 --
alpar@9	759 -- This routine expands n-tuple appending to it a given symbol, which
alpar@9	760 -- becomes its new last component. */
alpar@9	761
alpar@9	762 TUPLE *expand_tuple
alpar@9	763 ( MPL *mpl,
alpar@9	764 TUPLE tuple, / destroyed */
alpar@9	765 SYMBOL sym / destroyed */
alpar@9	766 )
alpar@9	767 { TUPLE tail, temp;
alpar@9	768 xassert(sym != NULL);
alpar@9	769 /* create a new component */
alpar@9	770 tail = dmp_get_atom(mpl->tuples, sizeof(TUPLE));
alpar@9	771 tail->sym = sym;
alpar@9	772 tail->next = NULL;
alpar@9	773 /* and append it to the component list */
alpar@9	774 if (tuple == NULL)
alpar@9	775 tuple = tail;
alpar@9	776 else
alpar@9	777 { for (temp = tuple; temp->next != NULL; temp = temp->next);
alpar@9	778 temp->next = tail;
alpar@9	779 }
alpar@9	780 return tuple;
alpar@9	781 }
alpar@9	782
alpar@9	783 /*----------------------------------------------------------------------
alpar@9	784 -- tuple_dimen - determine dimension of n-tuple.
alpar@9	785 --
alpar@9	786 -- This routine returns dimension of n-tuple, i.e. number of components
alpar@9	787 -- in the n-tuple. */
alpar@9	788
alpar@9	789 int tuple_dimen
alpar@9	790 ( MPL *mpl,
alpar@9	791 TUPLE tuple / not changed */
alpar@9	792 )
alpar@9	793 { TUPLE *temp;
alpar@9	794 int dim = 0;
alpar@9	795 xassert(mpl == mpl);
alpar@9	796 for (temp = tuple; temp != NULL; temp = temp->next) dim++;
alpar@9	797 return dim;
alpar@9	798 }
alpar@9	799
alpar@9	800 /*----------------------------------------------------------------------
alpar@9	801 -- copy_tuple - make copy of n-tuple.
alpar@9	802 --
alpar@9	803 -- This routine returns an exact copy of n-tuple. */
alpar@9	804
alpar@9	805 TUPLE *copy_tuple
alpar@9	806 ( MPL *mpl,
alpar@9	807 TUPLE tuple / not changed */
alpar@9	808 )
alpar@9	809 { TUPLE head, tail;
alpar@9	810 if (tuple == NULL)
alpar@9	811 head = NULL;
alpar@9	812 else
alpar@9	813 { head = tail = dmp_get_atom(mpl->tuples, sizeof(TUPLE));
alpar@9	814 for (; tuple != NULL; tuple = tuple->next)
alpar@9	815 { xassert(tuple->sym != NULL);
alpar@9	816 tail->sym = copy_symbol(mpl, tuple->sym);
alpar@9	817 if (tuple->next != NULL)
alpar@9	818 tail = (tail->next = dmp_get_atom(mpl->tuples, sizeof(TUPLE)));
alpar@9	819 }
alpar@9	820 tail->next = NULL;
alpar@9	821 }
alpar@9	822 return head;
alpar@9	823 }
alpar@9	824
alpar@9	825 /*----------------------------------------------------------------------
alpar@9	826 -- compare_tuples - compare one n-tuple with another.
alpar@9	827 --
alpar@9	828 -- This routine compares two given n-tuples, which must have the same
alpar@9	829 -- dimension (not checked for the sake of efficiency), and returns one
alpar@9	830 -- of the following codes:
alpar@9	831 --
alpar@9	832 -- = 0 - both n-tuples are identical;
alpar@9	833 -- < 0 - the first n-tuple precedes the second one;
alpar@9	834 -- > 0 - the first n-tuple follows the second one.
alpar@9	835 --
alpar@9	836 -- Note that the linear order, in which n-tuples follow each other, is
alpar@9	837 -- implementation-dependent. It may be not an alphabetical order. */
alpar@9	838
alpar@9	839 int compare_tuples
alpar@9	840 ( MPL *mpl,
alpar@9	841 TUPLE tuple1, / not changed */
alpar@9	842 TUPLE tuple2 / not changed */
alpar@9	843 )
alpar@9	844 { TUPLE item1, item2;
alpar@9	845 int ret;
alpar@9	846 xassert(mpl == mpl);
alpar@9	847 for (item1 = tuple1, item2 = tuple2; item1 != NULL;
alpar@9	848 item1 = item1->next, item2 = item2->next)
alpar@9	849 { xassert(item2 != NULL);
alpar@9	850 xassert(item1->sym != NULL);
alpar@9	851 xassert(item2->sym != NULL);
alpar@9	852 ret = compare_symbols(mpl, item1->sym, item2->sym);
alpar@9	853 if (ret != 0) return ret;
alpar@9	854 }
alpar@9	855 xassert(item2 == NULL);
alpar@9	856 return 0;
alpar@9	857 }
alpar@9	858
alpar@9	859 /*----------------------------------------------------------------------
alpar@9	860 -- build_subtuple - build subtuple of given n-tuple.
alpar@9	861 --
alpar@9	862 -- This routine builds subtuple, which consists of first dim components
alpar@9	863 -- of given n-tuple. */
alpar@9	864
alpar@9	865 TUPLE *build_subtuple
alpar@9	866 ( MPL *mpl,
alpar@9	867 TUPLE tuple, / not changed */
alpar@9	868 int dim
alpar@9	869 )
alpar@9	870 { TUPLE head, temp;
alpar@9	871 int j;
alpar@9	872 head = create_tuple(mpl);
alpar@9	873 for (j = 1, temp = tuple; j <= dim; j++, temp = temp->next)
alpar@9	874 { xassert(temp != NULL);
alpar@9	875 head = expand_tuple(mpl, head, copy_symbol(mpl, temp->sym));
alpar@9	876 }
alpar@9	877 return head;
alpar@9	878 }
alpar@9	879
alpar@9	880 /*----------------------------------------------------------------------
alpar@9	881 -- delete_tuple - delete n-tuple.
alpar@9	882 --
alpar@9	883 -- This routine deletes specified n-tuple. */
alpar@9	884
alpar@9	885 void delete_tuple
alpar@9	886 ( MPL *mpl,
alpar@9	887 TUPLE tuple / destroyed */
alpar@9	888 )
alpar@9	889 { TUPLE *temp;
alpar@9	890 while (tuple != NULL)
alpar@9	891 { temp = tuple;
alpar@9	892 tuple = temp->next;
alpar@9	893 xassert(temp->sym != NULL);
alpar@9	894 delete_symbol(mpl, temp->sym);
alpar@9	895 dmp_free_atom(mpl->tuples, temp, sizeof(TUPLE));
alpar@9	896 }
alpar@9	897 return;
alpar@9	898 }
alpar@9	899
alpar@9	900 /*----------------------------------------------------------------------
alpar@9	901 -- format_tuple - format n-tuple for displaying or printing.
alpar@9	902 --
alpar@9	903 -- This routine converts specified n-tuple to a character string, which
alpar@9	904 -- is suitable for displaying or printing.
alpar@9	905 --
alpar@9	906 -- The resultant string is never longer than 255 characters. If it gets
alpar@9	907 -- longer, it is truncated from the right and appended by dots. */
alpar@9	908
alpar@9	909 char *format_tuple
alpar@9	910 ( MPL *mpl,
alpar@9	911 int c,
alpar@9	912 TUPLE tuple / not changed */
alpar@9	913 )
alpar@9	914 { TUPLE *temp;
alpar@9	915 int dim, j, len;
alpar@9	916 char buf = mpl->tup_buf, str[255+1], save;
alpar@9	917 # define safe_append(c) \
alpar@9	918 (void)(len < 255 ? (buf[len++] = (char)(c)) : 0)
alpar@9	919 buf[0] = '\0', len = 0;
alpar@9	920 dim = tuple_dimen(mpl, tuple);
alpar@9	921 if (c == '[' && dim > 0) safe_append('[');
alpar@9	922 if (c == '(' && dim > 1) safe_append('(');
alpar@9	923 for (temp = tuple; temp != NULL; temp = temp->next)
alpar@9	924 { if (temp != tuple) safe_append(',');
alpar@9	925 xassert(temp->sym != NULL);
alpar@9	926 save = mpl->sym_buf;
alpar@9	927 mpl->sym_buf = str;
alpar@9	928 format_symbol(mpl, temp->sym);
alpar@9	929 mpl->sym_buf = save;
alpar@9	930 xassert(strlen(str) < sizeof(str));
alpar@9	931 for (j = 0; str[j] != '\0'; j++) safe_append(str[j]);
alpar@9	932 }
alpar@9	933 if (c == '[' && dim > 0) safe_append(']');
alpar@9	934 if (c == '(' && dim > 1) safe_append(')');
alpar@9	935 # undef safe_append
alpar@9	936 buf[len] = '\0';
alpar@9	937 if (len == 255) strcpy(buf+252, "...");
alpar@9	938 xassert(strlen(buf) <= 255);
alpar@9	939 return buf;
alpar@9	940 }
alpar@9	941
alpar@9	942 /**********************************************************************/
alpar@9	943 /* * * ELEMENTAL SETS * * */
alpar@9	944 /**********************************************************************/
alpar@9	945
alpar@9	946 /*----------------------------------------------------------------------
alpar@9	947 -- create_elemset - create elemental set.
alpar@9	948 --
alpar@9	949 -- This routine creates an elemental set, whose members are n-tuples of
alpar@9	950 -- specified dimension. Being created the set is initially empty. */
alpar@9	951
alpar@9	952 ELEMSET create_elemset(MPL mpl, int dim)
alpar@9	953 { ELEMSET *set;
alpar@9	954 xassert(dim > 0);
alpar@9	955 set = create_array(mpl, A_NONE, dim);
alpar@9	956 return set;
alpar@9	957 }
alpar@9	958
alpar@9	959 /*----------------------------------------------------------------------
alpar@9	960 -- find_tuple - check if elemental set contains given n-tuple.
alpar@9	961 --
alpar@9	962 -- This routine finds given n-tuple in specified elemental set in order
alpar@9	963 -- to check if the set contains that n-tuple. If the n-tuple is found,
alpar@9	964 -- the routine returns pointer to corresponding array member. Otherwise
alpar@9	965 -- null pointer is returned. */
alpar@9	966
alpar@9	967 MEMBER *find_tuple
alpar@9	968 ( MPL *mpl,
alpar@9	969 ELEMSET set, / not changed */
alpar@9	970 TUPLE tuple / not changed */
alpar@9	971 )
alpar@9	972 { xassert(set != NULL);
alpar@9	973 xassert(set->type == A_NONE);
alpar@9	974 xassert(set->dim == tuple_dimen(mpl, tuple));
alpar@9	975 return find_member(mpl, set, tuple);
alpar@9	976 }
alpar@9	977
alpar@9	978 /*----------------------------------------------------------------------
alpar@9	979 -- add_tuple - add new n-tuple to elemental set.
alpar@9	980 --
alpar@9	981 -- This routine adds given n-tuple to specified elemental set.
alpar@9	982 --
alpar@9	983 -- For the sake of efficiency this routine doesn't check whether the
alpar@9	984 -- set already contains the same n-tuple or not. Therefore the calling
alpar@9	985 -- program should use the routine find_tuple (if necessary) in order to
alpar@9	986 -- make sure that the given n-tuple is not contained in the set, since
alpar@9	987 -- duplicate n-tuples within the same set are not allowed. */
alpar@9	988
alpar@9	989 MEMBER *add_tuple
alpar@9	990 ( MPL *mpl,
alpar@9	991 ELEMSET set, / modified */
alpar@9	992 TUPLE tuple / destroyed */
alpar@9	993 )
alpar@9	994 { MEMBER *memb;
alpar@9	995 xassert(set != NULL);
alpar@9	996 xassert(set->type == A_NONE);
alpar@9	997 xassert(set->dim == tuple_dimen(mpl, tuple));
alpar@9	998 memb = add_member(mpl, set, tuple);
alpar@9	999 memb->value.none = NULL;
alpar@9	1000 return memb;
alpar@9	1001 }
alpar@9	1002
alpar@9	1003 /*----------------------------------------------------------------------
alpar@9	1004 -- check_then_add - check and add new n-tuple to elemental set.
alpar@9	1005 --
alpar@9	1006 -- This routine is equivalent to the routine add_tuple except that it
alpar@9	1007 -- does check for duplicate n-tuples. */
alpar@9	1008
alpar@9	1009 MEMBER *check_then_add
alpar@9	1010 ( MPL *mpl,
alpar@9	1011 ELEMSET set, / modified */
alpar@9	1012 TUPLE tuple / destroyed */
alpar@9	1013 )
alpar@9	1014 { if (find_tuple(mpl, set, tuple) != NULL)
alpar@9	1015 error(mpl, "duplicate tuple %s detected", format_tuple(mpl,
alpar@9	1016 '(', tuple));
alpar@9	1017 return add_tuple(mpl, set, tuple);
alpar@9	1018 }
alpar@9	1019
alpar@9	1020 /*----------------------------------------------------------------------
alpar@9	1021 -- copy_elemset - make copy of elemental set.
alpar@9	1022 --
alpar@9	1023 -- This routine makes an exact copy of elemental set. */
alpar@9	1024
alpar@9	1025 ELEMSET *copy_elemset
alpar@9	1026 ( MPL *mpl,
alpar@9	1027 ELEMSET set / not changed */
alpar@9	1028 )
alpar@9	1029 { ELEMSET *copy;
alpar@9	1030 MEMBER *memb;
alpar@9	1031 xassert(set != NULL);
alpar@9	1032 xassert(set->type == A_NONE);
alpar@9	1033 xassert(set->dim > 0);
alpar@9	1034 copy = create_elemset(mpl, set->dim);
alpar@9	1035 for (memb = set->head; memb != NULL; memb = memb->next)
alpar@9	1036 add_tuple(mpl, copy, copy_tuple(mpl, memb->tuple));
alpar@9	1037 return copy;
alpar@9	1038 }
alpar@9	1039
alpar@9	1040 /*----------------------------------------------------------------------
alpar@9	1041 -- delete_elemset - delete elemental set.
alpar@9	1042 --
alpar@9	1043 -- This routine deletes specified elemental set. */
alpar@9	1044
alpar@9	1045 void delete_elemset
alpar@9	1046 ( MPL *mpl,
alpar@9	1047 ELEMSET set / destroyed */
alpar@9	1048 )
alpar@9	1049 { xassert(set != NULL);
alpar@9	1050 xassert(set->type == A_NONE);
alpar@9	1051 delete_array(mpl, set);
alpar@9	1052 return;
alpar@9	1053 }
alpar@9	1054
alpar@9	1055 /*----------------------------------------------------------------------
alpar@9	1056 -- arelset_size - compute size of "arithmetic" elemental set.
alpar@9	1057 --
alpar@9	1058 -- This routine computes the size of "arithmetic" elemental set, which
alpar@9	1059 -- is specified in the form of arithmetic progression:
alpar@9	1060 --
alpar@9	1061 -- { t0 .. tf by dt }.
alpar@9	1062 --
alpar@9	1063 -- The size is computed using the formula:
alpar@9	1064 --
alpar@9	1065 -- n = max(0, floor((tf - t0) / dt) + 1). */
alpar@9	1066
alpar@9	1067 int arelset_size(MPL *mpl, double t0, double tf, double dt)
alpar@9	1068 { double temp;
alpar@9	1069 if (dt == 0.0)
alpar@9	1070 error(mpl, "%.g .. %.g by %.*g; zero stride not allowed",
alpar@9	1071 DBL_DIG, t0, DBL_DIG, tf, DBL_DIG, dt);
alpar@9	1072 if (tf > 0.0 && t0 < 0.0 && tf > + 0.999 * DBL_MAX + t0)
alpar@9	1073 temp = +DBL_MAX;
alpar@9	1074 else if (tf < 0.0 && t0 > 0.0 && tf < - 0.999 * DBL_MAX + t0)
alpar@9	1075 temp = -DBL_MAX;
alpar@9	1076 else
alpar@9	1077 temp = tf - t0;
alpar@9	1078 if (fabs(dt) < 1.0 && fabs(temp) > (0.999 * DBL_MAX) * fabs(dt))
alpar@9	1079 { if (temp > 0.0 && dt > 0.0 \|\| temp < 0.0 && dt < 0.0)
alpar@9	1080 temp = +DBL_MAX;
alpar@9	1081 else
alpar@9	1082 temp = 0.0;
alpar@9	1083 }
alpar@9	1084 else
alpar@9	1085 { temp = floor(temp / dt) + 1.0;
alpar@9	1086 if (temp < 0.0) temp = 0.0;
alpar@9	1087 }
alpar@9	1088 xassert(temp >= 0.0);
alpar@9	1089 if (temp > (double)(INT_MAX - 1))
alpar@9	1090 error(mpl, "%.g .. %.g by %.*g; set too large",
alpar@9	1091 DBL_DIG, t0, DBL_DIG, tf, DBL_DIG, dt);
alpar@9	1092 return (int)(temp + 0.5);
alpar@9	1093 }
alpar@9	1094
alpar@9	1095 /*----------------------------------------------------------------------
alpar@9	1096 -- arelset_member - compute member of "arithmetic" elemental set.
alpar@9	1097 --
alpar@9	1098 -- This routine returns a numeric value of symbol, which is equivalent
alpar@9	1099 -- to j-th member of given "arithmetic" elemental set specified in the
alpar@9	1100 -- form of arithmetic progression:
alpar@9	1101 --
alpar@9	1102 -- { t0 .. tf by dt }.
alpar@9	1103 --
alpar@9	1104 -- The symbol value is computed with the formula:
alpar@9	1105 --
alpar@9	1106 -- j-th member = t0 + (j - 1) * dt,
alpar@9	1107 --
alpar@9	1108 -- The number j must satisfy to the restriction 1 <= j <= n, where n is
alpar@9	1109 -- the set size computed by the routine arelset_size. */
alpar@9	1110
alpar@9	1111 double arelset_member(MPL *mpl, double t0, double tf, double dt, int j)
alpar@9	1112 { xassert(1 <= j && j <= arelset_size(mpl, t0, tf, dt));
alpar@9	1113 return t0 + (double)(j - 1) * dt;
alpar@9	1114 }
alpar@9	1115
alpar@9	1116 /*----------------------------------------------------------------------
alpar@9	1117 -- create_arelset - create "arithmetic" elemental set.
alpar@9	1118 --
alpar@9	1119 -- This routine creates "arithmetic" elemental set, which is specified
alpar@9	1120 -- in the form of arithmetic progression:
alpar@9	1121 --
alpar@9	1122 -- { t0 .. tf by dt }.
alpar@9	1123 --
alpar@9	1124 -- Components of this set are 1-tuples. */
alpar@9	1125
alpar@9	1126 ELEMSET create_arelset(MPL mpl, double t0, double tf, double dt)
alpar@9	1127 { ELEMSET *set;
alpar@9	1128 int j, n;
alpar@9	1129 set = create_elemset(mpl, 1);
alpar@9	1130 n = arelset_size(mpl, t0, tf, dt);
alpar@9	1131 for (j = 1; j <= n; j++)
alpar@9	1132 { add_tuple
alpar@9	1133 ( mpl,
alpar@9	1134 set,
alpar@9	1135 expand_tuple
alpar@9	1136 ( mpl,
alpar@9	1137 create_tuple(mpl),
alpar@9	1138 create_symbol_num
alpar@9	1139 ( mpl,
alpar@9	1140 arelset_member(mpl, t0, tf, dt, j)
alpar@9	1141 )
alpar@9	1142 )
alpar@9	1143 );
alpar@9	1144 }
alpar@9	1145 return set;
alpar@9	1146 }
alpar@9	1147
alpar@9	1148 /*----------------------------------------------------------------------
alpar@9	1149 -- set_union - union of two elemental sets.
alpar@9	1150 --
alpar@9	1151 -- This routine computes the union:
alpar@9	1152 --
alpar@9	1153 -- X U Y = { j \| (j in X) or (j in Y) },
alpar@9	1154 --
alpar@9	1155 -- where X and Y are given elemental sets (destroyed on exit). */
alpar@9	1156
alpar@9	1157 ELEMSET *set_union
alpar@9	1158 ( MPL *mpl,
alpar@9	1159 ELEMSET X, / destroyed */
alpar@9	1160 ELEMSET Y / destroyed */
alpar@9	1161 )
alpar@9	1162 { MEMBER *memb;
alpar@9	1163 xassert(X != NULL);
alpar@9	1164 xassert(X->type == A_NONE);
alpar@9	1165 xassert(X->dim > 0);
alpar@9	1166 xassert(Y != NULL);
alpar@9	1167 xassert(Y->type == A_NONE);
alpar@9	1168 xassert(Y->dim > 0);
alpar@9	1169 xassert(X->dim == Y->dim);
alpar@9	1170 for (memb = Y->head; memb != NULL; memb = memb->next)
alpar@9	1171 { if (find_tuple(mpl, X, memb->tuple) == NULL)
alpar@9	1172 add_tuple(mpl, X, copy_tuple(mpl, memb->tuple));
alpar@9	1173 }
alpar@9	1174 delete_elemset(mpl, Y);
alpar@9	1175 return X;
alpar@9	1176 }
alpar@9	1177
alpar@9	1178 /*----------------------------------------------------------------------
alpar@9	1179 -- set_diff - difference between two elemental sets.
alpar@9	1180 --
alpar@9	1181 -- This routine computes the difference:
alpar@9	1182 --
alpar@9	1183 -- X \ Y = { j \| (j in X) and (j not in Y) },
alpar@9	1184 --
alpar@9	1185 -- where X and Y are given elemental sets (destroyed on exit). */
alpar@9	1186
alpar@9	1187 ELEMSET *set_diff
alpar@9	1188 ( MPL *mpl,
alpar@9	1189 ELEMSET X, / destroyed */
alpar@9	1190 ELEMSET Y / destroyed */
alpar@9	1191 )
alpar@9	1192 { ELEMSET *Z;
alpar@9	1193 MEMBER *memb;
alpar@9	1194 xassert(X != NULL);
alpar@9	1195 xassert(X->type == A_NONE);
alpar@9	1196 xassert(X->dim > 0);
alpar@9	1197 xassert(Y != NULL);
alpar@9	1198 xassert(Y->type == A_NONE);
alpar@9	1199 xassert(Y->dim > 0);
alpar@9	1200 xassert(X->dim == Y->dim);
alpar@9	1201 Z = create_elemset(mpl, X->dim);
alpar@9	1202 for (memb = X->head; memb != NULL; memb = memb->next)
alpar@9	1203 { if (find_tuple(mpl, Y, memb->tuple) == NULL)
alpar@9	1204 add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple));
alpar@9	1205 }
alpar@9	1206 delete_elemset(mpl, X);
alpar@9	1207 delete_elemset(mpl, Y);
alpar@9	1208 return Z;
alpar@9	1209 }
alpar@9	1210
alpar@9	1211 /*----------------------------------------------------------------------
alpar@9	1212 -- set_symdiff - symmetric difference between two elemental sets.
alpar@9	1213 --
alpar@9	1214 -- This routine computes the symmetric difference:
alpar@9	1215 --
alpar@9	1216 -- X (+) Y = (X \ Y) U (Y \ X),
alpar@9	1217 --
alpar@9	1218 -- where X and Y are given elemental sets (destroyed on exit). */
alpar@9	1219
alpar@9	1220 ELEMSET *set_symdiff
alpar@9	1221 ( MPL *mpl,
alpar@9	1222 ELEMSET X, / destroyed */
alpar@9	1223 ELEMSET Y / destroyed */
alpar@9	1224 )
alpar@9	1225 { ELEMSET *Z;
alpar@9	1226 MEMBER *memb;
alpar@9	1227 xassert(X != NULL);
alpar@9	1228 xassert(X->type == A_NONE);
alpar@9	1229 xassert(X->dim > 0);
alpar@9	1230 xassert(Y != NULL);
alpar@9	1231 xassert(Y->type == A_NONE);
alpar@9	1232 xassert(Y->dim > 0);
alpar@9	1233 xassert(X->dim == Y->dim);
alpar@9	1234 /* Z := X \ Y */
alpar@9	1235 Z = create_elemset(mpl, X->dim);
alpar@9	1236 for (memb = X->head; memb != NULL; memb = memb->next)
alpar@9	1237 { if (find_tuple(mpl, Y, memb->tuple) == NULL)
alpar@9	1238 add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple));
alpar@9	1239 }
alpar@9	1240 /* Z := Z U (Y \ X) */
alpar@9	1241 for (memb = Y->head; memb != NULL; memb = memb->next)
alpar@9	1242 { if (find_tuple(mpl, X, memb->tuple) == NULL)
alpar@9	1243 add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple));
alpar@9	1244 }
alpar@9	1245 delete_elemset(mpl, X);
alpar@9	1246 delete_elemset(mpl, Y);
alpar@9	1247 return Z;
alpar@9	1248 }
alpar@9	1249
alpar@9	1250 /*----------------------------------------------------------------------
alpar@9	1251 -- set_inter - intersection of two elemental sets.
alpar@9	1252 --
alpar@9	1253 -- This routine computes the intersection:
alpar@9	1254 --
alpar@9	1255 -- X ^ Y = { j \| (j in X) and (j in Y) },
alpar@9	1256 --
alpar@9	1257 -- where X and Y are given elemental sets (destroyed on exit). */
alpar@9	1258
alpar@9	1259 ELEMSET *set_inter
alpar@9	1260 ( MPL *mpl,
alpar@9	1261 ELEMSET X, / destroyed */
alpar@9	1262 ELEMSET Y / destroyed */
alpar@9	1263 )
alpar@9	1264 { ELEMSET *Z;
alpar@9	1265 MEMBER *memb;
alpar@9	1266 xassert(X != NULL);
alpar@9	1267 xassert(X->type == A_NONE);
alpar@9	1268 xassert(X->dim > 0);
alpar@9	1269 xassert(Y != NULL);
alpar@9	1270 xassert(Y->type == A_NONE);
alpar@9	1271 xassert(Y->dim > 0);
alpar@9	1272 xassert(X->dim == Y->dim);
alpar@9	1273 Z = create_elemset(mpl, X->dim);
alpar@9	1274 for (memb = X->head; memb != NULL; memb = memb->next)
alpar@9	1275 { if (find_tuple(mpl, Y, memb->tuple) != NULL)
alpar@9	1276 add_tuple(mpl, Z, copy_tuple(mpl, memb->tuple));
alpar@9	1277 }
alpar@9	1278 delete_elemset(mpl, X);
alpar@9	1279 delete_elemset(mpl, Y);
alpar@9	1280 return Z;
alpar@9	1281 }
alpar@9	1282
alpar@9	1283 /*----------------------------------------------------------------------
alpar@9	1284 -- set_cross - cross (Cartesian) product of two elemental sets.
alpar@9	1285 --
alpar@9	1286 -- This routine computes the cross (Cartesian) product:
alpar@9	1287 --
alpar@9	1288 -- X x Y = { (i,j) \| (i in X) and (j in Y) },
alpar@9	1289 --
alpar@9	1290 -- where X and Y are given elemental sets (destroyed on exit). */
alpar@9	1291
alpar@9	1292 ELEMSET *set_cross
alpar@9	1293 ( MPL *mpl,
alpar@9	1294 ELEMSET X, / destroyed */
alpar@9	1295 ELEMSET Y / destroyed */
alpar@9	1296 )
alpar@9	1297 { ELEMSET *Z;
alpar@9	1298 MEMBER memx, memy;
alpar@9	1299 TUPLE tuple, temp;
alpar@9	1300 xassert(X != NULL);
alpar@9	1301 xassert(X->type == A_NONE);
alpar@9	1302 xassert(X->dim > 0);
alpar@9	1303 xassert(Y != NULL);
alpar@9	1304 xassert(Y->type == A_NONE);
alpar@9	1305 xassert(Y->dim > 0);
alpar@9	1306 Z = create_elemset(mpl, X->dim + Y->dim);
alpar@9	1307 for (memx = X->head; memx != NULL; memx = memx->next)
alpar@9	1308 { for (memy = Y->head; memy != NULL; memy = memy->next)
alpar@9	1309 { tuple = copy_tuple(mpl, memx->tuple);
alpar@9	1310 for (temp = memy->tuple; temp != NULL; temp = temp->next)
alpar@9	1311 tuple = expand_tuple(mpl, tuple, copy_symbol(mpl,
alpar@9	1312 temp->sym));
alpar@9	1313 add_tuple(mpl, Z, tuple);
alpar@9	1314 }
alpar@9	1315 }
alpar@9	1316 delete_elemset(mpl, X);
alpar@9	1317 delete_elemset(mpl, Y);
alpar@9	1318 return Z;
alpar@9	1319 }
alpar@9	1320
alpar@9	1321 /**********************************************************************/
alpar@9	1322 /* * * ELEMENTAL VARIABLES * * */
alpar@9	1323 /**********************************************************************/
alpar@9	1324
alpar@9	1325 /* (there are no specific routines for elemental variables) */
alpar@9	1326
alpar@9	1327 /**********************************************************************/
alpar@9	1328 /* * * LINEAR FORMS * * */
alpar@9	1329 /**********************************************************************/
alpar@9	1330
alpar@9	1331 /*----------------------------------------------------------------------
alpar@9	1332 -- constant_term - create constant term.
alpar@9	1333 --
alpar@9	1334 -- This routine creates the linear form, which is a constant term. */
alpar@9	1335
alpar@9	1336 FORMULA constant_term(MPL mpl, double coef)
alpar@9	1337 { FORMULA *form;
alpar@9	1338 if (coef == 0.0)
alpar@9	1339 form = NULL;
alpar@9	1340 else
alpar@9	1341 { form = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
alpar@9	1342 form->coef = coef;
alpar@9	1343 form->var = NULL;
alpar@9	1344 form->next = NULL;
alpar@9	1345 }
alpar@9	1346 return form;
alpar@9	1347 }
alpar@9	1348
alpar@9	1349 /*----------------------------------------------------------------------
alpar@9	1350 -- single_variable - create single variable.
alpar@9	1351 --
alpar@9	1352 -- This routine creates the linear form, which is a single elemental
alpar@9	1353 -- variable. */
alpar@9	1354
alpar@9	1355 FORMULA *single_variable
alpar@9	1356 ( MPL *mpl,
alpar@9	1357 ELEMVAR var / referenced */
alpar@9	1358 )
alpar@9	1359 { FORMULA *form;
alpar@9	1360 xassert(var != NULL);
alpar@9	1361 form = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
alpar@9	1362 form->coef = 1.0;
alpar@9	1363 form->var = var;
alpar@9	1364 form->next = NULL;
alpar@9	1365 return form;
alpar@9	1366 }
alpar@9	1367
alpar@9	1368 /*----------------------------------------------------------------------
alpar@9	1369 -- copy_formula - make copy of linear form.
alpar@9	1370 --
alpar@9	1371 -- This routine returns an exact copy of linear form. */
alpar@9	1372
alpar@9	1373 FORMULA *copy_formula
alpar@9	1374 ( MPL *mpl,
alpar@9	1375 FORMULA form / not changed */
alpar@9	1376 )
alpar@9	1377 { FORMULA head, tail;
alpar@9	1378 if (form == NULL)
alpar@9	1379 head = NULL;
alpar@9	1380 else
alpar@9	1381 { head = tail = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
alpar@9	1382 for (; form != NULL; form = form->next)
alpar@9	1383 { tail->coef = form->coef;
alpar@9	1384 tail->var = form->var;
alpar@9	1385 if (form->next != NULL)
alpar@9	1386 tail = (tail->next = dmp_get_atom(mpl->formulae, sizeof(FORMULA)));
alpar@9	1387 }
alpar@9	1388 tail->next = NULL;
alpar@9	1389 }
alpar@9	1390 return head;
alpar@9	1391 }
alpar@9	1392
alpar@9	1393 /*----------------------------------------------------------------------
alpar@9	1394 -- delete_formula - delete linear form.
alpar@9	1395 --
alpar@9	1396 -- This routine deletes specified linear form. */
alpar@9	1397
alpar@9	1398 void delete_formula
alpar@9	1399 ( MPL *mpl,
alpar@9	1400 FORMULA form / destroyed */
alpar@9	1401 )
alpar@9	1402 { FORMULA *temp;
alpar@9	1403 while (form != NULL)
alpar@9	1404 { temp = form;
alpar@9	1405 form = form->next;
alpar@9	1406 dmp_free_atom(mpl->formulae, temp, sizeof(FORMULA));
alpar@9	1407 }
alpar@9	1408 return;
alpar@9	1409 }
alpar@9	1410
alpar@9	1411 /*----------------------------------------------------------------------
alpar@9	1412 -- linear_comb - linear combination of two linear forms.
alpar@9	1413 --
alpar@9	1414 -- This routine computes the linear combination:
alpar@9	1415 --
alpar@9	1416 -- a * fx + b * fy,
alpar@9	1417 --
alpar@9	1418 -- where a and b are numeric coefficients, fx and fy are linear forms
alpar@9	1419 -- (destroyed on exit). */
alpar@9	1420
alpar@9	1421 FORMULA *linear_comb
alpar@9	1422 ( MPL *mpl,
alpar@9	1423 double a, FORMULA fx, / destroyed */
alpar@9	1424 double b, FORMULA fy / destroyed */
alpar@9	1425 )
alpar@9	1426 { FORMULA form = NULL, term, *temp;
alpar@9	1427 double c0 = 0.0;
alpar@9	1428 for (term = fx; term != NULL; term = term->next)
alpar@9	1429 { if (term->var == NULL)
alpar@9	1430 c0 = fp_add(mpl, c0, fp_mul(mpl, a, term->coef));
alpar@9	1431 else
alpar@9	1432 term->var->temp =
alpar@9	1433 fp_add(mpl, term->var->temp, fp_mul(mpl, a, term->coef));
alpar@9	1434 }
alpar@9	1435 for (term = fy; term != NULL; term = term->next)
alpar@9	1436 { if (term->var == NULL)
alpar@9	1437 c0 = fp_add(mpl, c0, fp_mul(mpl, b, term->coef));
alpar@9	1438 else
alpar@9	1439 term->var->temp =
alpar@9	1440 fp_add(mpl, term->var->temp, fp_mul(mpl, b, term->coef));
alpar@9	1441 }
alpar@9	1442 for (term = fx; term != NULL; term = term->next)
alpar@9	1443 { if (term->var != NULL && term->var->temp != 0.0)
alpar@9	1444 { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
alpar@9	1445 temp->coef = term->var->temp, temp->var = term->var;
alpar@9	1446 temp->next = form, form = temp;
alpar@9	1447 term->var->temp = 0.0;
alpar@9	1448 }
alpar@9	1449 }
alpar@9	1450 for (term = fy; term != NULL; term = term->next)
alpar@9	1451 { if (term->var != NULL && term->var->temp != 0.0)
alpar@9	1452 { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
alpar@9	1453 temp->coef = term->var->temp, temp->var = term->var;
alpar@9	1454 temp->next = form, form = temp;
alpar@9	1455 term->var->temp = 0.0;
alpar@9	1456 }
alpar@9	1457 }
alpar@9	1458 if (c0 != 0.0)
alpar@9	1459 { temp = dmp_get_atom(mpl->formulae, sizeof(FORMULA));
alpar@9	1460 temp->coef = c0, temp->var = NULL;
alpar@9	1461 temp->next = form, form = temp;
alpar@9	1462 }
alpar@9	1463 delete_formula(mpl, fx);
alpar@9	1464 delete_formula(mpl, fy);
alpar@9	1465 return form;
alpar@9	1466 }
alpar@9	1467
alpar@9	1468 /*----------------------------------------------------------------------
alpar@9	1469 -- remove_constant - remove constant term from linear form.
alpar@9	1470 --
alpar@9	1471 -- This routine removes constant term from linear form and stores its
alpar@9	1472 -- value to given location. */
alpar@9	1473
alpar@9	1474 FORMULA *remove_constant
alpar@9	1475 ( MPL *mpl,
alpar@9	1476 FORMULA form, / destroyed */
alpar@9	1477 double coef / modified */
alpar@9	1478 )
alpar@9	1479 { FORMULA head = NULL, temp;
alpar@9	1480 *coef = 0.0;
alpar@9	1481 while (form != NULL)
alpar@9	1482 { temp = form;
alpar@9	1483 form = form->next;
alpar@9	1484 if (temp->var == NULL)
alpar@9	1485 { /* constant term */
alpar@9	1486 coef = fp_add(mpl, coef, temp->coef);
alpar@9	1487 dmp_free_atom(mpl->formulae, temp, sizeof(FORMULA));
alpar@9	1488 }
alpar@9	1489 else
alpar@9	1490 { /* linear term */
alpar@9	1491 temp->next = head;
alpar@9	1492 head = temp;
alpar@9	1493 }
alpar@9	1494 }
alpar@9	1495 return head;
alpar@9	1496 }
alpar@9	1497
alpar@9	1498 /*----------------------------------------------------------------------
alpar@9	1499 -- reduce_terms - reduce identical terms in linear form.
alpar@9	1500 --
alpar@9	1501 -- This routine reduces identical terms in specified linear form. */
alpar@9	1502
alpar@9	1503 FORMULA *reduce_terms
alpar@9	1504 ( MPL *mpl,
alpar@9	1505 FORMULA form / destroyed */
alpar@9	1506 )
alpar@9	1507 { FORMULA term, next_term;
alpar@9	1508 double c0 = 0.0;
alpar@9	1509 for (term = form; term != NULL; term = term->next)
alpar@9	1510 { if (term->var == NULL)
alpar@9	1511 c0 = fp_add(mpl, c0, term->coef);
alpar@9	1512 else
alpar@9	1513 term->var->temp = fp_add(mpl, term->var->temp, term->coef);
alpar@9	1514 }
alpar@9	1515 next_term = form, form = NULL;
alpar@9	1516 for (term = next_term; term != NULL; term = next_term)
alpar@9	1517 { next_term = term->next;
alpar@9	1518 if (term->var == NULL && c0 != 0.0)
alpar@9	1519 { term->coef = c0, c0 = 0.0;
alpar@9	1520 term->next = form, form = term;
alpar@9	1521 }
alpar@9	1522 else if (term->var != NULL && term->var->temp != 0.0)
alpar@9	1523 { term->coef = term->var->temp, term->var->temp = 0.0;
alpar@9	1524 term->next = form, form = term;
alpar@9	1525 }
alpar@9	1526 else
alpar@9	1527 dmp_free_atom(mpl->formulae, term, sizeof(FORMULA));
alpar@9	1528 }
alpar@9	1529 return form;
alpar@9	1530 }
alpar@9	1531
alpar@9	1532 /**********************************************************************/
alpar@9	1533 /* * * ELEMENTAL CONSTRAINTS * * */
alpar@9	1534 /**********************************************************************/
alpar@9	1535
alpar@9	1536 /* (there are no specific routines for elemental constraints) */
alpar@9	1537
alpar@9	1538 /**********************************************************************/
alpar@9	1539 /* * * GENERIC VALUES * * */
alpar@9	1540 /**********************************************************************/
alpar@9	1541
alpar@9	1542 /*----------------------------------------------------------------------
alpar@9	1543 -- delete_value - delete generic value.
alpar@9	1544 --
alpar@9	1545 -- This routine deletes specified generic value.
alpar@9	1546 --
alpar@9	1547 -- NOTE: The generic value to be deleted must be valid. */
alpar@9	1548
alpar@9	1549 void delete_value
alpar@9	1550 ( MPL *mpl,
alpar@9	1551 int type,
alpar@9	1552 VALUE value / content destroyed */
alpar@9	1553 )
alpar@9	1554 { xassert(value != NULL);
alpar@9	1555 switch (type)
alpar@9	1556 { case A_NONE:
alpar@9	1557 value->none = NULL;
alpar@9	1558 break;
alpar@9	1559 case A_NUMERIC:
alpar@9	1560 value->num = 0.0;
alpar@9	1561 break;
alpar@9	1562 case A_SYMBOLIC:
alpar@9	1563 delete_symbol(mpl, value->sym), value->sym = NULL;
alpar@9	1564 break;
alpar@9	1565 case A_LOGICAL:
alpar@9	1566 value->bit = 0;
alpar@9	1567 break;
alpar@9	1568 case A_TUPLE:
alpar@9	1569 delete_tuple(mpl, value->tuple), value->tuple = NULL;
alpar@9	1570 break;
alpar@9	1571 case A_ELEMSET:
alpar@9	1572 delete_elemset(mpl, value->set), value->set = NULL;
alpar@9	1573 break;
alpar@9	1574 case A_ELEMVAR:
alpar@9	1575 value->var = NULL;
alpar@9	1576 break;
alpar@9	1577 case A_FORMULA:
alpar@9	1578 delete_formula(mpl, value->form), value->form = NULL;
alpar@9	1579 break;
alpar@9	1580 case A_ELEMCON:
alpar@9	1581 value->con = NULL;
alpar@9	1582 break;
alpar@9	1583 default:
alpar@9	1584 xassert(type != type);
alpar@9	1585 }
alpar@9	1586 return;
alpar@9	1587 }
alpar@9	1588
alpar@9	1589 /**********************************************************************/
alpar@9	1590 /* * * SYMBOLICALLY INDEXED ARRAYS * * */
alpar@9	1591 /**********************************************************************/
alpar@9	1592
alpar@9	1593 /*----------------------------------------------------------------------
alpar@9	1594 -- create_array - create array.
alpar@9	1595 --
alpar@9	1596 -- This routine creates an array of specified type and dimension. Being
alpar@9	1597 -- created the array is initially empty.
alpar@9	1598 --
alpar@9	1599 -- The type indicator determines generic values, which can be assigned
alpar@9	1600 -- to the array members:
alpar@9	1601 --
alpar@9	1602 -- A_NONE - none (members have no assigned values)
alpar@9	1603 -- A_NUMERIC - floating-point numbers
alpar@9	1604 -- A_SYMBOLIC - symbols
alpar@9	1605 -- A_ELEMSET - elemental sets
alpar@9	1606 -- A_ELEMVAR - elemental variables
alpar@9	1607 -- A_ELEMCON - elemental constraints
alpar@9	1608 --
alpar@9	1609 -- The dimension may be 0, in which case the array consists of the only
alpar@9	1610 -- member (such arrays represent 0-dimensional objects). */
alpar@9	1611
alpar@9	1612 ARRAY create_array(MPL mpl, int type, int dim)
alpar@9	1613 { ARRAY *array;
alpar@9	1614 xassert(type == A_NONE \|\| type == A_NUMERIC \|\|
alpar@9	1615 type == A_SYMBOLIC \|\| type == A_ELEMSET \|\|
alpar@9	1616 type == A_ELEMVAR \|\| type == A_ELEMCON);
alpar@9	1617 xassert(dim >= 0);
alpar@9	1618 array = dmp_get_atom(mpl->arrays, sizeof(ARRAY));
alpar@9	1619 array->type = type;
alpar@9	1620 array->dim = dim;
alpar@9	1621 array->size = 0;
alpar@9	1622 array->head = NULL;
alpar@9	1623 array->tail = NULL;
alpar@9	1624 array->tree = NULL;
alpar@9	1625 array->prev = NULL;
alpar@9	1626 array->next = mpl->a_list;
alpar@9	1627 /* include the array in the global array list */
alpar@9	1628 if (array->next != NULL) array->next->prev = array;
alpar@9	1629 mpl->a_list = array;
alpar@9	1630 return array;
alpar@9	1631 }
alpar@9	1632
alpar@9	1633 /*----------------------------------------------------------------------
alpar@9	1634 -- find_member - find array member with given n-tuple.
alpar@9	1635 --
alpar@9	1636 -- This routine finds an array member, which has given n-tuple. If the
alpar@9	1637 -- array is short, the linear search is used. Otherwise the routine
alpar@9	1638 -- autimatically creates the search tree (i.e. the array index) to find
alpar@9	1639 -- members for logarithmic time. */
alpar@9	1640
alpar@9	1641 static int compare_member_tuples(void info, const void key1,
alpar@9	1642 const void *key2)
alpar@9	1643 { /* this is an auxiliary routine used to compare keys, which are
alpar@9	1644 n-tuples assigned to array members */
alpar@9	1645 return compare_tuples((MPL )info, (TUPLE )key1, (TUPLE *)key2);
alpar@9	1646 }
alpar@9	1647
alpar@9	1648 MEMBER *find_member
alpar@9	1649 ( MPL *mpl,
alpar@9	1650 ARRAY array, / not changed */
alpar@9	1651 TUPLE tuple / not changed */
alpar@9	1652 )
alpar@9	1653 { MEMBER *memb;
alpar@9	1654 xassert(array != NULL);
alpar@9	1655 /* the n-tuple must have the same dimension as the array */
alpar@9	1656 xassert(tuple_dimen(mpl, tuple) == array->dim);
alpar@9	1657 /* if the array is large enough, create the search tree and index
alpar@9	1658 all existing members of the array */
alpar@9	1659 if (array->size > 30 && array->tree == NULL)
alpar@9	1660 { array->tree = avl_create_tree(compare_member_tuples, mpl);
alpar@9	1661 for (memb = array->head; memb != NULL; memb = memb->next)
alpar@9	1662 avl_set_node_link(avl_insert_node(array->tree, memb->tuple),
alpar@9	1663 (void *)memb);
alpar@9	1664 }
alpar@9	1665 /* find a member, which has the given tuple */
alpar@9	1666 if (array->tree == NULL)
alpar@9	1667 { /* the search tree doesn't exist; use the linear search */
alpar@9	1668 for (memb = array->head; memb != NULL; memb = memb->next)
alpar@9	1669 if (compare_tuples(mpl, memb->tuple, tuple) == 0) break;
alpar@9	1670 }
alpar@9	1671 else
alpar@9	1672 { /* the search tree exists; use the binary search */
alpar@9	1673 AVLNODE *node;
alpar@9	1674 node = avl_find_node(array->tree, tuple);
alpar@9	1675 memb = (MEMBER *)(node == NULL ? NULL : avl_get_node_link(node));
alpar@9	1676 }
alpar@9	1677 return memb;
alpar@9	1678 }
alpar@9	1679
alpar@9	1680 /*----------------------------------------------------------------------
alpar@9	1681 -- add_member - add new member to array.
alpar@9	1682 --
alpar@9	1683 -- This routine creates a new member with given n-tuple and adds it to
alpar@9	1684 -- specified array.
alpar@9	1685 --
alpar@9	1686 -- For the sake of efficiency this routine doesn't check whether the
alpar@9	1687 -- array already contains a member with the given n-tuple or not. Thus,
alpar@9	1688 -- if necessary, the calling program should use the routine find_member
alpar@9	1689 -- in order to be sure that the array contains no member with the same
alpar@9	1690 -- n-tuple, because members with duplicate n-tuples are not allowed.
alpar@9	1691 --
alpar@9	1692 -- This routine assigns no generic value to the new member, because the
alpar@9	1693 -- calling program must do that. */
alpar@9	1694
alpar@9	1695 MEMBER *add_member
alpar@9	1696 ( MPL *mpl,
alpar@9	1697 ARRAY array, / modified */
alpar@9	1698 TUPLE tuple / destroyed */
alpar@9	1699 )
alpar@9	1700 { MEMBER *memb;
alpar@9	1701 xassert(array != NULL);
alpar@9	1702 /* the n-tuple must have the same dimension as the array */
alpar@9	1703 xassert(tuple_dimen(mpl, tuple) == array->dim);
alpar@9	1704 /* create new member */
alpar@9	1705 memb = dmp_get_atom(mpl->members, sizeof(MEMBER));
alpar@9	1706 memb->tuple = tuple;
alpar@9	1707 memb->next = NULL;
alpar@9	1708 memset(&memb->value, '?', sizeof(VALUE));
alpar@9	1709 /* and append it to the member list */
alpar@9	1710 array->size++;
alpar@9	1711 if (array->head == NULL)
alpar@9	1712 array->head = memb;
alpar@9	1713 else
alpar@9	1714 array->tail->next = memb;
alpar@9	1715 array->tail = memb;
alpar@9	1716 /* if the search tree exists, index the new member */
alpar@9	1717 if (array->tree != NULL)
alpar@9	1718 avl_set_node_link(avl_insert_node(array->tree, memb->tuple),
alpar@9	1719 (void *)memb);
alpar@9	1720 return memb;
alpar@9	1721 }
alpar@9	1722
alpar@9	1723 /*----------------------------------------------------------------------
alpar@9	1724 -- delete_array - delete array.
alpar@9	1725 --
alpar@9	1726 -- This routine deletes specified array.
alpar@9	1727 --
alpar@9	1728 -- Generic values assigned to the array members are not deleted by this
alpar@9	1729 -- routine. The calling program itself must delete all assigned generic
alpar@9	1730 -- values before deleting the array. */
alpar@9	1731
alpar@9	1732 void delete_array
alpar@9	1733 ( MPL *mpl,
alpar@9	1734 ARRAY array / destroyed */
alpar@9	1735 )
alpar@9	1736 { MEMBER *memb;
alpar@9	1737 xassert(array != NULL);
alpar@9	1738 /* delete all existing array members */
alpar@9	1739 while (array->head != NULL)
alpar@9	1740 { memb = array->head;
alpar@9	1741 array->head = memb->next;
alpar@9	1742 delete_tuple(mpl, memb->tuple);
alpar@9	1743 dmp_free_atom(mpl->members, memb, sizeof(MEMBER));
alpar@9	1744 }
alpar@9	1745 /* if the search tree exists, also delete it */
alpar@9	1746 if (array->tree != NULL) avl_delete_tree(array->tree);
alpar@9	1747 /* remove the array from the global array list */
alpar@9	1748 if (array->prev == NULL)
alpar@9	1749 mpl->a_list = array->next;
alpar@9	1750 else
alpar@9	1751 array->prev->next = array->next;
alpar@9	1752 if (array->next == NULL)
alpar@9	1753 ;
alpar@9	1754 else
alpar@9	1755 array->next->prev = array->prev;
alpar@9	1756 /* delete the array descriptor */
alpar@9	1757 dmp_free_atom(mpl->arrays, array, sizeof(ARRAY));
alpar@9	1758 return;
alpar@9	1759 }
alpar@9	1760
alpar@9	1761 /**********************************************************************/
alpar@9	1762 /* * * DOMAINS AND DUMMY INDICES * * */
alpar@9	1763 /**********************************************************************/
alpar@9	1764
alpar@9	1765 /*----------------------------------------------------------------------
alpar@9	1766 -- assign_dummy_index - assign new value to dummy index.
alpar@9	1767 --
alpar@9	1768 -- This routine assigns new value to specified dummy index and, that is
alpar@9	1769 -- important, invalidates all temporary resultant values, which depends
alpar@9	1770 -- on that dummy index. */
alpar@9	1771
alpar@9	1772 void assign_dummy_index
alpar@9	1773 ( MPL *mpl,
alpar@9	1774 DOMAIN_SLOT slot, / modified */
alpar@9	1775 SYMBOL value / not changed */
alpar@9	1776 )
alpar@9	1777 { CODE leaf, code;
alpar@9	1778 xassert(slot != NULL);
alpar@9	1779 xassert(value != NULL);
alpar@9	1780 /* delete the current value assigned to the dummy index */
alpar@9	1781 if (slot->value != NULL)
alpar@9	1782 { /* if the current value and the new one are identical, actual
alpar@9	1783 assignment is not needed */
alpar@9	1784 if (compare_symbols(mpl, slot->value, value) == 0) goto done;
alpar@9	1785 /* delete a symbol, which is the current value */
alpar@9	1786 delete_symbol(mpl, slot->value), slot->value = NULL;
alpar@9	1787 }
alpar@9	1788 /* now walk through all the pseudo-codes with op = O_INDEX, which
alpar@9	1789 refer to the dummy index to be changed (these pseudo-codes are
alpar@9	1790 leaves in the forest of all expressions in the database) */
alpar@9	1791 for (leaf = slot->list; leaf != NULL; leaf = leaf->arg.index.
alpar@9	1792 next)
alpar@9	1793 { xassert(leaf->op == O_INDEX);
alpar@9	1794 /* invalidate all resultant values, which depend on the dummy
alpar@9	1795 index, walking from the current leaf toward the root of the
alpar@9	1796 corresponding expression tree */
alpar@9	1797 for (code = leaf; code != NULL; code = code->up)
alpar@9	1798 { if (code->valid)
alpar@9	1799 { /* invalidate and delete resultant value */
alpar@9	1800 code->valid = 0;
alpar@9	1801 delete_value(mpl, code->type, &code->value);
alpar@9	1802 }
alpar@9	1803 }
alpar@9	1804 }
alpar@9	1805 /* assign new value to the dummy index */
alpar@9	1806 slot->value = copy_symbol(mpl, value);
alpar@9	1807 done: return;
alpar@9	1808 }
alpar@9	1809
alpar@9	1810 /*----------------------------------------------------------------------
alpar@9	1811 -- update_dummy_indices - update current values of dummy indices.
alpar@9	1812 --
alpar@9	1813 -- This routine assigns components of "backup" n-tuple to dummy indices
alpar@9	1814 -- of specified domain block. If no "backup" n-tuple is defined for the
alpar@9	1815 -- domain block, values of the dummy indices remain untouched. */
alpar@9	1816
alpar@9	1817 void update_dummy_indices
alpar@9	1818 ( MPL *mpl,
alpar@9	1819 DOMAIN_BLOCK block / not changed */
alpar@9	1820 )
alpar@9	1821 { DOMAIN_SLOT *slot;
alpar@9	1822 TUPLE *temp;
alpar@9	1823 if (block->backup != NULL)
alpar@9	1824 { for (slot = block->list, temp = block->backup; slot != NULL;
alpar@9	1825 slot = slot->next, temp = temp->next)
alpar@9	1826 { xassert(temp != NULL);
alpar@9	1827 xassert(temp->sym != NULL);
alpar@9	1828 assign_dummy_index(mpl, slot, temp->sym);
alpar@9	1829 }
alpar@9	1830 }
alpar@9	1831 return;
alpar@9	1832 }
alpar@9	1833
alpar@9	1834 /*----------------------------------------------------------------------
alpar@9	1835 -- enter_domain_block - enter domain block.
alpar@9	1836 --
alpar@9	1837 -- Let specified domain block have the form:
alpar@9	1838 --
alpar@9	1839 -- { ..., (j1, j2, ..., jn) in J, ... }
alpar@9	1840 --
alpar@9	1841 -- where j1, j2, ..., jn are dummy indices, J is a basic set.
alpar@9	1842 --
alpar@9	1843 -- This routine does the following:
alpar@9	1844 --
alpar@9	1845 -- 1. Checks if the given n-tuple is a member of the basic set J. Note
alpar@9	1846 -- that J being out of the scope of the domain block cannot depend
alpar@9	1847 -- on the dummy indices in the same and inner domain blocks, so it
alpar@9	1848 -- can be computed before the dummy indices are assigned new values.
alpar@9	1849 -- If this check fails, the routine returns with non-zero code.
alpar@9	1850 --
alpar@9	1851 -- 2. Saves current values of the dummy indices j1, j2, ..., jn.
alpar@9	1852 --
alpar@9	1853 -- 3. Assigns new values, which are components of the given n-tuple, to
alpar@9	1854 -- the dummy indices j1, j2, ..., jn. If dimension of the n-tuple is
alpar@9	1855 -- larger than n, its extra components n+1, n+2, ... are not used.
alpar@9	1856 --
alpar@9	1857 -- 4. Calls the formal routine func which either enters the next domain
alpar@9	1858 -- block or evaluates some code within the domain scope.
alpar@9	1859 --
alpar@9	1860 -- 5. Restores former values of the dummy indices j1, j2, ..., jn.
alpar@9	1861 --
alpar@9	1862 -- Since current values assigned to the dummy indices on entry to this
alpar@9	1863 -- routine are restored on exit, the formal routine func is allowed to
alpar@9	1864 -- call this routine recursively. */
alpar@9	1865
alpar@9	1866 int enter_domain_block
alpar@9	1867 ( MPL *mpl,
alpar@9	1868 DOMAIN_BLOCK block, / not changed */
alpar@9	1869 TUPLE tuple, / not changed */
alpar@9	1870 void info, void (func)(MPL mpl, void info)
alpar@9	1871 )
alpar@9	1872 { TUPLE *backup;
alpar@9	1873 int ret = 0;
alpar@9	1874 /* check if the given n-tuple is a member of the basic set */
alpar@9	1875 xassert(block->code != NULL);
alpar@9	1876 if (!is_member(mpl, block->code, tuple))
alpar@9	1877 { ret = 1;
alpar@9	1878 goto done;
alpar@9	1879 }
alpar@9	1880 /* save reference to "backup" n-tuple, which was used to assign
alpar@9	1881 current values of the dummy indices (it is sufficient to save
alpar@9	1882 reference, not value, because that n-tuple is defined in some
alpar@9	1883 outer level of recursion and therefore cannot be changed on
alpar@9	1884 this and deeper recursive calls) */
alpar@9	1885 backup = block->backup;
alpar@9	1886 /* set up new "backup" n-tuple, which defines new values of the
alpar@9	1887 dummy indices */
alpar@9	1888 block->backup = tuple;
alpar@9	1889 /* assign new values to the dummy indices */
alpar@9	1890 update_dummy_indices(mpl, block);
alpar@9	1891 /* call the formal routine that does the rest part of the job */
alpar@9	1892 func(mpl, info);
alpar@9	1893 /* restore reference to the former "backup" n-tuple */
alpar@9	1894 block->backup = backup;
alpar@9	1895 /* restore former values of the dummy indices; note that if the
alpar@9	1896 domain block just escaped has no other active instances which
alpar@9	1897 may exist due to recursion (it is indicated by a null pointer
alpar@9	1898 to the former n-tuple), former values of the dummy indices are
alpar@9	1899 undefined; therefore in this case the routine keeps currently
alpar@9	1900 assigned values of the dummy indices that involves keeping all
alpar@9	1901 dependent temporary results and thereby, if this domain block
alpar@9	1902 is not used recursively, allows improving efficiency */
alpar@9	1903 update_dummy_indices(mpl, block);
alpar@9	1904 done: return ret;
alpar@9	1905 }
alpar@9	1906
alpar@9	1907 /*----------------------------------------------------------------------
alpar@9	1908 -- eval_within_domain - perform evaluation within domain scope.
alpar@9	1909 --
alpar@9	1910 -- This routine assigns new values (symbols) to all dummy indices of
alpar@9	1911 -- specified domain and calls the formal routine func, which is used to
alpar@9	1912 -- evaluate some code in the domain scope. Each free dummy index in the
alpar@9	1913 -- domain is assigned a value specified in the corresponding component
alpar@9	1914 -- of given n-tuple. Non-free dummy indices are assigned values, which
alpar@9	1915 -- are computed by this routine.
alpar@9	1916 --
alpar@9	1917 -- Number of components in the given n-tuple must be the same as number
alpar@9	1918 -- of free indices in the domain.
alpar@9	1919 --
alpar@9	1920 -- If the given n-tuple is not a member of the domain set, the routine
alpar@9	1921 -- func is not called, and non-zero code is returned.
alpar@9	1922 --
alpar@9	1923 -- For the sake of convenience it is allowed to specify domain as NULL
alpar@9	1924 -- (then n-tuple also must be 0-tuple, i.e. empty), in which case this
alpar@9	1925 -- routine just calls the routine func and returns zero.
alpar@9	1926 --
alpar@9	1927 -- This routine allows recursive calls from the routine func providing
alpar@9	1928 -- correct values of dummy indices for each instance.
alpar@9	1929 --
alpar@9	1930 -- NOTE: The n-tuple passed to this routine must not be changed by any
alpar@9	1931 -- other routines called from the formal routine func until this
alpar@9	1932 -- routine has returned. */
alpar@9	1933
alpar@9	1934 struct eval_domain_info
alpar@9	1935 { /* working info used by the routine eval_within_domain */
alpar@9	1936 DOMAIN *domain;
alpar@9	1937 /* domain, which has to be entered */
alpar@9	1938 DOMAIN_BLOCK *block;
alpar@9	1939 /* domain block, which is currently processed */
alpar@9	1940 TUPLE *tuple;
alpar@9	1941 /* tail of original n-tuple, whose components have to be assigned
alpar@9	1942 to free dummy indices in the current domain block */
alpar@9	1943 void *info;
alpar@9	1944 /* transit pointer passed to the formal routine func */
alpar@9	1945 void (func)(MPL mpl, void *info);
alpar@9	1946 /* routine, which has to be executed in the domain scope */
alpar@9	1947 int failure;
alpar@9	1948 /* this flag indicates that given n-tuple is not a member of the
alpar@9	1949 domain set */
alpar@9	1950 };
alpar@9	1951
alpar@9	1952 static void eval_domain_func(MPL mpl, void _my_info)
alpar@9	1953 { /* this routine recursively enters into the domain scope and then
alpar@9	1954 calls the routine func */
alpar@9	1955 struct eval_domain_info *my_info = _my_info;
alpar@9	1956 if (my_info->block != NULL)
alpar@9	1957 { /* the current domain block to be entered exists */
alpar@9	1958 DOMAIN_BLOCK *block;
alpar@9	1959 DOMAIN_SLOT *slot;
alpar@9	1960 TUPLE tuple = NULL, temp = NULL;
alpar@9	1961 /* save pointer to the current domain block */
alpar@9	1962 block = my_info->block;
alpar@9	1963 /* and get ready to enter the next block (if it exists) */
alpar@9	1964 my_info->block = block->next;
alpar@9	1965 /* construct temporary n-tuple, whose components correspond to
alpar@9	1966 dummy indices (slots) of the current domain; components of
alpar@9	1967 the temporary n-tuple that correspond to free dummy indices
alpar@9	1968 are assigned references (not values!) to symbols specified
alpar@9	1969 in the corresponding components of the given n-tuple, while
alpar@9	1970 other components that correspond to non-free dummy indices
alpar@9	1971 are assigned symbolic values computed here */
alpar@9	1972 for (slot = block->list; slot != NULL; slot = slot->next)
alpar@9	1973 { /* create component that corresponds to the current slot */
alpar@9	1974 if (tuple == NULL)
alpar@9	1975 tuple = temp = dmp_get_atom(mpl->tuples, sizeof(TUPLE));
alpar@9	1976 else
alpar@9	1977 temp = (temp->next = dmp_get_atom(mpl->tuples, sizeof(TUPLE)));
alpar@9	1978 if (slot->code == NULL)
alpar@9	1979 { /* dummy index is free; take reference to symbol, which
alpar@9	1980 is specified in the corresponding component of given
alpar@9	1981 n-tuple */
alpar@9	1982 xassert(my_info->tuple != NULL);
alpar@9	1983 temp->sym = my_info->tuple->sym;
alpar@9	1984 xassert(temp->sym != NULL);
alpar@9	1985 my_info->tuple = my_info->tuple->next;
alpar@9	1986 }
alpar@9	1987 else
alpar@9	1988 { /* dummy index is non-free; compute symbolic value to be
alpar@9	1989 temporarily assigned to the dummy index */
alpar@9	1990 temp->sym = eval_symbolic(mpl, slot->code);
alpar@9	1991 }
alpar@9	1992 }
alpar@9	1993 temp->next = NULL;
alpar@9	1994 /* enter the current domain block */
alpar@9	1995 if (enter_domain_block(mpl, block, tuple, my_info,
alpar@9	1996 eval_domain_func)) my_info->failure = 1;
alpar@9	1997 /* delete temporary n-tuple as well as symbols that correspond
alpar@9	1998 to non-free dummy indices (they were computed here) */
alpar@9	1999 for (slot = block->list; slot != NULL; slot = slot->next)
alpar@9	2000 { xassert(tuple != NULL);
alpar@9	2001 temp = tuple;
alpar@9	2002 tuple = tuple->next;
alpar@9	2003 if (slot->code != NULL)
alpar@9	2004 { /* dummy index is non-free; delete symbolic value */
alpar@9	2005 delete_symbol(mpl, temp->sym);
alpar@9	2006 }
alpar@9	2007 /* delete component that corresponds to the current slot */
alpar@9	2008 dmp_free_atom(mpl->tuples, temp, sizeof(TUPLE));
alpar@9	2009 }
alpar@9	2010 }
alpar@9	2011 else
alpar@9	2012 { /* there are no more domain blocks, i.e. we have reached the
alpar@9	2013 domain scope */
alpar@9	2014 xassert(my_info->tuple == NULL);
alpar@9	2015 /* check optional predicate specified for the domain */
alpar@9	2016 if (my_info->domain->code != NULL && !eval_logical(mpl,
alpar@9	2017 my_info->domain->code))
alpar@9	2018 { /* the predicate is false */
alpar@9	2019 my_info->failure = 2;
alpar@9	2020 }
alpar@9	2021 else
alpar@9	2022 { /* the predicate is true; do the job */
alpar@9	2023 my_info->func(mpl, my_info->info);
alpar@9	2024 }
alpar@9	2025 }
alpar@9	2026 return;
alpar@9	2027 }
alpar@9	2028
alpar@9	2029 int eval_within_domain
alpar@9	2030 ( MPL *mpl,
alpar@9	2031 DOMAIN domain, / not changed */
alpar@9	2032 TUPLE tuple, / not changed */
alpar@9	2033 void info, void (func)(MPL mpl, void info)
alpar@9	2034 )
alpar@9	2035 { /* this routine performs evaluation within domain scope */
alpar@9	2036 struct eval_domain_info _my_info, *my_info = &_my_info;
alpar@9	2037 if (domain == NULL)
alpar@9	2038 { xassert(tuple == NULL);
alpar@9	2039 func(mpl, info);
alpar@9	2040 my_info->failure = 0;
alpar@9	2041 }
alpar@9	2042 else
alpar@9	2043 { xassert(tuple != NULL);
alpar@9	2044 my_info->domain = domain;
alpar@9	2045 my_info->block = domain->list;
alpar@9	2046 my_info->tuple = tuple;
alpar@9	2047 my_info->info = info;
alpar@9	2048 my_info->func = func;
alpar@9	2049 my_info->failure = 0;
alpar@9	2050 /* enter the very first domain block */
alpar@9	2051 eval_domain_func(mpl, my_info);
alpar@9	2052 }
alpar@9	2053 return my_info->failure;
alpar@9	2054 }
alpar@9	2055
alpar@9	2056 /*----------------------------------------------------------------------
alpar@9	2057 -- loop_within_domain - perform iterations within domain scope.
alpar@9	2058 --
alpar@9	2059 -- This routine iteratively assigns new values (symbols) to the dummy
alpar@9	2060 -- indices of specified domain by enumerating all n-tuples, which are
alpar@9	2061 -- members of the domain set, and for every n-tuple it calls the formal
alpar@9	2062 -- routine func to evaluate some code within the domain scope.
alpar@9	2063 --
alpar@9	2064 -- If the routine func returns non-zero, enumeration within the domain
alpar@9	2065 -- is prematurely terminated.
alpar@9	2066 --
alpar@9	2067 -- For the sake of convenience it is allowed to specify domain as NULL,
alpar@9	2068 -- in which case this routine just calls the routine func only once and
alpar@9	2069 -- returns zero.
alpar@9	2070 --
alpar@9	2071 -- This routine allows recursive calls from the routine func providing
alpar@9	2072 -- correct values of dummy indices for each instance. */
alpar@9	2073
alpar@9	2074 struct loop_domain_info
alpar@9	2075 { /* working info used by the routine loop_within_domain */
alpar@9	2076 DOMAIN *domain;
alpar@9	2077 /* domain, which has to be entered */
alpar@9	2078 DOMAIN_BLOCK *block;
alpar@9	2079 /* domain block, which is currently processed */
alpar@9	2080 int looping;
alpar@9	2081 /* clearing this flag leads to terminating enumeration */
alpar@9	2082 void *info;
alpar@9	2083 /* transit pointer passed to the formal routine func */
alpar@9	2084 int (func)(MPL mpl, void *info);
alpar@9	2085 /* routine, which needs to be executed in the domain scope */
alpar@9	2086 };
alpar@9	2087
alpar@9	2088 static void loop_domain_func(MPL mpl, void _my_info)
alpar@9	2089 { /* this routine enumerates all n-tuples in the basic set of the
alpar@9	2090 current domain block, enters recursively into the domain scope
alpar@9	2091 for every n-tuple, and then calls the routine func */
alpar@9	2092 struct loop_domain_info *my_info = _my_info;
alpar@9	2093 if (my_info->block != NULL)
alpar@9	2094 { /* the current domain block to be entered exists */
alpar@9	2095 DOMAIN_BLOCK *block;
alpar@9	2096 DOMAIN_SLOT *slot;
alpar@9	2097 TUPLE *bound;
alpar@9	2098 /* save pointer to the current domain block */
alpar@9	2099 block = my_info->block;
alpar@9	2100 /* and get ready to enter the next block (if it exists) */
alpar@9	2101 my_info->block = block->next;
alpar@9	2102 /* compute symbolic values, at which non-free dummy indices of
alpar@9	2103 the current domain block are bound; since that values don't
alpar@9	2104 depend on free dummy indices of the current block, they can
alpar@9	2105 be computed once out of the enumeration loop */
alpar@9	2106 bound = create_tuple(mpl);
alpar@9	2107 for (slot = block->list; slot != NULL; slot = slot->next)
alpar@9	2108 { if (slot->code != NULL)
alpar@9	2109 bound = expand_tuple(mpl, bound, eval_symbolic(mpl,
alpar@9	2110 slot->code));
alpar@9	2111 }
alpar@9	2112 /* start enumeration */
alpar@9	2113 xassert(block->code != NULL);
alpar@9	2114 if (block->code->op == O_DOTS)
alpar@9	2115 { /* the basic set is "arithmetic", in which case it doesn't
alpar@9	2116 need to be computed explicitly */
alpar@9	2117 TUPLE *tuple;
alpar@9	2118 int n, j;
alpar@9	2119 double t0, tf, dt;
alpar@9	2120 /* compute "parameters" of the basic set */
alpar@9	2121 t0 = eval_numeric(mpl, block->code->arg.arg.x);
alpar@9	2122 tf = eval_numeric(mpl, block->code->arg.arg.y);
alpar@9	2123 if (block->code->arg.arg.z == NULL)
alpar@9	2124 dt = 1.0;
alpar@9	2125 else
alpar@9	2126 dt = eval_numeric(mpl, block->code->arg.arg.z);
alpar@9	2127 /* determine cardinality of the basic set */
alpar@9	2128 n = arelset_size(mpl, t0, tf, dt);
alpar@9	2129 /* create dummy 1-tuple for members of the basic set */
alpar@9	2130 tuple = expand_tuple(mpl, create_tuple(mpl),
alpar@9	2131 create_symbol_num(mpl, 0.0));
alpar@9	2132 /* in case of "arithmetic" set there is exactly one dummy
alpar@9	2133 index, which cannot be non-free */
alpar@9	2134 xassert(bound == NULL);
alpar@9	2135 /* walk through 1-tuples of the basic set */
alpar@9	2136 for (j = 1; j <= n && my_info->looping; j++)
alpar@9	2137 { /* construct dummy 1-tuple for the current member */
alpar@9	2138 tuple->sym->num = arelset_member(mpl, t0, tf, dt, j);
alpar@9	2139 /* enter the current domain block */
alpar@9	2140 enter_domain_block(mpl, block, tuple, my_info,
alpar@9	2141 loop_domain_func);
alpar@9	2142 }
alpar@9	2143 /* delete dummy 1-tuple */
alpar@9	2144 delete_tuple(mpl, tuple);
alpar@9	2145 }
alpar@9	2146 else
alpar@9	2147 { /* the basic set is of general kind, in which case it needs
alpar@9	2148 to be explicitly computed */
alpar@9	2149 ELEMSET *set;
alpar@9	2150 MEMBER *memb;
alpar@9	2151 TUPLE temp1, temp2;
alpar@9	2152 /* compute the basic set */
alpar@9	2153 set = eval_elemset(mpl, block->code);
alpar@9	2154 /* walk through all n-tuples of the basic set */
alpar@9	2155 for (memb = set->head; memb != NULL && my_info->looping;
alpar@9	2156 memb = memb->next)
alpar@9	2157 { /* all components of the current n-tuple that correspond
alpar@9	2158 to non-free dummy indices must be feasible; otherwise
alpar@9	2159 the n-tuple is not in the basic set */
alpar@9	2160 temp1 = memb->tuple;
alpar@9	2161 temp2 = bound;
alpar@9	2162 for (slot = block->list; slot != NULL; slot = slot->next)
alpar@9	2163 { xassert(temp1 != NULL);
alpar@9	2164 if (slot->code != NULL)
alpar@9	2165 { /* non-free dummy index */
alpar@9	2166 xassert(temp2 != NULL);
alpar@9	2167 if (compare_symbols(mpl, temp1->sym, temp2->sym)
alpar@9	2168 != 0)
alpar@9	2169 { /* the n-tuple is not in the basic set */
alpar@9	2170 goto skip;
alpar@9	2171 }
alpar@9	2172 temp2 = temp2->next;
alpar@9	2173 }
alpar@9	2174 temp1 = temp1->next;
alpar@9	2175 }
alpar@9	2176 xassert(temp1 == NULL);
alpar@9	2177 xassert(temp2 == NULL);
alpar@9	2178 /* enter the current domain block */
alpar@9	2179 enter_domain_block(mpl, block, memb->tuple, my_info,
alpar@9	2180 loop_domain_func);
alpar@9	2181 skip: ;
alpar@9	2182 }
alpar@9	2183 /* delete the basic set */
alpar@9	2184 delete_elemset(mpl, set);
alpar@9	2185 }
alpar@9	2186 /* delete symbolic values binding non-free dummy indices */
alpar@9	2187 delete_tuple(mpl, bound);
alpar@9	2188 /* restore pointer to the current domain block */
alpar@9	2189 my_info->block = block;
alpar@9	2190 }
alpar@9	2191 else
alpar@9	2192 { /* there are no more domain blocks, i.e. we have reached the
alpar@9	2193 domain scope */
alpar@9	2194 /* check optional predicate specified for the domain */
alpar@9	2195 if (my_info->domain->code != NULL && !eval_logical(mpl,
alpar@9	2196 my_info->domain->code))
alpar@9	2197 { /* the predicate is false */
alpar@9	2198 /* nop */;
alpar@9	2199 }
alpar@9	2200 else
alpar@9	2201 { /* the predicate is true; do the job */
alpar@9	2202 my_info->looping = !my_info->func(mpl, my_info->info);
alpar@9	2203 }
alpar@9	2204 }
alpar@9	2205 return;
alpar@9	2206 }
alpar@9	2207
alpar@9	2208 void loop_within_domain
alpar@9	2209 ( MPL *mpl,
alpar@9	2210 DOMAIN domain, / not changed */
alpar@9	2211 void info, int (func)(MPL mpl, void info)
alpar@9	2212 )
alpar@9	2213 { /* this routine performs iterations within domain scope */
alpar@9	2214 struct loop_domain_info _my_info, *my_info = &_my_info;
alpar@9	2215 if (domain == NULL)
alpar@9	2216 func(mpl, info);
alpar@9	2217 else
alpar@9	2218 { my_info->domain = domain;
alpar@9	2219 my_info->block = domain->list;
alpar@9	2220 my_info->looping = 1;
alpar@9	2221 my_info->info = info;
alpar@9	2222 my_info->func = func;
alpar@9	2223 /* enter the very first domain block */
alpar@9	2224 loop_domain_func(mpl, my_info);
alpar@9	2225 }
alpar@9	2226 return;
alpar@9	2227 }
alpar@9	2228
alpar@9	2229 /*----------------------------------------------------------------------
alpar@9	2230 -- out_of_domain - raise domain exception.
alpar@9	2231 --
alpar@9	2232 -- This routine is called when a reference is made to a member of some
alpar@9	2233 -- model object, but its n-tuple is out of the object domain. */
alpar@9	2234
alpar@9	2235 void out_of_domain
alpar@9	2236 ( MPL *mpl,
alpar@9	2237 char name, / not changed */
alpar@9	2238 TUPLE tuple / not changed */
alpar@9	2239 )
alpar@9	2240 { xassert(name != NULL);
alpar@9	2241 xassert(tuple != NULL);
alpar@9	2242 error(mpl, "%s%s out of domain", name, format_tuple(mpl, '[',
alpar@9	2243 tuple));
alpar@9	2244 /* no return */
alpar@9	2245 }
alpar@9	2246
alpar@9	2247 /*----------------------------------------------------------------------
alpar@9	2248 -- get_domain_tuple - obtain current n-tuple from domain.
alpar@9	2249 --
alpar@9	2250 -- This routine constructs n-tuple, whose components are current values
alpar@9	2251 -- assigned to free dummy indices of specified domain.
alpar@9	2252 --
alpar@9	2253 -- For the sake of convenience it is allowed to specify domain as NULL,
alpar@9	2254 -- in which case this routine returns 0-tuple.
alpar@9	2255 --
alpar@9	2256 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	2257
alpar@9	2258 TUPLE *get_domain_tuple
alpar@9	2259 ( MPL *mpl,
alpar@9	2260 DOMAIN domain / not changed */
alpar@9	2261 )
alpar@9	2262 { DOMAIN_BLOCK *block;
alpar@9	2263 DOMAIN_SLOT *slot;
alpar@9	2264 TUPLE *tuple;
alpar@9	2265 tuple = create_tuple(mpl);
alpar@9	2266 if (domain != NULL)
alpar@9	2267 { for (block = domain->list; block != NULL; block = block->next)
alpar@9	2268 { for (slot = block->list; slot != NULL; slot = slot->next)
alpar@9	2269 { if (slot->code == NULL)
alpar@9	2270 { xassert(slot->value != NULL);
alpar@9	2271 tuple = expand_tuple(mpl, tuple, copy_symbol(mpl,
alpar@9	2272 slot->value));
alpar@9	2273 }
alpar@9	2274 }
alpar@9	2275 }
alpar@9	2276 }
alpar@9	2277 return tuple;
alpar@9	2278 }
alpar@9	2279
alpar@9	2280 /*----------------------------------------------------------------------
alpar@9	2281 -- clean_domain - clean domain.
alpar@9	2282 --
alpar@9	2283 -- This routine cleans specified domain that assumes deleting all stuff
alpar@9	2284 -- dynamically allocated during the generation phase. */
alpar@9	2285
alpar@9	2286 void clean_domain(MPL mpl, DOMAIN domain)
alpar@9	2287 { DOMAIN_BLOCK *block;
alpar@9	2288 DOMAIN_SLOT *slot;
alpar@9	2289 /* if no domain is specified, do nothing */
alpar@9	2290 if (domain == NULL) goto done;
alpar@9	2291 /* clean all domain blocks */
alpar@9	2292 for (block = domain->list; block != NULL; block = block->next)
alpar@9	2293 { /* clean all domain slots */
alpar@9	2294 for (slot = block->list; slot != NULL; slot = slot->next)
alpar@9	2295 { /* clean pseudo-code for computing bound value */
alpar@9	2296 clean_code(mpl, slot->code);
alpar@9	2297 /* delete symbolic value assigned to dummy index */
alpar@9	2298 if (slot->value != NULL)
alpar@9	2299 delete_symbol(mpl, slot->value), slot->value = NULL;
alpar@9	2300 }
alpar@9	2301 /* clean pseudo-code for computing basic set */
alpar@9	2302 clean_code(mpl, block->code);
alpar@9	2303 }
alpar@9	2304 /* clean pseudo-code for computing domain predicate */
alpar@9	2305 clean_code(mpl, domain->code);
alpar@9	2306 done: return;
alpar@9	2307 }
alpar@9	2308
alpar@9	2309 /**********************************************************************/
alpar@9	2310 /* * * MODEL SETS * * */
alpar@9	2311 /**********************************************************************/
alpar@9	2312
alpar@9	2313 /*----------------------------------------------------------------------
alpar@9	2314 -- check_elem_set - check elemental set assigned to set member.
alpar@9	2315 --
alpar@9	2316 -- This routine checks if given elemental set being assigned to member
alpar@9	2317 -- of specified model set satisfies to all restrictions.
alpar@9	2318 --
alpar@9	2319 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	2320
alpar@9	2321 void check_elem_set
alpar@9	2322 ( MPL *mpl,
alpar@9	2323 SET set, / not changed */
alpar@9	2324 TUPLE tuple, / not changed */
alpar@9	2325 ELEMSET refer / not changed */
alpar@9	2326 )
alpar@9	2327 { WITHIN *within;
alpar@9	2328 MEMBER *memb;
alpar@9	2329 int eqno;
alpar@9	2330 /* elemental set must be within all specified supersets */
alpar@9	2331 for (within = set->within, eqno = 1; within != NULL; within =
alpar@9	2332 within->next, eqno++)
alpar@9	2333 { xassert(within->code != NULL);
alpar@9	2334 for (memb = refer->head; memb != NULL; memb = memb->next)
alpar@9	2335 { if (!is_member(mpl, within->code, memb->tuple))
alpar@9	2336 { char buf[255+1];
alpar@9	2337 strcpy(buf, format_tuple(mpl, '(', memb->tuple));
alpar@9	2338 xassert(strlen(buf) < sizeof(buf));
alpar@9	2339 error(mpl, "%s%s contains %s which not within specified "
alpar@9	2340 "set; see (%d)", set->name, format_tuple(mpl, '[',
alpar@9	2341 tuple), buf, eqno);
alpar@9	2342 }
alpar@9	2343 }
alpar@9	2344 }
alpar@9	2345 return;
alpar@9	2346 }
alpar@9	2347
alpar@9	2348 /*----------------------------------------------------------------------
alpar@9	2349 -- take_member_set - obtain elemental set assigned to set member.
alpar@9	2350 --
alpar@9	2351 -- This routine obtains a reference to elemental set assigned to given
alpar@9	2352 -- member of specified model set and returns it on exit.
alpar@9	2353 --
alpar@9	2354 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	2355
alpar@9	2356 ELEMSET take_member_set / returns reference, not value */
alpar@9	2357 ( MPL *mpl,
alpar@9	2358 SET set, / not changed */
alpar@9	2359 TUPLE tuple / not changed */
alpar@9	2360 )
alpar@9	2361 { MEMBER *memb;
alpar@9	2362 ELEMSET *refer;
alpar@9	2363 /* find member in the set array */
alpar@9	2364 memb = find_member(mpl, set->array, tuple);
alpar@9	2365 if (memb != NULL)
alpar@9	2366 { /* member exists, so just take the reference */
alpar@9	2367 refer = memb->value.set;
alpar@9	2368 }
alpar@9	2369 else if (set->assign != NULL)
alpar@9	2370 { /* compute value using assignment expression */
alpar@9	2371 refer = eval_elemset(mpl, set->assign);
alpar@9	2372 add: /* check that the elemental set satisfies to all restrictions,
alpar@9	2373 assign it to new member, and add the member to the array */
alpar@9	2374 check_elem_set(mpl, set, tuple, refer);
alpar@9	2375 memb = add_member(mpl, set->array, copy_tuple(mpl, tuple));
alpar@9	2376 memb->value.set = refer;
alpar@9	2377 }
alpar@9	2378 else if (set->option != NULL)
alpar@9	2379 { /* compute default elemental set */
alpar@9	2380 refer = eval_elemset(mpl, set->option);
alpar@9	2381 goto add;
alpar@9	2382 }
alpar@9	2383 else
alpar@9	2384 { /* no value (elemental set) is provided */
alpar@9	2385 error(mpl, "no value for %s%s", set->name, format_tuple(mpl,
alpar@9	2386 '[', tuple));
alpar@9	2387 }
alpar@9	2388 return refer;
alpar@9	2389 }
alpar@9	2390
alpar@9	2391 /*----------------------------------------------------------------------
alpar@9	2392 -- eval_member_set - evaluate elemental set assigned to set member.
alpar@9	2393 --
alpar@9	2394 -- This routine evaluates a reference to elemental set assigned to given
alpar@9	2395 -- member of specified model set and returns it on exit. */
alpar@9	2396
alpar@9	2397 struct eval_set_info
alpar@9	2398 { /* working info used by the routine eval_member_set */
alpar@9	2399 SET *set;
alpar@9	2400 /* model set */
alpar@9	2401 TUPLE *tuple;
alpar@9	2402 /* n-tuple, which defines set member */
alpar@9	2403 MEMBER *memb;
alpar@9	2404 /* normally this pointer is NULL; the routine uses this pointer
alpar@9	2405 to check data provided in the data section, in which case it
alpar@9	2406 points to a member currently checked; this check is performed
alpar@9	2407 automatically only once when a reference to any member occurs
alpar@9	2408 for the first time */
alpar@9	2409 ELEMSET *refer;
alpar@9	2410 /* evaluated reference to elemental set */
alpar@9	2411 };
alpar@9	2412
alpar@9	2413 static void eval_set_func(MPL mpl, void _info)
alpar@9	2414 { /* this is auxiliary routine to work within domain scope */
alpar@9	2415 struct eval_set_info *info = _info;
alpar@9	2416 if (info->memb != NULL)
alpar@9	2417 { /* checking call; check elemental set being assigned */
alpar@9	2418 check_elem_set(mpl, info->set, info->memb->tuple,
alpar@9	2419 info->memb->value.set);
alpar@9	2420 }
alpar@9	2421 else
alpar@9	2422 { /* normal call; evaluate member, which has given n-tuple */
alpar@9	2423 info->refer = take_member_set(mpl, info->set, info->tuple);
alpar@9	2424 }
alpar@9	2425 return;
alpar@9	2426 }
alpar@9	2427
alpar@9	2428 #if 1 /* 12/XII-2008 */
alpar@9	2429 static void saturate_set(MPL mpl, SET set)
alpar@9	2430 { GADGET *gadget = set->gadget;
alpar@9	2431 ELEMSET *data;
alpar@9	2432 MEMBER elem, memb;
alpar@9	2433 TUPLE tuple, work[20];
alpar@9	2434 int i;
alpar@9	2435 xprintf("Generating %s...\n", set->name);
alpar@9	2436 eval_whole_set(mpl, gadget->set);
alpar@9	2437 /* gadget set must have exactly one member */
alpar@9	2438 xassert(gadget->set->array != NULL);
alpar@9	2439 xassert(gadget->set->array->head != NULL);
alpar@9	2440 xassert(gadget->set->array->head == gadget->set->array->tail);
alpar@9	2441 data = gadget->set->array->head->value.set;
alpar@9	2442 xassert(data->type == A_NONE);
alpar@9	2443 xassert(data->dim == gadget->set->dimen);
alpar@9	2444 /* walk thru all elements of the plain set */
alpar@9	2445 for (elem = data->head; elem != NULL; elem = elem->next)
alpar@9	2446 { /* create a copy of n-tuple */
alpar@9	2447 tuple = copy_tuple(mpl, elem->tuple);
alpar@9	2448 /* rearrange component of the n-tuple */
alpar@9	2449 for (i = 0; i < gadget->set->dimen; i++)
alpar@9	2450 work[i] = NULL;
alpar@9	2451 for (i = 0; tuple != NULL; tuple = tuple->next)
alpar@9	2452 work[gadget->ind[i++]-1] = tuple;
alpar@9	2453 xassert(i == gadget->set->dimen);
alpar@9	2454 for (i = 0; i < gadget->set->dimen; i++)
alpar@9	2455 { xassert(work[i] != NULL);
alpar@9	2456 work[i]->next = work[i+1];
alpar@9	2457 }
alpar@9	2458 /* construct subscript list from first set->dim components */
alpar@9	2459 if (set->dim == 0)
alpar@9	2460 tuple = NULL;
alpar@9	2461 else
alpar@9	2462 tuple = work[0], work[set->dim-1]->next = NULL;
alpar@9	2463 /* find corresponding member of the set to be initialized */
alpar@9	2464 memb = find_member(mpl, set->array, tuple);
alpar@9	2465 if (memb == NULL)
alpar@9	2466 { /* not found; add new member to the set and assign it empty
alpar@9	2467 elemental set */
alpar@9	2468 memb = add_member(mpl, set->array, tuple);
alpar@9	2469 memb->value.set = create_elemset(mpl, set->dimen);
alpar@9	2470 }
alpar@9	2471 else
alpar@9	2472 { /* found; free subscript list */
alpar@9	2473 delete_tuple(mpl, tuple);
alpar@9	2474 }
alpar@9	2475 /* construct new n-tuple from rest set->dimen components */
alpar@9	2476 tuple = work[set->dim];
alpar@9	2477 xassert(set->dim + set->dimen == gadget->set->dimen);
alpar@9	2478 work[gadget->set->dimen-1]->next = NULL;
alpar@9	2479 /* and add it to the elemental set assigned to the member
alpar@9	2480 (no check for duplicates is needed) */
alpar@9	2481 add_tuple(mpl, memb->value.set, tuple);
alpar@9	2482 }
alpar@9	2483 /* the set has been saturated with data */
alpar@9	2484 set->data = 1;
alpar@9	2485 return;
alpar@9	2486 }
alpar@9	2487 #endif
alpar@9	2488
alpar@9	2489 ELEMSET eval_member_set / returns reference, not value */
alpar@9	2490 ( MPL *mpl,
alpar@9	2491 SET set, / not changed */
alpar@9	2492 TUPLE tuple / not changed */
alpar@9	2493 )
alpar@9	2494 { /* this routine evaluates set member */
alpar@9	2495 struct eval_set_info _info, *info = &_info;
alpar@9	2496 xassert(set->dim == tuple_dimen(mpl, tuple));
alpar@9	2497 info->set = set;
alpar@9	2498 info->tuple = tuple;
alpar@9	2499 #if 1 /* 12/XII-2008 */
alpar@9	2500 if (set->gadget != NULL && set->data == 0)
alpar@9	2501 { /* initialize the set with data from a plain set */
alpar@9	2502 saturate_set(mpl, set);
alpar@9	2503 }
alpar@9	2504 #endif
alpar@9	2505 if (set->data == 1)
alpar@9	2506 { /* check data, which are provided in the data section, but not
alpar@9	2507 checked yet */
alpar@9	2508 /* save pointer to the last array member; note that during the
alpar@9	2509 check new members may be added beyond the last member due to
alpar@9	2510 references to the same parameter from default expression as
alpar@9	2511 well as from expressions that define restricting supersets;
alpar@9	2512 however, values assigned to the new members will be checked
alpar@9	2513 by other routine, so we don't need to check them here */
alpar@9	2514 MEMBER *tail = set->array->tail;
alpar@9	2515 /* change the data status to prevent infinite recursive loop
alpar@9	2516 due to references to the same set during the check */
alpar@9	2517 set->data = 2;
alpar@9	2518 /* check elemental sets assigned to array members in the data
alpar@9	2519 section until the marked member has been reached */
alpar@9	2520 for (info->memb = set->array->head; info->memb != NULL;
alpar@9	2521 info->memb = info->memb->next)
alpar@9	2522 { if (eval_within_domain(mpl, set->domain, info->memb->tuple,
alpar@9	2523 info, eval_set_func))
alpar@9	2524 out_of_domain(mpl, set->name, info->memb->tuple);
alpar@9	2525 if (info->memb == tail) break;
alpar@9	2526 }
alpar@9	2527 /* the check has been finished */
alpar@9	2528 }
alpar@9	2529 /* evaluate member, which has given n-tuple */
alpar@9	2530 info->memb = NULL;
alpar@9	2531 if (eval_within_domain(mpl, info->set->domain, info->tuple, info,
alpar@9	2532 eval_set_func))
alpar@9	2533 out_of_domain(mpl, set->name, info->tuple);
alpar@9	2534 /* bring evaluated reference to the calling program */
alpar@9	2535 return info->refer;
alpar@9	2536 }
alpar@9	2537
alpar@9	2538 /*----------------------------------------------------------------------
alpar@9	2539 -- eval_whole_set - evaluate model set over entire domain.
alpar@9	2540 --
alpar@9	2541 -- This routine evaluates all members of specified model set over entire
alpar@9	2542 -- domain. */
alpar@9	2543
alpar@9	2544 static int whole_set_func(MPL mpl, void info)
alpar@9	2545 { /* this is auxiliary routine to work within domain scope */
alpar@9	2546 SET set = (SET )info;
alpar@9	2547 TUPLE *tuple = get_domain_tuple(mpl, set->domain);
alpar@9	2548 eval_member_set(mpl, set, tuple);
alpar@9	2549 delete_tuple(mpl, tuple);
alpar@9	2550 return 0;
alpar@9	2551 }
alpar@9	2552
alpar@9	2553 void eval_whole_set(MPL mpl, SET set)
alpar@9	2554 { loop_within_domain(mpl, set->domain, set, whole_set_func);
alpar@9	2555 return;
alpar@9	2556 }
alpar@9	2557
alpar@9	2558 /*----------------------------------------------------------------------
alpar@9	2559 -- clean set - clean model set.
alpar@9	2560 --
alpar@9	2561 -- This routine cleans specified model set that assumes deleting all
alpar@9	2562 -- stuff dynamically allocated during the generation phase. */
alpar@9	2563
alpar@9	2564 void clean_set(MPL mpl, SET set)
alpar@9	2565 { WITHIN *within;
alpar@9	2566 MEMBER *memb;
alpar@9	2567 /* clean subscript domain */
alpar@9	2568 clean_domain(mpl, set->domain);
alpar@9	2569 /* clean pseudo-code for computing supersets */
alpar@9	2570 for (within = set->within; within != NULL; within = within->next)
alpar@9	2571 clean_code(mpl, within->code);
alpar@9	2572 /* clean pseudo-code for computing assigned value */
alpar@9	2573 clean_code(mpl, set->assign);
alpar@9	2574 /* clean pseudo-code for computing default value */
alpar@9	2575 clean_code(mpl, set->option);
alpar@9	2576 /* reset data status flag */
alpar@9	2577 set->data = 0;
alpar@9	2578 /* delete content array */
alpar@9	2579 for (memb = set->array->head; memb != NULL; memb = memb->next)
alpar@9	2580 delete_value(mpl, set->array->type, &memb->value);
alpar@9	2581 delete_array(mpl, set->array), set->array = NULL;
alpar@9	2582 return;
alpar@9	2583 }
alpar@9	2584
alpar@9	2585 /**********************************************************************/
alpar@9	2586 /* * * MODEL PARAMETERS * * */
alpar@9	2587 /**********************************************************************/
alpar@9	2588
alpar@9	2589 /*----------------------------------------------------------------------
alpar@9	2590 -- check_value_num - check numeric value assigned to parameter member.
alpar@9	2591 --
alpar@9	2592 -- This routine checks if numeric value being assigned to some member
alpar@9	2593 -- of specified numeric model parameter satisfies to all restrictions.
alpar@9	2594 --
alpar@9	2595 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	2596
alpar@9	2597 void check_value_num
alpar@9	2598 ( MPL *mpl,
alpar@9	2599 PARAMETER par, / not changed */
alpar@9	2600 TUPLE tuple, / not changed */
alpar@9	2601 double value
alpar@9	2602 )
alpar@9	2603 { CONDITION *cond;
alpar@9	2604 WITHIN *in;
alpar@9	2605 int eqno;
alpar@9	2606 /* the value must satisfy to the parameter type */
alpar@9	2607 switch (par->type)
alpar@9	2608 { case A_NUMERIC:
alpar@9	2609 break;
alpar@9	2610 case A_INTEGER:
alpar@9	2611 if (value != floor(value))
alpar@9	2612 error(mpl, "%s%s = %.*g not integer", par->name,
alpar@9	2613 format_tuple(mpl, '[', tuple), DBL_DIG, value);
alpar@9	2614 break;
alpar@9	2615 case A_BINARY:
alpar@9	2616 if (!(value == 0.0 \|\| value == 1.0))
alpar@9	2617 error(mpl, "%s%s = %.*g not binary", par->name,
alpar@9	2618 format_tuple(mpl, '[', tuple), DBL_DIG, value);
alpar@9	2619 break;
alpar@9	2620 default:
alpar@9	2621 xassert(par != par);
alpar@9	2622 }
alpar@9	2623 /* the value must satisfy to all specified conditions */
alpar@9	2624 for (cond = par->cond, eqno = 1; cond != NULL; cond = cond->next,
alpar@9	2625 eqno++)
alpar@9	2626 { double bound;
alpar@9	2627 char *rho;
alpar@9	2628 xassert(cond->code != NULL);
alpar@9	2629 bound = eval_numeric(mpl, cond->code);
alpar@9	2630 switch (cond->rho)
alpar@9	2631 { case O_LT:
alpar@9	2632 if (!(value < bound))
alpar@9	2633 { rho = "<";
alpar@9	2634 err: error(mpl, "%s%s = %.g not %s %.g; see (%d)",
alpar@9	2635 par->name, format_tuple(mpl, '[', tuple), DBL_DIG,
alpar@9	2636 value, rho, DBL_DIG, bound, eqno);
alpar@9	2637 }
alpar@9	2638 break;
alpar@9	2639 case O_LE:
alpar@9	2640 if (!(value <= bound)) { rho = "<="; goto err; }
alpar@9	2641 break;
alpar@9	2642 case O_EQ:
alpar@9	2643 if (!(value == bound)) { rho = "="; goto err; }
alpar@9	2644 break;
alpar@9	2645 case O_GE:
alpar@9	2646 if (!(value >= bound)) { rho = ">="; goto err; }
alpar@9	2647 break;
alpar@9	2648 case O_GT:
alpar@9	2649 if (!(value > bound)) { rho = ">"; goto err; }
alpar@9	2650 break;
alpar@9	2651 case O_NE:
alpar@9	2652 if (!(value != bound)) { rho = "<>"; goto err; }
alpar@9	2653 break;
alpar@9	2654 default:
alpar@9	2655 xassert(cond != cond);
alpar@9	2656 }
alpar@9	2657 }
alpar@9	2658 /* the value must be in all specified supersets */
alpar@9	2659 for (in = par->in, eqno = 1; in != NULL; in = in->next, eqno++)
alpar@9	2660 { TUPLE *dummy;
alpar@9	2661 xassert(in->code != NULL);
alpar@9	2662 xassert(in->code->dim == 1);
alpar@9	2663 dummy = expand_tuple(mpl, create_tuple(mpl),
alpar@9	2664 create_symbol_num(mpl, value));
alpar@9	2665 if (!is_member(mpl, in->code, dummy))
alpar@9	2666 error(mpl, "%s%s = %.*g not in specified set; see (%d)",
alpar@9	2667 par->name, format_tuple(mpl, '[', tuple), DBL_DIG,
alpar@9	2668 value, eqno);
alpar@9	2669 delete_tuple(mpl, dummy);
alpar@9	2670 }
alpar@9	2671 return;
alpar@9	2672 }
alpar@9	2673
alpar@9	2674 /*----------------------------------------------------------------------
alpar@9	2675 -- take_member_num - obtain num. value assigned to parameter member.
alpar@9	2676 --
alpar@9	2677 -- This routine obtains a numeric value assigned to member of specified
alpar@9	2678 -- numeric model parameter and returns it on exit.
alpar@9	2679 --
alpar@9	2680 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	2681
alpar@9	2682 double take_member_num
alpar@9	2683 ( MPL *mpl,
alpar@9	2684 PARAMETER par, / not changed */
alpar@9	2685 TUPLE tuple / not changed */
alpar@9	2686 )
alpar@9	2687 { MEMBER *memb;
alpar@9	2688 double value;
alpar@9	2689 /* find member in the parameter array */
alpar@9	2690 memb = find_member(mpl, par->array, tuple);
alpar@9	2691 if (memb != NULL)
alpar@9	2692 { /* member exists, so just take its value */
alpar@9	2693 value = memb->value.num;
alpar@9	2694 }
alpar@9	2695 else if (par->assign != NULL)
alpar@9	2696 { /* compute value using assignment expression */
alpar@9	2697 value = eval_numeric(mpl, par->assign);
alpar@9	2698 add: /* check that the value satisfies to all restrictions, assign
alpar@9	2699 it to new member, and add the member to the array */
alpar@9	2700 check_value_num(mpl, par, tuple, value);
alpar@9	2701 memb = add_member(mpl, par->array, copy_tuple(mpl, tuple));
alpar@9	2702 memb->value.num = value;
alpar@9	2703 }
alpar@9	2704 else if (par->option != NULL)
alpar@9	2705 { /* compute default value */
alpar@9	2706 value = eval_numeric(mpl, par->option);
alpar@9	2707 goto add;
alpar@9	2708 }
alpar@9	2709 else if (par->defval != NULL)
alpar@9	2710 { /* take default value provided in the data section */
alpar@9	2711 if (par->defval->str != NULL)
alpar@9	2712 error(mpl, "cannot convert %s to floating-point number",
alpar@9	2713 format_symbol(mpl, par->defval));
alpar@9	2714 value = par->defval->num;
alpar@9	2715 goto add;
alpar@9	2716 }
alpar@9	2717 else
alpar@9	2718 { /* no value is provided */
alpar@9	2719 error(mpl, "no value for %s%s", par->name, format_tuple(mpl,
alpar@9	2720 '[', tuple));
alpar@9	2721 }
alpar@9	2722 return value;
alpar@9	2723 }
alpar@9	2724
alpar@9	2725 /*----------------------------------------------------------------------
alpar@9	2726 -- eval_member_num - evaluate num. value assigned to parameter member.
alpar@9	2727 --
alpar@9	2728 -- This routine evaluates a numeric value assigned to given member of
alpar@9	2729 -- specified numeric model parameter and returns it on exit. */
alpar@9	2730
alpar@9	2731 struct eval_num_info
alpar@9	2732 { /* working info used by the routine eval_member_num */
alpar@9	2733 PARAMETER *par;
alpar@9	2734 /* model parameter */
alpar@9	2735 TUPLE *tuple;
alpar@9	2736 /* n-tuple, which defines parameter member */
alpar@9	2737 MEMBER *memb;
alpar@9	2738 /* normally this pointer is NULL; the routine uses this pointer
alpar@9	2739 to check data provided in the data section, in which case it
alpar@9	2740 points to a member currently checked; this check is performed
alpar@9	2741 automatically only once when a reference to any member occurs
alpar@9	2742 for the first time */
alpar@9	2743 double value;
alpar@9	2744 /* evaluated numeric value */
alpar@9	2745 };
alpar@9	2746
alpar@9	2747 static void eval_num_func(MPL mpl, void _info)
alpar@9	2748 { /* this is auxiliary routine to work within domain scope */
alpar@9	2749 struct eval_num_info *info = _info;
alpar@9	2750 if (info->memb != NULL)
alpar@9	2751 { /* checking call; check numeric value being assigned */
alpar@9	2752 check_value_num(mpl, info->par, info->memb->tuple,
alpar@9	2753 info->memb->value.num);
alpar@9	2754 }
alpar@9	2755 else
alpar@9	2756 { /* normal call; evaluate member, which has given n-tuple */
alpar@9	2757 info->value = take_member_num(mpl, info->par, info->tuple);
alpar@9	2758 }
alpar@9	2759 return;
alpar@9	2760 }
alpar@9	2761
alpar@9	2762 double eval_member_num
alpar@9	2763 ( MPL *mpl,
alpar@9	2764 PARAMETER par, / not changed */
alpar@9	2765 TUPLE tuple / not changed */
alpar@9	2766 )
alpar@9	2767 { /* this routine evaluates numeric parameter member */
alpar@9	2768 struct eval_num_info _info, *info = &_info;
alpar@9	2769 xassert(par->type == A_NUMERIC \|\| par->type == A_INTEGER \|\|
alpar@9	2770 par->type == A_BINARY);
alpar@9	2771 xassert(par->dim == tuple_dimen(mpl, tuple));
alpar@9	2772 info->par = par;
alpar@9	2773 info->tuple = tuple;
alpar@9	2774 if (par->data == 1)
alpar@9	2775 { /* check data, which are provided in the data section, but not
alpar@9	2776 checked yet */
alpar@9	2777 /* save pointer to the last array member; note that during the
alpar@9	2778 check new members may be added beyond the last member due to
alpar@9	2779 references to the same parameter from default expression as
alpar@9	2780 well as from expressions that define restricting conditions;
alpar@9	2781 however, values assigned to the new members will be checked
alpar@9	2782 by other routine, so we don't need to check them here */
alpar@9	2783 MEMBER *tail = par->array->tail;
alpar@9	2784 /* change the data status to prevent infinite recursive loop
alpar@9	2785 due to references to the same parameter during the check */
alpar@9	2786 par->data = 2;
alpar@9	2787 /* check values assigned to array members in the data section
alpar@9	2788 until the marked member has been reached */
alpar@9	2789 for (info->memb = par->array->head; info->memb != NULL;
alpar@9	2790 info->memb = info->memb->next)
alpar@9	2791 { if (eval_within_domain(mpl, par->domain, info->memb->tuple,
alpar@9	2792 info, eval_num_func))
alpar@9	2793 out_of_domain(mpl, par->name, info->memb->tuple);
alpar@9	2794 if (info->memb == tail) break;
alpar@9	2795 }
alpar@9	2796 /* the check has been finished */
alpar@9	2797 }
alpar@9	2798 /* evaluate member, which has given n-tuple */
alpar@9	2799 info->memb = NULL;
alpar@9	2800 if (eval_within_domain(mpl, info->par->domain, info->tuple, info,
alpar@9	2801 eval_num_func))
alpar@9	2802 out_of_domain(mpl, par->name, info->tuple);
alpar@9	2803 /* bring evaluated value to the calling program */
alpar@9	2804 return info->value;
alpar@9	2805 }
alpar@9	2806
alpar@9	2807 /*----------------------------------------------------------------------
alpar@9	2808 -- check_value_sym - check symbolic value assigned to parameter member.
alpar@9	2809 --
alpar@9	2810 -- This routine checks if symbolic value being assigned to some member
alpar@9	2811 -- of specified symbolic model parameter satisfies to all restrictions.
alpar@9	2812 --
alpar@9	2813 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	2814
alpar@9	2815 void check_value_sym
alpar@9	2816 ( MPL *mpl,
alpar@9	2817 PARAMETER par, / not changed */
alpar@9	2818 TUPLE tuple, / not changed */
alpar@9	2819 SYMBOL value / not changed */
alpar@9	2820 )
alpar@9	2821 { CONDITION *cond;
alpar@9	2822 WITHIN *in;
alpar@9	2823 int eqno;
alpar@9	2824 /* the value must satisfy to all specified conditions */
alpar@9	2825 for (cond = par->cond, eqno = 1; cond != NULL; cond = cond->next,
alpar@9	2826 eqno++)
alpar@9	2827 { SYMBOL *bound;
alpar@9	2828 char buf[255+1];
alpar@9	2829 xassert(cond->code != NULL);
alpar@9	2830 bound = eval_symbolic(mpl, cond->code);
alpar@9	2831 switch (cond->rho)
alpar@9	2832 {
alpar@9	2833 #if 1 /* 13/VIII-2008 */
alpar@9	2834 case O_LT:
alpar@9	2835 if (!(compare_symbols(mpl, value, bound) < 0))
alpar@9	2836 { strcpy(buf, format_symbol(mpl, bound));
alpar@9	2837 xassert(strlen(buf) < sizeof(buf));
alpar@9	2838 error(mpl, "%s%s = %s not < %s",
alpar@9	2839 par->name, format_tuple(mpl, '[', tuple),
alpar@9	2840 format_symbol(mpl, value), buf, eqno);
alpar@9	2841 }
alpar@9	2842 break;
alpar@9	2843 case O_LE:
alpar@9	2844 if (!(compare_symbols(mpl, value, bound) <= 0))
alpar@9	2845 { strcpy(buf, format_symbol(mpl, bound));
alpar@9	2846 xassert(strlen(buf) < sizeof(buf));
alpar@9	2847 error(mpl, "%s%s = %s not <= %s",
alpar@9	2848 par->name, format_tuple(mpl, '[', tuple),
alpar@9	2849 format_symbol(mpl, value), buf, eqno);
alpar@9	2850 }
alpar@9	2851 break;
alpar@9	2852 #endif
alpar@9	2853 case O_EQ:
alpar@9	2854 if (!(compare_symbols(mpl, value, bound) == 0))
alpar@9	2855 { strcpy(buf, format_symbol(mpl, bound));
alpar@9	2856 xassert(strlen(buf) < sizeof(buf));
alpar@9	2857 error(mpl, "%s%s = %s not = %s",
alpar@9	2858 par->name, format_tuple(mpl, '[', tuple),
alpar@9	2859 format_symbol(mpl, value), buf, eqno);
alpar@9	2860 }
alpar@9	2861 break;
alpar@9	2862 #if 1 /* 13/VIII-2008 */
alpar@9	2863 case O_GE:
alpar@9	2864 if (!(compare_symbols(mpl, value, bound) >= 0))
alpar@9	2865 { strcpy(buf, format_symbol(mpl, bound));
alpar@9	2866 xassert(strlen(buf) < sizeof(buf));
alpar@9	2867 error(mpl, "%s%s = %s not >= %s",
alpar@9	2868 par->name, format_tuple(mpl, '[', tuple),
alpar@9	2869 format_symbol(mpl, value), buf, eqno);
alpar@9	2870 }
alpar@9	2871 break;
alpar@9	2872 case O_GT:
alpar@9	2873 if (!(compare_symbols(mpl, value, bound) > 0))
alpar@9	2874 { strcpy(buf, format_symbol(mpl, bound));
alpar@9	2875 xassert(strlen(buf) < sizeof(buf));
alpar@9	2876 error(mpl, "%s%s = %s not > %s",
alpar@9	2877 par->name, format_tuple(mpl, '[', tuple),
alpar@9	2878 format_symbol(mpl, value), buf, eqno);
alpar@9	2879 }
alpar@9	2880 break;
alpar@9	2881 #endif
alpar@9	2882 case O_NE:
alpar@9	2883 if (!(compare_symbols(mpl, value, bound) != 0))
alpar@9	2884 { strcpy(buf, format_symbol(mpl, bound));
alpar@9	2885 xassert(strlen(buf) < sizeof(buf));
alpar@9	2886 error(mpl, "%s%s = %s not <> %s",
alpar@9	2887 par->name, format_tuple(mpl, '[', tuple),
alpar@9	2888 format_symbol(mpl, value), buf, eqno);
alpar@9	2889 }
alpar@9	2890 break;
alpar@9	2891 default:
alpar@9	2892 xassert(cond != cond);
alpar@9	2893 }
alpar@9	2894 delete_symbol(mpl, bound);
alpar@9	2895 }
alpar@9	2896 /* the value must be in all specified supersets */
alpar@9	2897 for (in = par->in, eqno = 1; in != NULL; in = in->next, eqno++)
alpar@9	2898 { TUPLE *dummy;
alpar@9	2899 xassert(in->code != NULL);
alpar@9	2900 xassert(in->code->dim == 1);
alpar@9	2901 dummy = expand_tuple(mpl, create_tuple(mpl), copy_symbol(mpl,
alpar@9	2902 value));
alpar@9	2903 if (!is_member(mpl, in->code, dummy))
alpar@9	2904 error(mpl, "%s%s = %s not in specified set; see (%d)",
alpar@9	2905 par->name, format_tuple(mpl, '[', tuple),
alpar@9	2906 format_symbol(mpl, value), eqno);
alpar@9	2907 delete_tuple(mpl, dummy);
alpar@9	2908 }
alpar@9	2909 return;
alpar@9	2910 }
alpar@9	2911
alpar@9	2912 /*----------------------------------------------------------------------
alpar@9	2913 -- take_member_sym - obtain symb. value assigned to parameter member.
alpar@9	2914 --
alpar@9	2915 -- This routine obtains a symbolic value assigned to member of specified
alpar@9	2916 -- symbolic model parameter and returns it on exit.
alpar@9	2917 --
alpar@9	2918 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	2919
alpar@9	2920 SYMBOL take_member_sym / returns value, not reference */
alpar@9	2921 ( MPL *mpl,
alpar@9	2922 PARAMETER par, / not changed */
alpar@9	2923 TUPLE tuple / not changed */
alpar@9	2924 )
alpar@9	2925 { MEMBER *memb;
alpar@9	2926 SYMBOL *value;
alpar@9	2927 /* find member in the parameter array */
alpar@9	2928 memb = find_member(mpl, par->array, tuple);
alpar@9	2929 if (memb != NULL)
alpar@9	2930 { /* member exists, so just take its value */
alpar@9	2931 value = copy_symbol(mpl, memb->value.sym);
alpar@9	2932 }
alpar@9	2933 else if (par->assign != NULL)
alpar@9	2934 { /* compute value using assignment expression */
alpar@9	2935 value = eval_symbolic(mpl, par->assign);
alpar@9	2936 add: /* check that the value satisfies to all restrictions, assign
alpar@9	2937 it to new member, and add the member to the array */
alpar@9	2938 check_value_sym(mpl, par, tuple, value);
alpar@9	2939 memb = add_member(mpl, par->array, copy_tuple(mpl, tuple));
alpar@9	2940 memb->value.sym = copy_symbol(mpl, value);
alpar@9	2941 }
alpar@9	2942 else if (par->option != NULL)
alpar@9	2943 { /* compute default value */
alpar@9	2944 value = eval_symbolic(mpl, par->option);
alpar@9	2945 goto add;
alpar@9	2946 }
alpar@9	2947 else if (par->defval != NULL)
alpar@9	2948 { /* take default value provided in the data section */
alpar@9	2949 value = copy_symbol(mpl, par->defval);
alpar@9	2950 goto add;
alpar@9	2951 }
alpar@9	2952 else
alpar@9	2953 { /* no value is provided */
alpar@9	2954 error(mpl, "no value for %s%s", par->name, format_tuple(mpl,
alpar@9	2955 '[', tuple));
alpar@9	2956 }
alpar@9	2957 return value;
alpar@9	2958 }
alpar@9	2959
alpar@9	2960 /*----------------------------------------------------------------------
alpar@9	2961 -- eval_member_sym - evaluate symb. value assigned to parameter member.
alpar@9	2962 --
alpar@9	2963 -- This routine evaluates a symbolic value assigned to given member of
alpar@9	2964 -- specified symbolic model parameter and returns it on exit. */
alpar@9	2965
alpar@9	2966 struct eval_sym_info
alpar@9	2967 { /* working info used by the routine eval_member_sym */
alpar@9	2968 PARAMETER *par;
alpar@9	2969 /* model parameter */
alpar@9	2970 TUPLE *tuple;
alpar@9	2971 /* n-tuple, which defines parameter member */
alpar@9	2972 MEMBER *memb;
alpar@9	2973 /* normally this pointer is NULL; the routine uses this pointer
alpar@9	2974 to check data provided in the data section, in which case it
alpar@9	2975 points to a member currently checked; this check is performed
alpar@9	2976 automatically only once when a reference to any member occurs
alpar@9	2977 for the first time */
alpar@9	2978 SYMBOL *value;
alpar@9	2979 /* evaluated symbolic value */
alpar@9	2980 };
alpar@9	2981
alpar@9	2982 static void eval_sym_func(MPL mpl, void _info)
alpar@9	2983 { /* this is auxiliary routine to work within domain scope */
alpar@9	2984 struct eval_sym_info *info = _info;
alpar@9	2985 if (info->memb != NULL)
alpar@9	2986 { /* checking call; check symbolic value being assigned */
alpar@9	2987 check_value_sym(mpl, info->par, info->memb->tuple,
alpar@9	2988 info->memb->value.sym);
alpar@9	2989 }
alpar@9	2990 else
alpar@9	2991 { /* normal call; evaluate member, which has given n-tuple */
alpar@9	2992 info->value = take_member_sym(mpl, info->par, info->tuple);
alpar@9	2993 }
alpar@9	2994 return;
alpar@9	2995 }
alpar@9	2996
alpar@9	2997 SYMBOL eval_member_sym / returns value, not reference */
alpar@9	2998 ( MPL *mpl,
alpar@9	2999 PARAMETER par, / not changed */
alpar@9	3000 TUPLE tuple / not changed */
alpar@9	3001 )
alpar@9	3002 { /* this routine evaluates symbolic parameter member */
alpar@9	3003 struct eval_sym_info _info, *info = &_info;
alpar@9	3004 xassert(par->type == A_SYMBOLIC);
alpar@9	3005 xassert(par->dim == tuple_dimen(mpl, tuple));
alpar@9	3006 info->par = par;
alpar@9	3007 info->tuple = tuple;
alpar@9	3008 if (par->data == 1)
alpar@9	3009 { /* check data, which are provided in the data section, but not
alpar@9	3010 checked yet */
alpar@9	3011 /* save pointer to the last array member; note that during the
alpar@9	3012 check new members may be added beyond the last member due to
alpar@9	3013 references to the same parameter from default expression as
alpar@9	3014 well as from expressions that define restricting conditions;
alpar@9	3015 however, values assigned to the new members will be checked
alpar@9	3016 by other routine, so we don't need to check them here */
alpar@9	3017 MEMBER *tail = par->array->tail;
alpar@9	3018 /* change the data status to prevent infinite recursive loop
alpar@9	3019 due to references to the same parameter during the check */
alpar@9	3020 par->data = 2;
alpar@9	3021 /* check values assigned to array members in the data section
alpar@9	3022 until the marked member has been reached */
alpar@9	3023 for (info->memb = par->array->head; info->memb != NULL;
alpar@9	3024 info->memb = info->memb->next)
alpar@9	3025 { if (eval_within_domain(mpl, par->domain, info->memb->tuple,
alpar@9	3026 info, eval_sym_func))
alpar@9	3027 out_of_domain(mpl, par->name, info->memb->tuple);
alpar@9	3028 if (info->memb == tail) break;
alpar@9	3029 }
alpar@9	3030 /* the check has been finished */
alpar@9	3031 }
alpar@9	3032 /* evaluate member, which has given n-tuple */
alpar@9	3033 info->memb = NULL;
alpar@9	3034 if (eval_within_domain(mpl, info->par->domain, info->tuple, info,
alpar@9	3035 eval_sym_func))
alpar@9	3036 out_of_domain(mpl, par->name, info->tuple);
alpar@9	3037 /* bring evaluated value to the calling program */
alpar@9	3038 return info->value;
alpar@9	3039 }
alpar@9	3040
alpar@9	3041 /*----------------------------------------------------------------------
alpar@9	3042 -- eval_whole_par - evaluate model parameter over entire domain.
alpar@9	3043 --
alpar@9	3044 -- This routine evaluates all members of specified model parameter over
alpar@9	3045 -- entire domain. */
alpar@9	3046
alpar@9	3047 static int whole_par_func(MPL mpl, void info)
alpar@9	3048 { /* this is auxiliary routine to work within domain scope */
alpar@9	3049 PARAMETER par = (PARAMETER )info;
alpar@9	3050 TUPLE *tuple = get_domain_tuple(mpl, par->domain);
alpar@9	3051 switch (par->type)
alpar@9	3052 { case A_NUMERIC:
alpar@9	3053 case A_INTEGER:
alpar@9	3054 case A_BINARY:
alpar@9	3055 eval_member_num(mpl, par, tuple);
alpar@9	3056 break;
alpar@9	3057 case A_SYMBOLIC:
alpar@9	3058 delete_symbol(mpl, eval_member_sym(mpl, par, tuple));
alpar@9	3059 break;
alpar@9	3060 default:
alpar@9	3061 xassert(par != par);
alpar@9	3062 }
alpar@9	3063 delete_tuple(mpl, tuple);
alpar@9	3064 return 0;
alpar@9	3065 }
alpar@9	3066
alpar@9	3067 void eval_whole_par(MPL mpl, PARAMETER par)
alpar@9	3068 { loop_within_domain(mpl, par->domain, par, whole_par_func);
alpar@9	3069 return;
alpar@9	3070 }
alpar@9	3071
alpar@9	3072 /*----------------------------------------------------------------------
alpar@9	3073 -- clean_parameter - clean model parameter.
alpar@9	3074 --
alpar@9	3075 -- This routine cleans specified model parameter that assumes deleting
alpar@9	3076 -- all stuff dynamically allocated during the generation phase. */
alpar@9	3077
alpar@9	3078 void clean_parameter(MPL mpl, PARAMETER par)
alpar@9	3079 { CONDITION *cond;
alpar@9	3080 WITHIN *in;
alpar@9	3081 MEMBER *memb;
alpar@9	3082 /* clean subscript domain */
alpar@9	3083 clean_domain(mpl, par->domain);
alpar@9	3084 /* clean pseudo-code for computing restricting conditions */
alpar@9	3085 for (cond = par->cond; cond != NULL; cond = cond->next)
alpar@9	3086 clean_code(mpl, cond->code);
alpar@9	3087 /* clean pseudo-code for computing restricting supersets */
alpar@9	3088 for (in = par->in; in != NULL; in = in->next)
alpar@9	3089 clean_code(mpl, in->code);
alpar@9	3090 /* clean pseudo-code for computing assigned value */
alpar@9	3091 clean_code(mpl, par->assign);
alpar@9	3092 /* clean pseudo-code for computing default value */
alpar@9	3093 clean_code(mpl, par->option);
alpar@9	3094 /* reset data status flag */
alpar@9	3095 par->data = 0;
alpar@9	3096 /* delete default symbolic value */
alpar@9	3097 if (par->defval != NULL)
alpar@9	3098 delete_symbol(mpl, par->defval), par->defval = NULL;
alpar@9	3099 /* delete content array */
alpar@9	3100 for (memb = par->array->head; memb != NULL; memb = memb->next)
alpar@9	3101 delete_value(mpl, par->array->type, &memb->value);
alpar@9	3102 delete_array(mpl, par->array), par->array = NULL;
alpar@9	3103 return;
alpar@9	3104 }
alpar@9	3105
alpar@9	3106 /**********************************************************************/
alpar@9	3107 /* * * MODEL VARIABLES * * */
alpar@9	3108 /**********************************************************************/
alpar@9	3109
alpar@9	3110 /*----------------------------------------------------------------------
alpar@9	3111 -- take_member_var - obtain reference to elemental variable.
alpar@9	3112 --
alpar@9	3113 -- This routine obtains a reference to elemental variable assigned to
alpar@9	3114 -- given member of specified model variable and returns it on exit. If
alpar@9	3115 -- necessary, new elemental variable is created.
alpar@9	3116 --
alpar@9	3117 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	3118
alpar@9	3119 ELEMVAR take_member_var / returns reference */
alpar@9	3120 ( MPL *mpl,
alpar@9	3121 VARIABLE var, / not changed */
alpar@9	3122 TUPLE tuple / not changed */
alpar@9	3123 )
alpar@9	3124 { MEMBER *memb;
alpar@9	3125 ELEMVAR *refer;
alpar@9	3126 /* find member in the variable array */
alpar@9	3127 memb = find_member(mpl, var->array, tuple);
alpar@9	3128 if (memb != NULL)
alpar@9	3129 { /* member exists, so just take the reference */
alpar@9	3130 refer = memb->value.var;
alpar@9	3131 }
alpar@9	3132 else
alpar@9	3133 { /* member is referenced for the first time and therefore does
alpar@9	3134 not exist; create new elemental variable, assign it to new
alpar@9	3135 member, and add the member to the variable array */
alpar@9	3136 memb = add_member(mpl, var->array, copy_tuple(mpl, tuple));
alpar@9	3137 refer = (memb->value.var =
alpar@9	3138 dmp_get_atom(mpl->elemvars, sizeof(ELEMVAR)));
alpar@9	3139 refer->j = 0;
alpar@9	3140 refer->var = var;
alpar@9	3141 refer->memb = memb;
alpar@9	3142 /* compute lower bound */
alpar@9	3143 if (var->lbnd == NULL)
alpar@9	3144 refer->lbnd = 0.0;
alpar@9	3145 else
alpar@9	3146 refer->lbnd = eval_numeric(mpl, var->lbnd);
alpar@9	3147 /* compute upper bound */
alpar@9	3148 if (var->ubnd == NULL)
alpar@9	3149 refer->ubnd = 0.0;
alpar@9	3150 else if (var->ubnd == var->lbnd)
alpar@9	3151 refer->ubnd = refer->lbnd;
alpar@9	3152 else
alpar@9	3153 refer->ubnd = eval_numeric(mpl, var->ubnd);
alpar@9	3154 /* nullify working quantity */
alpar@9	3155 refer->temp = 0.0;
alpar@9	3156 #if 1 /* 15/V-2010 */
alpar@9	3157 /* solution has not been obtained by the solver yet */
alpar@9	3158 refer->stat = 0;
alpar@9	3159 refer->prim = refer->dual = 0.0;
alpar@9	3160 #endif
alpar@9	3161 }
alpar@9	3162 return refer;
alpar@9	3163 }
alpar@9	3164
alpar@9	3165 /*----------------------------------------------------------------------
alpar@9	3166 -- eval_member_var - evaluate reference to elemental variable.
alpar@9	3167 --
alpar@9	3168 -- This routine evaluates a reference to elemental variable assigned to
alpar@9	3169 -- member of specified model variable and returns it on exit. */
alpar@9	3170
alpar@9	3171 struct eval_var_info
alpar@9	3172 { /* working info used by the routine eval_member_var */
alpar@9	3173 VARIABLE *var;
alpar@9	3174 /* model variable */
alpar@9	3175 TUPLE *tuple;
alpar@9	3176 /* n-tuple, which defines variable member */
alpar@9	3177 ELEMVAR *refer;
alpar@9	3178 /* evaluated reference to elemental variable */
alpar@9	3179 };
alpar@9	3180
alpar@9	3181 static void eval_var_func(MPL mpl, void _info)
alpar@9	3182 { /* this is auxiliary routine to work within domain scope */
alpar@9	3183 struct eval_var_info *info = _info;
alpar@9	3184 info->refer = take_member_var(mpl, info->var, info->tuple);
alpar@9	3185 return;
alpar@9	3186 }
alpar@9	3187
alpar@9	3188 ELEMVAR eval_member_var / returns reference */
alpar@9	3189 ( MPL *mpl,
alpar@9	3190 VARIABLE var, / not changed */
alpar@9	3191 TUPLE tuple / not changed */
alpar@9	3192 )
alpar@9	3193 { /* this routine evaluates variable member */
alpar@9	3194 struct eval_var_info _info, *info = &_info;
alpar@9	3195 xassert(var->dim == tuple_dimen(mpl, tuple));
alpar@9	3196 info->var = var;
alpar@9	3197 info->tuple = tuple;
alpar@9	3198 /* evaluate member, which has given n-tuple */
alpar@9	3199 if (eval_within_domain(mpl, info->var->domain, info->tuple, info,
alpar@9	3200 eval_var_func))
alpar@9	3201 out_of_domain(mpl, var->name, info->tuple);
alpar@9	3202 /* bring evaluated reference to the calling program */
alpar@9	3203 return info->refer;
alpar@9	3204 }
alpar@9	3205
alpar@9	3206 /*----------------------------------------------------------------------
alpar@9	3207 -- eval_whole_var - evaluate model variable over entire domain.
alpar@9	3208 --
alpar@9	3209 -- This routine evaluates all members of specified model variable over
alpar@9	3210 -- entire domain. */
alpar@9	3211
alpar@9	3212 static int whole_var_func(MPL mpl, void info)
alpar@9	3213 { /* this is auxiliary routine to work within domain scope */
alpar@9	3214 VARIABLE var = (VARIABLE )info;
alpar@9	3215 TUPLE *tuple = get_domain_tuple(mpl, var->domain);
alpar@9	3216 eval_member_var(mpl, var, tuple);
alpar@9	3217 delete_tuple(mpl, tuple);
alpar@9	3218 return 0;
alpar@9	3219 }
alpar@9	3220
alpar@9	3221 void eval_whole_var(MPL mpl, VARIABLE var)
alpar@9	3222 { loop_within_domain(mpl, var->domain, var, whole_var_func);
alpar@9	3223 return;
alpar@9	3224 }
alpar@9	3225
alpar@9	3226 /*----------------------------------------------------------------------
alpar@9	3227 -- clean_variable - clean model variable.
alpar@9	3228 --
alpar@9	3229 -- This routine cleans specified model variable that assumes deleting
alpar@9	3230 -- all stuff dynamically allocated during the generation phase. */
alpar@9	3231
alpar@9	3232 void clean_variable(MPL mpl, VARIABLE var)
alpar@9	3233 { MEMBER *memb;
alpar@9	3234 /* clean subscript domain */
alpar@9	3235 clean_domain(mpl, var->domain);
alpar@9	3236 /* clean code for computing lower bound */
alpar@9	3237 clean_code(mpl, var->lbnd);
alpar@9	3238 /* clean code for computing upper bound */
alpar@9	3239 if (var->ubnd != var->lbnd) clean_code(mpl, var->ubnd);
alpar@9	3240 /* delete content array */
alpar@9	3241 for (memb = var->array->head; memb != NULL; memb = memb->next)
alpar@9	3242 dmp_free_atom(mpl->elemvars, memb->value.var, sizeof(ELEMVAR));
alpar@9	3243 delete_array(mpl, var->array), var->array = NULL;
alpar@9	3244 return;
alpar@9	3245 }
alpar@9	3246
alpar@9	3247 /**********************************************************************/
alpar@9	3248 /* * * MODEL CONSTRAINTS AND OBJECTIVES * * */
alpar@9	3249 /**********************************************************************/
alpar@9	3250
alpar@9	3251 /*----------------------------------------------------------------------
alpar@9	3252 -- take_member_con - obtain reference to elemental constraint.
alpar@9	3253 --
alpar@9	3254 -- This routine obtains a reference to elemental constraint assigned
alpar@9	3255 -- to given member of specified model constraint and returns it on exit.
alpar@9	3256 -- If necessary, new elemental constraint is created.
alpar@9	3257 --
alpar@9	3258 -- NOTE: This routine must not be called out of domain scope. */
alpar@9	3259
alpar@9	3260 ELEMCON take_member_con / returns reference */
alpar@9	3261 ( MPL *mpl,
alpar@9	3262 CONSTRAINT con, / not changed */
alpar@9	3263 TUPLE tuple / not changed */
alpar@9	3264 )
alpar@9	3265 { MEMBER *memb;
alpar@9	3266 ELEMCON *refer;
alpar@9	3267 /* find member in the constraint array */
alpar@9	3268 memb = find_member(mpl, con->array, tuple);
alpar@9	3269 if (memb != NULL)
alpar@9	3270 { /* member exists, so just take the reference */
alpar@9	3271 refer = memb->value.con;
alpar@9	3272 }
alpar@9	3273 else
alpar@9	3274 { /* member is referenced for the first time and therefore does
alpar@9	3275 not exist; create new elemental constraint, assign it to new
alpar@9	3276 member, and add the member to the constraint array */
alpar@9	3277 memb = add_member(mpl, con->array, copy_tuple(mpl, tuple));
alpar@9	3278 refer = (memb->value.con =
alpar@9	3279 dmp_get_atom(mpl->elemcons, sizeof(ELEMCON)));
alpar@9	3280 refer->i = 0;
alpar@9	3281 refer->con = con;
alpar@9	3282 refer->memb = memb;
alpar@9	3283 /* compute linear form */
alpar@9	3284 xassert(con->code != NULL);
alpar@9	3285 refer->form = eval_formula(mpl, con->code);
alpar@9	3286 /* compute lower and upper bounds */
alpar@9	3287 if (con->lbnd == NULL && con->ubnd == NULL)
alpar@9	3288 { /* objective has no bounds */
alpar@9	3289 double temp;
alpar@9	3290 xassert(con->type == A_MINIMIZE \|\| con->type == A_MAXIMIZE);
alpar@9	3291 /* carry the constant term to the right-hand side */
alpar@9	3292 refer->form = remove_constant(mpl, refer->form, &temp);
alpar@9	3293 refer->lbnd = refer->ubnd = - temp;
alpar@9	3294 }
alpar@9	3295 else if (con->lbnd != NULL && con->ubnd == NULL)
alpar@9	3296 { /* constraint a * x + b >= c * y + d is transformed to the
alpar@9	3297 standard form a * x - c * y >= d - b */
alpar@9	3298 double temp;
alpar@9	3299 xassert(con->type == A_CONSTRAINT);
alpar@9	3300 refer->form = linear_comb(mpl,
alpar@9	3301 +1.0, refer->form,
alpar@9	3302 -1.0, eval_formula(mpl, con->lbnd));
alpar@9	3303 refer->form = remove_constant(mpl, refer->form, &temp);
alpar@9	3304 refer->lbnd = - temp;
alpar@9	3305 refer->ubnd = 0.0;
alpar@9	3306 }
alpar@9	3307 else if (con->lbnd == NULL && con->ubnd != NULL)
alpar@9	3308 { /* constraint a * x + b <= c * y + d is transformed to the
alpar@9	3309 standard form a * x - c * y <= d - b */
alpar@9	3310 double temp;
alpar@9	3311 xassert(con->type == A_CONSTRAINT);
alpar@9	3312 refer->form = linear_comb(mpl,
alpar@9	3313 +1.0, refer->form,
alpar@9	3314 -1.0, eval_formula(mpl, con->ubnd));
alpar@9	3315 refer->form = remove_constant(mpl, refer->form, &temp);
alpar@9	3316 refer->lbnd = 0.0;
alpar@9	3317 refer->ubnd = - temp;
alpar@9	3318 }
alpar@9	3319 else if (con->lbnd == con->ubnd)
alpar@9	3320 { /* constraint a * x + b = c * y + d is transformed to the
alpar@9	3321 standard form a * x - c * y = d - b */
alpar@9	3322 double temp;
alpar@9	3323 xassert(con->type == A_CONSTRAINT);
alpar@9	3324 refer->form = linear_comb(mpl,
alpar@9	3325 +1.0, refer->form,
alpar@9	3326 -1.0, eval_formula(mpl, con->lbnd));
alpar@9	3327 refer->form = remove_constant(mpl, refer->form, &temp);
alpar@9	3328 refer->lbnd = refer->ubnd = - temp;
alpar@9	3329 }
alpar@9	3330 else
alpar@9	3331 { /* ranged constraint c <= a * x + b <= d is transformed to
alpar@9	3332 the standard form c - b <= a * x <= d - b */
alpar@9	3333 double temp, temp1, temp2;
alpar@9	3334 xassert(con->type == A_CONSTRAINT);
alpar@9	3335 refer->form = remove_constant(mpl, refer->form, &temp);
alpar@9	3336 xassert(remove_constant(mpl, eval_formula(mpl, con->lbnd),
alpar@9	3337 &temp1) == NULL);
alpar@9	3338 xassert(remove_constant(mpl, eval_formula(mpl, con->ubnd),
alpar@9	3339 &temp2) == NULL);
alpar@9	3340 refer->lbnd = fp_sub(mpl, temp1, temp);
alpar@9	3341 refer->ubnd = fp_sub(mpl, temp2, temp);
alpar@9	3342 }
alpar@9	3343 #if 1 /* 15/V-2010 */
alpar@9	3344 /* solution has not been obtained by the solver yet */
alpar@9	3345 refer->stat = 0;
alpar@9	3346 refer->prim = refer->dual = 0.0;
alpar@9	3347 #endif
alpar@9	3348 }
alpar@9	3349 return refer;
alpar@9	3350 }
alpar@9	3351
alpar@9	3352 /*----------------------------------------------------------------------
alpar@9	3353 -- eval_member_con - evaluate reference to elemental constraint.
alpar@9	3354 --
alpar@9	3355 -- This routine evaluates a reference to elemental constraint assigned
alpar@9	3356 -- to member of specified model constraint and returns it on exit. */
alpar@9	3357
alpar@9	3358 struct eval_con_info
alpar@9	3359 { /* working info used by the routine eval_member_con */
alpar@9	3360 CONSTRAINT *con;
alpar@9	3361 /* model constraint */
alpar@9	3362 TUPLE *tuple;
alpar@9	3363 /* n-tuple, which defines constraint member */
alpar@9	3364 ELEMCON *refer;
alpar@9	3365 /* evaluated reference to elemental constraint */
alpar@9	3366 };
alpar@9	3367
alpar@9	3368 static void eval_con_func(MPL mpl, void _info)
alpar@9	3369 { /* this is auxiliary routine to work within domain scope */
alpar@9	3370 struct eval_con_info *info = _info;
alpar@9	3371 info->refer = take_member_con(mpl, info->con, info->tuple);
alpar@9	3372 return;
alpar@9	3373 }
alpar@9	3374
alpar@9	3375 ELEMCON eval_member_con / returns reference */
alpar@9	3376 ( MPL *mpl,
alpar@9	3377 CONSTRAINT con, / not changed */
alpar@9	3378 TUPLE tuple / not changed */
alpar@9	3379 )
alpar@9	3380 { /* this routine evaluates constraint member */
alpar@9	3381 struct eval_con_info _info, *info = &_info;
alpar@9	3382 xassert(con->dim == tuple_dimen(mpl, tuple));
alpar@9	3383 info->con = con;
alpar@9	3384 info->tuple = tuple;
alpar@9	3385 /* evaluate member, which has given n-tuple */
alpar@9	3386 if (eval_within_domain(mpl, info->con->domain, info->tuple, info,
alpar@9	3387 eval_con_func))
alpar@9	3388 out_of_domain(mpl, con->name, info->tuple);
alpar@9	3389 /* bring evaluated reference to the calling program */
alpar@9	3390 return info->refer;
alpar@9	3391 }
alpar@9	3392
alpar@9	3393 /*----------------------------------------------------------------------
alpar@9	3394 -- eval_whole_con - evaluate model constraint over entire domain.
alpar@9	3395 --
alpar@9	3396 -- This routine evaluates all members of specified model constraint over
alpar@9	3397 -- entire domain. */
alpar@9	3398
alpar@9	3399 static int whole_con_func(MPL mpl, void info)
alpar@9	3400 { /* this is auxiliary routine to work within domain scope */
alpar@9	3401 CONSTRAINT con = (CONSTRAINT )info;
alpar@9	3402 TUPLE *tuple = get_domain_tuple(mpl, con->domain);
alpar@9	3403 eval_member_con(mpl, con, tuple);
alpar@9	3404 delete_tuple(mpl, tuple);
alpar@9	3405 return 0;
alpar@9	3406 }
alpar@9	3407
alpar@9	3408 void eval_whole_con(MPL mpl, CONSTRAINT con)
alpar@9	3409 { loop_within_domain(mpl, con->domain, con, whole_con_func);
alpar@9	3410 return;
alpar@9	3411 }
alpar@9	3412
alpar@9	3413 /*----------------------------------------------------------------------
alpar@9	3414 -- clean_constraint - clean model constraint.
alpar@9	3415 --
alpar@9	3416 -- This routine cleans specified model constraint that assumes deleting
alpar@9	3417 -- all stuff dynamically allocated during the generation phase. */
alpar@9	3418
alpar@9	3419 void clean_constraint(MPL mpl, CONSTRAINT con)
alpar@9	3420 { MEMBER *memb;
alpar@9	3421 /* clean subscript domain */
alpar@9	3422 clean_domain(mpl, con->domain);
alpar@9	3423 /* clean code for computing main linear form */
alpar@9	3424 clean_code(mpl, con->code);
alpar@9	3425 /* clean code for computing lower bound */
alpar@9	3426 clean_code(mpl, con->lbnd);
alpar@9	3427 /* clean code for computing upper bound */
alpar@9	3428 if (con->ubnd != con->lbnd) clean_code(mpl, con->ubnd);
alpar@9	3429 /* delete content array */
alpar@9	3430 for (memb = con->array->head; memb != NULL; memb = memb->next)
alpar@9	3431 { delete_formula(mpl, memb->value.con->form);
alpar@9	3432 dmp_free_atom(mpl->elemcons, memb->value.con, sizeof(ELEMCON));
alpar@9	3433 }
alpar@9	3434 delete_array(mpl, con->array), con->array = NULL;
alpar@9	3435 return;
alpar@9	3436 }
alpar@9	3437
alpar@9	3438 /**********************************************************************/
alpar@9	3439 /* * * PSEUDO-CODE * * */
alpar@9	3440 /**********************************************************************/
alpar@9	3441
alpar@9	3442 /*----------------------------------------------------------------------
alpar@9	3443 -- eval_numeric - evaluate pseudo-code to determine numeric value.
alpar@9	3444 --
alpar@9	3445 -- This routine evaluates specified pseudo-code to determine resultant
alpar@9	3446 -- numeric value, which is returned on exit. */
alpar@9	3447
alpar@9	3448 struct iter_num_info
alpar@9	3449 { /* working info used by the routine iter_num_func */
alpar@9	3450 CODE *code;
alpar@9	3451 /* pseudo-code for iterated operation to be performed */
alpar@9	3452 double value;
alpar@9	3453 /* resultant value */
alpar@9	3454 };
alpar@9	3455
alpar@9	3456 static int iter_num_func(MPL mpl, void _info)
alpar@9	3457 { /* this is auxiliary routine used to perform iterated operation
alpar@9	3458 on numeric "integrand" within domain scope */
alpar@9	3459 struct iter_num_info *info = _info;
alpar@9	3460 double temp;
alpar@9	3461 temp = eval_numeric(mpl, info->code->arg.loop.x);
alpar@9	3462 switch (info->code->op)
alpar@9	3463 { case O_SUM:
alpar@9	3464 /* summation over domain */
alpar@9	3465 info->value = fp_add(mpl, info->value, temp);
alpar@9	3466 break;
alpar@9	3467 case O_PROD:
alpar@9	3468 /* multiplication over domain */
alpar@9	3469 info->value = fp_mul(mpl, info->value, temp);
alpar@9	3470 break;
alpar@9	3471 case O_MINIMUM:
alpar@9	3472 /* minimum over domain */
alpar@9	3473 if (info->value > temp) info->value = temp;
alpar@9	3474 break;
alpar@9	3475 case O_MAXIMUM:
alpar@9	3476 /* maximum over domain */
alpar@9	3477 if (info->value < temp) info->value = temp;
alpar@9	3478 break;
alpar@9	3479 default:
alpar@9	3480 xassert(info != info);
alpar@9	3481 }
alpar@9	3482 return 0;
alpar@9	3483 }
alpar@9	3484
alpar@9	3485 double eval_numeric(MPL mpl, CODE code)
alpar@9	3486 { double value;
alpar@9	3487 xassert(code != NULL);
alpar@9	3488 xassert(code->type == A_NUMERIC);
alpar@9	3489 xassert(code->dim == 0);
alpar@9	3490 /* if the operation has a side effect, invalidate and delete the
alpar@9	3491 resultant value */
alpar@9	3492 if (code->vflag && code->valid)
alpar@9	3493 { code->valid = 0;
alpar@9	3494 delete_value(mpl, code->type, &code->value);
alpar@9	3495 }
alpar@9	3496 /* if resultant value is valid, no evaluation is needed */
alpar@9	3497 if (code->valid)
alpar@9	3498 { value = code->value.num;
alpar@9	3499 goto done;
alpar@9	3500 }
alpar@9	3501 /* evaluate pseudo-code recursively */
alpar@9	3502 switch (code->op)
alpar@9	3503 { case O_NUMBER:
alpar@9	3504 /* take floating-point number */
alpar@9	3505 value = code->arg.num;
alpar@9	3506 break;
alpar@9	3507 case O_MEMNUM:
alpar@9	3508 /* take member of numeric parameter */
alpar@9	3509 { TUPLE *tuple;
alpar@9	3510 ARG_LIST *e;
alpar@9	3511 tuple = create_tuple(mpl);
alpar@9	3512 for (e = code->arg.par.list; e != NULL; e = e->next)
alpar@9	3513 tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
alpar@9	3514 e->x));
alpar@9	3515 value = eval_member_num(mpl, code->arg.par.par, tuple);
alpar@9	3516 delete_tuple(mpl, tuple);
alpar@9	3517 }
alpar@9	3518 break;
alpar@9	3519 case O_MEMVAR:
alpar@9	3520 /* take computed value of elemental variable */
alpar@9	3521 { TUPLE *tuple;
alpar@9	3522 ARG_LIST *e;
alpar@9	3523 #if 1 /* 15/V-2010 */
alpar@9	3524 ELEMVAR *var;
alpar@9	3525 #endif
alpar@9	3526 tuple = create_tuple(mpl);
alpar@9	3527 for (e = code->arg.var.list; e != NULL; e = e->next)
alpar@9	3528 tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
alpar@9	3529 e->x));
alpar@9	3530 #if 0 /* 15/V-2010 */
alpar@9	3531 value = eval_member_var(mpl, code->arg.var.var, tuple)
alpar@9	3532 ->value;
alpar@9	3533 #else
alpar@9	3534 var = eval_member_var(mpl, code->arg.var.var, tuple);
alpar@9	3535 switch (code->arg.var.suff)
alpar@9	3536 { case DOT_LB:
alpar@9	3537 if (var->var->lbnd == NULL)
alpar@9	3538 value = -DBL_MAX;
alpar@9	3539 else
alpar@9	3540 value = var->lbnd;
alpar@9	3541 break;
alpar@9	3542 case DOT_UB:
alpar@9	3543 if (var->var->ubnd == NULL)
alpar@9	3544 value = +DBL_MAX;
alpar@9	3545 else
alpar@9	3546 value = var->ubnd;
alpar@9	3547 break;
alpar@9	3548 case DOT_STATUS:
alpar@9	3549 value = var->stat;
alpar@9	3550 break;
alpar@9	3551 case DOT_VAL:
alpar@9	3552 value = var->prim;
alpar@9	3553 break;
alpar@9	3554 case DOT_DUAL:
alpar@9	3555 value = var->dual;
alpar@9	3556 break;
alpar@9	3557 default:
alpar@9	3558 xassert(code != code);
alpar@9	3559 }
alpar@9	3560 #endif
alpar@9	3561 delete_tuple(mpl, tuple);
alpar@9	3562 }
alpar@9	3563 break;
alpar@9	3564 #if 1 /* 15/V-2010 */
alpar@9	3565 case O_MEMCON:
alpar@9	3566 /* take computed value of elemental constraint */
alpar@9	3567 { TUPLE *tuple;
alpar@9	3568 ARG_LIST *e;
alpar@9	3569 ELEMCON *con;
alpar@9	3570 tuple = create_tuple(mpl);
alpar@9	3571 for (e = code->arg.con.list; e != NULL; e = e->next)
alpar@9	3572 tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
alpar@9	3573 e->x));
alpar@9	3574 con = eval_member_con(mpl, code->arg.con.con, tuple);
alpar@9	3575 switch (code->arg.con.suff)
alpar@9	3576 { case DOT_LB:
alpar@9	3577 if (con->con->lbnd == NULL)
alpar@9	3578 value = -DBL_MAX;
alpar@9	3579 else
alpar@9	3580 value = con->lbnd;
alpar@9	3581 break;
alpar@9	3582 case DOT_UB:
alpar@9	3583 if (con->con->ubnd == NULL)
alpar@9	3584 value = +DBL_MAX;
alpar@9	3585 else
alpar@9	3586 value = con->ubnd;
alpar@9	3587 break;
alpar@9	3588 case DOT_STATUS:
alpar@9	3589 value = con->stat;
alpar@9	3590 break;
alpar@9	3591 case DOT_VAL:
alpar@9	3592 value = con->prim;
alpar@9	3593 break;
alpar@9	3594 case DOT_DUAL:
alpar@9	3595 value = con->dual;
alpar@9	3596 break;
alpar@9	3597 default:
alpar@9	3598 xassert(code != code);
alpar@9	3599 }
alpar@9	3600 delete_tuple(mpl, tuple);
alpar@9	3601 }
alpar@9	3602 break;
alpar@9	3603 #endif
alpar@9	3604 case O_IRAND224:
alpar@9	3605 /* pseudo-random in [0, 2^24-1] */
alpar@9	3606 value = fp_irand224(mpl);
alpar@9	3607 break;
alpar@9	3608 case O_UNIFORM01:
alpar@9	3609 /* pseudo-random in [0, 1) */
alpar@9	3610 value = fp_uniform01(mpl);
alpar@9	3611 break;
alpar@9	3612 case O_NORMAL01:
alpar@9	3613 /* gaussian random, mu = 0, sigma = 1 */
alpar@9	3614 value = fp_normal01(mpl);
alpar@9	3615 break;
alpar@9	3616 case O_GMTIME:
alpar@9	3617 /* current calendar time */
alpar@9	3618 value = fn_gmtime(mpl);
alpar@9	3619 break;
alpar@9	3620 case O_CVTNUM:
alpar@9	3621 /* conversion to numeric */
alpar@9	3622 { SYMBOL *sym;
alpar@9	3623 sym = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	3624 #if 0 /* 23/XI-2008 */
alpar@9	3625 if (sym->str != NULL)
alpar@9	3626 error(mpl, "cannot convert %s to floating-point numbe"
alpar@9	3627 "r", format_symbol(mpl, sym));
alpar@9	3628 value = sym->num;
alpar@9	3629 #else
alpar@9	3630 if (sym->str == NULL)
alpar@9	3631 value = sym->num;
alpar@9	3632 else
alpar@9	3633 { if (str2num(sym->str, &value))
alpar@9	3634 error(mpl, "cannot convert %s to floating-point nu"
alpar@9	3635 "mber", format_symbol(mpl, sym));
alpar@9	3636 }
alpar@9	3637 #endif
alpar@9	3638 delete_symbol(mpl, sym);
alpar@9	3639 }
alpar@9	3640 break;
alpar@9	3641 case O_PLUS:
alpar@9	3642 /* unary plus */
alpar@9	3643 value = + eval_numeric(mpl, code->arg.arg.x);
alpar@9	3644 break;
alpar@9	3645 case O_MINUS:
alpar@9	3646 /* unary minus */
alpar@9	3647 value = - eval_numeric(mpl, code->arg.arg.x);
alpar@9	3648 break;
alpar@9	3649 case O_ABS:
alpar@9	3650 /* absolute value */
alpar@9	3651 value = fabs(eval_numeric(mpl, code->arg.arg.x));
alpar@9	3652 break;
alpar@9	3653 case O_CEIL:
alpar@9	3654 /* round upward ("ceiling of x") */
alpar@9	3655 value = ceil(eval_numeric(mpl, code->arg.arg.x));
alpar@9	3656 break;
alpar@9	3657 case O_FLOOR:
alpar@9	3658 /* round downward ("floor of x") */
alpar@9	3659 value = floor(eval_numeric(mpl, code->arg.arg.x));
alpar@9	3660 break;
alpar@9	3661 case O_EXP:
alpar@9	3662 /* base-e exponential */
alpar@9	3663 value = fp_exp(mpl, eval_numeric(mpl, code->arg.arg.x));
alpar@9	3664 break;
alpar@9	3665 case O_LOG:
alpar@9	3666 /* natural logarithm */
alpar@9	3667 value = fp_log(mpl, eval_numeric(mpl, code->arg.arg.x));
alpar@9	3668 break;
alpar@9	3669 case O_LOG10:
alpar@9	3670 /* common (decimal) logarithm */
alpar@9	3671 value = fp_log10(mpl, eval_numeric(mpl, code->arg.arg.x));
alpar@9	3672 break;
alpar@9	3673 case O_SQRT:
alpar@9	3674 /* square root */
alpar@9	3675 value = fp_sqrt(mpl, eval_numeric(mpl, code->arg.arg.x));
alpar@9	3676 break;
alpar@9	3677 case O_SIN:
alpar@9	3678 /* trigonometric sine */
alpar@9	3679 value = fp_sin(mpl, eval_numeric(mpl, code->arg.arg.x));
alpar@9	3680 break;
alpar@9	3681 case O_COS:
alpar@9	3682 /* trigonometric cosine */
alpar@9	3683 value = fp_cos(mpl, eval_numeric(mpl, code->arg.arg.x));
alpar@9	3684 break;
alpar@9	3685 case O_ATAN:
alpar@9	3686 /* trigonometric arctangent (one argument) */
alpar@9	3687 value = fp_atan(mpl, eval_numeric(mpl, code->arg.arg.x));
alpar@9	3688 break;
alpar@9	3689 case O_ATAN2:
alpar@9	3690 /* trigonometric arctangent (two arguments) */
alpar@9	3691 value = fp_atan2(mpl,
alpar@9	3692 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3693 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3694 break;
alpar@9	3695 case O_ROUND:
alpar@9	3696 /* round to nearest integer */
alpar@9	3697 value = fp_round(mpl,
alpar@9	3698 eval_numeric(mpl, code->arg.arg.x), 0.0);
alpar@9	3699 break;
alpar@9	3700 case O_ROUND2:
alpar@9	3701 /* round to n fractional digits */
alpar@9	3702 value = fp_round(mpl,
alpar@9	3703 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3704 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3705 break;
alpar@9	3706 case O_TRUNC:
alpar@9	3707 /* truncate to nearest integer */
alpar@9	3708 value = fp_trunc(mpl,
alpar@9	3709 eval_numeric(mpl, code->arg.arg.x), 0.0);
alpar@9	3710 break;
alpar@9	3711 case O_TRUNC2:
alpar@9	3712 /* truncate to n fractional digits */
alpar@9	3713 value = fp_trunc(mpl,
alpar@9	3714 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3715 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3716 break;
alpar@9	3717 case O_ADD:
alpar@9	3718 /* addition */
alpar@9	3719 value = fp_add(mpl,
alpar@9	3720 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3721 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3722 break;
alpar@9	3723 case O_SUB:
alpar@9	3724 /* subtraction */
alpar@9	3725 value = fp_sub(mpl,
alpar@9	3726 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3727 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3728 break;
alpar@9	3729 case O_LESS:
alpar@9	3730 /* non-negative subtraction */
alpar@9	3731 value = fp_less(mpl,
alpar@9	3732 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3733 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3734 break;
alpar@9	3735 case O_MUL:
alpar@9	3736 /* multiplication */
alpar@9	3737 value = fp_mul(mpl,
alpar@9	3738 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3739 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3740 break;
alpar@9	3741 case O_DIV:
alpar@9	3742 /* division */
alpar@9	3743 value = fp_div(mpl,
alpar@9	3744 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3745 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3746 break;
alpar@9	3747 case O_IDIV:
alpar@9	3748 /* quotient of exact division */
alpar@9	3749 value = fp_idiv(mpl,
alpar@9	3750 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3751 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3752 break;
alpar@9	3753 case O_MOD:
alpar@9	3754 /* remainder of exact division */
alpar@9	3755 value = fp_mod(mpl,
alpar@9	3756 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3757 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3758 break;
alpar@9	3759 case O_POWER:
alpar@9	3760 /* exponentiation (raise to power) */
alpar@9	3761 value = fp_power(mpl,
alpar@9	3762 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3763 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3764 break;
alpar@9	3765 case O_UNIFORM:
alpar@9	3766 /* pseudo-random in [a, b) */
alpar@9	3767 value = fp_uniform(mpl,
alpar@9	3768 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3769 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3770 break;
alpar@9	3771 case O_NORMAL:
alpar@9	3772 /* gaussian random, given mu and sigma */
alpar@9	3773 value = fp_normal(mpl,
alpar@9	3774 eval_numeric(mpl, code->arg.arg.x),
alpar@9	3775 eval_numeric(mpl, code->arg.arg.y));
alpar@9	3776 break;
alpar@9	3777 case O_CARD:
alpar@9	3778 { ELEMSET *set;
alpar@9	3779 set = eval_elemset(mpl, code->arg.arg.x);
alpar@9	3780 value = set->size;
alpar@9	3781 delete_array(mpl, set);
alpar@9	3782 }
alpar@9	3783 break;
alpar@9	3784 case O_LENGTH:
alpar@9	3785 { SYMBOL *sym;
alpar@9	3786 char str[MAX_LENGTH+1];
alpar@9	3787 sym = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	3788 if (sym->str == NULL)
alpar@9	3789 sprintf(str, "%.*g", DBL_DIG, sym->num);
alpar@9	3790 else
alpar@9	3791 fetch_string(mpl, sym->str, str);
alpar@9	3792 delete_symbol(mpl, sym);
alpar@9	3793 value = strlen(str);
alpar@9	3794 }
alpar@9	3795 break;
alpar@9	3796 case O_STR2TIME:
alpar@9	3797 { SYMBOL *sym;
alpar@9	3798 char str[MAX_LENGTH+1], fmt[MAX_LENGTH+1];
alpar@9	3799 sym = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	3800 if (sym->str == NULL)
alpar@9	3801 sprintf(str, "%.*g", DBL_DIG, sym->num);
alpar@9	3802 else
alpar@9	3803 fetch_string(mpl, sym->str, str);
alpar@9	3804 delete_symbol(mpl, sym);
alpar@9	3805 sym = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	3806 if (sym->str == NULL)
alpar@9	3807 sprintf(fmt, "%.*g", DBL_DIG, sym->num);
alpar@9	3808 else
alpar@9	3809 fetch_string(mpl, sym->str, fmt);
alpar@9	3810 delete_symbol(mpl, sym);
alpar@9	3811 value = fn_str2time(mpl, str, fmt);
alpar@9	3812 }
alpar@9	3813 break;
alpar@9	3814 case O_FORK:
alpar@9	3815 /* if-then-else */
alpar@9	3816 if (eval_logical(mpl, code->arg.arg.x))
alpar@9	3817 value = eval_numeric(mpl, code->arg.arg.y);
alpar@9	3818 else if (code->arg.arg.z == NULL)
alpar@9	3819 value = 0.0;
alpar@9	3820 else
alpar@9	3821 value = eval_numeric(mpl, code->arg.arg.z);
alpar@9	3822 break;
alpar@9	3823 case O_MIN:
alpar@9	3824 /* minimal value (n-ary) */
alpar@9	3825 { ARG_LIST *e;
alpar@9	3826 double temp;
alpar@9	3827 value = +DBL_MAX;
alpar@9	3828 for (e = code->arg.list; e != NULL; e = e->next)
alpar@9	3829 { temp = eval_numeric(mpl, e->x);
alpar@9	3830 if (value > temp) value = temp;
alpar@9	3831 }
alpar@9	3832 }
alpar@9	3833 break;
alpar@9	3834 case O_MAX:
alpar@9	3835 /* maximal value (n-ary) */
alpar@9	3836 { ARG_LIST *e;
alpar@9	3837 double temp;
alpar@9	3838 value = -DBL_MAX;
alpar@9	3839 for (e = code->arg.list; e != NULL; e = e->next)
alpar@9	3840 { temp = eval_numeric(mpl, e->x);
alpar@9	3841 if (value < temp) value = temp;
alpar@9	3842 }
alpar@9	3843 }
alpar@9	3844 break;
alpar@9	3845 case O_SUM:
alpar@9	3846 /* summation over domain */
alpar@9	3847 { struct iter_num_info _info, *info = &_info;
alpar@9	3848 info->code = code;
alpar@9	3849 info->value = 0.0;
alpar@9	3850 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	3851 iter_num_func);
alpar@9	3852 value = info->value;
alpar@9	3853 }
alpar@9	3854 break;
alpar@9	3855 case O_PROD:
alpar@9	3856 /* multiplication over domain */
alpar@9	3857 { struct iter_num_info _info, *info = &_info;
alpar@9	3858 info->code = code;
alpar@9	3859 info->value = 1.0;
alpar@9	3860 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	3861 iter_num_func);
alpar@9	3862 value = info->value;
alpar@9	3863 }
alpar@9	3864 break;
alpar@9	3865 case O_MINIMUM:
alpar@9	3866 /* minimum over domain */
alpar@9	3867 { struct iter_num_info _info, *info = &_info;
alpar@9	3868 info->code = code;
alpar@9	3869 info->value = +DBL_MAX;
alpar@9	3870 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	3871 iter_num_func);
alpar@9	3872 if (info->value == +DBL_MAX)
alpar@9	3873 error(mpl, "min{} over empty set; result undefined");
alpar@9	3874 value = info->value;
alpar@9	3875 }
alpar@9	3876 break;
alpar@9	3877 case O_MAXIMUM:
alpar@9	3878 /* maximum over domain */
alpar@9	3879 { struct iter_num_info _info, *info = &_info;
alpar@9	3880 info->code = code;
alpar@9	3881 info->value = -DBL_MAX;
alpar@9	3882 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	3883 iter_num_func);
alpar@9	3884 if (info->value == -DBL_MAX)
alpar@9	3885 error(mpl, "max{} over empty set; result undefined");
alpar@9	3886 value = info->value;
alpar@9	3887 }
alpar@9	3888 break;
alpar@9	3889 default:
alpar@9	3890 xassert(code != code);
alpar@9	3891 }
alpar@9	3892 /* save resultant value */
alpar@9	3893 xassert(!code->valid);
alpar@9	3894 code->valid = 1;
alpar@9	3895 code->value.num = value;
alpar@9	3896 done: return value;
alpar@9	3897 }
alpar@9	3898
alpar@9	3899 /*----------------------------------------------------------------------
alpar@9	3900 -- eval_symbolic - evaluate pseudo-code to determine symbolic value.
alpar@9	3901 --
alpar@9	3902 -- This routine evaluates specified pseudo-code to determine resultant
alpar@9	3903 -- symbolic value, which is returned on exit. */
alpar@9	3904
alpar@9	3905 SYMBOL eval_symbolic(MPL mpl, CODE *code)
alpar@9	3906 { SYMBOL *value;
alpar@9	3907 xassert(code != NULL);
alpar@9	3908 xassert(code->type == A_SYMBOLIC);
alpar@9	3909 xassert(code->dim == 0);
alpar@9	3910 /* if the operation has a side effect, invalidate and delete the
alpar@9	3911 resultant value */
alpar@9	3912 if (code->vflag && code->valid)
alpar@9	3913 { code->valid = 0;
alpar@9	3914 delete_value(mpl, code->type, &code->value);
alpar@9	3915 }
alpar@9	3916 /* if resultant value is valid, no evaluation is needed */
alpar@9	3917 if (code->valid)
alpar@9	3918 { value = copy_symbol(mpl, code->value.sym);
alpar@9	3919 goto done;
alpar@9	3920 }
alpar@9	3921 /* evaluate pseudo-code recursively */
alpar@9	3922 switch (code->op)
alpar@9	3923 { case O_STRING:
alpar@9	3924 /* take character string */
alpar@9	3925 value = create_symbol_str(mpl, create_string(mpl,
alpar@9	3926 code->arg.str));
alpar@9	3927 break;
alpar@9	3928 case O_INDEX:
alpar@9	3929 /* take dummy index */
alpar@9	3930 xassert(code->arg.index.slot->value != NULL);
alpar@9	3931 value = copy_symbol(mpl, code->arg.index.slot->value);
alpar@9	3932 break;
alpar@9	3933 case O_MEMSYM:
alpar@9	3934 /* take member of symbolic parameter */
alpar@9	3935 { TUPLE *tuple;
alpar@9	3936 ARG_LIST *e;
alpar@9	3937 tuple = create_tuple(mpl);
alpar@9	3938 for (e = code->arg.par.list; e != NULL; e = e->next)
alpar@9	3939 tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
alpar@9	3940 e->x));
alpar@9	3941 value = eval_member_sym(mpl, code->arg.par.par, tuple);
alpar@9	3942 delete_tuple(mpl, tuple);
alpar@9	3943 }
alpar@9	3944 break;
alpar@9	3945 case O_CVTSYM:
alpar@9	3946 /* conversion to symbolic */
alpar@9	3947 value = create_symbol_num(mpl, eval_numeric(mpl,
alpar@9	3948 code->arg.arg.x));
alpar@9	3949 break;
alpar@9	3950 case O_CONCAT:
alpar@9	3951 /* concatenation */
alpar@9	3952 value = concat_symbols(mpl,
alpar@9	3953 eval_symbolic(mpl, code->arg.arg.x),
alpar@9	3954 eval_symbolic(mpl, code->arg.arg.y));
alpar@9	3955 break;
alpar@9	3956 case O_FORK:
alpar@9	3957 /* if-then-else */
alpar@9	3958 if (eval_logical(mpl, code->arg.arg.x))
alpar@9	3959 value = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	3960 else if (code->arg.arg.z == NULL)
alpar@9	3961 value = create_symbol_num(mpl, 0.0);
alpar@9	3962 else
alpar@9	3963 value = eval_symbolic(mpl, code->arg.arg.z);
alpar@9	3964 break;
alpar@9	3965 case O_SUBSTR:
alpar@9	3966 case O_SUBSTR3:
alpar@9	3967 { double pos, len;
alpar@9	3968 char str[MAX_LENGTH+1];
alpar@9	3969 value = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	3970 if (value->str == NULL)
alpar@9	3971 sprintf(str, "%.*g", DBL_DIG, value->num);
alpar@9	3972 else
alpar@9	3973 fetch_string(mpl, value->str, str);
alpar@9	3974 delete_symbol(mpl, value);
alpar@9	3975 if (code->op == O_SUBSTR)
alpar@9	3976 { pos = eval_numeric(mpl, code->arg.arg.y);
alpar@9	3977 if (pos != floor(pos))
alpar@9	3978 error(mpl, "substr('...', %.*g); non-integer secon"
alpar@9	3979 "d argument", DBL_DIG, pos);
alpar@9	3980 if (pos < 1 \|\| pos > strlen(str) + 1)
alpar@9	3981 error(mpl, "substr('...', %.*g); substring out of "
alpar@9	3982 "range", DBL_DIG, pos);
alpar@9	3983 }
alpar@9	3984 else
alpar@9	3985 { pos = eval_numeric(mpl, code->arg.arg.y);
alpar@9	3986 len = eval_numeric(mpl, code->arg.arg.z);
alpar@9	3987 if (pos != floor(pos) \|\| len != floor(len))
alpar@9	3988 error(mpl, "substr('...', %.g, %.g); non-integer"
alpar@9	3989 " second and/or third argument", DBL_DIG, pos,
alpar@9	3990 DBL_DIG, len);
alpar@9	3991 if (pos < 1 \|\| len < 0 \|\| pos + len > strlen(str) + 1)
alpar@9	3992 error(mpl, "substr('...', %.g, %.g); substring o"
alpar@9	3993 "ut of range", DBL_DIG, pos, DBL_DIG, len);
alpar@9	3994 str[(int)pos + (int)len - 1] = '\0';
alpar@9	3995 }
alpar@9	3996 value = create_symbol_str(mpl, create_string(mpl, str +
alpar@9	3997 (int)pos - 1));
alpar@9	3998 }
alpar@9	3999 break;
alpar@9	4000 case O_TIME2STR:
alpar@9	4001 { double num;
alpar@9	4002 SYMBOL *sym;
alpar@9	4003 char str[MAX_LENGTH+1], fmt[MAX_LENGTH+1];
alpar@9	4004 num = eval_numeric(mpl, code->arg.arg.x);
alpar@9	4005 sym = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	4006 if (sym->str == NULL)
alpar@9	4007 sprintf(fmt, "%.*g", DBL_DIG, sym->num);
alpar@9	4008 else
alpar@9	4009 fetch_string(mpl, sym->str, fmt);
alpar@9	4010 delete_symbol(mpl, sym);
alpar@9	4011 fn_time2str(mpl, str, num, fmt);
alpar@9	4012 value = create_symbol_str(mpl, create_string(mpl, str));
alpar@9	4013 }
alpar@9	4014 break;
alpar@9	4015 default:
alpar@9	4016 xassert(code != code);
alpar@9	4017 }
alpar@9	4018 /* save resultant value */
alpar@9	4019 xassert(!code->valid);
alpar@9	4020 code->valid = 1;
alpar@9	4021 code->value.sym = copy_symbol(mpl, value);
alpar@9	4022 done: return value;
alpar@9	4023 }
alpar@9	4024
alpar@9	4025 /*----------------------------------------------------------------------
alpar@9	4026 -- eval_logical - evaluate pseudo-code to determine logical value.
alpar@9	4027 --
alpar@9	4028 -- This routine evaluates specified pseudo-code to determine resultant
alpar@9	4029 -- logical value, which is returned on exit. */
alpar@9	4030
alpar@9	4031 struct iter_log_info
alpar@9	4032 { /* working info used by the routine iter_log_func */
alpar@9	4033 CODE *code;
alpar@9	4034 /* pseudo-code for iterated operation to be performed */
alpar@9	4035 int value;
alpar@9	4036 /* resultant value */
alpar@9	4037 };
alpar@9	4038
alpar@9	4039 static int iter_log_func(MPL mpl, void _info)
alpar@9	4040 { /* this is auxiliary routine used to perform iterated operation
alpar@9	4041 on logical "integrand" within domain scope */
alpar@9	4042 struct iter_log_info *info = _info;
alpar@9	4043 int ret = 0;
alpar@9	4044 switch (info->code->op)
alpar@9	4045 { case O_FORALL:
alpar@9	4046 /* conjunction over domain */
alpar@9	4047 info->value &= eval_logical(mpl, info->code->arg.loop.x);
alpar@9	4048 if (!info->value) ret = 1;
alpar@9	4049 break;
alpar@9	4050 case O_EXISTS:
alpar@9	4051 /* disjunction over domain */
alpar@9	4052 info->value \|= eval_logical(mpl, info->code->arg.loop.x);
alpar@9	4053 if (info->value) ret = 1;
alpar@9	4054 break;
alpar@9	4055 default:
alpar@9	4056 xassert(info != info);
alpar@9	4057 }
alpar@9	4058 return ret;
alpar@9	4059 }
alpar@9	4060
alpar@9	4061 int eval_logical(MPL mpl, CODE code)
alpar@9	4062 { int value;
alpar@9	4063 xassert(code->type == A_LOGICAL);
alpar@9	4064 xassert(code->dim == 0);
alpar@9	4065 /* if the operation has a side effect, invalidate and delete the
alpar@9	4066 resultant value */
alpar@9	4067 if (code->vflag && code->valid)
alpar@9	4068 { code->valid = 0;
alpar@9	4069 delete_value(mpl, code->type, &code->value);
alpar@9	4070 }
alpar@9	4071 /* if resultant value is valid, no evaluation is needed */
alpar@9	4072 if (code->valid)
alpar@9	4073 { value = code->value.bit;
alpar@9	4074 goto done;
alpar@9	4075 }
alpar@9	4076 /* evaluate pseudo-code recursively */
alpar@9	4077 switch (code->op)
alpar@9	4078 { case O_CVTLOG:
alpar@9	4079 /* conversion to logical */
alpar@9	4080 value = (eval_numeric(mpl, code->arg.arg.x) != 0.0);
alpar@9	4081 break;
alpar@9	4082 case O_NOT:
alpar@9	4083 /* negation (logical "not") */
alpar@9	4084 value = !eval_logical(mpl, code->arg.arg.x);
alpar@9	4085 break;
alpar@9	4086 case O_LT:
alpar@9	4087 /* comparison on 'less than' */
alpar@9	4088 #if 0 /* 02/VIII-2008 */
alpar@9	4089 value = (eval_numeric(mpl, code->arg.arg.x) <
alpar@9	4090 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4091 #else
alpar@9	4092 xassert(code->arg.arg.x != NULL);
alpar@9	4093 if (code->arg.arg.x->type == A_NUMERIC)
alpar@9	4094 value = (eval_numeric(mpl, code->arg.arg.x) <
alpar@9	4095 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4096 else
alpar@9	4097 { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	4098 SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	4099 value = (compare_symbols(mpl, sym1, sym2) < 0);
alpar@9	4100 delete_symbol(mpl, sym1);
alpar@9	4101 delete_symbol(mpl, sym2);
alpar@9	4102 }
alpar@9	4103 #endif
alpar@9	4104 break;
alpar@9	4105 case O_LE:
alpar@9	4106 /* comparison on 'not greater than' */
alpar@9	4107 #if 0 /* 02/VIII-2008 */
alpar@9	4108 value = (eval_numeric(mpl, code->arg.arg.x) <=
alpar@9	4109 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4110 #else
alpar@9	4111 xassert(code->arg.arg.x != NULL);
alpar@9	4112 if (code->arg.arg.x->type == A_NUMERIC)
alpar@9	4113 value = (eval_numeric(mpl, code->arg.arg.x) <=
alpar@9	4114 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4115 else
alpar@9	4116 { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	4117 SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	4118 value = (compare_symbols(mpl, sym1, sym2) <= 0);
alpar@9	4119 delete_symbol(mpl, sym1);
alpar@9	4120 delete_symbol(mpl, sym2);
alpar@9	4121 }
alpar@9	4122 #endif
alpar@9	4123 break;
alpar@9	4124 case O_EQ:
alpar@9	4125 /* comparison on 'equal to' */
alpar@9	4126 xassert(code->arg.arg.x != NULL);
alpar@9	4127 if (code->arg.arg.x->type == A_NUMERIC)
alpar@9	4128 value = (eval_numeric(mpl, code->arg.arg.x) ==
alpar@9	4129 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4130 else
alpar@9	4131 { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	4132 SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	4133 value = (compare_symbols(mpl, sym1, sym2) == 0);
alpar@9	4134 delete_symbol(mpl, sym1);
alpar@9	4135 delete_symbol(mpl, sym2);
alpar@9	4136 }
alpar@9	4137 break;
alpar@9	4138 case O_GE:
alpar@9	4139 /* comparison on 'not less than' */
alpar@9	4140 #if 0 /* 02/VIII-2008 */
alpar@9	4141 value = (eval_numeric(mpl, code->arg.arg.x) >=
alpar@9	4142 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4143 #else
alpar@9	4144 xassert(code->arg.arg.x != NULL);
alpar@9	4145 if (code->arg.arg.x->type == A_NUMERIC)
alpar@9	4146 value = (eval_numeric(mpl, code->arg.arg.x) >=
alpar@9	4147 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4148 else
alpar@9	4149 { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	4150 SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	4151 value = (compare_symbols(mpl, sym1, sym2) >= 0);
alpar@9	4152 delete_symbol(mpl, sym1);
alpar@9	4153 delete_symbol(mpl, sym2);
alpar@9	4154 }
alpar@9	4155 #endif
alpar@9	4156 break;
alpar@9	4157 case O_GT:
alpar@9	4158 /* comparison on 'greater than' */
alpar@9	4159 #if 0 /* 02/VIII-2008 */
alpar@9	4160 value = (eval_numeric(mpl, code->arg.arg.x) >
alpar@9	4161 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4162 #else
alpar@9	4163 xassert(code->arg.arg.x != NULL);
alpar@9	4164 if (code->arg.arg.x->type == A_NUMERIC)
alpar@9	4165 value = (eval_numeric(mpl, code->arg.arg.x) >
alpar@9	4166 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4167 else
alpar@9	4168 { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	4169 SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	4170 value = (compare_symbols(mpl, sym1, sym2) > 0);
alpar@9	4171 delete_symbol(mpl, sym1);
alpar@9	4172 delete_symbol(mpl, sym2);
alpar@9	4173 }
alpar@9	4174 #endif
alpar@9	4175 break;
alpar@9	4176 case O_NE:
alpar@9	4177 /* comparison on 'not equal to' */
alpar@9	4178 xassert(code->arg.arg.x != NULL);
alpar@9	4179 if (code->arg.arg.x->type == A_NUMERIC)
alpar@9	4180 value = (eval_numeric(mpl, code->arg.arg.x) !=
alpar@9	4181 eval_numeric(mpl, code->arg.arg.y));
alpar@9	4182 else
alpar@9	4183 { SYMBOL *sym1 = eval_symbolic(mpl, code->arg.arg.x);
alpar@9	4184 SYMBOL *sym2 = eval_symbolic(mpl, code->arg.arg.y);
alpar@9	4185 value = (compare_symbols(mpl, sym1, sym2) != 0);
alpar@9	4186 delete_symbol(mpl, sym1);
alpar@9	4187 delete_symbol(mpl, sym2);
alpar@9	4188 }
alpar@9	4189 break;
alpar@9	4190 case O_AND:
alpar@9	4191 /* conjunction (logical "and") */
alpar@9	4192 value = eval_logical(mpl, code->arg.arg.x) &&
alpar@9	4193 eval_logical(mpl, code->arg.arg.y);
alpar@9	4194 break;
alpar@9	4195 case O_OR:
alpar@9	4196 /* disjunction (logical "or") */
alpar@9	4197 value = eval_logical(mpl, code->arg.arg.x) \|\|
alpar@9	4198 eval_logical(mpl, code->arg.arg.y);
alpar@9	4199 break;
alpar@9	4200 case O_IN:
alpar@9	4201 /* test on 'x in Y' */
alpar@9	4202 { TUPLE *tuple;
alpar@9	4203 tuple = eval_tuple(mpl, code->arg.arg.x);
alpar@9	4204 value = is_member(mpl, code->arg.arg.y, tuple);
alpar@9	4205 delete_tuple(mpl, tuple);
alpar@9	4206 }
alpar@9	4207 break;
alpar@9	4208 case O_NOTIN:
alpar@9	4209 /* test on 'x not in Y' */
alpar@9	4210 { TUPLE *tuple;
alpar@9	4211 tuple = eval_tuple(mpl, code->arg.arg.x);
alpar@9	4212 value = !is_member(mpl, code->arg.arg.y, tuple);
alpar@9	4213 delete_tuple(mpl, tuple);
alpar@9	4214 }
alpar@9	4215 break;
alpar@9	4216 case O_WITHIN:
alpar@9	4217 /* test on 'X within Y' */
alpar@9	4218 { ELEMSET *set;
alpar@9	4219 MEMBER *memb;
alpar@9	4220 set = eval_elemset(mpl, code->arg.arg.x);
alpar@9	4221 value = 1;
alpar@9	4222 for (memb = set->head; memb != NULL; memb = memb->next)
alpar@9	4223 { if (!is_member(mpl, code->arg.arg.y, memb->tuple))
alpar@9	4224 { value = 0;
alpar@9	4225 break;
alpar@9	4226 }
alpar@9	4227 }
alpar@9	4228 delete_elemset(mpl, set);
alpar@9	4229 }
alpar@9	4230 break;
alpar@9	4231 case O_NOTWITHIN:
alpar@9	4232 /* test on 'X not within Y' */
alpar@9	4233 { ELEMSET *set;
alpar@9	4234 MEMBER *memb;
alpar@9	4235 set = eval_elemset(mpl, code->arg.arg.x);
alpar@9	4236 value = 1;
alpar@9	4237 for (memb = set->head; memb != NULL; memb = memb->next)
alpar@9	4238 { if (is_member(mpl, code->arg.arg.y, memb->tuple))
alpar@9	4239 { value = 0;
alpar@9	4240 break;
alpar@9	4241 }
alpar@9	4242 }
alpar@9	4243 delete_elemset(mpl, set);
alpar@9	4244 }
alpar@9	4245 break;
alpar@9	4246 case O_FORALL:
alpar@9	4247 /* conjunction (A-quantification) */
alpar@9	4248 { struct iter_log_info _info, *info = &_info;
alpar@9	4249 info->code = code;
alpar@9	4250 info->value = 1;
alpar@9	4251 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	4252 iter_log_func);
alpar@9	4253 value = info->value;
alpar@9	4254 }
alpar@9	4255 break;
alpar@9	4256 case O_EXISTS:
alpar@9	4257 /* disjunction (E-quantification) */
alpar@9	4258 { struct iter_log_info _info, *info = &_info;
alpar@9	4259 info->code = code;
alpar@9	4260 info->value = 0;
alpar@9	4261 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	4262 iter_log_func);
alpar@9	4263 value = info->value;
alpar@9	4264 }
alpar@9	4265 break;
alpar@9	4266 default:
alpar@9	4267 xassert(code != code);
alpar@9	4268 }
alpar@9	4269 /* save resultant value */
alpar@9	4270 xassert(!code->valid);
alpar@9	4271 code->valid = 1;
alpar@9	4272 code->value.bit = value;
alpar@9	4273 done: return value;
alpar@9	4274 }
alpar@9	4275
alpar@9	4276 /*----------------------------------------------------------------------
alpar@9	4277 -- eval_tuple - evaluate pseudo-code to construct n-tuple.
alpar@9	4278 --
alpar@9	4279 -- This routine evaluates specified pseudo-code to construct resultant
alpar@9	4280 -- n-tuple, which is returned on exit. */
alpar@9	4281
alpar@9	4282 TUPLE eval_tuple(MPL mpl, CODE *code)
alpar@9	4283 { TUPLE *value;
alpar@9	4284 xassert(code != NULL);
alpar@9	4285 xassert(code->type == A_TUPLE);
alpar@9	4286 xassert(code->dim > 0);
alpar@9	4287 /* if the operation has a side effect, invalidate and delete the
alpar@9	4288 resultant value */
alpar@9	4289 if (code->vflag && code->valid)
alpar@9	4290 { code->valid = 0;
alpar@9	4291 delete_value(mpl, code->type, &code->value);
alpar@9	4292 }
alpar@9	4293 /* if resultant value is valid, no evaluation is needed */
alpar@9	4294 if (code->valid)
alpar@9	4295 { value = copy_tuple(mpl, code->value.tuple);
alpar@9	4296 goto done;
alpar@9	4297 }
alpar@9	4298 /* evaluate pseudo-code recursively */
alpar@9	4299 switch (code->op)
alpar@9	4300 { case O_TUPLE:
alpar@9	4301 /* make n-tuple */
alpar@9	4302 { ARG_LIST *e;
alpar@9	4303 value = create_tuple(mpl);
alpar@9	4304 for (e = code->arg.list; e != NULL; e = e->next)
alpar@9	4305 value = expand_tuple(mpl, value, eval_symbolic(mpl,
alpar@9	4306 e->x));
alpar@9	4307 }
alpar@9	4308 break;
alpar@9	4309 case O_CVTTUP:
alpar@9	4310 /* convert to 1-tuple */
alpar@9	4311 value = expand_tuple(mpl, create_tuple(mpl),
alpar@9	4312 eval_symbolic(mpl, code->arg.arg.x));
alpar@9	4313 break;
alpar@9	4314 default:
alpar@9	4315 xassert(code != code);
alpar@9	4316 }
alpar@9	4317 /* save resultant value */
alpar@9	4318 xassert(!code->valid);
alpar@9	4319 code->valid = 1;
alpar@9	4320 code->value.tuple = copy_tuple(mpl, value);
alpar@9	4321 done: return value;
alpar@9	4322 }
alpar@9	4323
alpar@9	4324 /*----------------------------------------------------------------------
alpar@9	4325 -- eval_elemset - evaluate pseudo-code to construct elemental set.
alpar@9	4326 --
alpar@9	4327 -- This routine evaluates specified pseudo-code to construct resultant
alpar@9	4328 -- elemental set, which is returned on exit. */
alpar@9	4329
alpar@9	4330 struct iter_set_info
alpar@9	4331 { /* working info used by the routine iter_set_func */
alpar@9	4332 CODE *code;
alpar@9	4333 /* pseudo-code for iterated operation to be performed */
alpar@9	4334 ELEMSET *value;
alpar@9	4335 /* resultant value */
alpar@9	4336 };
alpar@9	4337
alpar@9	4338 static int iter_set_func(MPL mpl, void _info)
alpar@9	4339 { /* this is auxiliary routine used to perform iterated operation
alpar@9	4340 on n-tuple "integrand" within domain scope */
alpar@9	4341 struct iter_set_info *info = _info;
alpar@9	4342 TUPLE *tuple;
alpar@9	4343 switch (info->code->op)
alpar@9	4344 { case O_SETOF:
alpar@9	4345 /* compute next n-tuple and add it to the set; in this case
alpar@9	4346 duplicate n-tuples are silently ignored */
alpar@9	4347 tuple = eval_tuple(mpl, info->code->arg.loop.x);
alpar@9	4348 if (find_tuple(mpl, info->value, tuple) == NULL)
alpar@9	4349 add_tuple(mpl, info->value, tuple);
alpar@9	4350 else
alpar@9	4351 delete_tuple(mpl, tuple);
alpar@9	4352 break;
alpar@9	4353 case O_BUILD:
alpar@9	4354 /* construct next n-tuple using current values assigned to
alpar@9	4355 free dummy indices as its components and add it to the
alpar@9	4356 set; in this case duplicate n-tuples cannot appear */
alpar@9	4357 add_tuple(mpl, info->value, get_domain_tuple(mpl,
alpar@9	4358 info->code->arg.loop.domain));
alpar@9	4359 break;
alpar@9	4360 default:
alpar@9	4361 xassert(info != info);
alpar@9	4362 }
alpar@9	4363 return 0;
alpar@9	4364 }
alpar@9	4365
alpar@9	4366 ELEMSET eval_elemset(MPL mpl, CODE *code)
alpar@9	4367 { ELEMSET *value;
alpar@9	4368 xassert(code != NULL);
alpar@9	4369 xassert(code->type == A_ELEMSET);
alpar@9	4370 xassert(code->dim > 0);
alpar@9	4371 /* if the operation has a side effect, invalidate and delete the
alpar@9	4372 resultant value */
alpar@9	4373 if (code->vflag && code->valid)
alpar@9	4374 { code->valid = 0;
alpar@9	4375 delete_value(mpl, code->type, &code->value);
alpar@9	4376 }
alpar@9	4377 /* if resultant value is valid, no evaluation is needed */
alpar@9	4378 if (code->valid)
alpar@9	4379 { value = copy_elemset(mpl, code->value.set);
alpar@9	4380 goto done;
alpar@9	4381 }
alpar@9	4382 /* evaluate pseudo-code recursively */
alpar@9	4383 switch (code->op)
alpar@9	4384 { case O_MEMSET:
alpar@9	4385 /* take member of set */
alpar@9	4386 { TUPLE *tuple;
alpar@9	4387 ARG_LIST *e;
alpar@9	4388 tuple = create_tuple(mpl);
alpar@9	4389 for (e = code->arg.set.list; e != NULL; e = e->next)
alpar@9	4390 tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
alpar@9	4391 e->x));
alpar@9	4392 value = copy_elemset(mpl,
alpar@9	4393 eval_member_set(mpl, code->arg.set.set, tuple));
alpar@9	4394 delete_tuple(mpl, tuple);
alpar@9	4395 }
alpar@9	4396 break;
alpar@9	4397 case O_MAKE:
alpar@9	4398 /* make elemental set of n-tuples */
alpar@9	4399 { ARG_LIST *e;
alpar@9	4400 value = create_elemset(mpl, code->dim);
alpar@9	4401 for (e = code->arg.list; e != NULL; e = e->next)
alpar@9	4402 check_then_add(mpl, value, eval_tuple(mpl, e->x));
alpar@9	4403 }
alpar@9	4404 break;
alpar@9	4405 case O_UNION:
alpar@9	4406 /* union of two elemental sets */
alpar@9	4407 value = set_union(mpl,
alpar@9	4408 eval_elemset(mpl, code->arg.arg.x),
alpar@9	4409 eval_elemset(mpl, code->arg.arg.y));
alpar@9	4410 break;
alpar@9	4411 case O_DIFF:
alpar@9	4412 /* difference between two elemental sets */
alpar@9	4413 value = set_diff(mpl,
alpar@9	4414 eval_elemset(mpl, code->arg.arg.x),
alpar@9	4415 eval_elemset(mpl, code->arg.arg.y));
alpar@9	4416 break;
alpar@9	4417 case O_SYMDIFF:
alpar@9	4418 /* symmetric difference between two elemental sets */
alpar@9	4419 value = set_symdiff(mpl,
alpar@9	4420 eval_elemset(mpl, code->arg.arg.x),
alpar@9	4421 eval_elemset(mpl, code->arg.arg.y));
alpar@9	4422 break;
alpar@9	4423 case O_INTER:
alpar@9	4424 /* intersection of two elemental sets */
alpar@9	4425 value = set_inter(mpl,
alpar@9	4426 eval_elemset(mpl, code->arg.arg.x),
alpar@9	4427 eval_elemset(mpl, code->arg.arg.y));
alpar@9	4428 break;
alpar@9	4429 case O_CROSS:
alpar@9	4430 /* cross (Cartesian) product of two elemental sets */
alpar@9	4431 value = set_cross(mpl,
alpar@9	4432 eval_elemset(mpl, code->arg.arg.x),
alpar@9	4433 eval_elemset(mpl, code->arg.arg.y));
alpar@9	4434 break;
alpar@9	4435 case O_DOTS:
alpar@9	4436 /* build "arithmetic" elemental set */
alpar@9	4437 value = create_arelset(mpl,
alpar@9	4438 eval_numeric(mpl, code->arg.arg.x),
alpar@9	4439 eval_numeric(mpl, code->arg.arg.y),
alpar@9	4440 code->arg.arg.z == NULL ? 1.0 : eval_numeric(mpl,
alpar@9	4441 code->arg.arg.z));
alpar@9	4442 break;
alpar@9	4443 case O_FORK:
alpar@9	4444 /* if-then-else */
alpar@9	4445 if (eval_logical(mpl, code->arg.arg.x))
alpar@9	4446 value = eval_elemset(mpl, code->arg.arg.y);
alpar@9	4447 else
alpar@9	4448 value = eval_elemset(mpl, code->arg.arg.z);
alpar@9	4449 break;
alpar@9	4450 case O_SETOF:
alpar@9	4451 /* compute elemental set */
alpar@9	4452 { struct iter_set_info _info, *info = &_info;
alpar@9	4453 info->code = code;
alpar@9	4454 info->value = create_elemset(mpl, code->dim);
alpar@9	4455 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	4456 iter_set_func);
alpar@9	4457 value = info->value;
alpar@9	4458 }
alpar@9	4459 break;
alpar@9	4460 case O_BUILD:
alpar@9	4461 /* build elemental set identical to domain set */
alpar@9	4462 { struct iter_set_info _info, *info = &_info;
alpar@9	4463 info->code = code;
alpar@9	4464 info->value = create_elemset(mpl, code->dim);
alpar@9	4465 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	4466 iter_set_func);
alpar@9	4467 value = info->value;
alpar@9	4468 }
alpar@9	4469 break;
alpar@9	4470 default:
alpar@9	4471 xassert(code != code);
alpar@9	4472 }
alpar@9	4473 /* save resultant value */
alpar@9	4474 xassert(!code->valid);
alpar@9	4475 code->valid = 1;
alpar@9	4476 code->value.set = copy_elemset(mpl, value);
alpar@9	4477 done: return value;
alpar@9	4478 }
alpar@9	4479
alpar@9	4480 /*----------------------------------------------------------------------
alpar@9	4481 -- is_member - check if n-tuple is in set specified by pseudo-code.
alpar@9	4482 --
alpar@9	4483 -- This routine checks if given n-tuple is a member of elemental set
alpar@9	4484 -- specified in the form of pseudo-code (i.e. by expression).
alpar@9	4485 --
alpar@9	4486 -- The n-tuple may have more components that dimension of the elemental
alpar@9	4487 -- set, in which case the extra components are ignored. */
alpar@9	4488
alpar@9	4489 static void null_func(MPL mpl, void info)
alpar@9	4490 { /* this is dummy routine used to enter the domain scope */
alpar@9	4491 xassert(mpl == mpl);
alpar@9	4492 xassert(info == NULL);
alpar@9	4493 return;
alpar@9	4494 }
alpar@9	4495
alpar@9	4496 int is_member(MPL mpl, CODE code, TUPLE *tuple)
alpar@9	4497 { int value;
alpar@9	4498 xassert(code != NULL);
alpar@9	4499 xassert(code->type == A_ELEMSET);
alpar@9	4500 xassert(code->dim > 0);
alpar@9	4501 xassert(tuple != NULL);
alpar@9	4502 switch (code->op)
alpar@9	4503 { case O_MEMSET:
alpar@9	4504 /* check if given n-tuple is member of elemental set, which
alpar@9	4505 is assigned to member of model set */
alpar@9	4506 { ARG_LIST *e;
alpar@9	4507 TUPLE *temp;
alpar@9	4508 ELEMSET *set;
alpar@9	4509 /* evaluate reference to elemental set */
alpar@9	4510 temp = create_tuple(mpl);
alpar@9	4511 for (e = code->arg.set.list; e != NULL; e = e->next)
alpar@9	4512 temp = expand_tuple(mpl, temp, eval_symbolic(mpl,
alpar@9	4513 e->x));
alpar@9	4514 set = eval_member_set(mpl, code->arg.set.set, temp);
alpar@9	4515 delete_tuple(mpl, temp);
alpar@9	4516 /* check if the n-tuple is contained in the set array */
alpar@9	4517 temp = build_subtuple(mpl, tuple, set->dim);
alpar@9	4518 value = (find_tuple(mpl, set, temp) != NULL);
alpar@9	4519 delete_tuple(mpl, temp);
alpar@9	4520 }
alpar@9	4521 break;
alpar@9	4522 case O_MAKE:
alpar@9	4523 /* check if given n-tuple is member of literal set */
alpar@9	4524 { ARG_LIST *e;
alpar@9	4525 TUPLE temp, that;
alpar@9	4526 value = 0;
alpar@9	4527 temp = build_subtuple(mpl, tuple, code->dim);
alpar@9	4528 for (e = code->arg.list; e != NULL; e = e->next)
alpar@9	4529 { that = eval_tuple(mpl, e->x);
alpar@9	4530 value = (compare_tuples(mpl, temp, that) == 0);
alpar@9	4531 delete_tuple(mpl, that);
alpar@9	4532 if (value) break;
alpar@9	4533 }
alpar@9	4534 delete_tuple(mpl, temp);
alpar@9	4535 }
alpar@9	4536 break;
alpar@9	4537 case O_UNION:
alpar@9	4538 value = is_member(mpl, code->arg.arg.x, tuple) \|\|
alpar@9	4539 is_member(mpl, code->arg.arg.y, tuple);
alpar@9	4540 break;
alpar@9	4541 case O_DIFF:
alpar@9	4542 value = is_member(mpl, code->arg.arg.x, tuple) &&
alpar@9	4543 !is_member(mpl, code->arg.arg.y, tuple);
alpar@9	4544 break;
alpar@9	4545 case O_SYMDIFF:
alpar@9	4546 { int in1 = is_member(mpl, code->arg.arg.x, tuple);
alpar@9	4547 int in2 = is_member(mpl, code->arg.arg.y, tuple);
alpar@9	4548 value = (in1 && !in2) \|\| (!in1 && in2);
alpar@9	4549 }
alpar@9	4550 break;
alpar@9	4551 case O_INTER:
alpar@9	4552 value = is_member(mpl, code->arg.arg.x, tuple) &&
alpar@9	4553 is_member(mpl, code->arg.arg.y, tuple);
alpar@9	4554 break;
alpar@9	4555 case O_CROSS:
alpar@9	4556 { int j;
alpar@9	4557 value = is_member(mpl, code->arg.arg.x, tuple);
alpar@9	4558 if (value)
alpar@9	4559 { for (j = 1; j <= code->arg.arg.x->dim; j++)
alpar@9	4560 { xassert(tuple != NULL);
alpar@9	4561 tuple = tuple->next;
alpar@9	4562 }
alpar@9	4563 value = is_member(mpl, code->arg.arg.y, tuple);
alpar@9	4564 }
alpar@9	4565 }
alpar@9	4566 break;
alpar@9	4567 case O_DOTS:
alpar@9	4568 /* check if given 1-tuple is member of "arithmetic" set */
alpar@9	4569 { int j;
alpar@9	4570 double x, t0, tf, dt;
alpar@9	4571 xassert(code->dim == 1);
alpar@9	4572 /* compute "parameters" of the "arithmetic" set */
alpar@9	4573 t0 = eval_numeric(mpl, code->arg.arg.x);
alpar@9	4574 tf = eval_numeric(mpl, code->arg.arg.y);
alpar@9	4575 if (code->arg.arg.z == NULL)
alpar@9	4576 dt = 1.0;
alpar@9	4577 else
alpar@9	4578 dt = eval_numeric(mpl, code->arg.arg.z);
alpar@9	4579 /* make sure the parameters are correct */
alpar@9	4580 arelset_size(mpl, t0, tf, dt);
alpar@9	4581 /* if component of 1-tuple is symbolic, not numeric, the
alpar@9	4582 1-tuple cannot be member of "arithmetic" set */
alpar@9	4583 xassert(tuple->sym != NULL);
alpar@9	4584 if (tuple->sym->str != NULL)
alpar@9	4585 { value = 0;
alpar@9	4586 break;
alpar@9	4587 }
alpar@9	4588 /* determine numeric value of the component */
alpar@9	4589 x = tuple->sym->num;
alpar@9	4590 /* if the component value is out of the set range, the
alpar@9	4591 1-tuple is not in the set */
alpar@9	4592 if (dt > 0.0 && !(t0 <= x && x <= tf) \|\|
alpar@9	4593 dt < 0.0 && !(tf <= x && x <= t0))
alpar@9	4594 { value = 0;
alpar@9	4595 break;
alpar@9	4596 }
alpar@9	4597 /* estimate ordinal number of the 1-tuple in the set */
alpar@9	4598 j = (int)(((x - t0) / dt) + 0.5) + 1;
alpar@9	4599 /* perform the main check */
alpar@9	4600 value = (arelset_member(mpl, t0, tf, dt, j) == x);
alpar@9	4601 }
alpar@9	4602 break;
alpar@9	4603 case O_FORK:
alpar@9	4604 /* check if given n-tuple is member of conditional set */
alpar@9	4605 if (eval_logical(mpl, code->arg.arg.x))
alpar@9	4606 value = is_member(mpl, code->arg.arg.y, tuple);
alpar@9	4607 else
alpar@9	4608 value = is_member(mpl, code->arg.arg.z, tuple);
alpar@9	4609 break;
alpar@9	4610 case O_SETOF:
alpar@9	4611 /* check if given n-tuple is member of computed set */
alpar@9	4612 /* it is not clear how to efficiently perform the check not
alpar@9	4613 computing the entire elemental set :+( */
alpar@9	4614 error(mpl, "implementation restriction; in/within setof{} n"
alpar@9	4615 "ot allowed");
alpar@9	4616 break;
alpar@9	4617 case O_BUILD:
alpar@9	4618 /* check if given n-tuple is member of domain set */
alpar@9	4619 { TUPLE *temp;
alpar@9	4620 temp = build_subtuple(mpl, tuple, code->dim);
alpar@9	4621 /* try to enter the domain scope; if it is successful,
alpar@9	4622 the n-tuple is in the domain set */
alpar@9	4623 value = (eval_within_domain(mpl, code->arg.loop.domain,
alpar@9	4624 temp, NULL, null_func) == 0);
alpar@9	4625 delete_tuple(mpl, temp);
alpar@9	4626 }
alpar@9	4627 break;
alpar@9	4628 default:
alpar@9	4629 xassert(code != code);
alpar@9	4630 }
alpar@9	4631 return value;
alpar@9	4632 }
alpar@9	4633
alpar@9	4634 /*----------------------------------------------------------------------
alpar@9	4635 -- eval_formula - evaluate pseudo-code to construct linear form.
alpar@9	4636 --
alpar@9	4637 -- This routine evaluates specified pseudo-code to construct resultant
alpar@9	4638 -- linear form, which is returned on exit. */
alpar@9	4639
alpar@9	4640 struct iter_form_info
alpar@9	4641 { /* working info used by the routine iter_form_func */
alpar@9	4642 CODE *code;
alpar@9	4643 /* pseudo-code for iterated operation to be performed */
alpar@9	4644 FORMULA *value;
alpar@9	4645 /* resultant value */
alpar@9	4646 FORMULA *tail;
alpar@9	4647 /* pointer to the last term */
alpar@9	4648 };
alpar@9	4649
alpar@9	4650 static int iter_form_func(MPL mpl, void _info)
alpar@9	4651 { /* this is auxiliary routine used to perform iterated operation
alpar@9	4652 on linear form "integrand" within domain scope */
alpar@9	4653 struct iter_form_info *info = _info;
alpar@9	4654 switch (info->code->op)
alpar@9	4655 { case O_SUM:
alpar@9	4656 /* summation over domain */
alpar@9	4657 #if 0
alpar@9	4658 info->value =
alpar@9	4659 linear_comb(mpl,
alpar@9	4660 +1.0, info->value,
alpar@9	4661 +1.0, eval_formula(mpl, info->code->arg.loop.x));
alpar@9	4662 #else
alpar@9	4663 /* the routine linear_comb needs to look through all terms
alpar@9	4664 of both linear forms to reduce identical terms, so using
alpar@9	4665 it here is not a good idea (for example, evaluation of
alpar@9	4666 sum{i in 1..n} x[i] required quadratic time); the better
alpar@9	4667 idea is to gather all terms of the integrand in one list
alpar@9	4668 and reduce identical terms only once after all terms of
alpar@9	4669 the resultant linear form have been evaluated */
alpar@9	4670 { FORMULA form, term;
alpar@9	4671 form = eval_formula(mpl, info->code->arg.loop.x);
alpar@9	4672 if (info->value == NULL)
alpar@9	4673 { xassert(info->tail == NULL);
alpar@9	4674 info->value = form;
alpar@9	4675 }
alpar@9	4676 else
alpar@9	4677 { xassert(info->tail != NULL);
alpar@9	4678 info->tail->next = form;
alpar@9	4679 }
alpar@9	4680 for (term = form; term != NULL; term = term->next)
alpar@9	4681 info->tail = term;
alpar@9	4682 }
alpar@9	4683 #endif
alpar@9	4684 break;
alpar@9	4685 default:
alpar@9	4686 xassert(info != info);
alpar@9	4687 }
alpar@9	4688 return 0;
alpar@9	4689 }
alpar@9	4690
alpar@9	4691 FORMULA eval_formula(MPL mpl, CODE *code)
alpar@9	4692 { FORMULA *value;
alpar@9	4693 xassert(code != NULL);
alpar@9	4694 xassert(code->type == A_FORMULA);
alpar@9	4695 xassert(code->dim == 0);
alpar@9	4696 /* if the operation has a side effect, invalidate and delete the
alpar@9	4697 resultant value */
alpar@9	4698 if (code->vflag && code->valid)
alpar@9	4699 { code->valid = 0;
alpar@9	4700 delete_value(mpl, code->type, &code->value);
alpar@9	4701 }
alpar@9	4702 /* if resultant value is valid, no evaluation is needed */
alpar@9	4703 if (code->valid)
alpar@9	4704 { value = copy_formula(mpl, code->value.form);
alpar@9	4705 goto done;
alpar@9	4706 }
alpar@9	4707 /* evaluate pseudo-code recursively */
alpar@9	4708 switch (code->op)
alpar@9	4709 { case O_MEMVAR:
alpar@9	4710 /* take member of variable */
alpar@9	4711 { TUPLE *tuple;
alpar@9	4712 ARG_LIST *e;
alpar@9	4713 tuple = create_tuple(mpl);
alpar@9	4714 for (e = code->arg.var.list; e != NULL; e = e->next)
alpar@9	4715 tuple = expand_tuple(mpl, tuple, eval_symbolic(mpl,
alpar@9	4716 e->x));
alpar@9	4717 #if 1 /* 15/V-2010 */
alpar@9	4718 xassert(code->arg.var.suff == DOT_NONE);
alpar@9	4719 #endif
alpar@9	4720 value = single_variable(mpl,
alpar@9	4721 eval_member_var(mpl, code->arg.var.var, tuple));
alpar@9	4722 delete_tuple(mpl, tuple);
alpar@9	4723 }
alpar@9	4724 break;
alpar@9	4725 case O_CVTLFM:
alpar@9	4726 /* convert to linear form */
alpar@9	4727 value = constant_term(mpl, eval_numeric(mpl,
alpar@9	4728 code->arg.arg.x));
alpar@9	4729 break;
alpar@9	4730 case O_PLUS:
alpar@9	4731 /* unary plus */
alpar@9	4732 value = linear_comb(mpl,
alpar@9	4733 0.0, constant_term(mpl, 0.0),
alpar@9	4734 +1.0, eval_formula(mpl, code->arg.arg.x));
alpar@9	4735 break;
alpar@9	4736 case O_MINUS:
alpar@9	4737 /* unary minus */
alpar@9	4738 value = linear_comb(mpl,
alpar@9	4739 0.0, constant_term(mpl, 0.0),
alpar@9	4740 -1.0, eval_formula(mpl, code->arg.arg.x));
alpar@9	4741 break;
alpar@9	4742 case O_ADD:
alpar@9	4743 /* addition */
alpar@9	4744 value = linear_comb(mpl,
alpar@9	4745 +1.0, eval_formula(mpl, code->arg.arg.x),
alpar@9	4746 +1.0, eval_formula(mpl, code->arg.arg.y));
alpar@9	4747 break;
alpar@9	4748 case O_SUB:
alpar@9	4749 /* subtraction */
alpar@9	4750 value = linear_comb(mpl,
alpar@9	4751 +1.0, eval_formula(mpl, code->arg.arg.x),
alpar@9	4752 -1.0, eval_formula(mpl, code->arg.arg.y));
alpar@9	4753 break;
alpar@9	4754 case O_MUL:
alpar@9	4755 /* multiplication */
alpar@9	4756 xassert(code->arg.arg.x != NULL);
alpar@9	4757 xassert(code->arg.arg.y != NULL);
alpar@9	4758 if (code->arg.arg.x->type == A_NUMERIC)
alpar@9	4759 { xassert(code->arg.arg.y->type == A_FORMULA);
alpar@9	4760 value = linear_comb(mpl,
alpar@9	4761 eval_numeric(mpl, code->arg.arg.x),
alpar@9	4762 eval_formula(mpl, code->arg.arg.y),
alpar@9	4763 0.0, constant_term(mpl, 0.0));
alpar@9	4764 }
alpar@9	4765 else
alpar@9	4766 { xassert(code->arg.arg.x->type == A_FORMULA);
alpar@9	4767 xassert(code->arg.arg.y->type == A_NUMERIC);
alpar@9	4768 value = linear_comb(mpl,
alpar@9	4769 eval_numeric(mpl, code->arg.arg.y),
alpar@9	4770 eval_formula(mpl, code->arg.arg.x),
alpar@9	4771 0.0, constant_term(mpl, 0.0));
alpar@9	4772 }
alpar@9	4773 break;
alpar@9	4774 case O_DIV:
alpar@9	4775 /* division */
alpar@9	4776 value = linear_comb(mpl,
alpar@9	4777 fp_div(mpl, 1.0, eval_numeric(mpl, code->arg.arg.y)),
alpar@9	4778 eval_formula(mpl, code->arg.arg.x),
alpar@9	4779 0.0, constant_term(mpl, 0.0));
alpar@9	4780 break;
alpar@9	4781 case O_FORK:
alpar@9	4782 /* if-then-else */
alpar@9	4783 if (eval_logical(mpl, code->arg.arg.x))
alpar@9	4784 value = eval_formula(mpl, code->arg.arg.y);
alpar@9	4785 else if (code->arg.arg.z == NULL)
alpar@9	4786 value = constant_term(mpl, 0.0);
alpar@9	4787 else
alpar@9	4788 value = eval_formula(mpl, code->arg.arg.z);
alpar@9	4789 break;
alpar@9	4790 case O_SUM:
alpar@9	4791 /* summation over domain */
alpar@9	4792 { struct iter_form_info _info, *info = &_info;
alpar@9	4793 info->code = code;
alpar@9	4794 info->value = constant_term(mpl, 0.0);
alpar@9	4795 info->tail = NULL;
alpar@9	4796 loop_within_domain(mpl, code->arg.loop.domain, info,
alpar@9	4797 iter_form_func);
alpar@9	4798 value = reduce_terms(mpl, info->value);
alpar@9	4799 }
alpar@9	4800 break;
alpar@9	4801 default:
alpar@9	4802 xassert(code != code);
alpar@9	4803 }
alpar@9	4804 /* save resultant value */
alpar@9	4805 xassert(!code->valid);
alpar@9	4806 code->valid = 1;
alpar@9	4807 code->value.form = copy_formula(mpl, value);
alpar@9	4808 done: return value;
alpar@9	4809 }
alpar@9	4810
alpar@9	4811 /*----------------------------------------------------------------------
alpar@9	4812 -- clean_code - clean pseudo-code.
alpar@9	4813 --
alpar@9	4814 -- This routine recursively cleans specified pseudo-code that assumes
alpar@9	4815 -- deleting all temporary resultant values. */
alpar@9	4816
alpar@9	4817 void clean_code(MPL mpl, CODE code)
alpar@9	4818 { ARG_LIST *e;
alpar@9	4819 /* if no pseudo-code is specified, do nothing */
alpar@9	4820 if (code == NULL) goto done;
alpar@9	4821 /* if resultant value is valid (exists), delete it */
alpar@9	4822 if (code->valid)
alpar@9	4823 { code->valid = 0;
alpar@9	4824 delete_value(mpl, code->type, &code->value);
alpar@9	4825 }
alpar@9	4826 /* recursively clean pseudo-code for operands */
alpar@9	4827 switch (code->op)
alpar@9	4828 { case O_NUMBER:
alpar@9	4829 case O_STRING:
alpar@9	4830 case O_INDEX:
alpar@9	4831 break;
alpar@9	4832 case O_MEMNUM:
alpar@9	4833 case O_MEMSYM:
alpar@9	4834 for (e = code->arg.par.list; e != NULL; e = e->next)
alpar@9	4835 clean_code(mpl, e->x);
alpar@9	4836 break;
alpar@9	4837 case O_MEMSET:
alpar@9	4838 for (e = code->arg.set.list; e != NULL; e = e->next)
alpar@9	4839 clean_code(mpl, e->x);
alpar@9	4840 break;
alpar@9	4841 case O_MEMVAR:
alpar@9	4842 for (e = code->arg.var.list; e != NULL; e = e->next)
alpar@9	4843 clean_code(mpl, e->x);
alpar@9	4844 break;
alpar@9	4845 #if 1 /* 15/V-2010 */
alpar@9	4846 case O_MEMCON:
alpar@9	4847 for (e = code->arg.con.list; e != NULL; e = e->next)
alpar@9	4848 clean_code(mpl, e->x);
alpar@9	4849 break;
alpar@9	4850 #endif
alpar@9	4851 case O_TUPLE:
alpar@9	4852 case O_MAKE:
alpar@9	4853 for (e = code->arg.list; e != NULL; e = e->next)
alpar@9	4854 clean_code(mpl, e->x);
alpar@9	4855 break;
alpar@9	4856 case O_SLICE:
alpar@9	4857 xassert(code != code);
alpar@9	4858 case O_IRAND224:
alpar@9	4859 case O_UNIFORM01:
alpar@9	4860 case O_NORMAL01:
alpar@9	4861 case O_GMTIME:
alpar@9	4862 break;
alpar@9	4863 case O_CVTNUM:
alpar@9	4864 case O_CVTSYM:
alpar@9	4865 case O_CVTLOG:
alpar@9	4866 case O_CVTTUP:
alpar@9	4867 case O_CVTLFM:
alpar@9	4868 case O_PLUS:
alpar@9	4869 case O_MINUS:
alpar@9	4870 case O_NOT:
alpar@9	4871 case O_ABS:
alpar@9	4872 case O_CEIL:
alpar@9	4873 case O_FLOOR:
alpar@9	4874 case O_EXP:
alpar@9	4875 case O_LOG:
alpar@9	4876 case O_LOG10:
alpar@9	4877 case O_SQRT:
alpar@9	4878 case O_SIN:
alpar@9	4879 case O_COS:
alpar@9	4880 case O_ATAN:
alpar@9	4881 case O_ROUND:
alpar@9	4882 case O_TRUNC:
alpar@9	4883 case O_CARD:
alpar@9	4884 case O_LENGTH:
alpar@9	4885 /* unary operation */
alpar@9	4886 clean_code(mpl, code->arg.arg.x);
alpar@9	4887 break;
alpar@9	4888 case O_ADD:
alpar@9	4889 case O_SUB:
alpar@9	4890 case O_LESS:
alpar@9	4891 case O_MUL:
alpar@9	4892 case O_DIV:
alpar@9	4893 case O_IDIV:
alpar@9	4894 case O_MOD:
alpar@9	4895 case O_POWER:
alpar@9	4896 case O_ATAN2:
alpar@9	4897 case O_ROUND2:
alpar@9	4898 case O_TRUNC2:
alpar@9	4899 case O_UNIFORM:
alpar@9	4900 case O_NORMAL:
alpar@9	4901 case O_CONCAT:
alpar@9	4902 case O_LT:
alpar@9	4903 case O_LE:
alpar@9	4904 case O_EQ:
alpar@9	4905 case O_GE:
alpar@9	4906 case O_GT:
alpar@9	4907 case O_NE:
alpar@9	4908 case O_AND:
alpar@9	4909 case O_OR:
alpar@9	4910 case O_UNION:
alpar@9	4911 case O_DIFF:
alpar@9	4912 case O_SYMDIFF:
alpar@9	4913 case O_INTER:
alpar@9	4914 case O_CROSS:
alpar@9	4915 case O_IN:
alpar@9	4916 case O_NOTIN:
alpar@9	4917 case O_WITHIN:
alpar@9	4918 case O_NOTWITHIN:
alpar@9	4919 case O_SUBSTR:
alpar@9	4920 case O_STR2TIME:
alpar@9	4921 case O_TIME2STR:
alpar@9	4922 /* binary operation */
alpar@9	4923 clean_code(mpl, code->arg.arg.x);
alpar@9	4924 clean_code(mpl, code->arg.arg.y);
alpar@9	4925 break;
alpar@9	4926 case O_DOTS:
alpar@9	4927 case O_FORK:
alpar@9	4928 case O_SUBSTR3:
alpar@9	4929 /* ternary operation */
alpar@9	4930 clean_code(mpl, code->arg.arg.x);
alpar@9	4931 clean_code(mpl, code->arg.arg.y);
alpar@9	4932 clean_code(mpl, code->arg.arg.z);
alpar@9	4933 break;
alpar@9	4934 case O_MIN:
alpar@9	4935 case O_MAX:
alpar@9	4936 /* n-ary operation */
alpar@9	4937 for (e = code->arg.list; e != NULL; e = e->next)
alpar@9	4938 clean_code(mpl, e->x);
alpar@9	4939 break;
alpar@9	4940 case O_SUM:
alpar@9	4941 case O_PROD:
alpar@9	4942 case O_MINIMUM:
alpar@9	4943 case O_MAXIMUM:
alpar@9	4944 case O_FORALL:
alpar@9	4945 case O_EXISTS:
alpar@9	4946 case O_SETOF:
alpar@9	4947 case O_BUILD:
alpar@9	4948 /* iterated operation */
alpar@9	4949 clean_domain(mpl, code->arg.loop.domain);
alpar@9	4950 clean_code(mpl, code->arg.loop.x);
alpar@9	4951 break;
alpar@9	4952 default:
alpar@9	4953 xassert(code->op != code->op);
alpar@9	4954 }
alpar@9	4955 done: return;
alpar@9	4956 }
alpar@9	4957
alpar@9	4958 #if 1 /* 11/II-2008 */
alpar@9	4959 /**********************************************************************/
alpar@9	4960 /* * * DATA TABLES * * */
alpar@9	4961 /**********************************************************************/
alpar@9	4962
alpar@9	4963 int mpl_tab_num_args(TABDCA *dca)
alpar@9	4964 { /* returns the number of arguments */
alpar@9	4965 return dca->na;
alpar@9	4966 }
alpar@9	4967
alpar@9	4968 const char mpl_tab_get_arg(TABDCA dca, int k)
alpar@9	4969 { /* returns pointer to k-th argument */
alpar@9	4970 xassert(1 <= k && k <= dca->na);
alpar@9	4971 return dca->arg[k];
alpar@9	4972 }
alpar@9	4973
alpar@9	4974 int mpl_tab_num_flds(TABDCA *dca)
alpar@9	4975 { /* returns the number of fields */
alpar@9	4976 return dca->nf;
alpar@9	4977 }
alpar@9	4978
alpar@9	4979 const char mpl_tab_get_name(TABDCA dca, int k)
alpar@9	4980 { /* returns pointer to name of k-th field */
alpar@9	4981 xassert(1 <= k && k <= dca->nf);
alpar@9	4982 return dca->name[k];
alpar@9	4983 }
alpar@9	4984
alpar@9	4985 int mpl_tab_get_type(TABDCA *dca, int k)
alpar@9	4986 { /* returns type of k-th field */
alpar@9	4987 xassert(1 <= k && k <= dca->nf);
alpar@9	4988 return dca->type[k];
alpar@9	4989 }
alpar@9	4990
alpar@9	4991 double mpl_tab_get_num(TABDCA *dca, int k)
alpar@9	4992 { /* returns numeric value of k-th field */
alpar@9	4993 xassert(1 <= k && k <= dca->nf);
alpar@9	4994 xassert(dca->type[k] == 'N');
alpar@9	4995 return dca->num[k];
alpar@9	4996 }
alpar@9	4997
alpar@9	4998 const char mpl_tab_get_str(TABDCA dca, int k)
alpar@9	4999 { /* returns pointer to string value of k-th field */
alpar@9	5000 xassert(1 <= k && k <= dca->nf);
alpar@9	5001 xassert(dca->type[k] == 'S');
alpar@9	5002 xassert(dca->str[k] != NULL);
alpar@9	5003 return dca->str[k];
alpar@9	5004 }
alpar@9	5005
alpar@9	5006 void mpl_tab_set_num(TABDCA *dca, int k, double num)
alpar@9	5007 { /* assign numeric value to k-th field */
alpar@9	5008 xassert(1 <= k && k <= dca->nf);
alpar@9	5009 xassert(dca->type[k] == '?');
alpar@9	5010 dca->type[k] = 'N';
alpar@9	5011 dca->num[k] = num;
alpar@9	5012 return;
alpar@9	5013 }
alpar@9	5014
alpar@9	5015 void mpl_tab_set_str(TABDCA dca, int k, const char str)
alpar@9	5016 { /* assign string value to k-th field */
alpar@9	5017 xassert(1 <= k && k <= dca->nf);
alpar@9	5018 xassert(dca->type[k] == '?');
alpar@9	5019 xassert(strlen(str) <= MAX_LENGTH);
alpar@9	5020 xassert(dca->str[k] != NULL);
alpar@9	5021 dca->type[k] = 'S';
alpar@9	5022 strcpy(dca->str[k], str);
alpar@9	5023 return;
alpar@9	5024 }
alpar@9	5025
alpar@9	5026 static int write_func(MPL mpl, void info)
alpar@9	5027 { /* this is auxiliary routine to work within domain scope */
alpar@9	5028 TABLE *tab = info;
alpar@9	5029 TABDCA *dca = mpl->dca;
alpar@9	5030 TABOUT *out;
alpar@9	5031 SYMBOL *sym;
alpar@9	5032 int k;
alpar@9	5033 char buf[MAX_LENGTH+1];
alpar@9	5034 /* evaluate field values */
alpar@9	5035 k = 0;
alpar@9	5036 for (out = tab->u.out.list; out != NULL; out = out->next)
alpar@9	5037 { k++;
alpar@9	5038 switch (out->code->type)
alpar@9	5039 { case A_NUMERIC:
alpar@9	5040 dca->type[k] = 'N';
alpar@9	5041 dca->num[k] = eval_numeric(mpl, out->code);
alpar@9	5042 dca->str[k][0] = '\0';
alpar@9	5043 break;
alpar@9	5044 case A_SYMBOLIC:
alpar@9	5045 sym = eval_symbolic(mpl, out->code);
alpar@9	5046 if (sym->str == NULL)
alpar@9	5047 { dca->type[k] = 'N';
alpar@9	5048 dca->num[k] = sym->num;
alpar@9	5049 dca->str[k][0] = '\0';
alpar@9	5050 }
alpar@9	5051 else
alpar@9	5052 { dca->type[k] = 'S';
alpar@9	5053 dca->num[k] = 0.0;
alpar@9	5054 fetch_string(mpl, sym->str, buf);
alpar@9	5055 strcpy(dca->str[k], buf);
alpar@9	5056 }
alpar@9	5057 delete_symbol(mpl, sym);
alpar@9	5058 break;
alpar@9	5059 default:
alpar@9	5060 xassert(out != out);
alpar@9	5061 }
alpar@9	5062 }
alpar@9	5063 /* write record to output table */
alpar@9	5064 mpl_tab_drv_write(mpl);
alpar@9	5065 return 0;
alpar@9	5066 }
alpar@9	5067
alpar@9	5068 void execute_table(MPL mpl, TABLE tab)
alpar@9	5069 { /* execute table statement */
alpar@9	5070 TABARG *arg;
alpar@9	5071 TABFLD *fld;
alpar@9	5072 TABIN *in;
alpar@9	5073 TABOUT *out;
alpar@9	5074 TABDCA *dca;
alpar@9	5075 SET *set;
alpar@9	5076 int k;
alpar@9	5077 char buf[MAX_LENGTH+1];
alpar@9	5078 /* allocate table driver communication area */
alpar@9	5079 xassert(mpl->dca == NULL);
alpar@9	5080 mpl->dca = dca = xmalloc(sizeof(TABDCA));
alpar@9	5081 dca->id = 0;
alpar@9	5082 dca->link = NULL;
alpar@9	5083 dca->na = 0;
alpar@9	5084 dca->arg = NULL;
alpar@9	5085 dca->nf = 0;
alpar@9	5086 dca->name = NULL;
alpar@9	5087 dca->type = NULL;
alpar@9	5088 dca->num = NULL;
alpar@9	5089 dca->str = NULL;
alpar@9	5090 /* allocate arguments */
alpar@9	5091 xassert(dca->na == 0);
alpar@9	5092 for (arg = tab->arg; arg != NULL; arg = arg->next)
alpar@9	5093 dca->na++;
alpar@9	5094 dca->arg = xcalloc(1+dca->na, sizeof(char *));
alpar@9	5095 #if 1 /* 28/IX-2008 */
alpar@9	5096 for (k = 1; k <= dca->na; k++) dca->arg[k] = NULL;
alpar@9	5097 #endif
alpar@9	5098 /* evaluate argument values */
alpar@9	5099 k = 0;
alpar@9	5100 for (arg = tab->arg; arg != NULL; arg = arg->next)
alpar@9	5101 { SYMBOL *sym;
alpar@9	5102 k++;
alpar@9	5103 xassert(arg->code->type == A_SYMBOLIC);
alpar@9	5104 sym = eval_symbolic(mpl, arg->code);
alpar@9	5105 if (sym->str == NULL)
alpar@9	5106 sprintf(buf, "%.*g", DBL_DIG, sym->num);
alpar@9	5107 else
alpar@9	5108 fetch_string(mpl, sym->str, buf);
alpar@9	5109 delete_symbol(mpl, sym);
alpar@9	5110 dca->arg[k] = xmalloc(strlen(buf)+1);
alpar@9	5111 strcpy(dca->arg[k], buf);
alpar@9	5112 }
alpar@9	5113 /* perform table input/output */
alpar@9	5114 switch (tab->type)
alpar@9	5115 { case A_INPUT: goto read_table;
alpar@9	5116 case A_OUTPUT: goto write_table;
alpar@9	5117 default: xassert(tab != tab);
alpar@9	5118 }
alpar@9	5119 read_table:
alpar@9	5120 /* read data from input table */
alpar@9	5121 /* add the only member to the control set and assign it empty
alpar@9	5122 elemental set */
alpar@9	5123 set = tab->u.in.set;
alpar@9	5124 if (set != NULL)
alpar@9	5125 { if (set->data)
alpar@9	5126 error(mpl, "%s already provided with data", set->name);
alpar@9	5127 xassert(set->array->head == NULL);
alpar@9	5128 add_member(mpl, set->array, NULL)->value.set =
alpar@9	5129 create_elemset(mpl, set->dimen);
alpar@9	5130 set->data = 1;
alpar@9	5131 }
alpar@9	5132 /* check parameters specified in the input list */
alpar@9	5133 for (in = tab->u.in.list; in != NULL; in = in->next)
alpar@9	5134 { if (in->par->data)
alpar@9	5135 error(mpl, "%s already provided with data", in->par->name);
alpar@9	5136 in->par->data = 1;
alpar@9	5137 }
alpar@9	5138 /* allocate and initialize fields */
alpar@9	5139 xassert(dca->nf == 0);
alpar@9	5140 for (fld = tab->u.in.fld; fld != NULL; fld = fld->next)
alpar@9	5141 dca->nf++;
alpar@9	5142 for (in = tab->u.in.list; in != NULL; in = in->next)
alpar@9	5143 dca->nf++;
alpar@9	5144 dca->name = xcalloc(1+dca->nf, sizeof(char *));
alpar@9	5145 dca->type = xcalloc(1+dca->nf, sizeof(int));
alpar@9	5146 dca->num = xcalloc(1+dca->nf, sizeof(double));
alpar@9	5147 dca->str = xcalloc(1+dca->nf, sizeof(char *));
alpar@9	5148 k = 0;
alpar@9	5149 for (fld = tab->u.in.fld; fld != NULL; fld = fld->next)
alpar@9	5150 { k++;
alpar@9	5151 dca->name[k] = fld->name;
alpar@9	5152 dca->type[k] = '?';
alpar@9	5153 dca->num[k] = 0.0;
alpar@9	5154 dca->str[k] = xmalloc(MAX_LENGTH+1);
alpar@9	5155 dca->str[k][0] = '\0';
alpar@9	5156 }
alpar@9	5157 for (in = tab->u.in.list; in != NULL; in = in->next)
alpar@9	5158 { k++;
alpar@9	5159 dca->name[k] = in->name;
alpar@9	5160 dca->type[k] = '?';
alpar@9	5161 dca->num[k] = 0.0;
alpar@9	5162 dca->str[k] = xmalloc(MAX_LENGTH+1);
alpar@9	5163 dca->str[k][0] = '\0';
alpar@9	5164 }
alpar@9	5165 /* open input table */
alpar@9	5166 mpl_tab_drv_open(mpl, 'R');
alpar@9	5167 /* read and process records */
alpar@9	5168 for (;;)
alpar@9	5169 { TUPLE *tup;
alpar@9	5170 /* reset field types */
alpar@9	5171 for (k = 1; k <= dca->nf; k++)
alpar@9	5172 dca->type[k] = '?';
alpar@9	5173 /* read next record */
alpar@9	5174 if (mpl_tab_drv_read(mpl)) break;
alpar@9	5175 /* all fields must be set by the driver */
alpar@9	5176 for (k = 1; k <= dca->nf; k++)
alpar@9	5177 { if (dca->type[k] == '?')
alpar@9	5178 error(mpl, "field %s missing in input table",
alpar@9	5179 dca->name[k]);
alpar@9	5180 }
alpar@9	5181 /* construct n-tuple */
alpar@9	5182 tup = create_tuple(mpl);
alpar@9	5183 k = 0;
alpar@9	5184 for (fld = tab->u.in.fld; fld != NULL; fld = fld->next)
alpar@9	5185 { k++;
alpar@9	5186 xassert(k <= dca->nf);
alpar@9	5187 switch (dca->type[k])
alpar@9	5188 { case 'N':
alpar@9	5189 tup = expand_tuple(mpl, tup, create_symbol_num(mpl,
alpar@9	5190 dca->num[k]));
alpar@9	5191 break;
alpar@9	5192 case 'S':
alpar@9	5193 xassert(strlen(dca->str[k]) <= MAX_LENGTH);
alpar@9	5194 tup = expand_tuple(mpl, tup, create_symbol_str(mpl,
alpar@9	5195 create_string(mpl, dca->str[k])));
alpar@9	5196 break;
alpar@9	5197 default:
alpar@9	5198 xassert(dca != dca);
alpar@9	5199 }
alpar@9	5200 }
alpar@9	5201 /* add n-tuple just read to the control set */
alpar@9	5202 if (tab->u.in.set != NULL)
alpar@9	5203 check_then_add(mpl, tab->u.in.set->array->head->value.set,
alpar@9	5204 copy_tuple(mpl, tup));
alpar@9	5205 /* assign values to the parameters in the input list */
alpar@9	5206 for (in = tab->u.in.list; in != NULL; in = in->next)
alpar@9	5207 { MEMBER *memb;
alpar@9	5208 k++;
alpar@9	5209 xassert(k <= dca->nf);
alpar@9	5210 /* there must be no member with the same n-tuple */
alpar@9	5211 if (find_member(mpl, in->par->array, tup) != NULL)
alpar@9	5212 error(mpl, "%s%s already defined", in->par->name,
alpar@9	5213 format_tuple(mpl, '[', tup));
alpar@9	5214 /* create new parameter member with given n-tuple */
alpar@9	5215 memb = add_member(mpl, in->par->array, copy_tuple(mpl, tup))
alpar@9	5216 ;
alpar@9	5217 /* assign value to the parameter member */
alpar@9	5218 switch (in->par->type)
alpar@9	5219 { case A_NUMERIC:
alpar@9	5220 case A_INTEGER:
alpar@9	5221 case A_BINARY:
alpar@9	5222 if (dca->type[k] != 'N')
alpar@9	5223 error(mpl, "%s requires numeric data",
alpar@9	5224 in->par->name);
alpar@9	5225 memb->value.num = dca->num[k];
alpar@9	5226 break;
alpar@9	5227 case A_SYMBOLIC:
alpar@9	5228 switch (dca->type[k])
alpar@9	5229 { case 'N':
alpar@9	5230 memb->value.sym = create_symbol_num(mpl,
alpar@9	5231 dca->num[k]);
alpar@9	5232 break;
alpar@9	5233 case 'S':
alpar@9	5234 xassert(strlen(dca->str[k]) <= MAX_LENGTH);
alpar@9	5235 memb->value.sym = create_symbol_str(mpl,
alpar@9	5236 create_string(mpl,dca->str[k]));
alpar@9	5237 break;
alpar@9	5238 default:
alpar@9	5239 xassert(dca != dca);
alpar@9	5240 }
alpar@9	5241 break;
alpar@9	5242 default:
alpar@9	5243 xassert(in != in);
alpar@9	5244 }
alpar@9	5245 }
alpar@9	5246 /* n-tuple is no more needed */
alpar@9	5247 delete_tuple(mpl, tup);
alpar@9	5248 }
alpar@9	5249 /* close input table */
alpar@9	5250 mpl_tab_drv_close(mpl);
alpar@9	5251 goto done;
alpar@9	5252 write_table:
alpar@9	5253 /* write data to output table */
alpar@9	5254 /* allocate and initialize fields */
alpar@9	5255 xassert(dca->nf == 0);
alpar@9	5256 for (out = tab->u.out.list; out != NULL; out = out->next)
alpar@9	5257 dca->nf++;
alpar@9	5258 dca->name = xcalloc(1+dca->nf, sizeof(char *));
alpar@9	5259 dca->type = xcalloc(1+dca->nf, sizeof(int));
alpar@9	5260 dca->num = xcalloc(1+dca->nf, sizeof(double));
alpar@9	5261 dca->str = xcalloc(1+dca->nf, sizeof(char *));
alpar@9	5262 k = 0;
alpar@9	5263 for (out = tab->u.out.list; out != NULL; out = out->next)
alpar@9	5264 { k++;
alpar@9	5265 dca->name[k] = out->name;
alpar@9	5266 dca->type[k] = '?';
alpar@9	5267 dca->num[k] = 0.0;
alpar@9	5268 dca->str[k] = xmalloc(MAX_LENGTH+1);
alpar@9	5269 dca->str[k][0] = '\0';
alpar@9	5270 }
alpar@9	5271 /* open output table */
alpar@9	5272 mpl_tab_drv_open(mpl, 'W');
alpar@9	5273 /* evaluate fields and write records */
alpar@9	5274 loop_within_domain(mpl, tab->u.out.domain, tab, write_func);
alpar@9	5275 /* close output table */
alpar@9	5276 mpl_tab_drv_close(mpl);
alpar@9	5277 done: /* free table driver communication area */
alpar@9	5278 free_dca(mpl);
alpar@9	5279 return;
alpar@9	5280 }
alpar@9	5281
alpar@9	5282 void free_dca(MPL *mpl)
alpar@9	5283 { /* free table driver communucation area */
alpar@9	5284 TABDCA *dca = mpl->dca;
alpar@9	5285 int k;
alpar@9	5286 if (dca != NULL)
alpar@9	5287 { if (dca->link != NULL)
alpar@9	5288 mpl_tab_drv_close(mpl);
alpar@9	5289 if (dca->arg != NULL)
alpar@9	5290 { for (k = 1; k <= dca->na; k++)
alpar@9	5291 #if 1 /* 28/IX-2008 */
alpar@9	5292 if (dca->arg[k] != NULL)
alpar@9	5293 #endif
alpar@9	5294 xfree(dca->arg[k]);
alpar@9	5295 xfree(dca->arg);
alpar@9	5296 }
alpar@9	5297 if (dca->name != NULL) xfree(dca->name);
alpar@9	5298 if (dca->type != NULL) xfree(dca->type);
alpar@9	5299 if (dca->num != NULL) xfree(dca->num);
alpar@9	5300 if (dca->str != NULL)
alpar@9	5301 { for (k = 1; k <= dca->nf; k++)
alpar@9	5302 xfree(dca->str[k]);
alpar@9	5303 xfree(dca->str);
alpar@9	5304 }
alpar@9	5305 xfree(dca), mpl->dca = NULL;
alpar@9	5306 }
alpar@9	5307 return;
alpar@9	5308 }
alpar@9	5309
alpar@9	5310 void clean_table(MPL mpl, TABLE tab)
alpar@9	5311 { /* clean table statement */
alpar@9	5312 TABARG *arg;
alpar@9	5313 TABOUT *out;
alpar@9	5314 /* clean string list */
alpar@9	5315 for (arg = tab->arg; arg != NULL; arg = arg->next)
alpar@9	5316 clean_code(mpl, arg->code);
alpar@9	5317 switch (tab->type)
alpar@9	5318 { case A_INPUT:
alpar@9	5319 break;
alpar@9	5320 case A_OUTPUT:
alpar@9	5321 /* clean subscript domain */
alpar@9	5322 clean_domain(mpl, tab->u.out.domain);
alpar@9	5323 /* clean output list */
alpar@9	5324 for (out = tab->u.out.list; out != NULL; out = out->next)
alpar@9	5325 clean_code(mpl, out->code);
alpar@9	5326 break;
alpar@9	5327 default:
alpar@9	5328 xassert(tab != tab);
alpar@9	5329 }
alpar@9	5330 return;
alpar@9	5331 }
alpar@9	5332 #endif
alpar@9	5333
alpar@9	5334 /**********************************************************************/
alpar@9	5335 /* * * MODEL STATEMENTS * * */
alpar@9	5336 /**********************************************************************/
alpar@9	5337
alpar@9	5338 /*----------------------------------------------------------------------
alpar@9	5339 -- execute_check - execute check statement.
alpar@9	5340 --
alpar@9	5341 -- This routine executes specified check statement. */
alpar@9	5342
alpar@9	5343 static int check_func(MPL mpl, void info)
alpar@9	5344 { /* this is auxiliary routine to work within domain scope */
alpar@9	5345 CHECK chk = (CHECK )info;
alpar@9	5346 if (!eval_logical(mpl, chk->code))
alpar@9	5347 error(mpl, "check%s failed", format_tuple(mpl, '[',
alpar@9	5348 get_domain_tuple(mpl, chk->domain)));
alpar@9	5349 return 0;
alpar@9	5350 }
alpar@9	5351
alpar@9	5352 void execute_check(MPL mpl, CHECK chk)
alpar@9	5353 { loop_within_domain(mpl, chk->domain, chk, check_func);
alpar@9	5354 return;
alpar@9	5355 }
alpar@9	5356
alpar@9	5357 /*----------------------------------------------------------------------
alpar@9	5358 -- clean_check - clean check statement.
alpar@9	5359 --
alpar@9	5360 -- This routine cleans specified check statement that assumes deleting
alpar@9	5361 -- all stuff dynamically allocated on generating/postsolving phase. */
alpar@9	5362
alpar@9	5363 void clean_check(MPL mpl, CHECK chk)
alpar@9	5364 { /* clean subscript domain */
alpar@9	5365 clean_domain(mpl, chk->domain);
alpar@9	5366 /* clean pseudo-code for computing predicate */
alpar@9	5367 clean_code(mpl, chk->code);
alpar@9	5368 return;
alpar@9	5369 }
alpar@9	5370
alpar@9	5371 /*----------------------------------------------------------------------
alpar@9	5372 -- execute_display - execute display statement.
alpar@9	5373 --
alpar@9	5374 -- This routine executes specified display statement. */
alpar@9	5375
alpar@9	5376 static void display_set(MPL mpl, SET set, MEMBER *memb)
alpar@9	5377 { /* display member of model set */
alpar@9	5378 ELEMSET *s = memb->value.set;
alpar@9	5379 MEMBER *m;
alpar@9	5380 write_text(mpl, "%s%s%s\n", set->name,
alpar@9	5381 format_tuple(mpl, '[', memb->tuple),
alpar@9	5382 s->head == NULL ? " is empty" : ":");
alpar@9	5383 for (m = s->head; m != NULL; m = m->next)
alpar@9	5384 write_text(mpl, " %s\n", format_tuple(mpl, '(', m->tuple));
alpar@9	5385 return;
alpar@9	5386 }
alpar@9	5387
alpar@9	5388 static void display_par(MPL mpl, PARAMETER par, MEMBER *memb)
alpar@9	5389 { /* display member of model parameter */
alpar@9	5390 switch (par->type)
alpar@9	5391 { case A_NUMERIC:
alpar@9	5392 case A_INTEGER:
alpar@9	5393 case A_BINARY:
alpar@9	5394 write_text(mpl, "%s%s = %.*g\n", par->name,
alpar@9	5395 format_tuple(mpl, '[', memb->tuple),
alpar@9	5396 DBL_DIG, memb->value.num);
alpar@9	5397 break;
alpar@9	5398 case A_SYMBOLIC:
alpar@9	5399 write_text(mpl, "%s%s = %s\n", par->name,
alpar@9	5400 format_tuple(mpl, '[', memb->tuple),
alpar@9	5401 format_symbol(mpl, memb->value.sym));
alpar@9	5402 break;
alpar@9	5403 default:
alpar@9	5404 xassert(par != par);
alpar@9	5405 }
alpar@9	5406 return;
alpar@9	5407 }
alpar@9	5408
alpar@9	5409 #if 1 /* 15/V-2010 */
alpar@9	5410 static void display_var(MPL mpl, VARIABLE var, MEMBER *memb,
alpar@9	5411 int suff)
alpar@9	5412 { /* display member of model variable */
alpar@9	5413 if (suff == DOT_NONE \|\| suff == DOT_VAL)
alpar@9	5414 write_text(mpl, "%s%s.val = %.*g\n", var->name,
alpar@9	5415 format_tuple(mpl, '[', memb->tuple), DBL_DIG,
alpar@9	5416 memb->value.var->prim);
alpar@9	5417 else if (suff == DOT_LB)
alpar@9	5418 write_text(mpl, "%s%s.lb = %.*g\n", var->name,
alpar@9	5419 format_tuple(mpl, '[', memb->tuple), DBL_DIG,
alpar@9	5420 memb->value.var->var->lbnd == NULL ? -DBL_MAX :
alpar@9	5421 memb->value.var->lbnd);
alpar@9	5422 else if (suff == DOT_UB)
alpar@9	5423 write_text(mpl, "%s%s.ub = %.*g\n", var->name,
alpar@9	5424 format_tuple(mpl, '[', memb->tuple), DBL_DIG,
alpar@9	5425 memb->value.var->var->ubnd == NULL ? +DBL_MAX :
alpar@9	5426 memb->value.var->ubnd);
alpar@9	5427 else if (suff == DOT_STATUS)
alpar@9	5428 write_text(mpl, "%s%s.status = %d\n", var->name, format_tuple
alpar@9	5429 (mpl, '[', memb->tuple), memb->value.var->stat);
alpar@9	5430 else if (suff == DOT_DUAL)
alpar@9	5431 write_text(mpl, "%s%s.dual = %.*g\n", var->name,
alpar@9	5432 format_tuple(mpl, '[', memb->tuple), DBL_DIG,
alpar@9	5433 memb->value.var->dual);
alpar@9	5434 else
alpar@9	5435 xassert(suff != suff);
alpar@9	5436 return;
alpar@9	5437 }
alpar@9	5438 #endif
alpar@9	5439
alpar@9	5440 #if 1 /* 15/V-2010 */
alpar@9	5441 static void display_con(MPL mpl, CONSTRAINT con, MEMBER *memb,
alpar@9	5442 int suff)
alpar@9	5443 { /* display member of model constraint */
alpar@9	5444 if (suff == DOT_NONE \|\| suff == DOT_VAL)
alpar@9	5445 write_text(mpl, "%s%s.val = %.*g\n", con->name,
alpar@9	5446 format_tuple(mpl, '[', memb->tuple), DBL_DIG,
alpar@9	5447 memb->value.con->prim);
alpar@9	5448 else if (suff == DOT_LB)
alpar@9	5449 write_text(mpl, "%s%s.lb = %.*g\n", con->name,
alpar@9	5450 format_tuple(mpl, '[', memb->tuple), DBL_DIG,
alpar@9	5451 memb->value.con->con->lbnd == NULL ? -DBL_MAX :
alpar@9	5452 memb->value.con->lbnd);
alpar@9	5453 else if (suff == DOT_UB)
alpar@9	5454 write_text(mpl, "%s%s.ub = %.*g\n", con->name,
alpar@9	5455 format_tuple(mpl, '[', memb->tuple), DBL_DIG,
alpar@9	5456 memb->value.con->con->ubnd == NULL ? +DBL_MAX :
alpar@9	5457 memb->value.con->ubnd);
alpar@9	5458 else if (suff == DOT_STATUS)
alpar@9	5459 write_text(mpl, "%s%s.status = %d\n", con->name, format_tuple
alpar@9	5460 (mpl, '[', memb->tuple), memb->value.con->stat);
alpar@9	5461 else if (suff == DOT_DUAL)
alpar@9	5462 write_text(mpl, "%s%s.dual = %.*g\n", con->name,
alpar@9	5463 format_tuple(mpl, '[', memb->tuple), DBL_DIG,
alpar@9	5464 memb->value.con->dual);
alpar@9	5465 else
alpar@9	5466 xassert(suff != suff);
alpar@9	5467 return;
alpar@9	5468 }
alpar@9	5469 #endif
alpar@9	5470
alpar@9	5471 static void display_memb(MPL mpl, CODE code)
alpar@9	5472 { /* display member specified by pseudo-code */
alpar@9	5473 MEMBER memb;
alpar@9	5474 ARG_LIST *e;
alpar@9	5475 xassert(code->op == O_MEMNUM \|\| code->op == O_MEMSYM
alpar@9	5476 \|\| code->op == O_MEMSET \|\| code->op == O_MEMVAR
alpar@9	5477 \|\| code->op == O_MEMCON);
alpar@9	5478 memb.tuple = create_tuple(mpl);
alpar@9	5479 for (e = code->arg.par.list; e != NULL; e = e->next)
alpar@9	5480 memb.tuple = expand_tuple(mpl, memb.tuple, eval_symbolic(mpl,
alpar@9	5481 e->x));
alpar@9	5482 switch (code->op)
alpar@9	5483 { case O_MEMNUM:
alpar@9	5484 memb.value.num = eval_member_num(mpl, code->arg.par.par,
alpar@9	5485 memb.tuple);
alpar@9	5486 display_par(mpl, code->arg.par.par, &memb);
alpar@9	5487 break;
alpar@9	5488 case O_MEMSYM:
alpar@9	5489 memb.value.sym = eval_member_sym(mpl, code->arg.par.par,
alpar@9	5490 memb.tuple);
alpar@9	5491 display_par(mpl, code->arg.par.par, &memb);
alpar@9	5492 delete_symbol(mpl, memb.value.sym);
alpar@9	5493 break;
alpar@9	5494 case O_MEMSET:
alpar@9	5495 memb.value.set = eval_member_set(mpl, code->arg.set.set,
alpar@9	5496 memb.tuple);
alpar@9	5497 display_set(mpl, code->arg.set.set, &memb);
alpar@9	5498 break;
alpar@9	5499 case O_MEMVAR:
alpar@9	5500 memb.value.var = eval_member_var(mpl, code->arg.var.var,
alpar@9	5501 memb.tuple);
alpar@9	5502 display_var
alpar@9	5503 (mpl, code->arg.var.var, &memb, code->arg.var.suff);
alpar@9	5504 break;
alpar@9	5505 case O_MEMCON:
alpar@9	5506 memb.value.con = eval_member_con(mpl, code->arg.con.con,
alpar@9	5507 memb.tuple);
alpar@9	5508 display_con
alpar@9	5509 (mpl, code->arg.con.con, &memb, code->arg.con.suff);
alpar@9	5510 break;
alpar@9	5511 default:
alpar@9	5512 xassert(code != code);
alpar@9	5513 }
alpar@9	5514 delete_tuple(mpl, memb.tuple);
alpar@9	5515 return;
alpar@9	5516 }
alpar@9	5517
alpar@9	5518 static void display_code(MPL mpl, CODE code)
alpar@9	5519 { /* display value of expression */
alpar@9	5520 switch (code->type)
alpar@9	5521 { case A_NUMERIC:
alpar@9	5522 /* numeric value */
alpar@9	5523 { double num;
alpar@9	5524 num = eval_numeric(mpl, code);
alpar@9	5525 write_text(mpl, "%.*g\n", DBL_DIG, num);
alpar@9	5526 }
alpar@9	5527 break;
alpar@9	5528 case A_SYMBOLIC:
alpar@9	5529 /* symbolic value */
alpar@9	5530 { SYMBOL *sym;
alpar@9	5531 sym = eval_symbolic(mpl, code);
alpar@9	5532 write_text(mpl, "%s\n", format_symbol(mpl, sym));
alpar@9	5533 delete_symbol(mpl, sym);
alpar@9	5534 }
alpar@9	5535 break;
alpar@9	5536 case A_LOGICAL:
alpar@9	5537 /* logical value */
alpar@9	5538 { int bit;
alpar@9	5539 bit = eval_logical(mpl, code);
alpar@9	5540 write_text(mpl, "%s\n", bit ? "true" : "false");
alpar@9	5541 }
alpar@9	5542 break;
alpar@9	5543 case A_TUPLE:
alpar@9	5544 /* n-tuple */
alpar@9	5545 { TUPLE *tuple;
alpar@9	5546 tuple = eval_tuple(mpl, code);
alpar@9	5547 write_text(mpl, "%s\n", format_tuple(mpl, '(', tuple));
alpar@9	5548 delete_tuple(mpl, tuple);
alpar@9	5549 }
alpar@9	5550 break;
alpar@9	5551 case A_ELEMSET:
alpar@9	5552 /* elemental set */
alpar@9	5553 { ELEMSET *set;
alpar@9	5554 MEMBER *memb;
alpar@9	5555 set = eval_elemset(mpl, code);
alpar@9	5556 if (set->head == 0)
alpar@9	5557 write_text(mpl, "set is empty\n");
alpar@9	5558 for (memb = set->head; memb != NULL; memb = memb->next)
alpar@9	5559 write_text(mpl, " %s\n", format_tuple(mpl, '(',
alpar@9	5560 memb->tuple));
alpar@9	5561 delete_elemset(mpl, set);
alpar@9	5562 }
alpar@9	5563 break;
alpar@9	5564 case A_FORMULA:
alpar@9	5565 /* linear form */
alpar@9	5566 { FORMULA form, term;
alpar@9	5567 form = eval_formula(mpl, code);
alpar@9	5568 if (form == NULL)
alpar@9	5569 write_text(mpl, "linear form is empty\n");
alpar@9	5570 for (term = form; term != NULL; term = term->next)
alpar@9	5571 { if (term->var == NULL)
alpar@9	5572 write_text(mpl, " %.*g\n", term->coef);
alpar@9	5573 else
alpar@9	5574 write_text(mpl, " %.*g %s%s\n", DBL_DIG,
alpar@9	5575 term->coef, term->var->var->name,
alpar@9	5576 format_tuple(mpl, '[', term->var->memb->tuple));
alpar@9	5577 }
alpar@9	5578 delete_formula(mpl, form);
alpar@9	5579 }
alpar@9	5580 break;
alpar@9	5581 default:
alpar@9	5582 xassert(code != code);
alpar@9	5583 }
alpar@9	5584 return;
alpar@9	5585 }
alpar@9	5586
alpar@9	5587 static int display_func(MPL mpl, void info)
alpar@9	5588 { /* this is auxiliary routine to work within domain scope */
alpar@9	5589 DISPLAY dpy = (DISPLAY )info;
alpar@9	5590 DISPLAY1 *entry;
alpar@9	5591 for (entry = dpy->list; entry != NULL; entry = entry->next)
alpar@9	5592 { if (entry->type == A_INDEX)
alpar@9	5593 { /* dummy index */
alpar@9	5594 DOMAIN_SLOT *slot = entry->u.slot;
alpar@9	5595 write_text(mpl, "%s = %s\n", slot->name,
alpar@9	5596 format_symbol(mpl, slot->value));
alpar@9	5597 }
alpar@9	5598 else if (entry->type == A_SET)
alpar@9	5599 { /* model set */
alpar@9	5600 SET *set = entry->u.set;
alpar@9	5601 MEMBER *memb;
alpar@9	5602 if (set->assign != NULL)
alpar@9	5603 { /* the set has assignment expression; evaluate all its
alpar@9	5604 members over entire domain */
alpar@9	5605 eval_whole_set(mpl, set);
alpar@9	5606 }
alpar@9	5607 else
alpar@9	5608 { /* the set has no assignment expression; refer to its
alpar@9	5609 any existing member ignoring resultant value to check
alpar@9	5610 the data provided the data section */
alpar@9	5611 #if 1 /* 12/XII-2008 */
alpar@9	5612 if (set->gadget != NULL && set->data == 0)
alpar@9	5613 { /* initialize the set with data from a plain set */
alpar@9	5614 saturate_set(mpl, set);
alpar@9	5615 }
alpar@9	5616 #endif
alpar@9	5617 if (set->array->head != NULL)
alpar@9	5618 eval_member_set(mpl, set, set->array->head->tuple);
alpar@9	5619 }
alpar@9	5620 /* display all members of the set array */
alpar@9	5621 if (set->array->head == NULL)
alpar@9	5622 write_text(mpl, "%s has empty content\n", set->name);
alpar@9	5623 for (memb = set->array->head; memb != NULL; memb =
alpar@9	5624 memb->next) display_set(mpl, set, memb);
alpar@9	5625 }
alpar@9	5626 else if (entry->type == A_PARAMETER)
alpar@9	5627 { /* model parameter */
alpar@9	5628 PARAMETER *par = entry->u.par;
alpar@9	5629 MEMBER *memb;
alpar@9	5630 if (par->assign != NULL)
alpar@9	5631 { /* the parameter has an assignment expression; evaluate
alpar@9	5632 all its member over entire domain */
alpar@9	5633 eval_whole_par(mpl, par);
alpar@9	5634 }
alpar@9	5635 else
alpar@9	5636 { /* the parameter has no assignment expression; refer to
alpar@9	5637 its any existing member ignoring resultant value to
alpar@9	5638 check the data provided in the data section */
alpar@9	5639 if (par->array->head != NULL)
alpar@9	5640 { if (par->type != A_SYMBOLIC)
alpar@9	5641 eval_member_num(mpl, par, par->array->head->tuple);
alpar@9	5642 else
alpar@9	5643 delete_symbol(mpl, eval_member_sym(mpl, par,
alpar@9	5644 par->array->head->tuple));
alpar@9	5645 }
alpar@9	5646 }
alpar@9	5647 /* display all members of the parameter array */
alpar@9	5648 if (par->array->head == NULL)
alpar@9	5649 write_text(mpl, "%s has empty content\n", par->name);
alpar@9	5650 for (memb = par->array->head; memb != NULL; memb =
alpar@9	5651 memb->next) display_par(mpl, par, memb);
alpar@9	5652 }
alpar@9	5653 else if (entry->type == A_VARIABLE)
alpar@9	5654 { /* model variable */
alpar@9	5655 VARIABLE *var = entry->u.var;
alpar@9	5656 MEMBER *memb;
alpar@9	5657 xassert(mpl->flag_p);
alpar@9	5658 /* display all members of the variable array */
alpar@9	5659 if (var->array->head == NULL)
alpar@9	5660 write_text(mpl, "%s has empty content\n", var->name);
alpar@9	5661 for (memb = var->array->head; memb != NULL; memb =
alpar@9	5662 memb->next) display_var(mpl, var, memb, DOT_NONE);
alpar@9	5663 }
alpar@9	5664 else if (entry->type == A_CONSTRAINT)
alpar@9	5665 { /* model constraint */
alpar@9	5666 CONSTRAINT *con = entry->u.con;
alpar@9	5667 MEMBER *memb;
alpar@9	5668 xassert(mpl->flag_p);
alpar@9	5669 /* display all members of the constraint array */
alpar@9	5670 if (con->array->head == NULL)
alpar@9	5671 write_text(mpl, "%s has empty content\n", con->name);
alpar@9	5672 for (memb = con->array->head; memb != NULL; memb =
alpar@9	5673 memb->next) display_con(mpl, con, memb, DOT_NONE);
alpar@9	5674 }
alpar@9	5675 else if (entry->type == A_EXPRESSION)
alpar@9	5676 { /* expression */
alpar@9	5677 CODE *code = entry->u.code;
alpar@9	5678 if (code->op == O_MEMNUM \|\| code->op == O_MEMSYM \|\|
alpar@9	5679 code->op == O_MEMSET \|\| code->op == O_MEMVAR \|\|
alpar@9	5680 code->op == O_MEMCON)
alpar@9	5681 display_memb(mpl, code);
alpar@9	5682 else
alpar@9	5683 display_code(mpl, code);
alpar@9	5684 }
alpar@9	5685 else
alpar@9	5686 xassert(entry != entry);
alpar@9	5687 }
alpar@9	5688 return 0;
alpar@9	5689 }
alpar@9	5690
alpar@9	5691 void execute_display(MPL mpl, DISPLAY dpy)
alpar@9	5692 { loop_within_domain(mpl, dpy->domain, dpy, display_func);
alpar@9	5693 return;
alpar@9	5694 }
alpar@9	5695
alpar@9	5696 /*----------------------------------------------------------------------
alpar@9	5697 -- clean_display - clean display statement.
alpar@9	5698 --
alpar@9	5699 -- This routine cleans specified display statement that assumes deleting
alpar@9	5700 -- all stuff dynamically allocated on generating/postsolving phase. */
alpar@9	5701
alpar@9	5702 void clean_display(MPL mpl, DISPLAY dpy)
alpar@9	5703 { DISPLAY1 *d;
alpar@9	5704 #if 0 /* 15/V-2010 */
alpar@9	5705 ARG_LIST *e;
alpar@9	5706 #endif
alpar@9	5707 /* clean subscript domain */
alpar@9	5708 clean_domain(mpl, dpy->domain);
alpar@9	5709 /* clean display list */
alpar@9	5710 for (d = dpy->list; d != NULL; d = d->next)
alpar@9	5711 { /* clean pseudo-code for computing expression */
alpar@9	5712 if (d->type == A_EXPRESSION)
alpar@9	5713 clean_code(mpl, d->u.code);
alpar@9	5714 #if 0 /* 15/V-2010 */
alpar@9	5715 /* clean pseudo-code for computing subscripts */
alpar@9	5716 for (e = d->list; e != NULL; e = e->next)
alpar@9	5717 clean_code(mpl, e->x);
alpar@9	5718 #endif
alpar@9	5719 }
alpar@9	5720 return;
alpar@9	5721 }
alpar@9	5722
alpar@9	5723 /*----------------------------------------------------------------------
alpar@9	5724 -- execute_printf - execute printf statement.
alpar@9	5725 --
alpar@9	5726 -- This routine executes specified printf statement. */
alpar@9	5727
alpar@9	5728 #if 1 /* 14/VII-2006 */
alpar@9	5729 static void print_char(MPL *mpl, int c)
alpar@9	5730 { if (mpl->prt_fp == NULL)
alpar@9	5731 write_char(mpl, c);
alpar@9	5732 else
alpar@9	5733 xfputc(c, mpl->prt_fp);
alpar@9	5734 return;
alpar@9	5735 }
alpar@9	5736
alpar@9	5737 static void print_text(MPL mpl, char fmt, ...)
alpar@9	5738 { va_list arg;
alpar@9	5739 char buf[OUTBUF_SIZE], *c;
alpar@9	5740 va_start(arg, fmt);
alpar@9	5741 vsprintf(buf, fmt, arg);
alpar@9	5742 xassert(strlen(buf) < sizeof(buf));
alpar@9	5743 va_end(arg);
alpar@9	5744 for (c = buf; c != '\0'; c++) print_char(mpl, c);
alpar@9	5745 return;
alpar@9	5746 }
alpar@9	5747 #endif
alpar@9	5748
alpar@9	5749 static int printf_func(MPL mpl, void info)
alpar@9	5750 { /* this is auxiliary routine to work within domain scope */
alpar@9	5751 PRINTF prt = (PRINTF )info;
alpar@9	5752 PRINTF1 *entry;
alpar@9	5753 SYMBOL *sym;
alpar@9	5754 char fmt[MAX_LENGTH+1], c, from, save;
alpar@9	5755 /* evaluate format control string */
alpar@9	5756 sym = eval_symbolic(mpl, prt->fmt);
alpar@9	5757 if (sym->str == NULL)
alpar@9	5758 sprintf(fmt, "%.*g", DBL_DIG, sym->num);
alpar@9	5759 else
alpar@9	5760 fetch_string(mpl, sym->str, fmt);
alpar@9	5761 delete_symbol(mpl, sym);
alpar@9	5762 /* scan format control string and perform formatting output */
alpar@9	5763 entry = prt->list;
alpar@9	5764 for (c = fmt; *c != '\0'; c++)
alpar@9	5765 { if (*c == '%')
alpar@9	5766 { /* scan format specifier */
alpar@9	5767 from = c++;
alpar@9	5768 if (*c == '%')
alpar@9	5769 { print_char(mpl, '%');
alpar@9	5770 continue;
alpar@9	5771 }
alpar@9	5772 if (entry == NULL) break;
alpar@9	5773 /* scan optional flags */
alpar@9	5774 while (c == '-' \|\| c == '+' \|\| c == ' ' \|\| c == '#' \|\|
alpar@9	5775 *c == '0') c++;
alpar@9	5776 /* scan optional minimum field width */
alpar@9	5777 while (isdigit((unsigned char)*c)) c++;
alpar@9	5778 /* scan optional precision */
alpar@9	5779 if (*c == '.')
alpar@9	5780 { c++;
alpar@9	5781 while (isdigit((unsigned char)*c)) c++;
alpar@9	5782 }
alpar@9	5783 /* scan conversion specifier and perform formatting */
alpar@9	5784 save = (c+1), (c+1) = '\0';
alpar@9	5785 if (c == 'd' \|\| c == 'i' \|\| c == 'e' \|\| c == 'E' \|\|
alpar@9	5786 c == 'f' \|\| c == 'F' \|\| c == 'g' \|\| c == 'G')
alpar@9	5787 { /* the specifier requires numeric value */
alpar@9	5788 double value;
alpar@9	5789 xassert(entry != NULL);
alpar@9	5790 switch (entry->code->type)
alpar@9	5791 { case A_NUMERIC:
alpar@9	5792 value = eval_numeric(mpl, entry->code);
alpar@9	5793 break;
alpar@9	5794 case A_SYMBOLIC:
alpar@9	5795 sym = eval_symbolic(mpl, entry->code);
alpar@9	5796 if (sym->str != NULL)
alpar@9	5797 error(mpl, "cannot convert %s to floating-point"
alpar@9	5798 " number", format_symbol(mpl, sym));
alpar@9	5799 value = sym->num;
alpar@9	5800 delete_symbol(mpl, sym);
alpar@9	5801 break;
alpar@9	5802 case A_LOGICAL:
alpar@9	5803 if (eval_logical(mpl, entry->code))
alpar@9	5804 value = 1.0;
alpar@9	5805 else
alpar@9	5806 value = 0.0;
alpar@9	5807 break;
alpar@9	5808 default:
alpar@9	5809 xassert(entry != entry);
alpar@9	5810 }
alpar@9	5811 if (c == 'd' \|\| c == 'i')
alpar@9	5812 { double int_max = (double)INT_MAX;
alpar@9	5813 if (!(-int_max <= value && value <= +int_max))
alpar@9	5814 error(mpl, "cannot convert %.*g to integer",
alpar@9	5815 DBL_DIG, value);
alpar@9	5816 print_text(mpl, from, (int)floor(value + 0.5));
alpar@9	5817 }
alpar@9	5818 else
alpar@9	5819 print_text(mpl, from, value);
alpar@9	5820 }
alpar@9	5821 else if (*c == 's')
alpar@9	5822 { /* the specifier requires symbolic value */
alpar@9	5823 char value[MAX_LENGTH+1];
alpar@9	5824 switch (entry->code->type)
alpar@9	5825 { case A_NUMERIC:
alpar@9	5826 sprintf(value, "%.*g", DBL_DIG, eval_numeric(mpl,
alpar@9	5827 entry->code));
alpar@9	5828 break;
alpar@9	5829 case A_LOGICAL:
alpar@9	5830 if (eval_logical(mpl, entry->code))
alpar@9	5831 strcpy(value, "T");
alpar@9	5832 else
alpar@9	5833 strcpy(value, "F");
alpar@9	5834 break;
alpar@9	5835 case A_SYMBOLIC:
alpar@9	5836 sym = eval_symbolic(mpl, entry->code);
alpar@9	5837 if (sym->str == NULL)
alpar@9	5838 sprintf(value, "%.*g", DBL_DIG, sym->num);
alpar@9	5839 else
alpar@9	5840 fetch_string(mpl, sym->str, value);
alpar@9	5841 delete_symbol(mpl, sym);
alpar@9	5842 break;
alpar@9	5843 default:
alpar@9	5844 xassert(entry != entry);
alpar@9	5845 }
alpar@9	5846 print_text(mpl, from, value);
alpar@9	5847 }
alpar@9	5848 else
alpar@9	5849 error(mpl, "format specifier missing or invalid");
alpar@9	5850 *(c+1) = save;
alpar@9	5851 entry = entry->next;
alpar@9	5852 }
alpar@9	5853 else if (*c == '\\')
alpar@9	5854 { /* write some control character */
alpar@9	5855 c++;
alpar@9	5856 if (*c == 't')
alpar@9	5857 print_char(mpl, '\t');
alpar@9	5858 else if (*c == 'n')
alpar@9	5859 print_char(mpl, '\n');
alpar@9	5860 #if 1 /* 28/X-2010 */
alpar@9	5861 else if (*c == '\0')
alpar@9	5862 { /* format string ends with backslash */
alpar@9	5863 error(mpl, "invalid use of escape character \\ in format"
alpar@9	5864 " control string");
alpar@9	5865 }
alpar@9	5866 #endif
alpar@9	5867 else
alpar@9	5868 print_char(mpl, *c);
alpar@9	5869 }
alpar@9	5870 else
alpar@9	5871 { /* write character without formatting */
alpar@9	5872 print_char(mpl, *c);
alpar@9	5873 }
alpar@9	5874 }
alpar@9	5875 return 0;
alpar@9	5876 }
alpar@9	5877
alpar@9	5878 #if 0 /* 14/VII-2006 */
alpar@9	5879 void execute_printf(MPL mpl, PRINTF prt)
alpar@9	5880 { loop_within_domain(mpl, prt->domain, prt, printf_func);
alpar@9	5881 return;
alpar@9	5882 }
alpar@9	5883 #else
alpar@9	5884 void execute_printf(MPL mpl, PRINTF prt)
alpar@9	5885 { if (prt->fname == NULL)
alpar@9	5886 { /* switch to the standard output */
alpar@9	5887 if (mpl->prt_fp != NULL)
alpar@9	5888 { xfclose(mpl->prt_fp), mpl->prt_fp = NULL;
alpar@9	5889 xfree(mpl->prt_file), mpl->prt_file = NULL;
alpar@9	5890 }
alpar@9	5891 }
alpar@9	5892 else
alpar@9	5893 { /* evaluate file name string */
alpar@9	5894 SYMBOL *sym;
alpar@9	5895 char fname[MAX_LENGTH+1];
alpar@9	5896 sym = eval_symbolic(mpl, prt->fname);
alpar@9	5897 if (sym->str == NULL)
alpar@9	5898 sprintf(fname, "%.*g", DBL_DIG, sym->num);
alpar@9	5899 else
alpar@9	5900 fetch_string(mpl, sym->str, fname);
alpar@9	5901 delete_symbol(mpl, sym);
alpar@9	5902 /* close the current print file, if necessary */
alpar@9	5903 if (mpl->prt_fp != NULL &&
alpar@9	5904 (!prt->app \|\| strcmp(mpl->prt_file, fname) != 0))
alpar@9	5905 { xfclose(mpl->prt_fp), mpl->prt_fp = NULL;
alpar@9	5906 xfree(mpl->prt_file), mpl->prt_file = NULL;
alpar@9	5907 }
alpar@9	5908 /* open the specified print file, if necessary */
alpar@9	5909 if (mpl->prt_fp == NULL)
alpar@9	5910 { mpl->prt_fp = xfopen(fname, prt->app ? "a" : "w");
alpar@9	5911 if (mpl->prt_fp == NULL)
alpar@9	5912 error(mpl, "unable to open `%s' for writing - %s",
alpar@9	5913 fname, xerrmsg());
alpar@9	5914 mpl->prt_file = xmalloc(strlen(fname)+1);
alpar@9	5915 strcpy(mpl->prt_file, fname);
alpar@9	5916 }
alpar@9	5917 }
alpar@9	5918 loop_within_domain(mpl, prt->domain, prt, printf_func);
alpar@9	5919 if (mpl->prt_fp != NULL)
alpar@9	5920 { xfflush(mpl->prt_fp);
alpar@9	5921 if (xferror(mpl->prt_fp))
alpar@9	5922 error(mpl, "writing error to `%s' - %s", mpl->prt_file,
alpar@9	5923 xerrmsg());
alpar@9	5924 }
alpar@9	5925 return;
alpar@9	5926 }
alpar@9	5927 #endif
alpar@9	5928
alpar@9	5929 /*----------------------------------------------------------------------
alpar@9	5930 -- clean_printf - clean printf statement.
alpar@9	5931 --
alpar@9	5932 -- This routine cleans specified printf statement that assumes deleting
alpar@9	5933 -- all stuff dynamically allocated on generating/postsolving phase. */
alpar@9	5934
alpar@9	5935 void clean_printf(MPL mpl, PRINTF prt)
alpar@9	5936 { PRINTF1 *p;
alpar@9	5937 /* clean subscript domain */
alpar@9	5938 clean_domain(mpl, prt->domain);
alpar@9	5939 /* clean pseudo-code for computing format string */
alpar@9	5940 clean_code(mpl, prt->fmt);
alpar@9	5941 /* clean printf list */
alpar@9	5942 for (p = prt->list; p != NULL; p = p->next)
alpar@9	5943 { /* clean pseudo-code for computing value to be printed */
alpar@9	5944 clean_code(mpl, p->code);
alpar@9	5945 }
alpar@9	5946 #if 1 /* 14/VII-2006 */
alpar@9	5947 /* clean pseudo-code for computing file name string */
alpar@9	5948 clean_code(mpl, prt->fname);
alpar@9	5949 #endif
alpar@9	5950 return;
alpar@9	5951 }
alpar@9	5952
alpar@9	5953 /*----------------------------------------------------------------------
alpar@9	5954 -- execute_for - execute for statement.
alpar@9	5955 --
alpar@9	5956 -- This routine executes specified for statement. */
alpar@9	5957
alpar@9	5958 static int for_func(MPL mpl, void info)
alpar@9	5959 { /* this is auxiliary routine to work within domain scope */
alpar@9	5960 FOR fur = (FOR )info;
alpar@9	5961 STATEMENT stmt, save;
alpar@9	5962 save = mpl->stmt;
alpar@9	5963 for (stmt = fur->list; stmt != NULL; stmt = stmt->next)
alpar@9	5964 execute_statement(mpl, stmt);
alpar@9	5965 mpl->stmt = save;
alpar@9	5966 return 0;
alpar@9	5967 }
alpar@9	5968
alpar@9	5969 void execute_for(MPL mpl, FOR fur)
alpar@9	5970 { loop_within_domain(mpl, fur->domain, fur, for_func);
alpar@9	5971 return;
alpar@9	5972 }
alpar@9	5973
alpar@9	5974 /*----------------------------------------------------------------------
alpar@9	5975 -- clean_for - clean for statement.
alpar@9	5976 --
alpar@9	5977 -- This routine cleans specified for statement that assumes deleting all
alpar@9	5978 -- stuff dynamically allocated on generating/postsolving phase. */
alpar@9	5979
alpar@9	5980 void clean_for(MPL mpl, FOR fur)
alpar@9	5981 { STATEMENT *stmt;
alpar@9	5982 /* clean subscript domain */
alpar@9	5983 clean_domain(mpl, fur->domain);
alpar@9	5984 /* clean all sub-statements */
alpar@9	5985 for (stmt = fur->list; stmt != NULL; stmt = stmt->next)
alpar@9	5986 clean_statement(mpl, stmt);
alpar@9	5987 return;
alpar@9	5988 }
alpar@9	5989
alpar@9	5990 /*----------------------------------------------------------------------
alpar@9	5991 -- execute_statement - execute specified model statement.
alpar@9	5992 --
alpar@9	5993 -- This routine executes specified model statement. */
alpar@9	5994
alpar@9	5995 void execute_statement(MPL mpl, STATEMENT stmt)
alpar@9	5996 { mpl->stmt = stmt;
alpar@9	5997 switch (stmt->type)
alpar@9	5998 { case A_SET:
alpar@9	5999 case A_PARAMETER:
alpar@9	6000 case A_VARIABLE:
alpar@9	6001 break;
alpar@9	6002 case A_CONSTRAINT:
alpar@9	6003 xprintf("Generating %s...\n", stmt->u.con->name);
alpar@9	6004 eval_whole_con(mpl, stmt->u.con);
alpar@9	6005 break;
alpar@9	6006 case A_TABLE:
alpar@9	6007 switch (stmt->u.tab->type)
alpar@9	6008 { case A_INPUT:
alpar@9	6009 xprintf("Reading %s...\n", stmt->u.tab->name);
alpar@9	6010 break;
alpar@9	6011 case A_OUTPUT:
alpar@9	6012 xprintf("Writing %s...\n", stmt->u.tab->name);
alpar@9	6013 break;
alpar@9	6014 default:
alpar@9	6015 xassert(stmt != stmt);
alpar@9	6016 }
alpar@9	6017 execute_table(mpl, stmt->u.tab);
alpar@9	6018 break;
alpar@9	6019 case A_SOLVE:
alpar@9	6020 break;
alpar@9	6021 case A_CHECK:
alpar@9	6022 xprintf("Checking (line %d)...\n", stmt->line);
alpar@9	6023 execute_check(mpl, stmt->u.chk);
alpar@9	6024 break;
alpar@9	6025 case A_DISPLAY:
alpar@9	6026 write_text(mpl, "Display statement at line %d\n",
alpar@9	6027 stmt->line);
alpar@9	6028 execute_display(mpl, stmt->u.dpy);
alpar@9	6029 break;
alpar@9	6030 case A_PRINTF:
alpar@9	6031 execute_printf(mpl, stmt->u.prt);
alpar@9	6032 break;
alpar@9	6033 case A_FOR:
alpar@9	6034 execute_for(mpl, stmt->u.fur);
alpar@9	6035 break;
alpar@9	6036 default:
alpar@9	6037 xassert(stmt != stmt);
alpar@9	6038 }
alpar@9	6039 return;
alpar@9	6040 }
alpar@9	6041
alpar@9	6042 /*----------------------------------------------------------------------
alpar@9	6043 -- clean_statement - clean specified model statement.
alpar@9	6044 --
alpar@9	6045 -- This routine cleans specified model statement that assumes deleting
alpar@9	6046 -- all stuff dynamically allocated on generating/postsolving phase. */
alpar@9	6047
alpar@9	6048 void clean_statement(MPL mpl, STATEMENT stmt)
alpar@9	6049 { switch(stmt->type)
alpar@9	6050 { case A_SET:
alpar@9	6051 clean_set(mpl, stmt->u.set); break;
alpar@9	6052 case A_PARAMETER:
alpar@9	6053 clean_parameter(mpl, stmt->u.par); break;
alpar@9	6054 case A_VARIABLE:
alpar@9	6055 clean_variable(mpl, stmt->u.var); break;
alpar@9	6056 case A_CONSTRAINT:
alpar@9	6057 clean_constraint(mpl, stmt->u.con); break;
alpar@9	6058 #if 1 /* 11/II-2008 */
alpar@9	6059 case A_TABLE:
alpar@9	6060 clean_table(mpl, stmt->u.tab); break;
alpar@9	6061 #endif
alpar@9	6062 case A_SOLVE:
alpar@9	6063 break;
alpar@9	6064 case A_CHECK:
alpar@9	6065 clean_check(mpl, stmt->u.chk); break;
alpar@9	6066 case A_DISPLAY:
alpar@9	6067 clean_display(mpl, stmt->u.dpy); break;
alpar@9	6068 case A_PRINTF:
alpar@9	6069 clean_printf(mpl, stmt->u.prt); break;
alpar@9	6070 case A_FOR:
alpar@9	6071 clean_for(mpl, stmt->u.fur); break;
alpar@9	6072 default:
alpar@9	6073 xassert(stmt != stmt);
alpar@9	6074 }
alpar@9	6075 return;
alpar@9	6076 }
alpar@9	6077
alpar@9	6078 /* eof */