/* glplan7.c (l_stmt) */

/*----------------------------------------------------------------------
-- Copyright (C) 2000, 2001, 2002 Andrew Makhorin <mao@mai2.rcnet.ru>,
--               Department for Applied Informatics, Moscow Aviation
--               Institute, Moscow, Russia. All rights reserved.
--
-- This file is a part of GLPK (GNU Linear Programming Kit).
--
-- GLPK is free software; you can redistribute it and/or modify it
-- under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- GLPK is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public
-- License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with GLPK; see the file COPYING. If not, write to the Free
-- Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
----------------------------------------------------------------------*/

#include <ctype.h>
#include <stdio.h>
#include <string.h>
#include "glplang.h"

/*----------------------------------------------------------------------
-- assign_stmt - parse assignment statement.
--
-- This routine parses assignment statement using the syntax:
--
-- <assignment> ::= <left part> := <right part>
-- <assignment> ::= <left part> where <expression> := <right part>
-- <left part> ::= <name> <suffix>
-- <left part> ::= <name> <suffix> [ <selector list> ]
-- <suffix> ::= <empty> | . lo | . up | . fx
-- <selector list> ::= <selector>
-- <selector list> ::= <selector list> , <selector>
-- <selector> ::= <letter>
-- <selector> ::= # <name>
-- <right part> ::= <expression>
-- <right part> ::= <arith expr> <= <arith expr>
-- <right part> ::= <arith expr> =  <arith expr>
-- <right part> ::= <arith expr> >= <arith expr> */

void assign_stmt(void)
{     SPAR *spar;          /* array in the left part */
      int suff;            /* name suffix:
                              0   - no suffix
                              'L' - .lo
                              'U' - .up
                              'S' - .fx */
      int mute[MAX_DIM];   /* mute letter or '?' */
      ITEM *iref[MAX_DIM]; /* item reference or NULL */
      SPAR *cond;          /* optional predicate or NULL */
      SPAR *that;          /* the right part */
      int form;            /* constraint form:
                              0    - free form
                              C_LE - ... <= ...
                              C_EQ - ...  = ...
                              C_GE - ... >= ... */
      MEMB *memb, *list;
      ITEM *item[MAX_DIM];
      AVLNODE *node;
      int k, t;
      /* determine array in the left part */
      insist(token == T_NAME);
      node = find_by_key(pdb->tree, image);
      if (node == NULL)
         fatal("`%s' not declared", image);
      if (node->type == 'I')
         fatal("invalid use of item `%s'", image);
      if (node->type == 'S')
         fatal("invalid use of set `%s'", image);
      spar = node->link;
      get_token(/* name */);
      /* parse optional suffix */
      suff = 0;
      if (t_spec("."))
      {  if (!(spar->type == 'V' || spar->type == 'C'))
            fatal("suffix not allowed");
         get_token(/* . */);
         if (t_name("lo"))
            suff = 'L';
         else if (t_name("up"))
            suff = 'U';
         else if (t_name("fx"))
            suff = 'S';
         else
            fatal("invalid suffix `.%s'", image);
         get_token(/* lo | up | fx */);
      }
      /* variable should have suffix */
      if (spar->type == 'V' && suff == 0)
         fatal("invalid use of variable `%s'", spar->name);
      /* parse optional subscript list */
      if (!t_spec("["))
      {  if (spar->dim > 0)
            fatal("subscript list required for `%s'", spar->name);
         goto skip;
      }
      if (spar->dim == 0)
         fatal("invalid use of subscript list for `%s'", spar->name);
      get_token(/* [ */);
      k = 0;
      for (;;)
      {  /* parse the next subscript */
         if (k == spar->dim)
            fatal("too many subscripts for `%s'", spar->name);
         if (token == T_NAME)
         {  /* parse mute letter */
            if (!(strlen(image) == 1 && islower(image[0])))
               fatal("invalid mute letter `%s'", image);
            /* identical mute letters should refer to identical sets */
            t = find_mute(k, mute, image[0]);
            if (t >= 0 && spar->set[t] != spar->set[k])
               fatal("mute letter `%c' refers to different sets",
                  image[0]);
            mute[k] = image[0];
            iref[k] = NULL;
            get_token(/* mute letter */);
         }
         else if (t_spec("#"))
         {  /* parse item reference */
            get_token(/* # */);
            if (token != T_NAME)
               fatal("item name missing or invalid");
            node = find_by_key(pdb->tree, image);
            if (node == NULL)
               fatal("item `%s' not declared", image);
            if (node->type != 'I')
               fatal("invalid use of `%s'", image);
            if (spar->set[k] != ((ITEM *)node->link)->set)
               fatal("`%s' belongs to incompatible set", image);
            mute[k] = '?';
            iref[k] = node->link;
            get_token(/* item */);
         }
         else
            fatal("invalid subscript");
         k++;
         if (t_spec("]")) break;
         if (!t_spec(",")) fatal("missing right bracket");
         get_token(/* , */);
      }
      if (k != spar->dim)
         fatal("too few subscripts for `%s'", spar->name);
      get_token(/* ] */);
skip: /* parse optional predicate */
      cond = NULL;
      if (t_name("where"))
      {  get_token(/* where */);
         cond = expression();
         if (cond->type != 'P')
            fatal("expression following `where' must be predicate");
         /* each mute letter in the predicate should be presented in
            the left part; besides, domains should be identical */
         for (k = 0; k < cond->dim; k++)
         {  t = find_mute(spar->dim, mute, cond->mute[k]);
            if (t < 0)
               fatal("mute letter `%c' missing in the left part",
                  cond->mute[k]);
            if (spar->set[t] != cond->set[k])
               fatal("mute letter `%c' refers to different sets",
                  cond->mute[k]);
         }
         /* each mute letter in the left part which is missing in the
            predicate involves increasing predicate dimension */
         for (k = 0; k < spar->dim; k++)
         {  if (mute[k] == '?') continue;
            t = find_mute(cond->dim, cond->mute, mute[k]);
            if (t < 0)
               cond = expand_spar(cond, spar->set[k], mute[k]);
         }
         /* index members of the predicate */
         create_index(cond);
         for (memb = cond->first; memb != NULL; memb = memb->next)
            index_memb(memb);
      }
      /* check left part delimiter */
      if (!t_spec(":=")) fatal("missing delimiter `:='");
      get_token(/* := */);
      /* parse the right part */
      form = 0;
      if (spar->type == 'C' && suff == 0)
      {  that = arith_expr();
         if (t_spec("<="))
         {  get_token(/* <= */);
            form = C_LE;
         }
         else if (t_spec("="))
         {  get_token(/* = */);
            form = C_EQ;
         }
         else if (t_spec(">="))
         {  get_token(/* >= */);
            form = C_GE;
         }
         if (form != 0)
            that = addition(C_SUB, that, arith_expr());
      }
      else
         that = expression();
      /* check type of the right part */
      insist(that->type == 'P' || that->type == 'X');
      if (spar->type == 'P' && that->type != 'P' ||
          spar->type != 'P' && that->type == 'P')
         fatal("assignment inconsistent");
      /* each mute letter in the right part should be also presented in
         the left part */
      for (k = 0; k < that->dim; k++)
      {  t = find_mute(spar->dim, mute, that->mute[k]);
         if (t < 0)
            fatal("mute letter `%c' missing in the left part",
               that->mute[k]);
         if (spar->set[t] != that->set[k])
            fatal("mute letter `%c' refers to different sets",
               that->mute[k]);
      }
      /* each mute letter in the left part which is missing in the
         right part involves increasing the right part dimension */
      for (k = 0; k < spar->dim; k++)
      {  if (mute[k] == '?') continue;
         t = find_mute(that->dim, that->mute, mute[k]);
            if (t < 0)
               that = expand_spar(that, spar->set[k], mute[k]);
      }
      /* remove members of the array in the left part that are affected
         by assignment */
      list = spar->first;
      spar->first = spar->last = NULL;
      while (list != NULL)
      {  int *type;
         double *lb, *ub;
         memb = list;
         list = memb->next;
         /* if memb->item[k] differs from the corresponding #item in
            the left part, the current member should be kept */
         for (k = 0; k < spar->dim; k++)
         {  if (iref[k] != NULL && memb->item[k] != iref[k])
               goto keep;
         }
         /* if there were no predicate, the current member would be
            deleted; however, if the predicate is *false*, the member
            should be kept */
         if (cond != NULL)
         {  for (k = 0; k < cond->dim; k++)
            {  t = find_mute(spar->dim, mute, cond->mute[k]);
               insist(t >= 0);
               item[k] = memb->item[t];
            }
            if (find_memb(item) == NULL) goto keep;
         }
         /* destroy the current member */
         if (spar->type == 'P')
         {  insist(memb->link == NULL);
            free_atom(pdb->memb_pool, memb);
            continue;
         }
         if (spar->type == 'X')
         {  insist(memb->link != NULL);
            erase_expr(memb->link);
            free_atom(pdb->memb_pool, memb);
            continue;
         }
         if (spar->type == 'C' && suff == 0)
         {  CONS *cons = memb->link;
            insist(cons != NULL && cons->expr != NULL);
            erase_expr(cons->expr);
            free_atom(pdb->cons_pool, cons);
            free_atom(pdb->memb_pool, memb);
            continue;
         }
         /* pseudo arrays */
         switch (spar->type)
         {  case 'V':
               type = &((VAR *)memb->link)->type;
               lb = &((VAR *)memb->link)->lb;
               ub = &((VAR *)memb->link)->ub;
               break;
            case 'C':
               type = &((CONS *)memb->link)->type;
               lb = &((CONS *)memb->link)->lb;
               ub = &((CONS *)memb->link)->ub;
               break;
            default:
               insist(spar->type != spar->type);
         }
         switch (suff)
         {  case 'L':
               /* reset lower bound */
               if (*type == 'L')
                  *type = 'F';
               else if (*type == 'D')
                  *type = 'U';
               *lb = 0.0;
               break;
            case 'U':
               /* reset upper bound */
               if (*type == 'U')
                  *type = 'F';
               else if (*type == 'D')
                  *type = 'L';
               *ub = 0.0;
               break;
            case 'S':
               /* reset fixed value */
               *type = 'F';
               *lb = *ub = 0.0;
               break;
            default:
               insist(suff != suff);
         }
keep:    /* keep the current member */
         memb->next = NULL;
         if (spar->first == NULL)
            spar->first = memb;
         else
            spar->last->next = memb;
         spar->last = memb;
      }
      /* remove members of the right part which don't satisfy the
         specified predicate */
      if (cond != NULL)
      {  insist(cond->dim == that->dim);
         list = that->first;
         that->first = that->last = NULL;
         while (list != NULL)
         {  memb = list;
            list = memb->next;
            /* build item for predicate member */
            for (k = 0; k < cond->dim; k++)
            {  t = find_mute(that->dim, that->mute, cond->mute[k]);
               insist(t >= 0);
               item[k] = memb->item[t];
            }
            /* check the predicate */
            if (find_memb(item) == NULL)
            {  /* predicate is *false* */
               if (that->type == 'X')
               {  insist(memb->link != NULL);
                  erase_expr(memb->link);
               }
               free_atom(pdb->memb_pool, memb);
            }
            else
            {  /* predicate is *true* */
               memb->next = NULL;
               if (that->first == NULL)
                  that->first = memb;
               else
                  that->last->next = memb;
               that->last = memb;
            }
         }
         /* predicate is no longer needed */
         delete_index();
         erase_spar(cond);
      }
      /* index members of the array in the left part */
      create_index(spar);
      for (memb = spar->first; memb != NULL; memb = memb->next)
         index_memb(memb);
      /* perform assignment (spar := spar U that) */
      while (that->first != NULL)
      {  MEMB *temp;
         EXPR *expr;
         int *type;
         double *lb, *ub;
         memb = that->first;
         that->first = memb->next;
         /* build tuple for the left part array */
         for (k = 0; k < spar->dim; k++)
         {  if (iref[k] == NULL)
            {  t = find_mute(that->dim, that->mute, mute[k]);
               insist(t >= 0);
               item[k] = memb->item[t];
            }
            else
               item[k] = iref[k];
         }
         for (k = 0; k < spar->dim; k++) memb->item[k] = item[k];
         /* now the current member should be added to the left part
            array (except cases of pseudo arrays) */
         if (spar->type == 'P')
         {  insist(memb->link == NULL);
            goto add;
         }
         if (spar->type == 'X')
         {  insist(memb->link != NULL);
            goto add;
         }
         if (spar->type == 'C' && suff == 0)
         {  CONS *cons;
            cons = get_atom(pdb->cons_pool);
            insist(memb->link != NULL);
            cons->expr = memb->link;
            switch (form)
            {  case 0:
                  cons->type = 'F';
                  break;
               case C_LE:
                  cons->type = 'U';
                  break;
               case C_GE:
                  cons->type = 'L';
                  break;
               case C_EQ:
                  cons->type = 'S';
                  break;
               default:
                  insist(form != form);
            }
            cons->lb = cons->ub = 0.0;
            memb->link = cons;
            goto add;
         }
         /* pseudo arrays */
         temp = find_memb(memb->item);
         if (temp != NULL)
         {  /* check for constant expression */
            expr = memb->link;
            insist(expr != NULL);
            if (!(expr->head->op == C_CON && expr->head->next == NULL))
               fatal("constant expression required");
            /* change a member of pseudo array */
            switch (spar->type)
            {  case 'V':
                  type = &((VAR *)temp->link)->type;
                  lb = &((VAR *)temp->link)->lb;
                  ub = &((VAR *)temp->link)->ub;
                  break;
               case 'C':
                  type = &((CONS *)temp->link)->type;
                  lb = &((CONS *)temp->link)->lb;
                  ub = &((CONS *)temp->link)->ub;
                  break;
               default:
                  insist(spar->type != spar->type);
            }
            switch (suff)
            {  case 'L':
                  /* set lower bound */
                  if (*type == 'F')
                     *type = 'L';
                  else if (*type == 'U')
                     *type = 'D';
                  else
                     insist(type != type);
                  *lb = expr->head->arg.con;
                  break;
               case 'U':
                  /* set upper bound */
                  if (*type == 'F')
                     *type = 'U';
                  else if (*type == 'L')
                     *type = 'D';
                  else
                     insist(type != type);
                  *ub = expr->head->arg.con;
                  break;
               case 'S':
                  /* set fixed value */
                  if (*type == 'F')
                     *type = 'S';
                  else
                     insist(type != type);
                  *lb = *ub = expr->head->arg.con;
                  break;
               default:
                  insist(suff != suff);
            }
         }
         /* destroy right part member */
         erase_expr(memb->link);
         free_atom(pdb->memb_pool, memb);
         continue;
add:     /* add right part member to the left part array */
         /* there should be NO multiplets */
         insist(find_memb(memb->item) == NULL);
         memb->next = NULL;
         if (spar->first == NULL)
            spar->first = memb;
         else
            spar->last->next = memb;
         spar->last = memb;
      }
      delete_index();
      free_atom(pdb->spar_pool, that);
      /* check delimiter */
      if (!t_spec(";")) fatal("semicolon expected");
      get_token(/* ; */);
      /* done ! */
      return;
}

/*----------------------------------------------------------------------
-- objective - parse objective statement.
--
-- This routine parses objective statement using the syntax
--
-- <objective> ::= minimize <designator>
-- <objective> ::= maximize <designator>
--
-- where designator should be a member of constraint array. */

void objective(void)
{     SPAR *spar;
      MEMB *memb;
      ITEM *item[MAX_DIM];
      AVLNODE *node;
      int k;
      if (t_name("minimize"))
         pdb->obj_dir = '-';
      else if (t_name("maximize"))
         pdb->obj_dir = '+';
      else
         insist(token != token);
      get_token(/* minimize | maximize */);
      /* parse constraint name */
      if (token != T_NAME)
         fatal("objective name missing or invalid");
      node = find_by_key(pdb->tree, image);
      if (node == NULL)
         fatal("objective `%s' not declared", image);
      if (node->type != 'C')
         fatal("invalid use of `%s'", image);
      spar = node->link;
      get_token(/* name */);
      /* parse optional subscript list */
      if (!t_spec("["))
      {  if (spar->dim > 0)
            fatal("subscript list required for `%s'", spar->name);
         goto skip;
      }
      if (spar->dim == 0)
         fatal("invalid use of subscript list for `%s'", spar->name);
      get_token(/* [ */);
      k = 0;
      for (;;)
      {  /* parse the next subscript */
         if (k == spar->dim)
            fatal("too many subscripts for `%s'", spar->name);
         if (!t_spec("#"))
            fatal("invalid subscript");
         get_token(/* # */);
         if (token != T_NAME)
            fatal("item name missing or invalid");
         node = find_by_key(pdb->tree, image);
         if (node == NULL)
            fatal("item `%s' not declared", image);
         if (node->type != 'I')
            fatal("invalid use of `%s'", image);
         if (spar->set[k] != ((ITEM *)node->link)->set)
            fatal("`%s' belongs to incompatible set", image);
         item[k] = node->link;
         k++;
         get_token(/* item name */);
         if (t_spec("]")) break;
         if (!t_spec(",")) fatal("missing right bracket");
         get_token(/* , */);
      }
      if (k != spar->dim)
         fatal("too few subscripts for `%s'", spar->name);
      get_token(/* ] */);
skip: /* find objective member */
      for (memb = spar->first; memb != NULL; memb = memb->next)
      {  for (k = 0; k < spar->dim; k++)
            if (memb->item[k] != item[k]) break;
         if (k == spar->dim) break;
      }
      if (memb == NULL) fatal("objective not exist");
      if (pdb->obj_spar != NULL) fatal("objective already defined");
      pdb->obj_spar = spar;
      pdb->obj_memb = memb;
      if (!t_spec(";")) fatal("semicolon missing");
      get_token(/* ; */);
      return;
}

/*----------------------------------------------------------------------
-- display_stmt - parse print statement.
--
-- This routine parses display statement using the syntax:
--
-- <display statement> ::= print <object list> ;
-- <object list> ::= <object> | <object list> , <object>
-- <object> ::= <name> | ( <expression> )
--
-- where name may denote any named object (set, predicate, parameter,
-- variable, constraint, or set element). */

void display_stmt(void)
{     AVLNODE *node;
      char str[100];
      outstr(NULL);
      sprintf(str, "*** display statement at line %d ***",
         pdb->text->line);
      outstr(str);
      outstr("\n");
      get_token(/* print */);
loop: if (token == T_NAME)
      {  node = find_by_key(pdb->tree, image);
         if (node == NULL)
            fatal("symbol `%s' not declared", image);
         if (node->type == 'I')
         {  ITEM *item = node->link;
            outstr("\n");
            outstr("item ");
            outstr(item->name);
            outstr(" in set ");
            outstr(item->set->name);
            outstr("\n");
         }
         else
            print_spar(node->link, 0);
         get_token(/* name */);
      }
      else if (t_spec("("))
      {  get_token(/* ( */);
         print_spar(expression(), 1);
         if (!t_spec(")")) fatal("missing right parenthesis");
         get_token(/* ) */);
      }
      else
         fatal("display statement syntax error");
      if (t_spec(","))
      {  get_token(/* , */);
         goto loop;
      }
      if (!t_spec(";")) fatal("semicolon missing");
      outstr("\n");
      get_token(/* ; */);
      return;
}

/*----------------------------------------------------------------------
-- parse_model - parse model description.
--
-- This routine parses model description using the syntax:
--
-- <model> ::= model <name> ; <statement list> end ; _|_
-- <statement list> ::= <statement> | <statement list> , <statement>
-- <statement> ::= <set declaration>
-- <statement> ::= <predicate declaration>
-- <statement> ::= <parameter declaration>
-- <statement> ::= <variable declaration>
-- <statement> ::= <constraint declaration>
-- <statement> ::= <assignment statement>
-- <statement> ::= <objective statement>
-- <statement> ::= <display statement>
--
-- Syntactically this routine corresponds to the main non-terminal. */

void parse_model(void)
{     if (!t_name("model")) fatal("`model' keyword missing");
      get_token(/* model */);
      if (token != T_NAME) fatal("model name missing or invalid");
      strcpy(pdb->model_name, image);
      get_token(/* name */);
      if (!t_spec(";")) fatal("semicolon missing");
      get_token(/* ; */);
      /* parse declaration and statement list */
      for (;;)
      {  if (token == T_EOF)
            fatal("unexpected end of file");
         else if (t_name("set") || t_name("sets"))
            set_decl();
         else if (t_name("predicate") || t_name("predicates"))
            array_decl('P');
         else if (t_name("parameter") || t_name("parameters"))
            array_decl('X');
         else if (t_name("variable") || t_name("variables"))
            var_decl(0);
         else if (t_name("integer"))
         {  get_token(/* integer */);
            if (!(t_name("variable") || t_name("variables")))
               fatal("`variable' keyword missing");
            var_decl(1);
         }
         else if (t_name("binary"))
         {  get_token(/* binary */);
            if (!(t_name("variable") || t_name("variables")))
               fatal("`variable' keyword missing");
            var_decl(2);
         }
         else if (t_name("constraint") || t_name("constraints"))
            array_decl('C');
         else if (t_name("minimize") || t_name("maximize"))
            objective();
         else if (t_name("display"))
            display_stmt();
         else if (t_name("end"))
            break;
         else if (token == T_NAME)
            assign_stmt();
         else
            fatal("syntax error");
      }
      get_token(/* end */);
      if (!t_spec(";")) fatal("semicolon expected");
      get_token(/* ; */);
      if (token != T_EOF)
         fatal("extra symbols detected behind end statement");
      return;
}

/* eof */
