src/glpmpl02.c
author Alpar Juttner <alpar@cs.elte.hu>
Sun, 05 Dec 2010 17:35:23 +0100
changeset 2 4c8956a7bdf4
permissions -rw-r--r--
Set up CMAKE build environment
alpar@1
     1
/* glpmpl02.c */
alpar@1
     2
alpar@1
     3
/***********************************************************************
alpar@1
     4
*  This code is part of GLPK (GNU Linear Programming Kit).
alpar@1
     5
*
alpar@1
     6
*  Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
alpar@1
     7
*  2009, 2010 Andrew Makhorin, Department for Applied Informatics,
alpar@1
     8
*  Moscow Aviation Institute, Moscow, Russia. All rights reserved.
alpar@1
     9
*  E-mail: <mao@gnu.org>.
alpar@1
    10
*
alpar@1
    11
*  GLPK is free software: you can redistribute it and/or modify it
alpar@1
    12
*  under the terms of the GNU General Public License as published by
alpar@1
    13
*  the Free Software Foundation, either version 3 of the License, or
alpar@1
    14
*  (at your option) any later version.
alpar@1
    15
*
alpar@1
    16
*  GLPK is distributed in the hope that it will be useful, but WITHOUT
alpar@1
    17
*  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
alpar@1
    18
*  or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
alpar@1
    19
*  License for more details.
alpar@1
    20
*
alpar@1
    21
*  You should have received a copy of the GNU General Public License
alpar@1
    22
*  along with GLPK. If not, see <http://www.gnu.org/licenses/>.
alpar@1
    23
***********************************************************************/
alpar@1
    24
alpar@1
    25
#define _GLPSTD_STDIO
alpar@1
    26
#include "glpenv.h"
alpar@1
    27
#include "glpmpl.h"
alpar@1
    28
alpar@1
    29
/**********************************************************************/
alpar@1
    30
/* * *                  PROCESSING DATA SECTION                   * * */
alpar@1
    31
/**********************************************************************/
alpar@1
    32
alpar@1
    33
/*----------------------------------------------------------------------
alpar@1
    34
-- create_slice - create slice.
alpar@1
    35
--
alpar@1
    36
-- This routine creates a slice, which initially has no components. */
alpar@1
    37
alpar@1
    38
SLICE *create_slice(MPL *mpl)
alpar@1
    39
{     SLICE *slice;
alpar@1
    40
      xassert(mpl == mpl);
alpar@1
    41
      slice = NULL;
alpar@1
    42
      return slice;
alpar@1
    43
}
alpar@1
    44
alpar@1
    45
/*----------------------------------------------------------------------
alpar@1
    46
-- expand_slice - append new component to slice.
alpar@1
    47
--
alpar@1
    48
-- This routine expands slice appending to it either a given symbol or
alpar@1
    49
-- null component, which becomes the last component of the slice. */
alpar@1
    50
alpar@1
    51
SLICE *expand_slice
alpar@1
    52
(     MPL *mpl,
alpar@1
    53
      SLICE *slice,           /* destroyed */
alpar@1
    54
      SYMBOL *sym             /* destroyed */
alpar@1
    55
)
alpar@1
    56
{     SLICE *tail, *temp;
alpar@1
    57
      /* create a new component */
alpar@1
    58
      tail = dmp_get_atom(mpl->tuples, sizeof(SLICE));
alpar@1
    59
      tail->sym = sym;
alpar@1
    60
      tail->next = NULL;
alpar@1
    61
      /* and append it to the component list */
alpar@1
    62
      if (slice == NULL)
alpar@1
    63
         slice = tail;
alpar@1
    64
      else
alpar@1
    65
      {  for (temp = slice; temp->next != NULL; temp = temp->next);
alpar@1
    66
         temp->next = tail;
alpar@1
    67
      }
alpar@1
    68
      return slice;
alpar@1
    69
}
alpar@1
    70
alpar@1
    71
/*----------------------------------------------------------------------
alpar@1
    72
-- slice_dimen - determine dimension of slice.
alpar@1
    73
--
alpar@1
    74
-- This routine returns dimension of slice, which is number of all its
alpar@1
    75
-- components including null ones. */
alpar@1
    76
alpar@1
    77
int slice_dimen
alpar@1
    78
(     MPL *mpl,
alpar@1
    79
      SLICE *slice            /* not changed */
alpar@1
    80
)
alpar@1
    81
{     SLICE *temp;
alpar@1
    82
      int dim;
alpar@1
    83
      xassert(mpl == mpl);
alpar@1
    84
      dim = 0;
alpar@1
    85
      for (temp = slice; temp != NULL; temp = temp->next) dim++;
alpar@1
    86
      return dim;
alpar@1
    87
}
alpar@1
    88
alpar@1
    89
/*----------------------------------------------------------------------
alpar@1
    90
-- slice_arity - determine arity of slice.
alpar@1
    91
--
alpar@1
    92
-- This routine returns arity of slice, i.e. number of null components
alpar@1
    93
-- (indicated by asterisks) in the slice. */
alpar@1
    94
alpar@1
    95
int slice_arity
alpar@1
    96
(     MPL *mpl,
alpar@1
    97
      SLICE *slice            /* not changed */
alpar@1
    98
)
alpar@1
    99
{     SLICE *temp;
alpar@1
   100
      int arity;
alpar@1
   101
      xassert(mpl == mpl);
alpar@1
   102
      arity = 0;
alpar@1
   103
      for (temp = slice; temp != NULL; temp = temp->next)
alpar@1
   104
         if (temp->sym == NULL) arity++;
alpar@1
   105
      return arity;
alpar@1
   106
}
alpar@1
   107
alpar@1
   108
/*----------------------------------------------------------------------
alpar@1
   109
-- fake_slice - create fake slice of all asterisks.
alpar@1
   110
--
alpar@1
   111
-- This routine creates a fake slice of given dimension, which contains
alpar@1
   112
-- asterisks in all components. Zero dimension is allowed. */
alpar@1
   113
alpar@1
   114
SLICE *fake_slice(MPL *mpl, int dim)
alpar@1
   115
{     SLICE *slice;
alpar@1
   116
      slice = create_slice(mpl);
alpar@1
   117
      while (dim-- > 0) slice = expand_slice(mpl, slice, NULL);
alpar@1
   118
      return slice;
alpar@1
   119
}
alpar@1
   120
alpar@1
   121
/*----------------------------------------------------------------------
alpar@1
   122
-- delete_slice - delete slice.
alpar@1
   123
--
alpar@1
   124
-- This routine deletes specified slice. */
alpar@1
   125
alpar@1
   126
void delete_slice
alpar@1
   127
(     MPL *mpl,
alpar@1
   128
      SLICE *slice            /* destroyed */
alpar@1
   129
)
alpar@1
   130
{     SLICE *temp;
alpar@1
   131
      while (slice != NULL)
alpar@1
   132
      {  temp = slice;
alpar@1
   133
         slice = temp->next;
alpar@1
   134
         if (temp->sym != NULL) delete_symbol(mpl, temp->sym);
alpar@1
   135
xassert(sizeof(SLICE) == sizeof(TUPLE));
alpar@1
   136
         dmp_free_atom(mpl->tuples, temp, sizeof(TUPLE));
alpar@1
   137
      }
alpar@1
   138
      return;
alpar@1
   139
}
alpar@1
   140
alpar@1
   141
/*----------------------------------------------------------------------
alpar@1
   142
-- is_number - check if current token is number.
alpar@1
   143
--
alpar@1
   144
-- If the current token is a number, this routine returns non-zero.
alpar@1
   145
-- Otherwise zero is returned. */
alpar@1
   146
alpar@1
   147
int is_number(MPL *mpl)
alpar@1
   148
{     return
alpar@1
   149
         mpl->token == T_NUMBER;
alpar@1
   150
}
alpar@1
   151
alpar@1
   152
/*----------------------------------------------------------------------
alpar@1
   153
-- is_symbol - check if current token is symbol.
alpar@1
   154
--
alpar@1
   155
-- If the current token is suitable to be a symbol, the routine returns
alpar@1
   156
-- non-zero. Otherwise zero is returned. */
alpar@1
   157
alpar@1
   158
int is_symbol(MPL *mpl)
alpar@1
   159
{     return
alpar@1
   160
         mpl->token == T_NUMBER ||
alpar@1
   161
         mpl->token == T_SYMBOL ||
alpar@1
   162
         mpl->token == T_STRING;
alpar@1
   163
}
alpar@1
   164
alpar@1
   165
/*----------------------------------------------------------------------
alpar@1
   166
-- is_literal - check if current token is given symbolic literal.
alpar@1
   167
--
alpar@1
   168
-- If the current token is given symbolic literal, this routine returns
alpar@1
   169
-- non-zero. Otherwise zero is returned.
alpar@1
   170
--
alpar@1
   171
-- This routine is used on processing the data section in the same way
alpar@1
   172
-- as the routine is_keyword on processing the model section. */
alpar@1
   173
alpar@1
   174
int is_literal(MPL *mpl, char *literal)
alpar@1
   175
{     return
alpar@1
   176
         is_symbol(mpl) && strcmp(mpl->image, literal) == 0;
alpar@1
   177
}
alpar@1
   178
alpar@1
   179
/*----------------------------------------------------------------------
alpar@1
   180
-- read_number - read number.
alpar@1
   181
--
alpar@1
   182
-- This routine reads the current token, which must be a number, and
alpar@1
   183
-- returns its numeric value. */
alpar@1
   184
alpar@1
   185
double read_number(MPL *mpl)
alpar@1
   186
{     double num;
alpar@1
   187
      xassert(is_number(mpl));
alpar@1
   188
      num = mpl->value;
alpar@1
   189
      get_token(mpl /* <number> */);
alpar@1
   190
      return num;
alpar@1
   191
}
alpar@1
   192
alpar@1
   193
/*----------------------------------------------------------------------
alpar@1
   194
-- read_symbol - read symbol.
alpar@1
   195
--
alpar@1
   196
-- This routine reads the current token, which must be a symbol, and
alpar@1
   197
-- returns its symbolic value. */
alpar@1
   198
alpar@1
   199
SYMBOL *read_symbol(MPL *mpl)
alpar@1
   200
{     SYMBOL *sym;
alpar@1
   201
      xassert(is_symbol(mpl));
alpar@1
   202
      if (is_number(mpl))
alpar@1
   203
         sym = create_symbol_num(mpl, mpl->value);
alpar@1
   204
      else
alpar@1
   205
         sym = create_symbol_str(mpl, create_string(mpl, mpl->image));
alpar@1
   206
      get_token(mpl /* <symbol> */);
alpar@1
   207
      return sym;
alpar@1
   208
}
alpar@1
   209
alpar@1
   210
/*----------------------------------------------------------------------
alpar@1
   211
-- read_slice - read slice.
alpar@1
   212
--
alpar@1
   213
-- This routine reads slice using the syntax:
alpar@1
   214
--
alpar@1
   215
-- <slice> ::= [ <symbol list> ]
alpar@1
   216
-- <slice> ::= ( <symbol list> )
alpar@1
   217
-- <symbol list> ::= <symbol or star>
alpar@1
   218
-- <symbol list> ::= <symbol list> , <symbol or star>
alpar@1
   219
-- <symbol or star> ::= <symbol>
alpar@1
   220
-- <symbol or star> ::= *
alpar@1
   221
--
alpar@1
   222
-- The bracketed form of slice is used for members of multi-dimensional
alpar@1
   223
-- objects while the parenthesized form is used for elemental sets. */
alpar@1
   224
alpar@1
   225
SLICE *read_slice
alpar@1
   226
(     MPL *mpl,
alpar@1
   227
      char *name,             /* not changed */
alpar@1
   228
      int dim
alpar@1
   229
)
alpar@1
   230
{     SLICE *slice;
alpar@1
   231
      int close;
alpar@1
   232
      xassert(name != NULL);
alpar@1
   233
      switch (mpl->token)
alpar@1
   234
      {  case T_LBRACKET:
alpar@1
   235
            close = T_RBRACKET;
alpar@1
   236
            break;
alpar@1
   237
         case T_LEFT:
alpar@1
   238
            xassert(dim > 0);
alpar@1
   239
            close = T_RIGHT;
alpar@1
   240
            break;
alpar@1
   241
         default:
alpar@1
   242
            xassert(mpl != mpl);
alpar@1
   243
      }
alpar@1
   244
      if (dim == 0)
alpar@1
   245
         error(mpl, "%s cannot be subscripted", name);
alpar@1
   246
      get_token(mpl /* ( | [ */);
alpar@1
   247
      /* read slice components */
alpar@1
   248
      slice = create_slice(mpl);
alpar@1
   249
      for (;;)
alpar@1
   250
      {  /* the current token must be a symbol or asterisk */
alpar@1
   251
         if (is_symbol(mpl))
alpar@1
   252
            slice = expand_slice(mpl, slice, read_symbol(mpl));
alpar@1
   253
         else if (mpl->token == T_ASTERISK)
alpar@1
   254
         {  slice = expand_slice(mpl, slice, NULL);
alpar@1
   255
            get_token(mpl /* * */);
alpar@1
   256
         }
alpar@1
   257
         else
alpar@1
   258
            error(mpl, "number, symbol, or asterisk missing where expec"
alpar@1
   259
               "ted");
alpar@1
   260
         /* check a token that follows the symbol */
alpar@1
   261
         if (mpl->token == T_COMMA)
alpar@1
   262
            get_token(mpl /* , */);
alpar@1
   263
         else if (mpl->token == close)
alpar@1
   264
            break;
alpar@1
   265
         else
alpar@1
   266
            error(mpl, "syntax error in slice");
alpar@1
   267
      }
alpar@1
   268
      /* number of slice components must be the same as the appropriate
alpar@1
   269
         dimension */
alpar@1
   270
      if (slice_dimen(mpl, slice) != dim)
alpar@1
   271
      {  switch (close)
alpar@1
   272
         {  case T_RBRACKET:
alpar@1
   273
               error(mpl, "%s must have %d subscript%s, not %d", name,
alpar@1
   274
                  dim, dim == 1 ? "" : "s", slice_dimen(mpl, slice));
alpar@1
   275
               break;
alpar@1
   276
            case T_RIGHT:
alpar@1
   277
               error(mpl, "%s has dimension %d, not %d", name, dim,
alpar@1
   278
                  slice_dimen(mpl, slice));
alpar@1
   279
               break;
alpar@1
   280
            default:
alpar@1
   281
               xassert(close != close);
alpar@1
   282
         }
alpar@1
   283
      }
alpar@1
   284
      get_token(mpl /* ) | ] */);
alpar@1
   285
      return slice;
alpar@1
   286
}
alpar@1
   287
alpar@1
   288
/*----------------------------------------------------------------------
alpar@1
   289
-- select_set - select set to saturate it with elemental sets.
alpar@1
   290
--
alpar@1
   291
-- This routine selects set to saturate it with elemental sets provided
alpar@1
   292
-- in the data section. */
alpar@1
   293
alpar@1
   294
SET *select_set
alpar@1
   295
(     MPL *mpl,
alpar@1
   296
      char *name              /* not changed */
alpar@1
   297
)
alpar@1
   298
{     SET *set;
alpar@1
   299
      AVLNODE *node;
alpar@1
   300
      xassert(name != NULL);
alpar@1
   301
      node = avl_find_node(mpl->tree, name);
alpar@1
   302
      if (node == NULL || avl_get_node_type(node) != A_SET)
alpar@1
   303
         error(mpl, "%s not a set", name);
alpar@1
   304
      set = (SET *)avl_get_node_link(node);
alpar@1
   305
      if (set->assign != NULL || set->gadget != NULL)
alpar@1
   306
         error(mpl, "%s needs no data", name);
alpar@1
   307
      set->data = 1;
alpar@1
   308
      return set;
alpar@1
   309
}
alpar@1
   310
alpar@1
   311
/*----------------------------------------------------------------------
alpar@1
   312
-- simple_format - read set data block in simple format.
alpar@1
   313
--
alpar@1
   314
-- This routine reads set data block using the syntax:
alpar@1
   315
--
alpar@1
   316
-- <simple format> ::= <symbol> , <symbol> , ... , <symbol>
alpar@1
   317
--
alpar@1
   318
-- where <symbols> are used to construct a complete n-tuple, which is
alpar@1
   319
-- included in elemental set assigned to the set member. Commae between
alpar@1
   320
-- symbols are optional and may be omitted anywhere.
alpar@1
   321
--
alpar@1
   322
-- Number of components in the slice must be the same as dimension of
alpar@1
   323
-- n-tuples in elemental sets assigned to the set members. To construct
alpar@1
   324
-- complete n-tuple the routine replaces null positions in the slice by
alpar@1
   325
-- corresponding <symbols>.
alpar@1
   326
--
alpar@1
   327
-- If the slice contains at least one null position, the current token
alpar@1
   328
-- must be symbol. Otherwise, the routine reads no symbols to construct
alpar@1
   329
-- the n-tuple, so the current token is not checked. */
alpar@1
   330
alpar@1
   331
void simple_format
alpar@1
   332
(     MPL *mpl,
alpar@1
   333
      SET *set,               /* not changed */
alpar@1
   334
      MEMBER *memb,           /* modified */
alpar@1
   335
      SLICE *slice            /* not changed */
alpar@1
   336
)
alpar@1
   337
{     TUPLE *tuple;
alpar@1
   338
      SLICE *temp;
alpar@1
   339
      SYMBOL *sym, *with = NULL;
alpar@1
   340
      xassert(set != NULL);
alpar@1
   341
      xassert(memb != NULL);
alpar@1
   342
      xassert(slice != NULL);
alpar@1
   343
      xassert(set->dimen == slice_dimen(mpl, slice));
alpar@1
   344
      xassert(memb->value.set->dim == set->dimen);
alpar@1
   345
      if (slice_arity(mpl, slice) > 0) xassert(is_symbol(mpl));
alpar@1
   346
      /* read symbols and construct complete n-tuple */
alpar@1
   347
      tuple = create_tuple(mpl);
alpar@1
   348
      for (temp = slice; temp != NULL; temp = temp->next)
alpar@1
   349
      {  if (temp->sym == NULL)
alpar@1
   350
         {  /* substitution is needed; read symbol */
alpar@1
   351
            if (!is_symbol(mpl))
alpar@1
   352
            {  int lack = slice_arity(mpl, temp);
alpar@1
   353
               /* with cannot be null due to assertion above */
alpar@1
   354
               xassert(with != NULL);
alpar@1
   355
               if (lack == 1)
alpar@1
   356
                  error(mpl, "one item missing in data group beginning "
alpar@1
   357
                     "with %s", format_symbol(mpl, with));
alpar@1
   358
               else
alpar@1
   359
                  error(mpl, "%d items missing in data group beginning "
alpar@1
   360
                     "with %s", lack, format_symbol(mpl, with));
alpar@1
   361
            }
alpar@1
   362
            sym = read_symbol(mpl);
alpar@1
   363
            if (with == NULL) with = sym;
alpar@1
   364
         }
alpar@1
   365
         else
alpar@1
   366
         {  /* copy symbol from the slice */
alpar@1
   367
            sym = copy_symbol(mpl, temp->sym);
alpar@1
   368
         }
alpar@1
   369
         /* append the symbol to the n-tuple */
alpar@1
   370
         tuple = expand_tuple(mpl, tuple, sym);
alpar@1
   371
         /* skip optional comma *between* <symbols> */
alpar@1
   372
         if (temp->next != NULL && mpl->token == T_COMMA)
alpar@1
   373
            get_token(mpl /* , */);
alpar@1
   374
      }
alpar@1
   375
      /* add constructed n-tuple to elemental set */
alpar@1
   376
      check_then_add(mpl, memb->value.set, tuple);
alpar@1
   377
      return;
alpar@1
   378
}
alpar@1
   379
alpar@1
   380
/*----------------------------------------------------------------------
alpar@1
   381
-- matrix_format - read set data block in matrix format.
alpar@1
   382
--
alpar@1
   383
-- This routine reads set data block using the syntax:
alpar@1
   384
--
alpar@1
   385
-- <matrix format> ::= <column> <column> ... <column> :=
alpar@1
   386
--               <row>   +/-      +/-    ...   +/-
alpar@1
   387
--               <row>   +/-      +/-    ...   +/-
alpar@1
   388
--                 .  .  .  .  .  .  .  .  .  .  .
alpar@1
   389
--               <row>   +/-      +/-    ...   +/-
alpar@1
   390
--
alpar@1
   391
-- where <rows> are symbols that denote rows of the matrix, <columns>
alpar@1
   392
-- are symbols that denote columns of the matrix, "+" and "-" indicate
alpar@1
   393
-- whether corresponding n-tuple needs to be included in the elemental
alpar@1
   394
-- set or not, respectively.
alpar@1
   395
--
alpar@1
   396
-- Number of the slice components must be the same as dimension of the
alpar@1
   397
-- elemental set. The slice must have two null positions. To construct
alpar@1
   398
-- complete n-tuple for particular element of the matrix the routine
alpar@1
   399
-- replaces first null position of the slice by the corresponding <row>
alpar@1
   400
-- (or <column>, if the flag tr is on) and second null position by the
alpar@1
   401
-- corresponding <column> (or by <row>, if the flag tr is on). */
alpar@1
   402
alpar@1
   403
void matrix_format
alpar@1
   404
(     MPL *mpl,
alpar@1
   405
      SET *set,               /* not changed */
alpar@1
   406
      MEMBER *memb,           /* modified */
alpar@1
   407
      SLICE *slice,           /* not changed */
alpar@1
   408
      int tr
alpar@1
   409
)
alpar@1
   410
{     SLICE *list, *col, *temp;
alpar@1
   411
      TUPLE *tuple;
alpar@1
   412
      SYMBOL *row;
alpar@1
   413
      xassert(set != NULL);
alpar@1
   414
      xassert(memb != NULL);
alpar@1
   415
      xassert(slice != NULL);
alpar@1
   416
      xassert(set->dimen == slice_dimen(mpl, slice));
alpar@1
   417
      xassert(memb->value.set->dim == set->dimen);
alpar@1
   418
      xassert(slice_arity(mpl, slice) == 2);
alpar@1
   419
      /* read the matrix heading that contains column symbols (there
alpar@1
   420
         may be no columns at all) */
alpar@1
   421
      list = create_slice(mpl);
alpar@1
   422
      while (mpl->token != T_ASSIGN)
alpar@1
   423
      {  /* read column symbol and append it to the column list */
alpar@1
   424
         if (!is_symbol(mpl))
alpar@1
   425
            error(mpl, "number, symbol, or := missing where expected");
alpar@1
   426
         list = expand_slice(mpl, list, read_symbol(mpl));
alpar@1
   427
      }
alpar@1
   428
      get_token(mpl /* := */);
alpar@1
   429
      /* read zero or more rows that contain matrix data */
alpar@1
   430
      while (is_symbol(mpl))
alpar@1
   431
      {  /* read row symbol (if the matrix has no columns, row symbols
alpar@1
   432
            are just ignored) */
alpar@1
   433
         row = read_symbol(mpl);
alpar@1
   434
         /* read the matrix row accordingly to the column list */
alpar@1
   435
         for (col = list; col != NULL; col = col->next)
alpar@1
   436
         {  int which = 0;
alpar@1
   437
            /* check indicator */
alpar@1
   438
            if (is_literal(mpl, "+"))
alpar@1
   439
               ;
alpar@1
   440
            else if (is_literal(mpl, "-"))
alpar@1
   441
            {  get_token(mpl /* - */);
alpar@1
   442
               continue;
alpar@1
   443
            }
alpar@1
   444
            else
alpar@1
   445
            {  int lack = slice_dimen(mpl, col);
alpar@1
   446
               if (lack == 1)
alpar@1
   447
                  error(mpl, "one item missing in data group beginning "
alpar@1
   448
                     "with %s", format_symbol(mpl, row));
alpar@1
   449
               else
alpar@1
   450
                  error(mpl, "%d items missing in data group beginning "
alpar@1
   451
                     "with %s", lack, format_symbol(mpl, row));
alpar@1
   452
            }
alpar@1
   453
            /* construct complete n-tuple */
alpar@1
   454
            tuple = create_tuple(mpl);
alpar@1
   455
            for (temp = slice; temp != NULL; temp = temp->next)
alpar@1
   456
            {  if (temp->sym == NULL)
alpar@1
   457
               {  /* substitution is needed */
alpar@1
   458
                  switch (++which)
alpar@1
   459
                  {  case 1:
alpar@1
   460
                        /* substitute in the first null position */
alpar@1
   461
                        tuple = expand_tuple(mpl, tuple,
alpar@1
   462
                           copy_symbol(mpl, tr ? col->sym : row));
alpar@1
   463
                        break;
alpar@1
   464
                     case 2:
alpar@1
   465
                        /* substitute in the second null position */
alpar@1
   466
                        tuple = expand_tuple(mpl, tuple,
alpar@1
   467
                           copy_symbol(mpl, tr ? row : col->sym));
alpar@1
   468
                        break;
alpar@1
   469
                     default:
alpar@1
   470
                        xassert(which != which);
alpar@1
   471
                  }
alpar@1
   472
               }
alpar@1
   473
               else
alpar@1
   474
               {  /* copy symbol from the slice */
alpar@1
   475
                  tuple = expand_tuple(mpl, tuple, copy_symbol(mpl,
alpar@1
   476
                     temp->sym));
alpar@1
   477
               }
alpar@1
   478
            }
alpar@1
   479
            xassert(which == 2);
alpar@1
   480
            /* add constructed n-tuple to elemental set */
alpar@1
   481
            check_then_add(mpl, memb->value.set, tuple);
alpar@1
   482
            get_token(mpl /* + */);
alpar@1
   483
         }
alpar@1
   484
         /* delete the row symbol */
alpar@1
   485
         delete_symbol(mpl, row);
alpar@1
   486
      }
alpar@1
   487
      /* delete the column list */
alpar@1
   488
      delete_slice(mpl, list);
alpar@1
   489
      return;
alpar@1
   490
}
alpar@1
   491
alpar@1
   492
/*----------------------------------------------------------------------
alpar@1
   493
-- set_data - read set data.
alpar@1
   494
--
alpar@1
   495
-- This routine reads set data using the syntax:
alpar@1
   496
--
alpar@1
   497
-- <set data> ::= set <set name> <assignments> ;
alpar@1
   498
-- <set data> ::= set <set name> [ <symbol list> ] <assignments> ;
alpar@1
   499
-- <set name> ::= <symbolic name>
alpar@1
   500
-- <assignments> ::= <empty>
alpar@1
   501
-- <assignments> ::= <assignments> , :=
alpar@1
   502
-- <assignments> ::= <assignments> , ( <symbol list> )
alpar@1
   503
-- <assignments> ::= <assignments> , <simple format>
alpar@1
   504
-- <assignments> ::= <assignments> , : <matrix format>
alpar@1
   505
-- <assignments> ::= <assignments> , (tr) <matrix format>
alpar@1
   506
-- <assignments> ::= <assignments> , (tr) : <matrix format>
alpar@1
   507
--
alpar@1
   508
-- Commae in <assignments> are optional and may be omitted anywhere. */
alpar@1
   509
alpar@1
   510
void set_data(MPL *mpl)
alpar@1
   511
{     SET *set;
alpar@1
   512
      TUPLE *tuple;
alpar@1
   513
      MEMBER *memb;
alpar@1
   514
      SLICE *slice;
alpar@1
   515
      int tr = 0;
alpar@1
   516
      xassert(is_literal(mpl, "set"));
alpar@1
   517
      get_token(mpl /* set */);
alpar@1
   518
      /* symbolic name of set must follows the keyword 'set' */
alpar@1
   519
      if (!is_symbol(mpl))
alpar@1
   520
         error(mpl, "set name missing where expected");
alpar@1
   521
      /* select the set to saturate it with data */
alpar@1
   522
      set = select_set(mpl, mpl->image);
alpar@1
   523
      get_token(mpl /* <symbolic name> */);
alpar@1
   524
      /* read optional subscript list, which identifies member of the
alpar@1
   525
         set to be read */
alpar@1
   526
      tuple = create_tuple(mpl);
alpar@1
   527
      if (mpl->token == T_LBRACKET)
alpar@1
   528
      {  /* subscript list is specified */
alpar@1
   529
         if (set->dim == 0)
alpar@1
   530
            error(mpl, "%s cannot be subscripted", set->name);
alpar@1
   531
         get_token(mpl /* [ */);
alpar@1
   532
         /* read symbols and construct subscript list */
alpar@1
   533
         for (;;)
alpar@1
   534
         {  if (!is_symbol(mpl))
alpar@1
   535
               error(mpl, "number or symbol missing where expected");
alpar@1
   536
            tuple = expand_tuple(mpl, tuple, read_symbol(mpl));
alpar@1
   537
            if (mpl->token == T_COMMA)
alpar@1
   538
               get_token(mpl /* , */);
alpar@1
   539
            else if (mpl->token == T_RBRACKET)
alpar@1
   540
               break;
alpar@1
   541
            else
alpar@1
   542
               error(mpl, "syntax error in subscript list");
alpar@1
   543
         }
alpar@1
   544
         if (set->dim != tuple_dimen(mpl, tuple))
alpar@1
   545
            error(mpl, "%s must have %d subscript%s rather than %d",
alpar@1
   546
               set->name, set->dim, set->dim == 1 ? "" : "s",
alpar@1
   547
               tuple_dimen(mpl, tuple));
alpar@1
   548
         get_token(mpl /* ] */);
alpar@1
   549
      }
alpar@1
   550
      else
alpar@1
   551
      {  /* subscript list is not specified */
alpar@1
   552
         if (set->dim != 0)
alpar@1
   553
            error(mpl, "%s must be subscripted", set->name);
alpar@1
   554
      }
alpar@1
   555
      /* there must be no member with the same subscript list */
alpar@1
   556
      if (find_member(mpl, set->array, tuple) != NULL)
alpar@1
   557
         error(mpl, "%s%s already defined",
alpar@1
   558
            set->name, format_tuple(mpl, '[', tuple));
alpar@1
   559
      /* add new member to the set and assign it empty elemental set */
alpar@1
   560
      memb = add_member(mpl, set->array, tuple);
alpar@1
   561
      memb->value.set = create_elemset(mpl, set->dimen);
alpar@1
   562
      /* create an initial fake slice of all asterisks */
alpar@1
   563
      slice = fake_slice(mpl, set->dimen);
alpar@1
   564
      /* read zero or more data assignments */
alpar@1
   565
      for (;;)
alpar@1
   566
      {  /* skip optional comma */
alpar@1
   567
         if (mpl->token == T_COMMA) get_token(mpl /* , */);
alpar@1
   568
         /* process assignment element */
alpar@1
   569
         if (mpl->token == T_ASSIGN)
alpar@1
   570
         {  /* assignment ligature is non-significant element */
alpar@1
   571
            get_token(mpl /* := */);
alpar@1
   572
         }
alpar@1
   573
         else if (mpl->token == T_LEFT)
alpar@1
   574
         {  /* left parenthesis begins either new slice or "transpose"
alpar@1
   575
               indicator */
alpar@1
   576
            int is_tr;
alpar@1
   577
            get_token(mpl /* ( */);
alpar@1
   578
            is_tr = is_literal(mpl, "tr");
alpar@1
   579
            unget_token(mpl /* ( */);
alpar@1
   580
            if (is_tr) goto left;
alpar@1
   581
            /* delete the current slice and read new one */
alpar@1
   582
            delete_slice(mpl, slice);
alpar@1
   583
            slice = read_slice(mpl, set->name, set->dimen);
alpar@1
   584
            /* each new slice resets the "transpose" indicator */
alpar@1
   585
            tr = 0;
alpar@1
   586
            /* if the new slice is 0-ary, formally there is one 0-tuple
alpar@1
   587
               (in the simple format) that follows it */
alpar@1
   588
            if (slice_arity(mpl, slice) == 0)
alpar@1
   589
               simple_format(mpl, set, memb, slice);
alpar@1
   590
         }
alpar@1
   591
         else if (is_symbol(mpl))
alpar@1
   592
         {  /* number or symbol begins data in the simple format */
alpar@1
   593
            simple_format(mpl, set, memb, slice);
alpar@1
   594
         }
alpar@1
   595
         else if (mpl->token == T_COLON)
alpar@1
   596
         {  /* colon begins data in the matrix format */
alpar@1
   597
            if (slice_arity(mpl, slice) != 2)
alpar@1
   598
err1:          error(mpl, "slice currently used must specify 2 asterisk"
alpar@1
   599
                  "s, not %d", slice_arity(mpl, slice));
alpar@1
   600
            get_token(mpl /* : */);
alpar@1
   601
            /* read elemental set data in the matrix format */
alpar@1
   602
            matrix_format(mpl, set, memb, slice, tr);
alpar@1
   603
         }
alpar@1
   604
         else if (mpl->token == T_LEFT)
alpar@1
   605
left:    {  /* left parenthesis begins the "transpose" indicator, which
alpar@1
   606
               is followed by data in the matrix format */
alpar@1
   607
            get_token(mpl /* ( */);
alpar@1
   608
            if (!is_literal(mpl, "tr"))
alpar@1
   609
err2:          error(mpl, "transpose indicator (tr) incomplete");
alpar@1
   610
            if (slice_arity(mpl, slice) != 2) goto err1;
alpar@1
   611
            get_token(mpl /* tr */);
alpar@1
   612
            if (mpl->token != T_RIGHT) goto err2;
alpar@1
   613
            get_token(mpl /* ) */);
alpar@1
   614
            /* in this case the colon is optional */
alpar@1
   615
            if (mpl->token == T_COLON) get_token(mpl /* : */);
alpar@1
   616
            /* set the "transpose" indicator */
alpar@1
   617
            tr = 1;
alpar@1
   618
            /* read elemental set data in the matrix format */
alpar@1
   619
            matrix_format(mpl, set, memb, slice, tr);
alpar@1
   620
         }
alpar@1
   621
         else if (mpl->token == T_SEMICOLON)
alpar@1
   622
         {  /* semicolon terminates the data block */
alpar@1
   623
            get_token(mpl /* ; */);
alpar@1
   624
            break;
alpar@1
   625
         }
alpar@1
   626
         else
alpar@1
   627
            error(mpl, "syntax error in set data block");
alpar@1
   628
      }
alpar@1
   629
      /* delete the current slice */
alpar@1
   630
      delete_slice(mpl, slice);
alpar@1
   631
      return;
alpar@1
   632
}
alpar@1
   633
alpar@1
   634
/*----------------------------------------------------------------------
alpar@1
   635
-- select_parameter - select parameter to saturate it with data.
alpar@1
   636
--
alpar@1
   637
-- This routine selects parameter to saturate it with data provided in
alpar@1
   638
-- the data section. */
alpar@1
   639
alpar@1
   640
PARAMETER *select_parameter
alpar@1
   641
(     MPL *mpl,
alpar@1
   642
      char *name              /* not changed */
alpar@1
   643
)
alpar@1
   644
{     PARAMETER *par;
alpar@1
   645
      AVLNODE *node;
alpar@1
   646
      xassert(name != NULL);
alpar@1
   647
      node = avl_find_node(mpl->tree, name);
alpar@1
   648
      if (node == NULL || avl_get_node_type(node) != A_PARAMETER)
alpar@1
   649
         error(mpl, "%s not a parameter", name);
alpar@1
   650
      par = (PARAMETER *)avl_get_node_link(node);
alpar@1
   651
      if (par->assign != NULL)
alpar@1
   652
         error(mpl, "%s needs no data", name);
alpar@1
   653
      if (par->data)
alpar@1
   654
         error(mpl, "%s already provided with data", name);
alpar@1
   655
      par->data = 1;
alpar@1
   656
      return par;
alpar@1
   657
}
alpar@1
   658
alpar@1
   659
/*----------------------------------------------------------------------
alpar@1
   660
-- set_default - set default parameter value.
alpar@1
   661
--
alpar@1
   662
-- This routine sets default value for specified parameter. */
alpar@1
   663
alpar@1
   664
void set_default
alpar@1
   665
(     MPL *mpl,
alpar@1
   666
      PARAMETER *par,         /* not changed */
alpar@1
   667
      SYMBOL *altval          /* destroyed */
alpar@1
   668
)
alpar@1
   669
{     xassert(par != NULL);
alpar@1
   670
      xassert(altval != NULL);
alpar@1
   671
      if (par->option != NULL)
alpar@1
   672
         error(mpl, "default value for %s already specified in model se"
alpar@1
   673
            "ction", par->name);
alpar@1
   674
      xassert(par->defval == NULL);
alpar@1
   675
      par->defval = altval;
alpar@1
   676
      return;
alpar@1
   677
}
alpar@1
   678
alpar@1
   679
/*----------------------------------------------------------------------
alpar@1
   680
-- read_value - read value and assign it to parameter member.
alpar@1
   681
--
alpar@1
   682
-- This routine reads numeric or symbolic value from the input stream
alpar@1
   683
-- and assigns to new parameter member specified by its n-tuple, which
alpar@1
   684
-- (the member) is created and added to the parameter array. */
alpar@1
   685
alpar@1
   686
MEMBER *read_value
alpar@1
   687
(     MPL *mpl,
alpar@1
   688
      PARAMETER *par,         /* not changed */
alpar@1
   689
      TUPLE *tuple            /* destroyed */
alpar@1
   690
)
alpar@1
   691
{     MEMBER *memb;
alpar@1
   692
      xassert(par != NULL);
alpar@1
   693
      xassert(is_symbol(mpl));
alpar@1
   694
      /* there must be no member with the same n-tuple */
alpar@1
   695
      if (find_member(mpl, par->array, tuple) != NULL)
alpar@1
   696
         error(mpl, "%s%s already defined",
alpar@1
   697
            par->name, format_tuple(mpl, '[', tuple));
alpar@1
   698
      /* create new parameter member with given n-tuple */
alpar@1
   699
      memb = add_member(mpl, par->array, tuple);
alpar@1
   700
      /* read value and assigns it to the new parameter member */
alpar@1
   701
      switch (par->type)
alpar@1
   702
      {  case A_NUMERIC:
alpar@1
   703
         case A_INTEGER:
alpar@1
   704
         case A_BINARY:
alpar@1
   705
            if (!is_number(mpl))
alpar@1
   706
               error(mpl, "%s requires numeric data", par->name);
alpar@1
   707
            memb->value.num = read_number(mpl);
alpar@1
   708
            break;
alpar@1
   709
         case A_SYMBOLIC:
alpar@1
   710
            memb->value.sym = read_symbol(mpl);
alpar@1
   711
            break;
alpar@1
   712
         default:
alpar@1
   713
            xassert(par != par);
alpar@1
   714
      }
alpar@1
   715
      return memb;
alpar@1
   716
}
alpar@1
   717
alpar@1
   718
/*----------------------------------------------------------------------
alpar@1
   719
-- plain_format - read parameter data block in plain format.
alpar@1
   720
--
alpar@1
   721
-- This routine reads parameter data block using the syntax:
alpar@1
   722
--
alpar@1
   723
-- <plain format> ::= <symbol> , <symbol> , ... , <symbol> , <value>
alpar@1
   724
--
alpar@1
   725
-- where <symbols> are used to determine a complete subscript list for
alpar@1
   726
-- parameter member, <value> is a numeric or symbolic value assigned to
alpar@1
   727
-- the parameter member. Commae between data items are optional and may
alpar@1
   728
-- be omitted anywhere.
alpar@1
   729
--
alpar@1
   730
-- Number of components in the slice must be the same as dimension of
alpar@1
   731
-- the parameter. To construct the complete subscript list the routine
alpar@1
   732
-- replaces null positions in the slice by corresponding <symbols>. */
alpar@1
   733
alpar@1
   734
void plain_format
alpar@1
   735
(     MPL *mpl,
alpar@1
   736
      PARAMETER *par,         /* not changed */
alpar@1
   737
      SLICE *slice            /* not changed */
alpar@1
   738
)
alpar@1
   739
{     TUPLE *tuple;
alpar@1
   740
      SLICE *temp;
alpar@1
   741
      SYMBOL *sym, *with = NULL;
alpar@1
   742
      xassert(par != NULL);
alpar@1
   743
      xassert(par->dim == slice_dimen(mpl, slice));
alpar@1
   744
      xassert(is_symbol(mpl));
alpar@1
   745
      /* read symbols and construct complete subscript list */
alpar@1
   746
      tuple = create_tuple(mpl);
alpar@1
   747
      for (temp = slice; temp != NULL; temp = temp->next)
alpar@1
   748
      {  if (temp->sym == NULL)
alpar@1
   749
         {  /* substitution is needed; read symbol */
alpar@1
   750
            if (!is_symbol(mpl))
alpar@1
   751
            {  int lack = slice_arity(mpl, temp) + 1;
alpar@1
   752
               xassert(with != NULL);
alpar@1
   753
               xassert(lack > 1);
alpar@1
   754
               error(mpl, "%d items missing in data group beginning wit"
alpar@1
   755
                  "h %s", lack, format_symbol(mpl, with));
alpar@1
   756
            }
alpar@1
   757
            sym = read_symbol(mpl);
alpar@1
   758
            if (with == NULL) with = sym;
alpar@1
   759
         }
alpar@1
   760
         else
alpar@1
   761
         {  /* copy symbol from the slice */
alpar@1
   762
            sym = copy_symbol(mpl, temp->sym);
alpar@1
   763
         }
alpar@1
   764
         /* append the symbol to the subscript list */
alpar@1
   765
         tuple = expand_tuple(mpl, tuple, sym);
alpar@1
   766
         /* skip optional comma */
alpar@1
   767
         if (mpl->token == T_COMMA) get_token(mpl /* , */);
alpar@1
   768
      }
alpar@1
   769
      /* read value and assign it to new parameter member */
alpar@1
   770
      if (!is_symbol(mpl))
alpar@1
   771
      {  xassert(with != NULL);
alpar@1
   772
         error(mpl, "one item missing in data group beginning with %s",
alpar@1
   773
            format_symbol(mpl, with));
alpar@1
   774
      }
alpar@1
   775
      read_value(mpl, par, tuple);
alpar@1
   776
      return;
alpar@1
   777
}
alpar@1
   778
alpar@1
   779
/*----------------------------------------------------------------------
alpar@1
   780
-- tabular_format - read parameter data block in tabular format.
alpar@1
   781
--
alpar@1
   782
-- This routine reads parameter data block using the syntax:
alpar@1
   783
--
alpar@1
   784
-- <tabular format> ::= <column> <column> ... <column> :=
alpar@1
   785
--                <row> <value>  <value>  ... <value>
alpar@1
   786
--                <row> <value>  <value>  ... <value>
alpar@1
   787
--                  .  .  .  .  .  .  .  .  .  .  .
alpar@1
   788
--                <row> <value>  <value>  ... <value>
alpar@1
   789
--
alpar@1
   790
-- where <rows> are symbols that denote rows of the table, <columns>
alpar@1
   791
-- are symbols that denote columns of the table, <values> are numeric
alpar@1
   792
-- or symbolic values assigned to the corresponding parameter members.
alpar@1
   793
-- If <value> is specified as single point, no value is provided.
alpar@1
   794
--
alpar@1
   795
-- Number of components in the slice must be the same as dimension of
alpar@1
   796
-- the parameter. The slice must have two null positions. To construct
alpar@1
   797
-- complete subscript list for particular <value> the routine replaces
alpar@1
   798
-- the first null position of the slice by the corresponding <row> (or
alpar@1
   799
-- <column>, if the flag tr is on) and the second null position by the
alpar@1
   800
-- corresponding <column> (or by <row>, if the flag tr is on). */
alpar@1
   801
alpar@1
   802
void tabular_format
alpar@1
   803
(     MPL *mpl,
alpar@1
   804
      PARAMETER *par,         /* not changed */
alpar@1
   805
      SLICE *slice,           /* not changed */
alpar@1
   806
      int tr
alpar@1
   807
)
alpar@1
   808
{     SLICE *list, *col, *temp;
alpar@1
   809
      TUPLE *tuple;
alpar@1
   810
      SYMBOL *row;
alpar@1
   811
      xassert(par != NULL);
alpar@1
   812
      xassert(par->dim == slice_dimen(mpl, slice));
alpar@1
   813
      xassert(slice_arity(mpl, slice) == 2);
alpar@1
   814
      /* read the table heading that contains column symbols (the table
alpar@1
   815
         may have no columns) */
alpar@1
   816
      list = create_slice(mpl);
alpar@1
   817
      while (mpl->token != T_ASSIGN)
alpar@1
   818
      {  /* read column symbol and append it to the column list */
alpar@1
   819
         if (!is_symbol(mpl))
alpar@1
   820
            error(mpl, "number, symbol, or := missing where expected");
alpar@1
   821
         list = expand_slice(mpl, list, read_symbol(mpl));
alpar@1
   822
      }
alpar@1
   823
      get_token(mpl /* := */);
alpar@1
   824
      /* read zero or more rows that contain tabular data */
alpar@1
   825
      while (is_symbol(mpl))
alpar@1
   826
      {  /* read row symbol (if the table has no columns, these symbols
alpar@1
   827
            are just ignored) */
alpar@1
   828
         row = read_symbol(mpl);
alpar@1
   829
         /* read values accordingly to the column list */
alpar@1
   830
         for (col = list; col != NULL; col = col->next)
alpar@1
   831
         {  int which = 0;
alpar@1
   832
            /* if the token is single point, no value is provided */
alpar@1
   833
            if (is_literal(mpl, "."))
alpar@1
   834
            {  get_token(mpl /* . */);
alpar@1
   835
               continue;
alpar@1
   836
            }
alpar@1
   837
            /* construct complete subscript list */
alpar@1
   838
            tuple = create_tuple(mpl);
alpar@1
   839
            for (temp = slice; temp != NULL; temp = temp->next)
alpar@1
   840
            {  if (temp->sym == NULL)
alpar@1
   841
               {  /* substitution is needed */
alpar@1
   842
                  switch (++which)
alpar@1
   843
                  {  case 1:
alpar@1
   844
                        /* substitute in the first null position */
alpar@1
   845
                        tuple = expand_tuple(mpl, tuple,
alpar@1
   846
                           copy_symbol(mpl, tr ? col->sym : row));
alpar@1
   847
                        break;
alpar@1
   848
                     case 2:
alpar@1
   849
                        /* substitute in the second null position */
alpar@1
   850
                        tuple = expand_tuple(mpl, tuple,
alpar@1
   851
                           copy_symbol(mpl, tr ? row : col->sym));
alpar@1
   852
                        break;
alpar@1
   853
                     default:
alpar@1
   854
                        xassert(which != which);
alpar@1
   855
                  }
alpar@1
   856
               }
alpar@1
   857
               else
alpar@1
   858
               {  /* copy symbol from the slice */
alpar@1
   859
                  tuple = expand_tuple(mpl, tuple, copy_symbol(mpl,
alpar@1
   860
                     temp->sym));
alpar@1
   861
               }
alpar@1
   862
            }
alpar@1
   863
            xassert(which == 2);
alpar@1
   864
            /* read value and assign it to new parameter member */
alpar@1
   865
            if (!is_symbol(mpl))
alpar@1
   866
            {  int lack = slice_dimen(mpl, col);
alpar@1
   867
               if (lack == 1)
alpar@1
   868
                  error(mpl, "one item missing in data group beginning "
alpar@1
   869
                     "with %s", format_symbol(mpl, row));
alpar@1
   870
               else
alpar@1
   871
                  error(mpl, "%d items missing in data group beginning "
alpar@1
   872
                     "with %s", lack, format_symbol(mpl, row));
alpar@1
   873
            }
alpar@1
   874
            read_value(mpl, par, tuple);
alpar@1
   875
         }
alpar@1
   876
         /* delete the row symbol */
alpar@1
   877
         delete_symbol(mpl, row);
alpar@1
   878
      }
alpar@1
   879
      /* delete the column list */
alpar@1
   880
      delete_slice(mpl, list);
alpar@1
   881
      return;
alpar@1
   882
}
alpar@1
   883
alpar@1
   884
/*----------------------------------------------------------------------
alpar@1
   885
-- tabbing_format - read parameter data block in tabbing format.
alpar@1
   886
--
alpar@1
   887
-- This routine reads parameter data block using the syntax:
alpar@1
   888
--
alpar@1
   889
-- <tabbing format> ::=  <prefix> <name>  , ... , <name>  , := ,
alpar@1
   890
--    <symbol> , ... , <symbol> , <value> , ... , <value> ,
alpar@1
   891
--    <symbol> , ... , <symbol> , <value> , ... , <value> ,
alpar@1
   892
--     .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .  .
alpar@1
   893
--    <symbol> , ... , <symbol> , <value> , ... , <value>
alpar@1
   894
-- <prefix> ::= <empty>
alpar@1
   895
-- <prefix> ::= <set name> :
alpar@1
   896
--
alpar@1
   897
-- where <names> are names of parameters (all the parameters must be
alpar@1
   898
-- subscripted and have identical dimensions), <symbols> are symbols
alpar@1
   899
-- used to define subscripts of parameter members, <values> are numeric
alpar@1
   900
-- or symbolic values assigned to the corresponding parameter members.
alpar@1
   901
-- Optional <prefix> may specify a simple set, in which case n-tuples
alpar@1
   902
-- built of <symbols> for each row of the data table (i.e. subscripts
alpar@1
   903
-- of parameter members) are added to the specified set. Commae between
alpar@1
   904
-- data items are optional and may be omitted anywhere.
alpar@1
   905
--
alpar@1
   906
-- If the parameter altval is not NULL, it specifies a default value
alpar@1
   907
-- provided for all the parameters specified in the data block.  */
alpar@1
   908
alpar@1
   909
void tabbing_format
alpar@1
   910
(     MPL *mpl,
alpar@1
   911
      SYMBOL *altval          /* not changed */
alpar@1
   912
)
alpar@1
   913
{     SET *set = NULL;
alpar@1
   914
      PARAMETER *par;
alpar@1
   915
      SLICE *list, *col;
alpar@1
   916
      TUPLE *tuple;
alpar@1
   917
      int next_token, j, dim = 0;
alpar@1
   918
      char *last_name = NULL;
alpar@1
   919
      /* read the optional <prefix> */
alpar@1
   920
      if (is_symbol(mpl))
alpar@1
   921
      {  get_token(mpl /* <symbol> */);
alpar@1
   922
         next_token = mpl->token;
alpar@1
   923
         unget_token(mpl /* <symbol> */);
alpar@1
   924
         if (next_token == T_COLON)
alpar@1
   925
         {  /* select the set to saturate it with data */
alpar@1
   926
            set = select_set(mpl, mpl->image);
alpar@1
   927
            /* the set must be simple (i.e. not set of sets) */
alpar@1
   928
            if (set->dim != 0)
alpar@1
   929
               error(mpl, "%s must be a simple set", set->name);
alpar@1
   930
            /* and must not be defined yet */
alpar@1
   931
            if (set->array->head != NULL)
alpar@1
   932
               error(mpl, "%s already defined", set->name);
alpar@1
   933
            /* add new (the only) member to the set and assign it empty
alpar@1
   934
               elemental set */
alpar@1
   935
            add_member(mpl, set->array, NULL)->value.set =
alpar@1
   936
               create_elemset(mpl, set->dimen);
alpar@1
   937
            last_name = set->name, dim = set->dimen;
alpar@1
   938
            get_token(mpl /* <symbol> */);
alpar@1
   939
            xassert(mpl->token == T_COLON);
alpar@1
   940
            get_token(mpl /* : */);
alpar@1
   941
         }
alpar@1
   942
      }
alpar@1
   943
      /* read the table heading that contains parameter names */
alpar@1
   944
      list = create_slice(mpl);
alpar@1
   945
      while (mpl->token != T_ASSIGN)
alpar@1
   946
      {  /* there must be symbolic name of parameter */
alpar@1
   947
         if (!is_symbol(mpl))
alpar@1
   948
            error(mpl, "parameter name or := missing where expected");
alpar@1
   949
         /* select the parameter to saturate it with data */
alpar@1
   950
         par = select_parameter(mpl, mpl->image);
alpar@1
   951
         /* the parameter must be subscripted */
alpar@1
   952
         if (par->dim == 0)
alpar@1
   953
            error(mpl, "%s not a subscripted parameter", mpl->image);
alpar@1
   954
         /* the set (if specified) and all the parameters in the data
alpar@1
   955
            block must have identical dimension */
alpar@1
   956
         if (dim != 0 && par->dim != dim)
alpar@1
   957
         {  xassert(last_name != NULL);
alpar@1
   958
            error(mpl, "%s has dimension %d while %s has dimension %d",
alpar@1
   959
               last_name, dim, par->name, par->dim);
alpar@1
   960
         }
alpar@1
   961
         /* set default value for the parameter (if specified) */
alpar@1
   962
         if (altval != NULL)
alpar@1
   963
            set_default(mpl, par, copy_symbol(mpl, altval));
alpar@1
   964
         /* append the parameter to the column list */
alpar@1
   965
         list = expand_slice(mpl, list, (SYMBOL *)par);
alpar@1
   966
         last_name = par->name, dim = par->dim;
alpar@1
   967
         get_token(mpl /* <symbol> */);
alpar@1
   968
         /* skip optional comma */
alpar@1
   969
         if (mpl->token == T_COMMA) get_token(mpl /* , */);
alpar@1
   970
      }
alpar@1
   971
      if (slice_dimen(mpl, list) == 0)
alpar@1
   972
         error(mpl, "at least one parameter name required");
alpar@1
   973
      get_token(mpl /* := */);
alpar@1
   974
      /* skip optional comma */
alpar@1
   975
      if (mpl->token == T_COMMA) get_token(mpl /* , */);
alpar@1
   976
      /* read rows that contain tabbing data */
alpar@1
   977
      while (is_symbol(mpl))
alpar@1
   978
      {  /* read subscript list */
alpar@1
   979
         tuple = create_tuple(mpl);
alpar@1
   980
         for (j = 1; j <= dim; j++)
alpar@1
   981
         {  /* read j-th subscript */
alpar@1
   982
            if (!is_symbol(mpl))
alpar@1
   983
            {  int lack = slice_dimen(mpl, list) + dim - j + 1;
alpar@1
   984
               xassert(tuple != NULL);
alpar@1
   985
               xassert(lack > 1);
alpar@1
   986
               error(mpl, "%d items missing in data group beginning wit"
alpar@1
   987
                  "h %s", lack, format_symbol(mpl, tuple->sym));
alpar@1
   988
            }
alpar@1
   989
            /* read and append j-th subscript to the n-tuple */
alpar@1
   990
            tuple = expand_tuple(mpl, tuple, read_symbol(mpl));
alpar@1
   991
            /* skip optional comma *between* <symbols> */
alpar@1
   992
            if (j < dim && mpl->token == T_COMMA)
alpar@1
   993
               get_token(mpl /* , */);
alpar@1
   994
         }
alpar@1
   995
         /* if the set is specified, add to it new n-tuple, which is a
alpar@1
   996
            copy of the subscript list just read */
alpar@1
   997
         if (set != NULL)
alpar@1
   998
            check_then_add(mpl, set->array->head->value.set,
alpar@1
   999
               copy_tuple(mpl, tuple));
alpar@1
  1000
         /* skip optional comma between <symbol> and <value> */
alpar@1
  1001
         if (mpl->token == T_COMMA) get_token(mpl /* , */);
alpar@1
  1002
         /* read values accordingly to the column list */
alpar@1
  1003
         for (col = list; col != NULL; col = col->next)
alpar@1
  1004
         {  /* if the token is single point, no value is provided */
alpar@1
  1005
            if (is_literal(mpl, "."))
alpar@1
  1006
            {  get_token(mpl /* . */);
alpar@1
  1007
               continue;
alpar@1
  1008
            }
alpar@1
  1009
            /* read value and assign it to new parameter member */
alpar@1
  1010
            if (!is_symbol(mpl))
alpar@1
  1011
            {  int lack = slice_dimen(mpl, col);
alpar@1
  1012
               xassert(tuple != NULL);
alpar@1
  1013
               if (lack == 1)
alpar@1
  1014
                  error(mpl, "one item missing in data group beginning "
alpar@1
  1015
                     "with %s", format_symbol(mpl, tuple->sym));
alpar@1
  1016
               else
alpar@1
  1017
                  error(mpl, "%d items missing in data group beginning "
alpar@1
  1018
                     "with %s", lack, format_symbol(mpl, tuple->sym));
alpar@1
  1019
            }
alpar@1
  1020
            read_value(mpl, (PARAMETER *)col->sym, copy_tuple(mpl,
alpar@1
  1021
               tuple));
alpar@1
  1022
            /* skip optional comma preceding the next value */
alpar@1
  1023
            if (col->next != NULL && mpl->token == T_COMMA)
alpar@1
  1024
               get_token(mpl /* , */);
alpar@1
  1025
         }
alpar@1
  1026
         /* delete the original subscript list */
alpar@1
  1027
         delete_tuple(mpl, tuple);
alpar@1
  1028
         /* skip optional comma (only if there is next data group) */
alpar@1
  1029
         if (mpl->token == T_COMMA)
alpar@1
  1030
         {  get_token(mpl /* , */);
alpar@1
  1031
            if (!is_symbol(mpl)) unget_token(mpl /* , */);
alpar@1
  1032
         }
alpar@1
  1033
      }
alpar@1
  1034
      /* delete the column list (it contains parameters, not symbols,
alpar@1
  1035
         so nullify it before) */
alpar@1
  1036
      for (col = list; col != NULL; col = col->next) col->sym = NULL;
alpar@1
  1037
      delete_slice(mpl, list);
alpar@1
  1038
      return;
alpar@1
  1039
}
alpar@1
  1040
alpar@1
  1041
/*----------------------------------------------------------------------
alpar@1
  1042
-- parameter_data - read parameter data.
alpar@1
  1043
--
alpar@1
  1044
-- This routine reads parameter data using the syntax:
alpar@1
  1045
--
alpar@1
  1046
-- <parameter data> ::= param <default value> : <tabbing format> ;
alpar@1
  1047
-- <parameter data> ::= param <parameter name> <default value>
alpar@1
  1048
--                      <assignments> ;
alpar@1
  1049
-- <parameter name> ::= <symbolic name>
alpar@1
  1050
-- <default value> ::= <empty>
alpar@1
  1051
-- <default value> ::= default <symbol>
alpar@1
  1052
-- <assignments> ::= <empty>
alpar@1
  1053
-- <assignments> ::= <assignments> , :=
alpar@1
  1054
-- <assignments> ::= <assignments> , [ <symbol list> ]
alpar@1
  1055
-- <assignments> ::= <assignments> , <plain format>
alpar@1
  1056
-- <assignemnts> ::= <assignments> , : <tabular format>
alpar@1
  1057
-- <assignments> ::= <assignments> , (tr) <tabular format>
alpar@1
  1058
-- <assignments> ::= <assignments> , (tr) : <tabular format>
alpar@1
  1059
--
alpar@1
  1060
-- Commae in <assignments> are optional and may be omitted anywhere. */
alpar@1
  1061
alpar@1
  1062
void parameter_data(MPL *mpl)
alpar@1
  1063
{     PARAMETER *par;
alpar@1
  1064
      SYMBOL *altval = NULL;
alpar@1
  1065
      SLICE *slice;
alpar@1
  1066
      int tr = 0;
alpar@1
  1067
      xassert(is_literal(mpl, "param"));
alpar@1
  1068
      get_token(mpl /* param */);
alpar@1
  1069
      /* read optional default value */
alpar@1
  1070
      if (is_literal(mpl, "default"))
alpar@1
  1071
      {  get_token(mpl /* default */);
alpar@1
  1072
         if (!is_symbol(mpl))
alpar@1
  1073
            error(mpl, "default value missing where expected");
alpar@1
  1074
         altval = read_symbol(mpl);
alpar@1
  1075
         /* if the default value follows the keyword 'param', the next
alpar@1
  1076
            token must be only the colon */
alpar@1
  1077
         if (mpl->token != T_COLON)
alpar@1
  1078
            error(mpl, "colon missing where expected");
alpar@1
  1079
      }
alpar@1
  1080
      /* being used after the keyword 'param' or the optional default
alpar@1
  1081
         value the colon begins data in the tabbing format */
alpar@1
  1082
      if (mpl->token == T_COLON)
alpar@1
  1083
      {  get_token(mpl /* : */);
alpar@1
  1084
         /* skip optional comma */
alpar@1
  1085
         if (mpl->token == T_COMMA) get_token(mpl /* , */);
alpar@1
  1086
         /* read parameter data in the tabbing format */
alpar@1
  1087
         tabbing_format(mpl, altval);
alpar@1
  1088
         /* on reading data in the tabbing format the default value is
alpar@1
  1089
            always copied, so delete the original symbol */
alpar@1
  1090
         if (altval != NULL) delete_symbol(mpl, altval);
alpar@1
  1091
         /* the next token must be only semicolon */
alpar@1
  1092
         if (mpl->token != T_SEMICOLON)
alpar@1
  1093
            error(mpl, "symbol, number, or semicolon missing where expe"
alpar@1
  1094
               "cted");
alpar@1
  1095
         get_token(mpl /* ; */);
alpar@1
  1096
         goto done;
alpar@1
  1097
      }
alpar@1
  1098
      /* in other cases there must be symbolic name of parameter, which
alpar@1
  1099
         follows the keyword 'param' */
alpar@1
  1100
      if (!is_symbol(mpl))
alpar@1
  1101
         error(mpl, "parameter name missing where expected");
alpar@1
  1102
      /* select the parameter to saturate it with data */
alpar@1
  1103
      par = select_parameter(mpl, mpl->image);
alpar@1
  1104
      get_token(mpl /* <symbol> */);
alpar@1
  1105
      /* read optional default value */
alpar@1
  1106
      if (is_literal(mpl, "default"))
alpar@1
  1107
      {  get_token(mpl /* default */);
alpar@1
  1108
         if (!is_symbol(mpl))
alpar@1
  1109
            error(mpl, "default value missing where expected");
alpar@1
  1110
         altval = read_symbol(mpl);
alpar@1
  1111
         /* set default value for the parameter */
alpar@1
  1112
         set_default(mpl, par, altval);
alpar@1
  1113
      }
alpar@1
  1114
      /* create initial fake slice of all asterisks */
alpar@1
  1115
      slice = fake_slice(mpl, par->dim);
alpar@1
  1116
      /* read zero or more data assignments */
alpar@1
  1117
      for (;;)
alpar@1
  1118
      {  /* skip optional comma */
alpar@1
  1119
         if (mpl->token == T_COMMA) get_token(mpl /* , */);
alpar@1
  1120
         /* process current assignment */
alpar@1
  1121
         if (mpl->token == T_ASSIGN)
alpar@1
  1122
         {  /* assignment ligature is non-significant element */
alpar@1
  1123
            get_token(mpl /* := */);
alpar@1
  1124
         }
alpar@1
  1125
         else if (mpl->token == T_LBRACKET)
alpar@1
  1126
         {  /* left bracket begins new slice; delete the current slice
alpar@1
  1127
               and read new one */
alpar@1
  1128
            delete_slice(mpl, slice);
alpar@1
  1129
            slice = read_slice(mpl, par->name, par->dim);
alpar@1
  1130
            /* each new slice resets the "transpose" indicator */
alpar@1
  1131
            tr = 0;
alpar@1
  1132
         }
alpar@1
  1133
         else if (is_symbol(mpl))
alpar@1
  1134
         {  /* number or symbol begins data in the plain format */
alpar@1
  1135
            plain_format(mpl, par, slice);
alpar@1
  1136
         }
alpar@1
  1137
         else if (mpl->token == T_COLON)
alpar@1
  1138
         {  /* colon begins data in the tabular format */
alpar@1
  1139
            if (par->dim == 0)
alpar@1
  1140
err1:          error(mpl, "%s not a subscripted parameter",
alpar@1
  1141
                  par->name);
alpar@1
  1142
            if (slice_arity(mpl, slice) != 2)
alpar@1
  1143
err2:          error(mpl, "slice currently used must specify 2 asterisk"
alpar@1
  1144
                  "s, not %d", slice_arity(mpl, slice));
alpar@1
  1145
            get_token(mpl /* : */);
alpar@1
  1146
            /* read parameter data in the tabular format */
alpar@1
  1147
            tabular_format(mpl, par, slice, tr);
alpar@1
  1148
         }
alpar@1
  1149
         else if (mpl->token == T_LEFT)
alpar@1
  1150
         {  /* left parenthesis begins the "transpose" indicator, which
alpar@1
  1151
               is followed by data in the tabular format */
alpar@1
  1152
            get_token(mpl /* ( */);
alpar@1
  1153
            if (!is_literal(mpl, "tr"))
alpar@1
  1154
err3:          error(mpl, "transpose indicator (tr) incomplete");
alpar@1
  1155
            if (par->dim == 0) goto err1;
alpar@1
  1156
            if (slice_arity(mpl, slice) != 2) goto err2;
alpar@1
  1157
            get_token(mpl /* tr */);
alpar@1
  1158
            if (mpl->token != T_RIGHT) goto err3;
alpar@1
  1159
            get_token(mpl /* ) */);
alpar@1
  1160
            /* in this case the colon is optional */
alpar@1
  1161
            if (mpl->token == T_COLON) get_token(mpl /* : */);
alpar@1
  1162
            /* set the "transpose" indicator */
alpar@1
  1163
            tr = 1;
alpar@1
  1164
            /* read parameter data in the tabular format */
alpar@1
  1165
            tabular_format(mpl, par, slice, tr);
alpar@1
  1166
         }
alpar@1
  1167
         else if (mpl->token == T_SEMICOLON)
alpar@1
  1168
         {  /* semicolon terminates the data block */
alpar@1
  1169
            get_token(mpl /* ; */);
alpar@1
  1170
            break;
alpar@1
  1171
         }
alpar@1
  1172
         else
alpar@1
  1173
            error(mpl, "syntax error in parameter data block");
alpar@1
  1174
      }
alpar@1
  1175
      /* delete the current slice */
alpar@1
  1176
      delete_slice(mpl, slice);
alpar@1
  1177
done: return;
alpar@1
  1178
}
alpar@1
  1179
alpar@1
  1180
/*----------------------------------------------------------------------
alpar@1
  1181
-- data_section - read data section.
alpar@1
  1182
--
alpar@1
  1183
-- This routine reads data section using the syntax:
alpar@1
  1184
--
alpar@1
  1185
-- <data section> ::= <empty>
alpar@1
  1186
-- <data section> ::= <data section> <data block> ;
alpar@1
  1187
-- <data block> ::= <set data>
alpar@1
  1188
-- <data block> ::= <parameter data>
alpar@1
  1189
--
alpar@1
  1190
-- Reading data section is terminated by either the keyword 'end' or
alpar@1
  1191
-- the end of file. */
alpar@1
  1192
alpar@1
  1193
void data_section(MPL *mpl)
alpar@1
  1194
{     while (!(mpl->token == T_EOF || is_literal(mpl, "end")))
alpar@1
  1195
      {  if (is_literal(mpl, "set"))
alpar@1
  1196
            set_data(mpl);
alpar@1
  1197
         else if (is_literal(mpl, "param"))
alpar@1
  1198
            parameter_data(mpl);
alpar@1
  1199
         else
alpar@1
  1200
            error(mpl, "syntax error in data section");
alpar@1
  1201
      }
alpar@1
  1202
      return;
alpar@1
  1203
}
alpar@1
  1204
alpar@1
  1205
/* eof */