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);
}