===================================================================
RCS file: /home/cvs/OpenXM_contrib2/asir2000/builtin/strobj.c,v
retrieving revision 1.27
retrieving revision 1.36
diff -u -p -r1.27 -r1.36
--- OpenXM_contrib2/asir2000/builtin/strobj.c	2004/03/05 05:15:47	1.27
+++ OpenXM_contrib2/asir2000/builtin/strobj.c	2004/03/10 05:37:24	1.36
@@ -45,7 +45,7 @@
  * DEVELOPER SHALL HAVE NO LIABILITY IN CONNECTION WITH THE USE,
  * PERFORMANCE OR NON-PERFORMANCE OF THE SOFTWARE.
  *
- * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.26 2004/03/05 01:47:19 noro Exp $
+ * $OpenXM: OpenXM_contrib2/asir2000/builtin/strobj.c,v 1.35 2004/03/10 05:27:03 noro Exp $
 */
 #include "ca.h"
 #include "parse.h"
@@ -77,9 +77,13 @@ void Pquotetotex();
 void Pquotetotex_env();
 void fnodetotex_tb(FNODE f,TB tb);
 char *symbol_name(char *name);
+char *conv_rule(char *name);
+char *conv_subscript(char *name);
+char *call_convfunc(char *name);
 void tb_to_string(TB tb,STRING *rp);
 void fnodenodetotex_tb(NODE n,TB tb);
 void fargstotex_tb(char *opname,FNODE f,TB tb);
+int top_is_minus(FNODE f);
 
 struct ftab str_tab[] = {
 	{"rtostr",Prtostr,1},
@@ -114,16 +118,22 @@ int register_symbol_table(Obj arg);
 int register_conv_rule(Obj arg);
 int register_dp_vars(Obj arg);
 int register_dp_vars_prefix(Obj arg);
+int register_dp_vars_hweyl(Obj arg);
 int register_show_lt(Obj arg);
 static struct TeXSymbol *user_texsymbol;
-static char *(*conv_rule)(char *);
 static char **dp_vars;
 static int dp_vars_len;
 static char *dp_vars_prefix;
 static int show_lt;
 static FUNC convfunc;
 static int is_lt;
+static int conv_flag;
+static int dp_vars_hweyl;
 
+#define CONV_SUBSCRIPT (1U<<0)
+#define CONV_DMODE (1U<<1)
+#define CONV_USERFUNC (1U<<31)
+
 static struct {
 	char *name;
 	Obj value;
@@ -133,77 +143,90 @@ static struct {
 	{"conv_rule",0,register_conv_rule},
 	{"dp_vars",0,register_dp_vars},
 	{"dp_vars_prefix",0,register_dp_vars_prefix},
+	{"dp_vars_hweyl",0,register_dp_vars_hweyl},
 	{"show_lt",0,register_show_lt},
 	{0,0,0},
 };
 
 #define PARTIAL "\\partial"
-char *conv_rule_d(char *name)
+
+char *conv_rule(char *name)
 {
-	int l,i,j,alpha,start;
-	char *b,*r;
-	l = strlen(name);
+	char *body,*r;
 
-	if ( name[0] == 'd' ) {
-		/* 3 : _{} */
-		b = (char *)ALLOCA((2*l+1+strlen(PARTIAL)+3)*sizeof(char));
-		sprintf(b,"%s_{",PARTIAL);
-		i = 1;
-		j = strlen(b);
-	} else {
-		b = (char *)ALLOCA((2*l+1)*sizeof(char));
-		i = j = 0;
-	}
-	for ( ; i < l && name[i] == '_'; i++);
-	for ( ; i < l; ) {
-		if ( !isalpha(name[i]) )
-			break;
-		else
-			b[j++] = name[i++];
-	}
-	if ( i == l )
-		if ( name[0] == 'd' )
-			goto END;
-		else
-			return name;
-	/* we found a digit or '_' */
-	b[j++] = '_'; b[j++] = '{';
-	if ( name[i] == '_' ) i++;
-	for ( start = 1; i < l; ) {
-		if ( name[i] == '{' || name[i] == '}' || name[i] == ' ' )
-			b[j++] = name[i++];
-		else if ( name[i] == '_' ) {
-			i++;
-			start = 1;
-			b[j++] = ',';
-		} else if ( start ) {
-			alpha = isalpha(name[i])?1:0;
-			b[j++] = name[i++];
-			start = 0;
-		} else if ( alpha ) {
-			if ( isalpha(name[i]) )
-				b[j++] = name[i++];
-			else {
-				alpha = 0;
-				start = 1;
-				b[j++] = ',';
+	if ( conv_flag & CONV_DMODE ) {
+		if ( *name == 'd' ) {
+			if ( conv_flag & CONV_SUBSCRIPT )
+				body = conv_subscript(name+1);
+			else
+				body = name+1;
+			r = MALLOC_ATOMIC((strlen(PARTIAL)+strlen(body)+5)*sizeof(char));
+			sprintf(r,"{%s}_{%s}",PARTIAL,body);
+			return r;
+		} else {
+			if ( conv_flag & CONV_SUBSCRIPT )
+				body = conv_subscript(name);
+			else
+				body = name;
+		}
+	} else if ( conv_flag & CONV_SUBSCRIPT )
+		return conv_subscript(name);
+	else if ( conv_flag & CONV_USERFUNC && convfunc )
+		return call_convfunc(name);
+	else
+		return name;
+}
+
+char *conv_subscript(char *name)
+{
+	int i,j,k,len,clen,slen,start,level;
+	char *buf,*head,*r,*h,*brace;
+	char **subs;
+
+	len = strlen(name);
+	subs = (char **)ALLOCA(len*sizeof(char* ));
+	for ( i = 0, j = 0, start = i; ; j++ ) {
+		while ( (i < len) && 
+			(name[i] == ' ' || name[i] == '_' || name[i] == ',') ) i++;
+		start = i;
+		if ( i == len ) break;
+		if ( name[i] == '{' ) {
+			for ( level = 1, i++; i < len && level; i++ ) {
+				if ( name[i] == '{' ) level++;
+				else if ( name[i] == '}' ) level--;
 			}
+			slen = i-start;	
+			brace = (char *)ALLOCA((slen+1)*sizeof(char));
+			strncpy(brace,name+start+1,slen-2);
+			brace[slen-2] = 0;
+			buf = conv_subscript(brace);
+			subs[j] = (char *)ALLOCA((strlen(buf)+3)*sizeof(char));
+			sprintf(subs[j],"{%s}",buf);
 		} else {
 			if ( isdigit(name[i]) )
-				b[j++] = name[i++];
-			else {
-				alpha = 1;
-				start = 1;
-				b[j++] = ',';
-			}
+				while ( i < len && isdigit(name[i]) ) i++;
+			else
+				while ( i < len && (isalpha(name[i]) || name[i] == '\\') ) i++;
+			slen = i-start;	
+			buf = (char *)ALLOCA((slen+1)*sizeof(char));
+			strncpy(buf,name+start,slen); buf[slen] = 0;
+			subs[j] = symbol_name(buf);
 		}
 	}
-	b[j++] = '}';
-END:
-	if ( name[0] == 'd' ) b[j++] = '}';
-	b[j++] = 0;
-	r = (char *)MALLOC_ATOMIC((j+1)*sizeof(char));	
-	strcpy(r,b);
+	for ( k = 0, clen = 0; k < j; k++ ) clen += strlen(subs[k]);
+	/* {subs(0)}_{{subs(1)},...,{subs(j-1)}} => {}:j+1 _:1 ,:j-2 */
+	h = r = MALLOC_ATOMIC((clen+(j+1)*2+1+(j-2)+1)*sizeof(char));
+	if ( j == 1 )
+		sprintf(h,"{%s}",subs[0]);
+	else {
+		sprintf(h,"{%s}_{{%s}",subs[0],subs[1]);
+		h += strlen(h);
+		for ( k = 2; k < j; k++ ) {
+			sprintf(h,",{%s}",subs[k]);
+			h += strlen(h);
+		}
+		strcpy(h,"}");
+	}
 	return r;
 }
 
@@ -266,6 +289,14 @@ int register_symbol_table(Obj arg)
 	return 1;
 }
 
+int register_dp_vars_hweyl(Obj arg)
+{
+	if ( INT(arg) ) {
+		dp_vars_hweyl = QTOS((Q)arg);
+		return 1;
+	} else return 0;
+}
+
 int register_show_lt(Obj arg)
 {
 	if ( INT(arg) ) {
@@ -277,24 +308,14 @@ int register_show_lt(Obj arg)
 int register_conv_rule(Obj arg)
 {
 	if ( INT(arg) ) {
-		switch ( QTOS((Q)arg) ) {
-			case 0:
-				conv_rule = 0;
-				return 1;
-				break;
-			case 1:
-				conv_rule = conv_rule_d;
-				return 1;
-				break;
-			default:
-				return 0;
-				break;
-		}
+		conv_flag = QTOS((Q)arg);
+		convfunc = 0;
+		return 1;
 	} else if ( OID(arg) == O_P && 
 		(int)(VR((P)arg))->attr == V_SR ) {
+		conv_flag = CONV_USERFUNC;
 		convfunc = (FUNC)(VR((P)arg)->priv);
 		/* f must be a function which takes single argument */
-		conv_rule = call_convfunc;
 		return 1;
 	} else return 0;
 }
@@ -364,6 +385,11 @@ void Pquotetotex_env(NODE arg,Obj *rp)
 		NEXT(n) = 0;
 		MKLIST(l,n0);
 		*rp = (Obj)l;
+	} else if ( ac == 1 && !ARG0(arg) ) {
+		/* set to default */
+		for ( i = 0; qtot_env[i].name; i++ )
+			qtot_env[i].value = 0;
+		*rp = 0;
 	} else if ( ac == 1 || ac == 2 ) {
 		asir_assert(ARG0(arg),O_STR,"quotetotex_env");
 		name = BDY((STRING)ARG0(arg));
@@ -736,10 +762,7 @@ char *symbol_name(char *name)
 	for ( i = 0; texsymbol[i].text; i++ )
 		if ( !strcmp(texsymbol[i].text,name) )
 			return texsymbol[i].symbol;
-	if ( conv_rule )
-		return (*conv_rule)(name);
-	else
-		return name;
+	return name;
 }
 
 void fnodetotex_tb(FNODE f,TB tb)
@@ -748,7 +771,7 @@ void fnodetotex_tb(FNODE f,TB tb)
 	char vname[BUFSIZ];
 	char *opname,*vname_conv;
 	Obj obj;
-	int i,len,allzero;
+	int i,len,allzero,elen,elen2;
 	FNODE fi,f2;
 
 	write_tb(" ",tb);
@@ -781,7 +804,7 @@ void fnodetotex_tb(FNODE f,TB tb)
 			opname = ((ARF)FA0(f))->name;
 			if ( !strcmp(opname,"+") ) {
 				fnodetotex_tb((FNODE)FA1(f),tb);
-				write_tb(opname,tb);
+				if ( !top_is_minus((FNODE)FA2(f)) ) write_tb(opname,tb);
 				fnodetotex_tb((FNODE)FA2(f),tb);
 			} else if ( !strcmp(opname,"-") ) {
 				if ( FA1(f) ) fnodetotex_tb((FNODE)FA1(f),tb);
@@ -935,7 +958,7 @@ void fnodetotex_tb(FNODE f,TB tb)
 
 		/* function */
 		case I_FUNC:
-			opname = symbol_name(((FUNC)FA0(f))->name);
+			opname = conv_rule(((FUNC)FA0(f))->name);
 			write_tb(opname,tb);
 			write_tb("(",tb);
 			fargstotex_tb(opname,FA1(f),tb);
@@ -944,7 +967,7 @@ void fnodetotex_tb(FNODE f,TB tb)
 
 		/* XXX */
 		case I_CAR:
-			opname = symbol_name("car");
+			opname = conv_rule("car");
 			write_tb(opname,tb);
 			write_tb("(",tb);
 			fargstotex_tb(opname,FA0(f),tb);
@@ -952,7 +975,7 @@ void fnodetotex_tb(FNODE f,TB tb)
 			break;
 
 		case I_CDR:
-			opname = symbol_name("cdr");
+			opname = conv_rule("cdr");
 			write_tb(opname,tb);
 			write_tb("(",tb);
 			fargstotex_tb(opname,FA0(f),tb);
@@ -962,6 +985,11 @@ void fnodetotex_tb(FNODE f,TB tb)
 		/* exponent vector */
 		case I_EV:
 			n = (NODE)FA0(f);
+			if ( dp_vars_hweyl ) {
+				elen = length(n);
+				elen2 = elen>>1;
+				elen = elen2<<1;
+			}
 			allzero = 1;
 			if ( show_lt && is_lt )
 				write_tb("\\underline{",tb);
@@ -969,13 +997,23 @@ void fnodetotex_tb(FNODE f,TB tb)
 				fi = (FNODE)BDY(n);
 				if ( fi->id == I_FORMULA && !FA0(fi) ) continue;
 				allzero = 0;
-				if ( dp_vars && i < dp_vars_len )
+				if ( dp_vars_hweyl ) {
+					if ( i < elen2 )
+						if ( dp_vars_prefix )
+							sprintf(vname,"%s_{%d}",dp_vars_prefix,i);
+						else
+							sprintf(vname,"x_{%d}",i);
+					else if ( i < elen )
+						sprintf(vname,"{\\partial}_{%d}",i-elen2);
+					else
+						strcpy(vname,"h");
+				} else if ( dp_vars && i < dp_vars_len )
 					strcpy(vname,dp_vars[i]);
 				else if ( dp_vars_prefix )
 					sprintf(vname,"%s_{%d}",dp_vars_prefix,i);
 				else
 					sprintf(vname,"x_{%d}",i);
-				vname_conv = symbol_name(vname);
+				vname_conv = conv_rule(vname);
 				if ( fi->id == I_FORMULA && UNIQ(FA0(fi)) ) {
 					len = strlen(vname_conv);
 					opname = MALLOC_ATOMIC(len+2);
@@ -1009,7 +1047,7 @@ void fnodetotex_tb(FNODE f,TB tb)
 		case I_FORMULA:
 			obj = (Obj)FA0(f);
 			if ( obj && OID(obj) == O_P ) {
-				opname = symbol_name(VR((P)obj)->name);
+				opname = conv_rule(VR((P)obj)->name);
 			} else {
 				len = estimate_length(CO,obj);
 				opname = (char *)MALLOC_ATOMIC(len+1);
@@ -1055,5 +1093,63 @@ void fargstotex_tb(char *name,FNODE f,TB tb)
 			fnodenodetotex_tb(n,tb);
 		} else
 			fnodetotex_tb(f,tb);
+	}
+}
+
+int top_is_minus(FNODE f)
+{
+	char *opname;
+	int len;
+	Obj obj;
+
+	if ( !f )
+		return 0;
+	switch ( f->id ) {
+		case I_MINUS:
+			return 1;
+		case I_BOP:
+			opname = ((ARF)FA0(f))->name;
+			switch ( opname[0] ) {
+				case '+': case '*': case '/': case '^': case '%': 
+					return top_is_minus((FNODE)FA1(f));
+				case '-':
+					if ( FA1(f) )
+						return top_is_minus((FNODE)FA1(f));
+					else
+						return 1;
+				default:
+					return 0;
+			}
+			break;
+		case I_COP:
+			return top_is_minus((FNODE)FA1(f));
+		case I_LOP:
+			if ( (lid)FA0(f) == L_NOT ) return 0;
+			else return top_is_minus((FNODE)FA1(f));
+		case I_AND: case I_OR:
+			return top_is_minus((FNODE)FA0(f));
+		case I_FORMULA:
+			obj = (Obj)FA0(f);
+			if ( !obj )
+				return 0;
+			else {
+				switch ( OID(obj) ) {
+					case O_N:
+						return mmono((P)obj);
+					case O_P:
+						/* must be a variable */
+						opname = conv_rule(VR((P)obj)->name);
+						return opname[0]=='-';
+					default:
+						/* ??? */
+						len = estimate_length(CO,obj);
+						opname = (char *)MALLOC_ATOMIC(len+1);
+						soutput_init(opname);
+						sprintexpr(CO,obj);
+						return opname[0]=='-';
+				}
+			}
+		default:
+			return 0;
 	}
 }