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