C++ BODY函数代码示例

short PEXPORT Kpp__SetupRule(LPRULE lpRule, LISTID idVarList,
                             LISTID idClassList, EXPID idIfPart,
                             EXPID idThenPart)
{
#ifdef INFERENCE
    PRIORITY(lpRule) = 0;
    MATCHES(lpRule) = NULLID;
    NUMVARS(lpRule) = KppListLen(idVarList);
    BODY(lpRule) = JoinIfThen(idIfPart, idThenPart);
    if (idIfPart)
        KppDeleteExp(idIfPart);
    if (idThenPart)
        KppDeleteExp(idThenPart);

    if (NUMVARS(lpRule) == 0)
        VARS(lpRule) = KppMakeList(0);
    else
    {
        VARS(lpRule) = MakeRuleArgList(idVarList, idClassList);
        if (idVarList)
            KppDeleteList(idVarList);
        if (idClassList)
            KppDeleteList(idClassList);
        idVarList = VARS(lpRule);
        KppClearVarList(idVarList);
        KppBindVars(idVarList, BODY(lpRule));
        }
#endif

   return TRUE;
}

RULEID __CopyRule(LPRULE lpOldRule, ITEMID idName)
{
#ifdef INFERENCE
    RULEID      idRule;
    LPRULE      lpRule;
    LPEXP       lpBody;
    EXPID       idBody;

    if (GetRule(idName) != NULLID)
        return NULLID;
    
    idRule = KppAddItemAndName (RULE, (LPLPSTR)&lpRule, idName);
    if (!idRule)
        return NULLID;
    NAME(lpRule) = idName;
    FLAGS(lpRule) = NULL;
    PRIORITY(lpRule) = 0;
    MATCHES(lpRule) = NULLID;
    NUMVARS(lpRule) = NUMVARS(lpOldRule);
    if (! (FLAGS(lpRule) & CBODY))
    {
        VARS(lpRule) = KppDeepListCopy(VARS(lpOldRule), Kpp__CopyVar,idRule);
        idBody = BODY(lpRule) = KppCopyExp(
                        BODY(lpOldRule), (LPLPSTR)&lpBody, kPERMMODE);
        KppReleaseExp(idBody);
    }
    KppReleaseItem(RULE, idRule);

    /* Add to KnowledgeTools */
    KppAddItemCB (RULE, 1);

    return idRule;
#endif
}

static VALUE 
rb_cpApplyDampedSpring(VALUE klass, VALUE a, VALUE b, 
  VALUE anchr1, VALUE anchr2, VALUE rlen, VALUE k, VALUE dmp, VALUE dt)
{
  cpApplyDampedSpring(BODY(a), BODY(b), *VGET(anchr1), *VGET(anchr2), 
  NUM2DBL(rlen), NUM2DBL(k), NUM2DBL(dmp), NUM2DBL(dt));
  return klass;
} 

short PEXPORT Kpp__ResetGoal(LPGOAL lpGoal)
{
#ifdef INFERENCE
    /* delete the goal body */
    if (! (FLAGS(lpGoal) & CBODY)
        && BODY(lpGoal) != NULLID)
        KppDeleteExp(BODY(lpGoal));
#endif

    return TRUE;
}

static VALUE
rb_cpBodyInitialize(VALUE self, VALUE m, VALUE i) {
  cpBody *body = BODY(self);
  cpBodyInit(body, NUM2DBL(m), NUM2DBL(i));
  body->data = (void *)self;
  return self;
}

SEXP attribute_hidden do_bodyCode(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    checkArity(op, args);
    if (TYPEOF(CAR(args)) == CLOSXP)
	return duplicate(BODY(CAR(args)));
    else return R_NilValue;
}

SEXP attribute_hidden do_envirgets(SEXP call, SEXP op, SEXP args, SEXP rho)
{
    SEXP env, s = CAR(args);

    checkArity(op, args);
    check1arg(args, call, "x");

    env = CADR(args);

    if (TYPEOF(CAR(args)) == CLOSXP
	&& (isEnvironment(env) ||
	    isEnvironment(env = simple_as_environment(env)) ||
	    isNull(env))) {
	if (isNull(env))
	    error(_("use of NULL environment is defunct"));
	if(MAYBE_SHARED(s))
	    /* this copies but does not duplicate args or code */
	    s = duplicate(s);
	if (TYPEOF(BODY(s)) == BCODESXP)
	    /* switch to interpreted version if compiled */
	    SET_BODY(s, R_ClosureExpr(CAR(args)));
	SET_CLOENV(s, env);
    }
    else if (isNull(env) || isEnvironment(env) ||
	isEnvironment(env = simple_as_environment(env)))
	setAttrib(s, R_DotEnvSymbol, env);
    else
	error(_("replacement object is not an environment"));
    return s;
}

WORD __EvalFunc(LPFUNC lpFunc, LISTID idArgList)
{
    WORD i = FALSE;
    ATOMID idName = NAME(lpFunc);
    EXPID idBody;
    LPEXP lpBody;
    LISTID idVarList;
    GLOBALHANDLE hBody;

    if (NUMVARS(lpFunc) != KppListLen(idArgList))
        return KppRegisterKappaMessage(hResThisDll, IDE_BADNUMARG, 
                                       idName, NULLID, NULLID);

    idVarList = VARS(lpFunc);
    idBody = BODY(lpFunc);
    if (!idBody)
        KappaReturnAtom(lpIDs->idNull);

    UnwindProtect(cleanup);
    if (lpKALView && lpKALView->bActive)
        (*lpKALView->PushFn)(idName);
    lpBody = KppCopyTempExp(idBody, (GLOBALHANDLE FAR *) &hBody);
    Kpp__LoadArgs(lpBody, idVarList, idArgList);
    
    i = Kpp_EvalExp(lpBody);
  cleanup:
    KppReleaseTempExp(hBody, i);
    KppUnbindVars(idVarList);
    if (lpKALView && lpKALView->bActive)
        (*lpKALView->Pop)(TRUE);
    EndProtect();
    
    return i;
}

static VALUE
rb_cpShapeSetBody(VALUE self, VALUE body)
{
	SHAPE(self)->body = BODY(body);
	rb_ivar_set(self, id_body, body);
	
	return body;
}

static VALUE
rb_cpBodyIsStatic(VALUE self) {
  cpBody * body = BODY(self);
  cpBool stat   = 0;
  // cpBodyInitStatic(body);
  stat = cpBodyIsStatic(body);
  return stat ? Qtrue : Qfalse;
  //
}

/* generatePlummer: generate Plummer model initial conditions for test
 * runs, scaled to units such that M = -4E = G = 1 (Henon, Heggie,
 * etc).  See Aarseth, SJ, Henon, M, & Wielen, R (1974) Astr & Ap, 37,
 * 183.
 */
static int nbGenerateIsotropicCore(lua_State* luaSt,

				   dsfmt_t* prng,
				   unsigned int nbody,
				   real mass1,
				   real mass2,

				   mwbool ignore,
				   
				   mwvector rShift,
				   mwvector vShift,
				   real radiusScale1,
				   real radiusScale2)
{
    unsigned int i;
    int table;
    Body b;
    real r, velScale;

    real mass = mass1 + mass2;
    real radiusScale = mw_sqrt(mw_pow(radiusScale1,2) + mw_pow(radiusScale2,2));
    memset(&b, 0, sizeof(b));

    velScale =  mw_sqrt(mass / radiusScale);     /* and recip. speed scale */

    b.bodynode.type = BODY(ignore);    /* Same for all in the model */
    b.bodynode.mass = mass / nbody;    /* Mass per particle */

    lua_createtable(luaSt, nbody, 0);
    table = lua_gettop(luaSt);
    
    for (i = 0; i < nbody; ++i)
    {
        do
        {
	  r = isotropicRandomR(prng, radiusScale1, radiusScale2, mass1, mass2);
	    /* FIXME: We should avoid the divide by 0.0 by multiplying
             * the original random number by 0.9999.. but I'm too lazy
             * to change the tests. Same with other models */
        }
        while (isinf(r));

        b.bodynode.pos = isotropicBodyPosition(prng, rShift, r);

        b.vel = isotropicBodyVelocity(prng, r, vShift, velScale, radiusScale1, radiusScale2, mass1, mass2);
	
        assert(nbPositionValid(b.bodynode.pos));

        pushBody(luaSt, &b);
	//	printf("Body %d is pushed. \n",i);
        lua_rawseti(luaSt, table, i + 1);
    }

    return 1;
}

static VALUE
rb_cpCircleInitialize(VALUE self, VALUE body, VALUE radius, VALUE offset)
{
	cpCircleShape *circle = (cpCircleShape *)SHAPE(self);
	
	cpCircleShapeInit(circle, BODY(body), NUM2DBL(radius), *VGET(offset));
	circle->shape.data = (void *)self;
	circle->shape.collision_type = Qnil;

	rb_ivar_set(self, id_body, body);
	
	return self;
}

static VALUE
rb_cpSegmentInitialize(VALUE self, VALUE body, VALUE a, VALUE b, VALUE r)
{
	cpSegmentShape *seg = (cpSegmentShape *)SHAPE(self);
	
	cpSegmentShapeInit(seg, BODY(body), *VGET(a), *VGET(b), NUM2DBL(r));
	seg->shape.data = (void *)self;
	seg->shape.collision_type = Qnil;

	rb_ivar_set(self, id_body, body);
	
	return self;
}

obj_t * apply(obj_t *args, obj_t *env) {

	assert(IS_LIST(args));

	if (IS_LIST(CAR(args)) && IS_FUNC(CAR(CAR(args)))) {

		return (FUNC(CAR(CAR(args))))(CDR(args), env);
	} else if (IS_LIST(CAR(args)) && IS_DEFUNC(CAR(CAR(args)))) {

		obj_t * func_args;
		obj_t * call_args;

		obj_t * body;
		obj_t * result;

		body = clone_obj(BODY(CAR(CAR(args))));
		func_args = ARGS(CAR(CAR(args)));
		call_args = CDR(args);

		/* ((<DEFUNC:[args=(X)][body=(TIMES X X)]>) 3) */

		while (IS_LIST(func_args) && IS_LIST(call_args)) {
			obj_t * func_arg = CAR(func_args);
			obj_t * call_arg = CAR(call_args);

			replace_obj(func_arg, call_arg, body);

			func_args = CDR(func_args);
			call_args = CDR(call_args);
		}

		if ((IS_LIST(func_args) && !IS_LIST(call_args)) ||
				(!IS_LIST(func_args) && IS_LIST(call_args))) {

			free_obj(body); /* clean up */

			fprintf(stdout, "Unexpected number of arguments\n");
			return alloc_fail();
		}

		result = eval(body, env);

		free_obj(body);

		return result;

	} else {

		return clone_obj(args);
	}
}

SEXP reassign_function(SEXP name, SEXP env, SEXP old_fun, SEXP new_fun)
{
  if (TYPEOF(name) != SYMSXP) error("name must be a symbol");
  if (TYPEOF(env) != ENVSXP) error("env must be an environment");
  if (TYPEOF(old_fun) != CLOSXP) error("old_fun must be a function");
  if (TYPEOF(new_fun) != CLOSXP) error("new_fun must be a function");

  SET_FORMALS(old_fun, FORMALS(new_fun));
  SET_BODY(old_fun, BODY(new_fun));
  SET_CLOENV(old_fun, CLOENV(new_fun));
  DUPLICATE_ATTRIB(old_fun, new_fun);

  return R_NilValue;
}