/* Interpretation of Xconq GDL, part 2.
   Copyright (C) 1989, 1991-1998 Stanley T. Shebs.

Xconq 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.  See the file COPYING.  */

/* Syntax is el cheapo Lisp. */

#include "conq.h"
extern int lookup_action_type PARAMS ((char *name));
extern void interp_utype_list PARAMS ((short *arr, Obj *lis));
extern void interp_short_array PARAMS ((short *arr, Obj *lis, int n));
extern void interp_long_array PARAMS ((long *arr, Obj *lis, int n));
extern int eval_number PARAMS ((Obj *val, int *isnumber));
#include "kernel.h"
#include "imf.h"

extern void interp_utype_value_list PARAMS ((short *arr, Obj *lis));
extern void interp_mtype_value_list PARAMS ((short *arr, Obj *lis));
extern void interp_atype_value_list PARAMS ((short *arr, Obj *lis));
extern void read_layer PARAMS ((Obj *contents, void (*setter)(int, int, int)));
extern void read_rle PARAMS ((Obj *contents, void (*setter)(int, int, int), short *chartable));

/* Globals used to communicate with the RLE reader. */

extern short layer_use_default;
extern int layer_default;
extern int layer_multiplier;
extern int layer_adder;
extern short layer_area_x, layer_area_y;
extern short layer_area_w, layer_area_h;

extern int ignore_specials;

extern char *readerrbuf;

#define TYPEPROP(TYPES, N, DEFNS, I, TYPE)  \
  ((TYPE *) &(((char *) (&(TYPES[N])))[DEFNS[I].offset]))[0]

/* This is a generic syntax check and escape. */

#define SYNTAX(X,TEST,MSG)  \
  if (!(TEST)) {  \
      syntax_error((X), (MSG));  \
      return;  \
  }
  
#define SYNTAX_RETURN(X,TEST,MSG,RET)  \
  if (!(TEST)) {  \
      syntax_error((X), (MSG));  \
      return (RET);  \
  }

#define TYPECHECK(PRED,X,MSG)  \
  if (!PRED(X)) {  \
      type_error((X), (MSG));  \
      return;  \
  }

#define TYPECHECK_RETURN(PRED,X,MSG,RET)  \
  if (!PRED(X)) {  \
      type_error((X), (MSG));  \
      return (RET);  \
  }

void
interp_utype_value_list(arr, lis)
short *arr;
Obj *lis;
{
    int u = 0;
    Obj *rest, *head, *types, *values, *subrest, *subrest2, *uval;

    /* Assume that if the destination array does not exist, there is
       probably a reason, and it's not our concern. */
    if (arr == NULL)
      return;
    for_all_list(lis, rest) {
    	head = car(rest);
    	if (numberp(head)) {
	    if (u < numutypes) {
	    	arr[u++] = c_number(head);
	    } else {
		init_warning("too many numbers in list");
	    }
	} else if (consp(head)) {
	    types = eval(car(head));
	    values = eval(cadr(head));
	    if (utypep(types)) {
		u = types->v.num;
	    	arr[u++] = c_number(values);
	    } else if (consp(values)) {
		for_both_lists(types, values, subrest, subrest2) {
		    uval = car(subrest);
		    TYPECHECK(utypep, uval, "not a unit type");
		    u = uval->v.num;
		    arr[u++] = c_number(car(subrest2));
		}
	    } else {
		for_all_list(types, subrest) {
		    uval = car(subrest);
		    TYPECHECK(utypep, uval, "not a unit type");
		    u = uval->v.num;
		    arr[u++] = c_number(values);
		}
	    }
	} else {
	    /* syntax error */
	}
    }
}

void
interp_mtype_value_list(arr, lis)
short *arr;
Obj *lis;
{
    int m = 0;
    Obj *rest, *head, *types, *values, *subrest, *subrest2, *mval;

    /* Assume that if the destination array does not exist, there is
       probably a reason, and it's not our concern. */
    if (arr == NULL)
      return;
    for_all_list(lis, rest) {
    	head = car(rest);
    	if (numberp(head)) {
	    if (m < nummtypes) {
	    	arr[m++] = c_number(head);
	    } else {
		init_warning("too many numbers in list");
	    }
	} else if (consp(head)) {
	    types = eval(car(head));
	    values = eval(cadr(head));
	    if (mtypep(types)) {
		m = types->v.num;
	    	arr[m++] = c_number(values);
	    } else if (consp(values)) {
		for_both_lists(types, values, subrest, subrest2) {
		    mval = car(subrest);
		    TYPECHECK(mtypep, mval, "not a material type");
		    m = mval->v.num;
		    arr[m++] = c_number(car(subrest2));
		}
	    } else {
		for_all_list(types, subrest) {
		    mval = car(subrest);
		    TYPECHECK(mtypep, mval, "not a material type");
		    m = mval->v.num;
		    arr[m++] = c_number(values);
		}
	    }
	} else {
	    /* syntax error */
	}
    }
}

void
interp_atype_value_list(arr, lis)
short *arr;
Obj *lis;
{
    int a = 0;
    Obj *rest, *head, *types, *values, *subrest, *subrest2, *aval;

    /* Assume that if the destination array does not exist, there is
       probably a reason, and it's not our concern. */
    if (arr == NULL)
      return;
    for_all_list(lis, rest) {
    	head = car(rest);
    	if (numberp(head)) {
	    if (a < numatypes) {
	    	arr[a++] = c_number(head);
	    } else {
		init_warning("too many numbers in list");
	    }
	} else if (consp(head)) {
	    types = eval(car(head));
	    values = eval(cadr(head));
	    if (atypep(types)) {
		a = types->v.num;
	    	arr[a++] = c_number(values);
	    } else if (consp(values)) {
		for_both_lists(types, values, subrest, subrest2) {
		    aval = car(subrest);
		    TYPECHECK(atypep, aval, "not an advance");
		    a = aval->v.num;
		    arr[a++] = c_number(car(subrest2));
		}
	    } else {
		for_all_list(types, subrest) {
		    aval = car(subrest);
		    TYPECHECK(atypep, aval, "not an advance");
		    a = aval->v.num;
		    arr[a++] = c_number(values);
		}
	    }
	} else {
	    /* syntax error */
	}
    }
}

void
read_layer(contents, setter)
Obj *contents;
void (*setter) PARAMS ((int, int, int));
{
    int i, slen, n, ix, len, usechartable = FALSE;
    char *str;
    short chartable[256];
    Obj *rest, *desc, *rest2, *subdesc, *sym, *num;

    layer_use_default = FALSE;
    layer_default = 0;
    layer_multiplier = 1;
    layer_adder = 0;
    layer_area_x = area.fullx;  layer_area_y = area.fully;
    layer_area_w = area.width;  layer_area_h = area.height;
    if (area.fullwidth > 0)
      layer_area_w = area.fullwidth;
    if (area.fullheight > 0)
      layer_area_h = area.fullheight;
    ignore_specials = FALSE;
    for_all_list(contents, rest) {
	desc = car(rest);
	if (stringp(desc)) {
	    /* Read from here to the end of the list, interpreting as
	       contents. */
	    read_rle(rest, setter, (usechartable ? chartable : NULL));
	    return;
	} else if (consp(desc) && symbolp(car(desc))) {
	    switch (keyword_code(c_string(car(desc)))) {
	      case K_CONSTANT:
		/* should set to a constant value taken from cadr */
		read_warning("Constant layers not supported yet");
		return;
	      case K_SUBAREA:
	        /* should apply data to a subarea */
		read_warning("Layer subareas not supported yet");
		break;
	      case K_XFORM:
		layer_multiplier = c_number(cadr(desc));
		layer_adder = c_number(caddr(desc));
		break;
	      case K_BY_BITS:
		break;
	      case K_BY_CHAR:
		/* Assign each char to its corresponding index. */
		/* First seed the table with a 1-1 map. */
		for (i = 0; i < 255; ++i)
		  chartable[i] = 0;
		for (i = 'a'; i <= '~'; ++i)
		  chartable[i] = i - 'a';
		for (i = ':'; i <= '['; ++i)
		  chartable[i] = i - ':' + 30;
		str = c_string(cadr(desc));
		len = strlen(str);
		for (i = 0; i < len; ++i) {
		    chartable[(int) str[i]] = i;
		    /* If special chars in by-char string, flag it. */
		    if (str[i] == '*' || str[i] == ',')
		      ignore_specials = TRUE;
		}
		usechartable = TRUE;
		break;
	      case K_BY_NAME:
		/* Work through list and match names to numbers. */
		/* First seed the table with a 1-1 map. */
		for (i = 0; i < 255; ++i)
		  chartable[i] = 0;
		for (i = 'a'; i <= '~'; ++i)
		  chartable[i] = i - 'a';
		for (i = ':'; i <= '['; ++i)
		  chartable[i] = i - ':' + 30;
		desc = cdr(desc);
		/* Support optional explicit string a la by-char. */
		if (stringp(car(desc))) {
		    str = c_string(car(desc));
		    slen = strlen(str);
		    for (i = 0; i < slen; ++i)
		      chartable[(int) str[i]] = i;
		    desc = cdr(desc);
		} else {
		    str = NULL;
		}
		i = 0;
		for (rest2 = desc; rest2 != lispnil; rest2 = cdr(rest2)) {
		    subdesc = car(rest2);
		    if (symbolp(subdesc)) {
		    	sym = subdesc;
		    	ix = i++;
		    } else if (consp(subdesc)) {
		    	sym = car(subdesc);
		    	num = cadr(subdesc);
		    	TYPECHECK(numberp, num,
				  "by-name explicit value is not a number");
		    	ix = c_number(num);
		    } else {
		    	read_warning("garbage by-name subdesc, ignoring");
		    	continue;
		    }
		    /* Eval the symbol into something resembling a value. */
		    sym = eval(sym);
		    TYPECHECK(numberishp, sym,
			      "by-name index is not a number or type");
		    n = c_number(sym);
		    chartable[(str ? str[ix] : (ix <= 29 ? ('a' + ix) : (':' + ix - 30)))] = n;
		}
		usechartable = TRUE;
		break;
	      default:
		sprintlisp(readerrbuf, desc, BUFSIZE);
		read_warning("Ignoring garbage terrain description %s",
			     readerrbuf);
	    }
	}
    }
}

/* General RLE reader.  This basically parses the run lengths and calls
   the function that records what was read. */

void
read_rle(contents, setter, chartable)
Obj *contents;
void (*setter) PARAMS ((int, int, int));
short *chartable;
{
    char ch, *rowstr;
    int i, x, y, run, val, sawval, sawneg, sgn, x1, y1, numbadchars = 0;
    Obj *rest;

    rest = contents;
    y = layer_area_h - 1;
    while (rest != lispnil && y >= 0) {
	/* should error check ... */
	rowstr = c_string(car(rest));
	i = 0;
	x = 0;  /* depends on shape of saved data... */
	while ((ch = rowstr[i++]) != '\0' && x < layer_area_w) {
	    sawval = FALSE;
	    sawneg = FALSE;
	    if (isdigit(ch) || ch == '-') {
		if (ch == '-') {
		    sawneg = TRUE;
		    ch = rowstr[i++];
		    /* A minus sign by itself is a problem. */
		    if (!isdigit(ch))
		      goto recovery;
		}
		/* Interpret a substring of digits as a run length. */
		run = ch - '0';
		while ((ch = rowstr[i++]) != 0 && isdigit(ch)) {
		    run = run * 10 + ch - '0';
		}
		/* A '*' separates a run and a numeric value. */
		if (ch == '*' && !ignore_specials) {
		    /* A negative run length is a problem. */
		    if (sawneg)
		      goto recovery;
		    ch = rowstr[i++];
		    /* If we're seeing garbled data, skip to the next line. */
		    if (ch == '\0')
		      goto recovery;
		    /* Recognize a negative number. */
		    sgn = 1;
		    if (ch == '-') {
			sgn = -1;
			ch = rowstr[i++];
		    }
		    /* Interpret these digits as a value. */
		    if (isdigit(ch)) {
			val = ch - '0';
			while ((ch = rowstr[i++]) != 0 && isdigit(ch)) {
			    val = val * 10 + ch - '0';
			}
			sawval = TRUE;
			val = sgn * val;
		    } else {
			/* Some other char seen - just ignore the '*' then. */
		    }
		    /* If we're seeing garbled data, skip to the next line. */
		    if (ch == '\0')
		      goto recovery;
		}
		/* If we're seeing garbled data, skip to the next line. */
		if (ch == '\0')
		  goto recovery;
	    } else {
		run = 1;
	    }
	    if (ch == ',' && !ignore_specials) {
	    	if (!sawval) {
		    /* This was a value instead of a run length. */
		    val = run;
		    /* If it was prefixed with a minus sign originally,
		       negate the value. */
		    if (sawneg)
		      val = - val;
		    run = 1;
		} else {
		    /* Comma is just being a separator. */
		}
	    } else if (chartable != NULL) {
		val = chartable[ch];
	    } else if (between('a', ch, '~')) {
		val = ch - 'a';
	    } else if (between(':', ch, '[')) {
		val = ch - ':' + 30;
	    } else {
	    	/* Warn about strange characters. */
		++numbadchars;
		if (numbadchars <= 5) {
		    read_warning(
		     "Bad char '%c' (0x%x) in layer, using NUL instead",
				 ch, ch);
		    /* Clarify that we're not going to report all bad chars. */
		    if (numbadchars == 5)
		      read_warning(
		     "Additional bad chars will not be reported individually");
		}
		val = 0;
	    }
	    val = val * layer_multiplier + layer_adder;
	    /* Given a run of values, stuff them into the layer. */
	    while (run-- > 0) {
	    	x1 = wrapx(x - layer_area_x);  y1 = y - layer_area_y;
	    	if (in_area(x1, y1))
		  (*setter)(x1, y1, val);
		++x;
	    }
	}
      recovery:
	/* Fill-in string may be too short for this row; just leave
	   the rest of it alone, assume that somebody has assured
	   that the contents are reasonable. */
	rest = cdr(rest);
	y--;
    }
    /* Report the count of garbage chars, in case there were a great many. */
    if (numbadchars > 0)
      init_warning("A total of %d bad chars were present", numbadchars);
}
