void ofxLua::scriptKeyReleased(int key) { if(L == NULL || !isFunction("keyReleased")) return; lua_getglobal(L, "keyReleased"); lua_pushinteger(L, key); if(lua_pcall(L, 1, 0, 0) != 0) { string msg = "Error running keyReleased(): " + (string) lua_tostring(L, -1); errorOccurred(msg); } }

SEXP rgl_setMouseCallbacks(SEXP button, SEXP begin, SEXP update, SEXP end) { Device* device; if (deviceManager && (device = deviceManager->getCurrentDevice())) { RGLView* rglview = device->getRGLView(); void* userData[3]; userControlPtr beginCallback, updateCallback; userControlEndPtr endCallback; userCleanupPtr cleanupCallback; int b = asInteger(button); if (b < 1 || b > 3) error("button must be 1, 2 or 3"); rglview->getMouseCallbacks(b, &beginCallback, &updateCallback, &endCallback, &cleanupCallback, (void**)&userData); if (isFunction(begin)) { beginCallback = &userControl; userData[0] = (void*)begin; R_PreserveObject(begin); } else if (begin == R_NilValue) beginCallback = 0; else error("callback must be a function"); if (isFunction(update)) { updateCallback = &userControl; userData[1] = (void*)update; R_PreserveObject(update); } else if (update == R_NilValue) updateCallback = 0; else error("callback must be a function"); if (isFunction(end)) { endCallback = &userControlEnd; userData[2] = (void*)end; R_PreserveObject(end); } else if (end == R_NilValue) endCallback = 0; else error("callback must be a function"); rglview->setMouseCallbacks(b, beginCallback, updateCallback, endCallback, &userCleanup, userData); } else error("no rgl device is open"); return R_NilValue; }

/** * Parse a subexpression and replace it with its result. */ void Calculator::parseSubexpression(QStringList & expressionParts) { int operatorLine = 0; int prioLine = 0; int priority = 0; int parenthesisPos = 0; int functionLine = 0; for(parenthesisPos = 0; parenthesisPos < expressionParts.size(); parenthesisPos++) if((expressionParts[parenthesisPos]== "(") || (expressionParts[parenthesisPos]=="-(")) parseParenthesis(expressionParts, parenthesisPos); else if(expressionParts[parenthesisPos]== ")"){ throw ExExpressionError(tr("Parenthesis syntax error.")); } if(expressionParts.size() < 2) //evaluation is complete, we had a (Expression) return; //now we have all function arguments directly behind the function name if(!(isNumber(expressionParts.last()) || isVariable(expressionParts.last()))) throw ExExpressionError(tr("Last term of expression must be a number.")); //evaluate function values from right to left for(functionLine = expressionParts.size() - 1; functionLine > -1; functionLine--) if(isFunction(expressionParts[functionLine])) evaluateFunction(expressionParts, functionLine); while(operatorLine < expressionParts.size() &&! isOperator(expressionParts[operatorLine])) operatorLine ++; if(operatorLine >= expressionParts.size() - 1) //no operator, invalid expression or nothing to be done throw ExExpressionError(tr("Missing operator.")); //we found an operator, now search for the first operator with highest priority prioLine = operatorLine; priority = operatorPriority(expressionParts[operatorLine]); while( prioLine < expressionParts.size() - 1 ) { prioLine ++; if(operatorPriority(expressionParts[prioLine]) > priority) { operatorLine = prioLine; priority = operatorPriority(expressionParts[prioLine]); } } //Now lets calculate if(operatorLine < 1) //we have a leading operator { if(expressionParts[operatorLine] == "-" | expressionParts[operatorLine] == "+") //we have a sign { if(expressionParts[operatorLine] == "-") expressionParts[0] = expressionParts[0] + expressionParts[1]; //make a negative number expressionParts.removeAt(1); //and delete the sign from list return; } else throw ExExpressionError(tr("No operator allowed in first position.")); } calculateSubExpression(expressionParts, operatorLine); }

static Token makeToken(const std::string& token_str) { Type type; if (token_str == "\n") { type = DELIMITER; } else if (isParameter(token_str) != -1) { type = PARAMETER; } else if (isSpecification(token_str)) { type = SPECIFICATION; } else if (isFunction(token_str) != -1) { type = FUNCTION; } else { throw Exception("Interpreter: invalid token"); } Token token( type, isParameter(token_str), isSpecification(token_str), isFunction(token_str) ); return token; }

/*! Calls this QScriptValue as a function, using \a thisObject as the `this' object in the function call, and passing \a arguments as arguments to the function. Returns the value returned from the function. If this QScriptValue is not a function, call() does nothing and returns an invalid QScriptValue. \a arguments can be an arguments object, an array, null or undefined; any other type will cause a TypeError to be thrown. Note that if \a thisObject is not an object, the global object (see \l{QScriptEngine::globalObject()}) will be used as the `this' object. One common usage of this function is to forward native function calls to another function: \snippet doc/src/snippets/code/src.script.qscriptvalue.cpp 3 \sa construct(), QScriptContext::argumentsObject() */ QScriptValue QScriptValue::call(const QScriptValue &thisObject, const QScriptValue &arguments) { if (isFunction() && thisObject.isValid() && (thisObject.engine() != engine())) { qWarning("QScriptValue::call() failed: " "cannot call function with thisObject created in " "a different engine"); return QScriptValue(); } return QScriptValuePrivate::valueOf(*this).call(QScriptValuePrivate::valueOf(thisObject), QScriptValuePrivate::valueOf(arguments)); }

void ofxLua::scriptMouseMoved(int x, int y ) { if(L == NULL || !isFunction("mouseMoved")) return; lua_getglobal(L, "mouseMoved"); lua_pushinteger(L, x); lua_pushinteger(L, y); if(lua_pcall(L, 2, 0, 0) != 0) { string msg = "Error running mouseMoved(): " + (string) lua_tostring(L, -1); errorOccurred(msg); } }

bool MyNumber::isFunction_or_Operator() { if (isFunction()) return true; if (isOperator()) return true; if (isParentheses()) return true; return false; }

/** Deletes last character. */ void Calculator::clearLast() { if(m_ExpressionParts.size() == 0) return; m_ExpressionParts.removeLast(); if(m_ExpressionParts.size() > 0 && isFunction(m_ExpressionParts.last())) //remove ( and function name m_ExpressionParts.removeLast(); m_ExpressionText = m_ExpressionParts.join(""); emit expressionTextChanged(m_ExpressionText); }

/********************************* * * * ge_ProcessQuery * * * *********************************/ static void ge_ProcessQuery(PE_QUERY query) { switch (query.tag) { case STRNG : st_PrintEntryInfo(st_NameToKey(query.info.query)); break; case ABOUT : clearBuff(); appendBuff(CHARITY_CONT_PROMPT "Charity Interpreter version "CHARITY_VERSION " was written by \n" CHARITY_CONT_PROMPT " Charles Tuckey, \n" CHARITY_CONT_PROMPT " Peter Vesely and \n" CHARITY_CONT_PROMPT " Barry Yee \n" CHARITY_CONT_PROMPT "from May to November, 1995.\n"); outputBuff(stdout); break; case SHOWCOMB : st_PrintEntryInfo(st_NameToKey(query.info.showcomb)); if (isFunction(query.info.showcomb)) { printMsg(MSG, "COMBINATOR DEFN for %s", query.info.showcomb); CodeTableShowComb(query.info.showcomb); } else if (isDatatype(query.info.showcomb)) { st_ShowDatatypeCombinators(st_NameToKey(query.info.showcomb)); } else ; /* do nothing */ break; case DUMPTABLE: st_DumpTable(); break; case REPLACE: if (gb_ReplaceFunctions) printMsg(MSG, "Functions replaced silently."); else printMsg(MSG, "User prompted to replace functions."); printMsg(MSG, "User prompted to replace datatypes."); break; case INCLUDEDIRS: printMsg(MSG,"Search path is %L.",(LIST *)g_strList_IncludeDirs); break; case SHOWMEM: MemDisplayState(); break; case QUERY: ge_ShowHelp(QUERY); break; default: printMsg(FATAL_MSG, "ge_ProcessQuery - Invalid tag (%d)", query.tag); } }

bool encodeFunctionCall(functionCallTermType *functionCall) { functionDefinitionType *theFunction; int functionOrdinal; symbolInContextType *workingContext; operandListType *parameterList; nullEncode(functionCall); workingContext = getWorkingContext(functionCall->functionName); if (isFunction(workingContext)) { if (!encodeByte(FUNCTION_CALL_TAG)) return(FALSE); theFunction = (functionDefinitionType *)workingContext-> value->value; if (!encodeBigword(functionNumber(theFunction))) return(FALSE); } else if (isBuiltInFunction(workingContext)) { functionOrdinal = workingContext->value->value; if (builtInFunctionTable[functionOrdinal].isSpecialFunction) return(encodeValue((*builtInFunctionTable[ functionOrdinal].functionEntry)(functionCall-> parameters, NO_FIXUP))); if (!encodeByte(BUILTIN_FUNCTION_CALL_TAG)) return(FALSE); if (builtInFunctionTable[functionOrdinal].ordinal < 0) { error(BUILT_IN_FUNCTION_NOT_AVAILABLE_IN_OBJECT_ERROR, builtInFunctionTable[functionOrdinal]. functionName); return(FALSE); } else if (!encodeBigword(builtInFunctionTable[ functionOrdinal].ordinal)) { return(FALSE); } } else { error(NOT_A_FUNCTION_ERROR, symbName(functionCall-> functionName)); return(FALSE); } parameterList = functionCall->parameters; if (!encodeByte(countParameters(parameterList))) return(FALSE); while (parameterList != NULL) if (!encodeOperand(parameterList)) return(FALSE); else parameterList = parameterList->nextOperand; return(TRUE); }

BasicSymbol* BasicScope::resolve(string name){ if(isVariable(name)){ return this->variables[name]; } if(isFunction(name)){ return this->functions[name][0]; } if(isStructure(name)){ return this->structures[name]; } throw TypeException("What are you trying to resolve!?"); }

// ----------------------------------------------------------------------------- // Called when a word list entry is activated (double-clicked) // ----------------------------------------------------------------------------- void ScriptEditorPanel::onWordListActivate(wxCommandEvent& e) { // Get word auto item = list_words_->GetSelection(); auto word = list_words_->GetItemText(item).ToStdString(); // Get language auto language = text_editor_->language(); if (!language) return; // Check for selection if (text_editor_->GetSelectionStart() < text_editor_->GetSelectionEnd()) { // Replace selection with word text_editor_->ReplaceSelection(word); text_editor_->SetFocus(); return; } // Check for function int pos = text_editor_->GetCurrentPos(); if (language->isFunction(word)) { auto func = language->function(word); // Add function + () word += "()"; text_editor_->InsertText(pos, word); // Move caret inside braces and show calltip pos += word.length() - 1; text_editor_->SetCurrentPos(pos + word.length() - 1); text_editor_->SetSelection(pos, pos); text_editor_->updateCalltip(); text_editor_->SetFocus(); } else { // Not a function, just add it & move caret position text_editor_->InsertText(pos, word); pos += word.length(); text_editor_->SetCurrentPos(pos); text_editor_->SetSelection(pos, pos); text_editor_->SetFocus(); } }

/* fmin(f, xmin, xmax tol) */ SEXP do_fmin(SEXP call, SEXP op, SEXP args, SEXP rho) { double xmin, xmax, tol; SEXP v, res; struct callinfo info; checkArity(op, args); PrintDefaults(rho); /* the function to be minimized */ v = CAR(args); if (!isFunction(v)) errorcall(call, _("attempt to minimize non-function")); args = CDR(args); /* xmin */ xmin = asReal(CAR(args)); if (!R_FINITE(xmin)) errorcall(call, _("invalid 'xmin' value")); args = CDR(args); /* xmax */ xmax = asReal(CAR(args)); if (!R_FINITE(xmax)) errorcall(call, _("invalid 'xmax' value")); if (xmin >= xmax) errorcall(call, _("'xmin' not less than 'xmax'")); args = CDR(args); /* tol */ tol = asReal(CAR(args)); if (!R_FINITE(tol) || tol <= 0.0) errorcall(call, _("invalid 'tol' value")); info.R_env = rho; PROTECT(info.R_fcall = lang2(v, R_NilValue)); PROTECT(res = allocVector(REALSXP, 1)); SETCADR(info.R_fcall, allocVector(REALSXP, 1)); REAL(res)[0] = Brent_fmin(xmin, xmax, (double (*)(double, void*)) fcn1, &info, tol); UNPROTECT(2); return res; }

void ClParserIdentifier:: debugPrint() const { if (isFunction()) fprintf(stderr, " fn"); else if (isStructPart()) fprintf(stderr, " str"); else if (isVariable()) fprintf(stderr, " var"); else if (isArgument()) fprintf(stderr, " arg"); else fprintf(stderr, " ??"); fprintf(stderr, " %s ", name_.c_str()); }

/*! Calls this QScriptValue as a function, using \a thisObject as the `this' object in the function call, and passing \a arguments as arguments to the function. Returns the value returned from the function. If this QScriptValue is not a function, call() does nothing and returns an invalid QScriptValue. \a arguments can be an arguments object, an array, null or undefined; any other type will cause a TypeError to be thrown. Note that if \a thisObject is not an object, the global object (see \l{QScriptEngine::globalObject()}) will be used as the `this' object. One common usage of this function is to forward native function calls to another function: \snippet doc/src/snippets/code/src_script_qscriptvalue.cpp 3 \sa construct(), QScriptContext::argumentsObject() */ QScriptValue QScriptValue::call(const QScriptValue &thisObject, const QScriptValue &arguments) { Q_D(QScriptValue); if (!d || !d->value.isObject()) return QScriptValue(); if (isFunction() && thisObject.isValid() && thisObject.engine() && (thisObject.engine() != engine())) { qWarning("QScriptValue::call() failed: " "cannot call function with thisObject created in " "a different engine"); return QScriptValue(); } QScriptEnginePrivate *eng = QScriptEnginePrivate::get(engine()); return eng->toPublic(d->value.call(eng->toImpl(thisObject), eng->toImpl(arguments))); }

SEXP lapply2(SEXP list, SEXP fn, SEXP rho) { int i, n = length(list); SEXP R_fcall, ans; if(!isNewList(list)) error("`list' must be a list"); if(!isFunction(fn)) error("`fn' must be a function"); if(!isEnvironment(rho)) error("`rho' should be an environment"); PROTECT(R_fcall = lang2(fn, R_NilValue)); PROTECT(ans = allocVector(VECSXP, n)); for(i = 0; i < n; i++) { SETCADR(R_fcall, VECTOR_ELT(list, i)); SET_VECTOR_ELT(ans, i, eval(R_fcall, rho)); } setAttrib(ans, R_NamesSymbol, getAttrib(list, R_NamesSymbol)); UNPROTECT(2); return(ans); }

void setVariable(const char *name, const char *value) { // get the field info from the object.. if(name[0] != '$' && dStrchr(name, '.') && !isFunction(name)) { S32 len = dStrlen(name); AssertFatal(len < sizeof(scratchBuffer)-1, "Sim::getVariable - name too long"); dMemcpy(scratchBuffer, name, len+1); char * token = dStrtok(scratchBuffer, "."); SimObject * obj = Sim::findObject(token); if(!obj) return; token = dStrtok(0, ".\0"); if(!token) return; while(token != NULL) { const char * val = obj->getDataField(StringTable->insert(token), 0); if(!val) return; char *fieldToken = token; token = dStrtok(0, ".\0"); if(token) { obj = Sim::findObject(token); if(!obj) return; } else { obj->setDataField(StringTable->insert(fieldToken), 0, value); } } } name = prependDollar(name); gEvalState.globalVars.setVariable(StringTable->insert(name), value); }

std::set<std::string> Expression::getVarNames()const { std::set<std::string> res; if (isFunction()) { for(const_iterator it=begin();it!= end(); ++it) { std::set<std::string> tmp = (**it).getVarNames(); res.insert(tmp.begin(),tmp.end()); } } else { if (!m_namespace->isNumber(name())) { res.insert(name()); } } return res; }

ChromiumDLL::JSObjHandle JavaScriptObject::executeFunction(ChromiumDLL::JavaScriptFunctionArgs *args) { if (!isFunction()) return GetJSFactory()->CreateException("Not a function!"); if (!args) return GetJSFactory()->CreateException("Args are null for function call"); JavaScriptContext* context = (JavaScriptContext*)args->context; JavaScriptObject* jso = (JavaScriptObject*)args->object.get(); CefV8ValueList argList; for (int x=0; x<args->argc; x++) { JavaScriptObject* jsoa = (JavaScriptObject*)args->argv[x].get(); if (jsoa) argList.push_back(jsoa->getCefV8()); else argList.push_back(NULL); } CefRefPtr<CefV8Value> retval; CefString exception; bool res = m_pObject->ExecuteFunctionWithContext(context->getCefV8(), jso?jso->getCefV8():NULL, argList, retval, exception); if (!res) { if (exception.c_str()) return GetJSFactory()->CreateException(exception.c_str()); return GetJSFactory()->CreateException("failed to run function"); } if (!retval) return NULL; return new JavaScriptObject(retval); }

void redux_redis_subscribe_loop(redisContext* context, int pattern, SEXP callback, SEXP envir) { if (!isFunction(callback)) { error("'callback' must be a function"); } if (!isEnvironment(envir)) { error("'envir' must be an environment"); } SEXP call = PROTECT(lang2(callback, R_NilValue)); redisReply *reply = NULL; int keep_going = 1; // Nasty: SEXP nms = PROTECT(allocVector(STRSXP, pattern ? 4 : 3)); int i = 0; SET_STRING_ELT(nms, i++, mkChar("type")); if (pattern) { SET_STRING_ELT(nms, i++, mkChar("pattern")); } SET_STRING_ELT(nms, i++, mkChar("channel")); SET_STRING_ELT(nms, i++, mkChar("value")); // And we're off. Adding a timeout here seems sensible to me as // that would allow for _some_ sort of interrupt checking, but as it // is, this seems extremely difficult to do without risking killing // the client. while (keep_going) { R_CheckUserInterrupt(); redisGetReply(context, (void*)&reply); SEXP x = PROTECT(redis_reply_to_sexp(reply, REPLY_ERROR_OK)); setAttrib(x, R_NamesSymbol, nms); SETCADR(call, x); freeReplyObject(reply); SEXP val = PROTECT(eval(call, envir)); if (TYPEOF(val) == LGLSXP && LENGTH(val) == 1 && INTEGER(val)[0] == 1) { keep_going = 0; } UNPROTECT(2); // x, val } UNPROTECT(2); // nms, call }

SEXP loop_apply(SEXP n, SEXP f, SEXP rho) { if(!isFunction(f)) error("'f' must be a function"); if(!isEnvironment(rho)) error("'rho' should be an environment"); int n1 = INTEGER(n)[0]; SEXP results, R_fcall; PROTECT(results = allocVector(VECSXP, n1)); PROTECT(R_fcall = lang2(f, R_NilValue)); SEXP ii; for(int i = 0; i < n1; i++) { PROTECT(ii = ScalarInteger(i + 1)); SETCADR(R_fcall, ii); SET_VECTOR_ELT(results, i, eval(R_fcall, rho)); UNPROTECT(1); } UNPROTECT(2); return results; }

SEXP dotTclcallback(SEXP args) { SEXP ans, callback = CADR(args), env; char buff[BUFFLEN]; char *s; Tcl_DString s_ds; if (isFunction(callback)) callback_closure(buff, BUFFLEN, callback); else if (isLanguage(callback)) { env = CADDR(args); callback_lang(buff, BUFFLEN, callback, env); } else error(_("argument is not of correct type")); Tcl_DStringInit(&s_ds); s = Tcl_UtfToExternalDString(NULL, buff, -1, &s_ds); ans = mkString(s); Tcl_DStringFree(&s_ds); return ans; }

bool Item::canBeMethod() const { if ( isFunction() || isMethod() ) return true; //a bit more complex: a callable array... if( type() == FLC_ITEM_ARRAY ) { CoreArray& arr = *asArray(); if ( ! arr.canBeMethod() ) return false; if ( arr.length() > 0 ) { // avoid infinite recursion. // even if arr[0] is not an array, the check is harmless, as we check by ptr value. return arr[0].asArray() != &arr && arr[0].isCallable(); } } // in all the other cases, the item is not callable return false; }

void buildCell(table_cell *cell) { if (isFunction(cell)) { buildCellWithFunction(cell); } }

/* I probably need some of the cache: parent children root And the precomputed results: init base pij These need to be the *untransposed* calculations. */ SEXP r_asr_marginal_mkn(SEXP r_k, SEXP r_pars, SEXP r_nodes, SEXP cache, SEXP res, SEXP root_f, SEXP rho) { const int n_states = INTEGER(r_k)[0]; const int neq = n_states; int n_nodes = LENGTH(r_nodes), *nodes = INTEGER(r_nodes); /* I think these are the only elements of the cache that we need */ int *parent = INTEGER(VECTOR_ELT(cache, 0)); int *children = INTEGER(VECTOR_ELT(cache, 1)); int root = INTEGER(VECTOR_ELT(cache, 2))[0]; /* And these are the precomputed bits we need */ double *r_init = REAL(VECTOR_ELT(res, 0)); double *r_base = REAL(VECTOR_ELT(res, 1)); double *r_lq = REAL(VECTOR_ELT(res, 2)); /* Spot 3 has 'vals' as of 0.9-2 */ double *pij = REAL(VECTOR_ELT(res, 4)); int n_out = LENGTH(VECTOR_ELT(res, 2)); /* These will be modified each time */ double *lq = (double*) R_alloc(n_out * neq, sizeof(double)); double *init = (double*) R_alloc(n_out * neq, sizeof(double)); double *base = (double*) R_alloc(n_out * neq, sizeof(double)); /* And this is a pointer to the root variables within */ double *root_vals = init + root * neq; SEXP ret, cpy_root_vals, cpy_lq, R_fcall, tmp; int idx, i, j, k; double *vals; if ( !isFunction(root_f) ) error("root_f must be a function"); if ( !isEnvironment(rho) ) error("rho must be a function"); PROTECT(ret = allocMatrix(REALSXP, n_states, n_nodes)); PROTECT(cpy_root_vals = allocVector(REALSXP, neq)); PROTECT(cpy_lq = allocVector(REALSXP, n_out)); for ( i = 0; i < n_nodes; i++ ) { idx = nodes[i]; vals = REAL(ret) + n_states * i; for ( j = 0; j < n_states; j++ ) { /* Copy clean data back in */ memcpy(lq, r_lq, n_out * sizeof(double)); memcpy(init, r_init, n_out * neq * sizeof(double)); memcpy(base, r_base, n_out * neq * sizeof(double)); for ( k = 0; k < n_states; k++ ) if ( k != j ) init[neq * idx + k] = 0.0; asr_marginal_mkn_1(k, idx, root, parent, children, pij, init, base, lq); memcpy(REAL(cpy_root_vals), root_vals, neq * sizeof(double)); memcpy(REAL(cpy_lq), lq, n_out * sizeof(double)); PROTECT(R_fcall = lang4(root_f, r_pars, cpy_root_vals, cpy_lq)); PROTECT(tmp = eval(R_fcall, rho)); vals[j] = REAL(tmp)[0]; UNPROTECT(2); } asr_normalise(n_states, vals); } UNPROTECT(3); return ret; }

FunctionType::FunctionType(const Type& t) throw(IllegalArgumentException) : Type(t) { PrettyCheckArgument(isNull() || isFunction(), this); }

Type FunctionType::getRangeType() const { NodeManagerScope nms(d_nodeManager); PrettyCheckArgument(isNull() || isFunction(), this); return makeType(d_typeNode->getRangeType()); }

int32_t NpcScriptInterface::luaNpcOpenShopWindow(lua_State* L) { // npc:openShopWindow(cid, items, buyCallback, sellCallback) if (!isTable(L, 3)) { reportErrorFunc("item list is not a table."); pushBoolean(L, false); return 1; } Player* player = getPlayer(L, 2); if (!player) { reportErrorFunc(getErrorDesc(LUA_ERROR_PLAYER_NOT_FOUND)); pushBoolean(L, false); return 1; } Npc* npc = getUserdata<Npc>(L, 1); if (!npc) { reportErrorFunc(getErrorDesc(LUA_ERROR_CREATURE_NOT_FOUND)); pushBoolean(L, false); return 1; } int32_t sellCallback = -1; if (isFunction(L, 5)) { sellCallback = luaL_ref(L, LUA_REGISTRYINDEX); } int32_t buyCallback = -1; if (isFunction(L, 4)) { buyCallback = luaL_ref(L, LUA_REGISTRYINDEX); } std::list<ShopInfo> items; pushNil(L); while (lua_next(L, 3) != 0) { ShopInfo item; item.itemId = popField<uint32_t>(L, "id"); item.subType = popField<int32_t>(L, "subType"); if (item.subType == 0) { item.subType = popField<int32_t>(L, "subtype"); } item.buyPrice = popField<uint32_t>(L, "buy"); item.sellPrice = popField<uint32_t>(L, "sell"); item.realName = popFieldString(L, "name"); items.push_back(item); lua_pop(L, 1); } lua_pop(L, 1); player->closeShopWindow(false); npc->addShopPlayer(player); player->setShopOwner(npc, buyCallback, sellCallback); player->openShopWindow(npc, items); pushBoolean(L, true); return 1; }

void FunctionParser::parse(std::list<std::string> &parsed, std::string& arg) { parsed.clear(); std::stack<std::string> s; getRidOfSpaces(); SI i = f.begin(); bool sign = 0; bool first = true; if (i != f.end() && *i == '-') { sign = 1; ++i; } for (; i != f.end();) { if (isdigit(*i)) { std::string n = getNumber(i); if (n == "####") { parsed.clear(); parsed.push_back("The number must contain only one .!"); return; } if (sign) { sign = 0; n.insert(n.begin(), '-'); } parsed.push_back(n); } else if (isOperator(*i)) { std::string op; op.insert(op.begin(), *i); if (!s.empty()) { while (!s.empty() && precendence(s.top(), op) >= 0 && s.top() != "(") { parsed.push_back(s.top()); s.pop(); } } s.push(op); ++i; } else if (*i == '(') { std::string bracket = "("; s.push(bracket); ++i; } else if (*i == ')') { while (!s.empty() && s.top() != "(") { parsed.push_back(s.top()); s.pop(); } if (s.empty()) { parsed.clear(); parsed.push_back("#There's an ) without (!");; return; } s.pop(); if (!s.empty() && isFunction(s.top())) { parsed.push_back(s.top()); s.pop(); } ++i; } else if (isalpha(*i)) { std::string name = getName(i); if (!isFunction(name)) { parsed.push_back(name); if (first) { arg = name; first = false; } else { if (name != arg) { parsed.clear(); parsed.push_back("#The function can take only one argument!"); } } } else { s.push(name); } } else { parsed.clear(); parsed.push_back("#Unknown token!"); return; } } while (!s.empty()) { parsed.push_back(s.top()); s.pop(); } }

SEXP predoslda(SEXP s_test, SEXP s_learn, SEXP s_grouping, SEXP s_wf, SEXP s_bw, SEXP s_k, SEXP s_method, SEXP s_env) { const R_len_t p = ncols(s_test); // dimensionality R_len_t N_learn = nrows(s_learn); // # training observations const R_len_t N_test = nrows(s_test); // # test observations const R_len_t K = nlevels(s_grouping); // # classes double *test = REAL(s_test); // pointer to test data set double *learn = REAL(s_learn); // pointer to training data set int *g = INTEGER(s_grouping); // pointer to class labels int *k = INTEGER(s_k); // pointer to number of nearest neighbors const int method = INTEGER(s_method)[0]; // method for scaling the covariance matrices //Rprintf("%u\n", method); SEXP s_posterior; // initialize posteriors PROTECT(s_posterior = allocMatrix(REALSXP, N_test, K)); double *posterior = REAL(s_posterior); SEXP s_dist; // initialize distances to test observation PROTECT(s_dist = allocVector(REALSXP, N_learn)); double *dist = REAL(s_dist); SEXP s_weights; // initialize weight vector PROTECT(s_weights = allocVector(REALSXP, N_learn)); double *weights = REAL(s_weights); double sum_weights; // sum of weights double class_weights[K]; // class wise sum of weights double norm_weights = 0; // normalization factor for unbiased version of covariance matrix double center[K][p]; // class means double covmatrix[p * p]; // pooled covariance matrix double z[p * K]; // difference between trial point and class center const char uplo = 'L', side = 'L'; int info = 0; double onedouble = 1.0, zerodouble = 0.0; double C[p * K]; double post[K]; int nas = 0; int i, j, l, m, n; // indices // select weight function typedef void (*wf_ptr_t) (double*, double*, int*, double*, int*);// *weights, *dist, *N, *bw, *k wf_ptr_t wf = NULL; if (isInteger(s_wf)) { const int wf_nr = INTEGER(s_wf)[0]; wf_ptr_t wfs[] = {biweight1, cauchy1, cosine1, epanechnikov1, exponential1, gaussian1, optcosine1, rectangular1, triangular1, biweight2, cauchy2, cosine2, epanechnikov2, exponential2, gaussian2, optcosine2, rectangular2, triangular2, biweight3, cauchy3, cosine3, epanechnikov3, exponential3, gaussian3, optcosine3, rectangular3, triangular3, cauchy4, exponential4, gaussian4}; wf = wfs[wf_nr - 1]; } // loop over all test observations for(n = 0; n < N_test; n++) { // 0. check for NAs in test nas = 0; for (j = 0; j < p; j++) { nas += ISNA(test[n + N_test * j]); } if (nas > 0) { // NAs in n-th test observation warning("NAs in test observation %u", n+1); // set posterior to NA for (m = 0; m < K; m++) { posterior[n + N_test * m] = NA_REAL; } } else { // 1. calculate distances to n-th test observation for (i = 0; i < N_learn; i++) { dist[i] = 0; for (j = 0; j < p; j++) { dist[i] += pow(learn[i + N_learn * j] - test[n + N_test * j], 2); } dist[i] = sqrt(dist[i]); weights[i] = 0; //Rprintf("dist %f\n", dist[i]); } // 2. calculate observation weights if (isInteger(s_wf)) { // case 1: wf is integer // calculate weights by reading number and calling corresponding C function wf (weights, dist, &N_learn, REAL(s_bw), k); } else if (isFunction(s_wf)) { // case 2: wf is R function // calculate weights by calling R function SEXP R_fcall; PROTECT(R_fcall = lang2(s_wf, R_NilValue)); SETCADR(R_fcall, s_dist); weights = REAL(eval(R_fcall, s_env)); UNPROTECT(1); // R_fcall } /*for(i = 0; i < N_learn; i++) { Rprintf("weights %f\n", weights[i]); }*/ // 3. initialization sum_weights = 0; for (m = 0; m < K; m++) { class_weights[m] = 0; for (j = 0; j < p; j++) { center[m][j] = 0; for (l = 0; l <= j; l++) { covmatrix[j + p * l] = 0; } } } // 4. calculate sum of weights, class wise sum of weights and unnormalized class means for (i = 0; i < N_learn; i++) { sum_weights += weights[i]; for (m = 0; m < K; m++) { if (g[i] == m + 1) { class_weights[m] += weights[i]; for (j = 0; j < p; j++) { center[m][j] += learn[i + N_learn * j] * weights[i]; } } } } //Rprintf("sum_weights %f\n", sum_weights); if (sum_weights == 0) { // all observation weights are zero warning("all observation weights are zero"); // set posterior to NA for (m = 0; m < K; m++) { posterior[n + N_test * m] = NA_REAL; } } else { // 5. calculate covariance matrix, only lower triangle if (method == 1) { // unbiased estimate norm_weights = 0; for (m = 0; m < K; m++) { //Rprintf("class_weights %f \n", class_weights[m]); if (class_weights[m] > 0) { for (i = 0; i < N_learn; i++) { if (g[i] == m + 1) { norm_weights += class_weights[m]/sum_weights * pow(weights[i]/class_weights[m], 2); } } } } //Rprintf("norm_weights %f\n", norm_weights); if (norm_weights == 1) { // it makes no sense to calculate the covariance matrix warning("iteration %u: NaNs in covariance matrix", n+1); } else { // calculate covariance matrix for (m = 0; m < K; m++) { if (class_weights[m] > 0) { // only for classes with positive sum of weights for (i = 0; i < N_learn; i++) { if (g[i] == m + 1) { for (j = 0; j < p; j++) { for (l = 0; l <= j; l++) { covmatrix[j + p * l] += weights[i]/sum_weights * (learn[i + N_learn * j] - center[m][j]/class_weights[m]) * (learn[i + N_learn * l] - center[m][l]/class_weights[m])/ (1 - norm_weights); } } } } } } } } else { // ML estimate for (m = 0; m < K; m++) { if (class_weights[m] > 0) { // only for classes with positive sum of weights for (i = 0; i < N_learn; i++) { if (g[i] == m + 1) { for (j = 0; j < p; j++) { for (l = 0; l <= j; l++) { covmatrix[j + p * l] += weights[i]/sum_weights * (learn[i + N_learn * j] - center[m][j]/class_weights[m]) * (learn[i + N_learn * l] - center[m][l]/class_weights[m]); } } } } } } } /*for (j = 0; j < p; j++) { for (l = 0; l <= j; l++) { Rprintf("covmatrix %f\n", covmatrix[j + p * l]); } }*/ if (norm_weights == 1) { // then nans in covmatrix, sum_weights = 0? for (m = 0; m < K; m++) { posterior[n + N_test * m] = NA_REAL; } } else { // 6. calculate inverse of covmatrix F77_CALL(dpotrf)(&uplo, &p, covmatrix, &p, &info); //Rprintf("info dpotrf %u\n", info); if (info != 0) { // error in Choleski factorization if (info < 0) { warning("iteration %u: argument %u had an illegal value\n", n+1, abs(info)); } else { warning("iteration %u: the leading minor of order %u is not positive definite and the Cholesky factorization could not be completed\n", n+1, info); } // set posterior to NA for (m = 0; m < K; m++) { posterior[n + N_test * m] = NA_REAL; } } else { // proceed with calculation of inverse covmatrix F77_CALL(dpotri)(&uplo, &p, covmatrix, &p, &info); //Rprintf("info dpotri %u\n", info); if (info != 0) { // error in calculation of inverse covmatrix if (info < 0) { warning("iteration %u: argument %u had an illegal value\n", n+1, abs(info)); } else { warning("iteration %u: element (%u, %u) of factor L is zero\n", n+1, info, info); } // set posterior to NA for (m = 0; m < K; m++) { posterior[n + N_test * m] = NA_REAL; } } else { // proceed // 7. calculate difference between n-th test observation and all class centers for (m = 0; m < K; m++) { if (class_weights[m] > 0) { // only for classes with positive sum of weights for (j = 0; j < p; j++) { z[j + p * m] = test[n + N_test * j] - center[m][j]/class_weights[m]; } } else { for (j = 0; j < p; j++) { z[j + p * m] = 0; } } } // 8. calcualte C = covmatrix * z F77_CALL(dsymm)(&side, &uplo, &p, &K, &onedouble, covmatrix, &p, z, &p, &zerodouble, C, &p); // 9. calculate t(z) * C (mahalanobis distance) and unnormalized posterior probabilities for (m = 0; m < K; m++) { if (class_weights[m] > 0) { post[m] = 0; for (j = 0; j < p; j++) { post[m] += C[j + p * m] * z[j + p * m]; } posterior[n + N_test * m] = log(class_weights[m]/sum_weights) - 0.5 * post[m]; } else { posterior[n + N_test * m] = R_NegInf; } //Rprintf("posterior %f\n", posterior[n + N_test * m]); } } } } } } } // end loop over test observations // 10. set dimnames of s_posterior SEXP dimnames; PROTECT(dimnames = allocVector(VECSXP, 2)); SET_VECTOR_ELT(dimnames, 0, VECTOR_ELT(getAttrib(s_test, R_DimNamesSymbol), 0)); SET_VECTOR_ELT(dimnames, 1, getAttrib(s_grouping, R_LevelsSymbol)); setAttrib(s_posterior, R_DimNamesSymbol, dimnames); UNPROTECT(4); // dimnames, s_dist, s_weights, s_posterior return(s_posterior); }