Пример #1
0
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);
	}
}
Пример #2
0
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;
}      
Пример #3
0
/**
  * 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);
}
Пример #4
0
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));
}
Пример #6
0
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;
}
Пример #8
0
/** 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);
}
Пример #9
0
/*********************************
 *                               *
 *    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);
}
Пример #11
0
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!?");
}
Пример #12
0
// -----------------------------------------------------------------------------
// 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();
	}
}
Пример #13
0
/* 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;
}
Пример #14
0
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());
}
Пример #15
0
/*!
  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)));
}
Пример #16
0
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);
}
Пример #17
0
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);
}
Пример #18
0
 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;
 }
Пример #19
0
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);
}
Пример #20
0
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
}
Пример #21
0
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;
}
Пример #22
0
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;
}
Пример #23
0
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;
}
Пример #24
0
void buildCell(table_cell *cell) {
    if (isFunction(cell)) {
        buildCellWithFunction(cell);
    }
}
Пример #25
0
/* 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;
}
Пример #26
0
FunctionType::FunctionType(const Type& t) throw(IllegalArgumentException)
    : Type(t) {
  PrettyCheckArgument(isNull() || isFunction(), this);
}
Пример #27
0
Type FunctionType::getRangeType() const {
  NodeManagerScope nms(d_nodeManager);
  PrettyCheckArgument(isNull() || isFunction(), this);
  return makeType(d_typeNode->getRangeType());
}
Пример #28
0
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;
}
Пример #29
0
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();
	}
}
Пример #30
0
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);
}