wxString cRawParser::HandleStringContent(const wxString& content, bool* variable, bool addprefix) {
wxString t(content);
if (variable)
*variable = MakeVariable(t);
else
MakeVariable(t);
if (t.IsEmpty())
return t;
if (addprefix)
t = wxString(m_prefix.c_str(), wxConvLocal) + t;
return t;
}
void cRawParser::ParseStringOption(wxString& str, const cXmlNode& node, const wxString& attribute, bool* variable, bool addprefix) {
wxString t(node.wxgetPropVal(attribute));
if (variable)
*variable = MakeVariable(t);
else
MakeVariable(t);
if (!t.IsEmpty()) {
if (addprefix) {
str = wxString(m_prefix.c_str(), wxConvLocal) + t;
} else {
str = t;
}
} else {
if (node.hasProp(attribute.utf8_str()))
str = "";
}
}
long cRawParser::ParseSigned(const cXmlNode& node, const wxString& nodes, const wxString& attribute) {
wxString t(node.getPropVal(attribute.mb_str(wxConvUTF8)).c_str(), wxConvUTF8);
MakeVariable(t);
long i;
if (t.IsEmpty())
throw MakeNodeException<RCT3Exception>(nodes+_(" tag misses ") + attribute + _(" attribute"), node);
if (!t.ToLong(&i))
throw MakeNodeException<RCT3InvalidValueException>(nodes+_(" tag, ") + attribute + _(" attribute: invalid value ")+t, node);
return i;
}
double cRawParser::ParseFloat(const cXmlNode& node, const wxString& nodes, const wxString& attribute) {
wxString t = node.wxgetPropVal(attribute);
MakeVariable(t);
double i;
if (t.IsEmpty())
throw MakeNodeException<RCT3Exception>(nodes+_(" tag misses ") + attribute + _(" attribute"), node);
string ts = static_cast<const char*>(t.utf8_str());
if (!parseFloat(ts, i))
throw MakeNodeException<RCT3InvalidValueException>(nodes+_(" tag, ") + attribute + _(" attribute: invalid value ")+t, node);
return i;
}
cOvlType cRawParser::ParseType(const cXmlNode& node, const wxString& nodes, const wxString& attribute) {
wxString t(node.wxgetPropVal(attribute));
MakeVariable(t);
if (t.IsEmpty())
throw MakeNodeException<RCT3Exception>(nodes+_(" tag misses ") + attribute + _(" attribute"), node);
if (t == "common") {
return OVLT_COMMON;
} else if (t == "unique") {
return OVLT_UNIQUE;
} else {
throw MakeNodeException<RCT3InvalidValueException>(nodes+_(" tag, ") + attribute + _(" attribute: invalid value ")+t, node);
}
}
unsigned long cRawParser::HandleUnsignedContent(const wxString& content, const cXmlNode& node, const wxString& nodes, const wxString& attribute) {
wxString t(content);
MakeVariable(t);
unsigned long i;
if (t.IsEmpty()) {
if (attribute.IsEmpty())
throw MakeNodeException<RCT3Exception>(wxString::Format(_("Tag '%s' misses content"), nodes.c_str()), node);
else
throw MakeNodeException<RCT3Exception>(wxString::Format(_("Tag '%s' misses attribute '%s'"), nodes.c_str(), attribute.c_str()), node);
}
if (t.StartsWith('b')) {
try {
bitset<32> bits(string(t.utf8_str()), 1);
i = bits.to_ulong();
} catch (exception& e) {
if (attribute.IsEmpty())
throw MakeNodeException<RCT3Exception>(wxString::Format(_("Tag '%s': invalid binary content '%s'"), nodes.c_str(), t.c_str()), node);
else
throw MakeNodeException<RCT3Exception>(wxString::Format(_("Tag '%s', '%s': invalid binary content '%s'"), nodes.c_str(), attribute.c_str(), t.c_str()), node);
}
} else if (t.StartsWith('h') || t.StartsWith("0x")) {
wxString hex;
if (!t.StartsWith('h', &hex))
t.StartsWith("0x", &hex);
if (!parseHexULong(hex, i)) {
if (attribute.IsEmpty())
throw MakeNodeException<RCT3Exception>(wxString::Format(_("Tag '%s': invalid hex content '%s'"), nodes.c_str(), t.c_str()), node);
else
throw MakeNodeException<RCT3Exception>(wxString::Format(_("Tag '%s', '%s': invalid hex content '%s'"), nodes.c_str(), attribute.c_str(), t.c_str()), node);
}
} else if (t == "true") {
i = 1;
} else if (t == "false") {
i = 0;
} else if (!t.ToULong(&i)) {
if (attribute.IsEmpty())
throw MakeNodeException<RCT3Exception>(wxString::Format(_("Tag '%s': invalid value '%s'"), nodes.c_str(), t.c_str()), node);
else
throw MakeNodeException<RCT3Exception>(wxString::Format(_("Tag '%s', '%s': invalid value '%s'"), nodes.c_str(), attribute.c_str(), t.c_str()), node);
}
return i;
}
static int FindSubexprs(SEXP expr, SEXP exprlist, SEXP tag)
{
SEXP e;
int k;
switch(TYPEOF(expr)) {
case SYMSXP:
case LGLSXP:
case INTSXP:
case REALSXP:
case CPLXSXP:
return 0;
break;
case LISTSXP:
if (inherits(expr, "expression"))
return FindSubexprs(CAR(expr), exprlist, tag);
else { InvalidExpression("FindSubexprs"); return -1/*-Wall*/; }
break;
case LANGSXP:
if (CAR(expr) == install("(")) {
return FindSubexprs(CADR(expr), exprlist, tag);
}
else {
e = CDR(expr);
while(e != R_NilValue) {
if ((k = FindSubexprs(CAR(e), exprlist, tag)) != 0)
SETCAR(e, MakeVariable(k, tag));
e = CDR(e);
}
return Accumulate(expr, exprlist);
}
break;
default:
InvalidExpression("FindSubexprs");
return -1/*-Wall*/;
}
}
SEXP deriv(SEXP args)
{
/* deriv(expr, namevec, function.arg, tag, hessian) */
SEXP ans, ans2, expr, funarg, names, s;
int f_index, *d_index, *d2_index;
int i, j, k, nexpr, nderiv=0, hessian;
SEXP exprlist, tag;
args = CDR(args);
InitDerivSymbols();
PROTECT(exprlist = LCONS(R_BraceSymbol, R_NilValue));
/* expr: */
if (isExpression(CAR(args)))
PROTECT(expr = VECTOR_ELT(CAR(args), 0));
else PROTECT(expr = CAR(args));
args = CDR(args);
/* namevec: */
names = CAR(args);
if (!isString(names) || (nderiv = length(names)) < 1)
error(_("invalid variable names"));
args = CDR(args);
/* function.arg: */
funarg = CAR(args);
args = CDR(args);
/* tag: */
tag = CAR(args);
if (!isString(tag) || length(tag) < 1
|| length(STRING_ELT(tag, 0)) < 1 || length(STRING_ELT(tag, 0)) > 60)
error(_("invalid tag"));
args = CDR(args);
/* hessian: */
hessian = asLogical(CAR(args));
/* NOTE: FindSubexprs is destructive, hence the duplication.
It can allocate, so protect the duplicate.
*/
PROTECT(ans = duplicate(expr));
f_index = FindSubexprs(ans, exprlist, tag);
d_index = (int*)R_alloc((size_t) nderiv, sizeof(int));
if (hessian)
d2_index = (int*)R_alloc((size_t) ((nderiv * (1 + nderiv))/2),
sizeof(int));
else d2_index = d_index;/*-Wall*/
UNPROTECT(1);
for(i=0, k=0; i<nderiv ; i++) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
PROTECT(ans2 = duplicate(ans)); /* keep a temporary copy */
d_index[i] = FindSubexprs(ans, exprlist, tag); /* examine the derivative first */
PROTECT(ans = duplicate(ans2)); /* restore the copy */
if (hessian) {
for(j = i; j < nderiv; j++) {
PROTECT(ans2 = duplicate(ans)); /* install could allocate */
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
d2_index[k] = FindSubexprs(ans2, exprlist, tag);
k++;
UNPROTECT(2);
}
}
UNPROTECT(4);
}
nexpr = length(exprlist) - 1;
if (f_index) {
Accumulate2(MakeVariable(f_index, tag), exprlist);
}
else {
PROTECT(ans = duplicate(expr));
Accumulate2(expr, exprlist);
UNPROTECT(1);
}
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
for (i = 0, k = 0; i < nderiv ; i++) {
if (d_index[i]) {
Accumulate2(MakeVariable(d_index[i], tag), exprlist);
if (hessian) {
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
UNPROTECT(2);
}
} else { /* the first derivative is constant or simple variable */
PROTECT(ans = duplicate(expr));
PROTECT(ans = D(ans, installTrChar(STRING_ELT(names, i))));
Accumulate2(ans, exprlist);
UNPROTECT(2);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (d2_index[k]) {
Accumulate2(MakeVariable(d2_index[k], tag), exprlist);
} else {
PROTECT(ans2 = duplicate(ans));
PROTECT(ans2 = D(ans2, installTrChar(STRING_ELT(names, j))));
if(isZero(ans2)) Accumulate2(R_MissingArg, exprlist);
else Accumulate2(ans2, exprlist);
UNPROTECT(2);
}
k++;
}
}
}
}
Accumulate2(R_NilValue, exprlist);
Accumulate2(R_NilValue, exprlist);
if (hessian) { Accumulate2(R_NilValue, exprlist); }
i = 0;
ans = CDR(exprlist);
while (i < nexpr) {
if (CountOccurrences(MakeVariable(i+1, tag), CDR(ans)) < 2) {
SETCDR(ans, Replace(MakeVariable(i+1, tag), CAR(ans), CDR(ans)));
SETCAR(ans, R_MissingArg);
}
else {
SEXP var;
PROTECT(var = MakeVariable(i+1, tag));
SETCAR(ans, lang3(install("<-"), var, AddParens(CAR(ans))));
UNPROTECT(1);
}
i = i + 1;
ans = CDR(ans);
}
/* .value <- ... */
SETCAR(ans, lang3(install("<-"), install(".value"), AddParens(CAR(ans))));
ans = CDR(ans);
/* .grad <- ... */
SETCAR(ans, CreateGrad(names));
ans = CDR(ans);
/* .hessian <- ... */
if (hessian) { SETCAR(ans, CreateHess(names)); ans = CDR(ans); }
/* .grad[, "..."] <- ... */
for (i = 0; i < nderiv ; i++) {
SETCAR(ans, DerivAssign(STRING_ELT(names, i), AddParens(CAR(ans))));
ans = CDR(ans);
if (hessian) {
for (j = i; j < nderiv; j++) {
if (CAR(ans) != R_MissingArg) {
if (i == j) {
SETCAR(ans, HessAssign1(STRING_ELT(names, i),
AddParens(CAR(ans))));
} else {
SETCAR(ans, HessAssign2(STRING_ELT(names, i),
STRING_ELT(names, j),
AddParens(CAR(ans))));
}
}
ans = CDR(ans);
}
}
}
/* attr(.value, "gradient") <- .grad */
SETCAR(ans, AddGrad());
ans = CDR(ans);
if (hessian) { SETCAR(ans, AddHess()); ans = CDR(ans); }
/* .value */
SETCAR(ans, install(".value"));
/* Prune the expression list removing eliminated sub-expressions */
SETCDR(exprlist, Prune(CDR(exprlist)));
if (TYPEOF(funarg) == LGLSXP && LOGICAL(funarg)[0]) { /* fun = TRUE */
funarg = names;
}
if (TYPEOF(funarg) == CLOSXP)
{
funarg = mkCLOSXP(FORMALS(funarg), exprlist, CLOENV(funarg));
}
else if (isString(funarg)) {
SEXP formals = allocList(length(funarg));
ans = formals;
for(i = 0; i < length(funarg); i++) {
SET_TAG(ans, installTrChar(STRING_ELT(funarg, i)));
SETCAR(ans, R_MissingArg);
ans = CDR(ans);
}
funarg = mkCLOSXP(formals, exprlist, R_GlobalEnv);
}
else {
funarg = allocVector(EXPRSXP, 1);
SET_VECTOR_ELT(funarg, 0, exprlist);
/* funarg = lang2(install("expression"), exprlist); */
}
UNPROTECT(2);
return funarg;
}