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;
}
short PEXPORT Kpp__ResetFunc(LPFUNC lpFunc)
{
if (! (FLAGS(lpFunc) & CBODY))
{
/* first delete the list of variables */
if (VARS(lpFunc) != NULLID)
{
KppClearVarList(VARS(lpFunc));
KppClearList(VARS(lpFunc), VAR);
KppDeleteList(VARS(lpFunc));
VARS (lpFunc) = NULLID;
}
/* then delete the body */
if (BODY(lpFunc) != NULLID)
{
KppDeleteExp(BODY(lpFunc));
BODY(lpFunc) = NULLID;
}
}
return TRUE;
}
GOALID __CopyGoal(LPGOAL lpOldGoal, ITEMID idName)
{
#ifdef INFERENCE
GOALID idGoal;
LPGOAL lpGoal;
LPEXP lpBody;
EXPID idBody;
if (GetGoal(idName) != NULLID)
return NULLID;
idGoal = KppAddItemAndName(GOAL, (LPLPSTR)&lpGoal, idName);
if (!idGoal)
return NULLID;
NAME(lpGoal) = idName;
FLAGS(lpGoal) = NULL;
PRIORITY(lpGoal) = 0;
if (! (FLAGS(lpGoal) & CBODY))
{
if (BODY(lpGoal) == NULLID)
idBody = NULLID;
else
{
idBody = BODY(lpGoal) = KppCopyExp(BODY(lpOldGoal),
(LPLPSTR)&lpBody, kPERMMODE);
KppReleaseExp(idBody);
}
}
KppReleaseItem(GOAL, idGoal);
/* Add to KnowledgeTools */
KppAddItemCB(GOAL, 1);
return idGoal;
#endif
}
short PEXPORT Kpp__ResetRule(LPRULE lpRule)
{
#ifdef INFERENCE
if (FLAGS(lpRule) & CBODY)
{
if (VARS(lpRule)) KppDeleteList(VARS(lpRule));
if (CIFPAIRS(lpRule)) KppDeleteList(CIFPAIRS(lpRule));
if (CTHENPAIRS(lpRule)) KppDeleteList(CTHENPAIRS(lpRule));
}
else
{
/* first delete the list of variables */
if (VARS(lpRule) != NULLID)
{
KppClearVarList(VARS(lpRule));
KppClearList(VARS(lpRule), VAR);
KppDeleteList(VARS(lpRule));
VARS (lpRule) = NULLID;
}
/* then delete the body */
if (BODY(lpRule) != NULLID)
{
KppDeleteExp(BODY(lpRule));
BODY(lpRule) = NULLID;
}
}
/* then delete list of matches if it exists! */
if (MATCHES(lpRule) != NULLID) {
KppDeleteMatchList(MATCHES(lpRule));
MATCHES(lpRule) = NULLID;
}
#endif
return TRUE;
}
FUNCID __CopyFunc(LPFUNC lpOldFunc, ITEMID idName)
{
FUNCID idFunc;
LPFUNC lpFunc;
LPEXP lpBody;
EXPID idBody;
if (GetFunc(idName) != NULLID)
return NULLID;
idFunc = KppAddItemAndName (FUNC, (LPLPSTR)&lpFunc, idName);
if (!idFunc)
return NULLID;
NAME(lpFunc) = idName;
FLAGS(lpFunc) = NULL;
NUMVARS(lpFunc) = NUMVARS(lpOldFunc);
if (! (FLAGS(lpFunc) & CBODY))
{
VARS(lpFunc) = KppDeepListCopy(VARS(lpOldFunc), Kpp__CopyVar, idFunc);
if (BODY(lpOldFunc) == NULLID)
idBody = NULLID;
else
{
idBody = BODY(lpFunc) = KppCopyExp(BODY(lpOldFunc),
(LPLPSTR)&lpBody, kPERMMODE);
KppReleaseExp(idBody);
}
}
KppReleaseItem(FUNC, idFunc);
/* Add to KnowledgeTools */
KppAddItemCB (FUNC, 1);
return idFunc;
}
/* PrintLanguage() or PrintClosure() : */
static void PrintLanguageEtc(SEXP s, Rboolean useSource, Rboolean isClosure)
{
int i;
SEXP t = getAttrib(s, R_SrcrefSymbol);
Rboolean useSrc = useSource && isInteger(t);
if (useSrc) {
PROTECT(t = lang2(R_AsCharacterSymbol, t));
t = eval(t, R_BaseEnv);
UNPROTECT(1);
} else {
t = deparse1w(s, 0, useSource | DEFAULTDEPARSE);
}
PROTECT(t);
for (i = 0; i < LENGTH(t); i++) {
Rprintf("%s\n", translateChar(STRING_ELT(t, i))); // translate: for srcref part (PR#16732)
}
UNPROTECT(1);
if (isClosure) {
if (isByteCode(BODY(s))) Rprintf("<bytecode: %p>\n", BODY(s));
t = CLOENV(s);
if (t != R_GlobalEnv)
Rprintf("%s\n", EncodeEnvironment(t));
}
}
static VALUE
rb_cpBodySetPositionFunc(int argc, VALUE *argv, VALUE self) {
VALUE block;
cpBody * body = BODY(self);
rb_scan_args(argc, argv, "&", &block);
// Restore defaults if no block
if (NIL_P(block)) {
body->position_func = cpBodyUpdatePosition; //Default;
return Qnil;
}
// set block for use in callback
rb_iv_set(self, "position_func", block);
body->position_func = bodyPositionCallback;
return self;
}
static VALUE
rb_cpBodySetVelocityFunc(int argc, VALUE *argv, VALUE self) {
VALUE block;
cpBody * body = BODY(self);
rb_scan_args(argc, argv, "0&", &block);
// Restore defaults if no block
if (NIL_P(block)) {
body->velocity_func = cpBodyUpdateVelocity; //Default;
return Qnil;
}
// set block for use in callback
rb_iv_set(self, "velocity_func", block);
body->velocity_func = bodyVelocityCallback;
return self;
}
GOALID PEXPORT Kpp_MakeGoal(ITEMID idName, EXPID idBody)
{
#ifdef INFERENCE
GOALID idGoal;
LPGOAL lpGoal;
if (!KppIsGoodAtom(idName))
return NULLID;
idGoal = Kpp_GetItem(GOAL, idName);
if (idGoal)
{
int over = KppAllowOverrideCB(GOAL, idName, idGoal, NULLID);
if (!over)
return KppRegisterKappaMessage(hResThisDll,
IDE_ITEMALREADYEXISTS,
idName, NULLID, NULLID);
else if (over == -1)
{
bItemSkipped = TRUE;
return idGoal;
}
}
CHECK_MAX_LIMITED_VER(GOAL, idName);
idGoal = KppAddItemAndName (GOAL, (LPLPSTR)&lpGoal, idName);
if (!idGoal)
return NULLID;
NAME(lpGoal) = idName;
FLAGS(lpGoal) = NULL;
PRIORITY(lpGoal) = 0;
if (!idBody)
idBody = KppBuildNullExp();
else
KppResetBoundFlag(idBody);
BODY(lpGoal) = idBody;
KppReleaseItem(GOAL, idGoal);
/* Add to KnowledgeTools */
KppAddItemCB (GOAL, 1);
return idGoal;
#endif
}
static cpBody *
rb_cpBodySleepValidate(VALUE vbody) {
cpBody * body = BODY(vbody);
cpSpace *space = body->CP_PRIVATE(space);
if(!space) {
rb_raise(rb_eArgError, "Cannot put a body to sleep that has not been added to a space.");
return NULL;
}
if (cpBodyIsStatic(body) && cpBodyIsRogue(body)) {
rb_raise(rb_eArgError, "Rogue AND static bodies cannot be put to sleep.");
return NULL;
}
if(cpSpaceIsLocked(space)) {
rb_raise(rb_eArgError, "Bodies can not be put to sleep during a query or a call to Space#add_collision_func. Put these calls into a post-step callback using Space#add_collision_handler.");
return NULL;
}
return body;
}
static VALUE
rb_cpPolyInitialize(VALUE self, VALUE body, VALUE arr, VALUE offset)
{
cpPolyShape *poly = (cpPolyShape *)SHAPE(self);
Check_Type(arr, T_ARRAY);
int numVerts = RARRAY_LEN(arr);
VALUE *ary_ptr = RARRAY_PTR(arr);
cpVect verts[numVerts];
for(int i=0; i<numVerts; i++)
verts[i] = *VGET(ary_ptr[i]);
cpPolyShapeInit(poly, BODY(body), numVerts, verts, *VGET(offset));
poly->shape.data = (void *)self;
poly->shape.collision_type = Qnil;
rb_ivar_set(self, id_body, body);
return self;
}
WORD PEXPORT KppTestGoal(ITEMID idGoal)
{
#ifdef INFERENCE
WORD i = FALSE;
EXPID idBody;
LPEXP lpBody2;
LPGOAL lpGoal = (LPGOAL) KppGetItem(GOAL, idGoal);
GLOBALHANDLE hBody2;
LOGICALID (EXPORT FAR *pBody)(void);
if (!lpGoal)
return KppRegisterKappaMessage (hResThisDll,
IDE_ERRORINFUNC, lpIDs->idError, NULLID, NULLID);
if (FLAGS(lpGoal) & CBODY)
{
pBody = CBODYPTR(lpGoal);
KppReleaseItem(GOAL, idGoal);
if ( !pBody )
return KppRegisterKappaMessage (hResThisDll,
IDE_ERRORINFUNC, lpIDs->idError, NULLID, NULLID);
KappaReturnAtom( pBody() );
}
else
{
idBody = BODY(lpGoal);
KppReleaseItem(GOAL, idGoal);
if (!idBody)
KappaReturnAtom(lpIDs->idNull);
lpBody2 = KppCopyTempExp(idBody, (GLOBALHANDLE FAR *)&hBody2);
UnwindProtect (cleanup);
i = Kpp_EvalExp(lpBody2);
cleanup:
KppReleaseTempExp(hBody2, i);
EndProtect();
return i;
}
#endif
}
WORD _EvalFunc(ITEMID idFunc, LPEXP lpArgList, WORD nArg)
{
LPFUNC lpFunc = (LPFUNC) KppGetItem(FUNC, idFunc);
WORD i = FALSE;
ATOMID idName;
EXPID idBody;
LPEXP lpBody;
LISTID idVarList;
GLOBALHANDLE hBody;
if (!lpFunc)
return KppRegisterKappaMessage(hResThisDll, IDE_ERRORINFUNC,
lpIDs->idError, NULLID, NULLID);
if (NUMVARS(lpFunc) != nArg)
{
idName = NAME(lpFunc);
KppReleaseItem(FUNC, idFunc);
return KppRegisterKappaMessage(hResThisDll, IDE_BADNUMARG,
idName, NULLID, NULLID);
}
idVarList = VARS(lpFunc);
idBody = BODY(lpFunc);
KppReleaseItem(FUNC, idFunc);
if (idBody == NULLID)
KappaReturnAtom(lpIDs->idNull);
lpBody = KppCopyTempExp(idBody, (GLOBALHANDLE FAR *)&hBody);
Kpp___LoadArgs(lpBody, idVarList, lpArgList);
UnwindProtect (cleanup);
i = Kpp_EvalExp(lpBody);
cleanup:
KppReleaseTempExp (hBody, i);
KppUnbindVars(idVarList);
EndProtect();
return i;
}
/*
* This actually does the interpolation, using the coefficients
* computed by sInterp(). Uses shares at offset byteNumber within the
* bodies.
* The Lagrange values come from the headers of the "shares" array.
*/
static PGPByte
sDoInterp(PGPByte *shares, PGPSize bodySize, PGPUInt32 nShares,
PGPUInt32 byteNumber)
{
PGPByte x, y;
PGPByte lagrange;
PGPUInt32 i;
x = 0;
for( i=0; i < nShares; ++i )
{
y = BODY(shares, bodySize, i)[byteNumber];
if (y != 0)
{
lagrange = HEADER(shares, bodySize, i)->lagrange;
y = f_exp[lagrange + f_log[y]];
}
x = f_add(x,y);
}
return x;
}
short PEXPORT Kpp__SetupFunc(LPFUNC lpFunc, LISTID idAtomList, EXPID idBody)
{
LISTID idVarList = KppMakeList(0);
if (idAtomList && idAtomList != lpIDs->idNull)
{
LIST_LOOP loop;
ATOMID idItem;
kpc_init_loop(idAtomList, &loop);
while (idItem = KppNextListElement(&loop)) {
LPVAR lpVar;
VARID idVar = KppAddItem(VAR, (LPLPSTR) &lpVar);
VARNAME(lpVar) = idItem;
BINDINGS(lpVar) = NULLID;
VARCLASS(lpVar) = NULLID;
VARPREV(lpVar) = NULLID;
KppReleaseItem(VAR, idVar);
KppAppendElem(idVarList, idVar);
}
}
KppDeleteList(idAtomList);
NUMVARS(lpFunc) = KppListLen(idVarList);
if (!idBody)
idBody = KppBuildNullExp();
else
KppResetBoundFlag(idBody);
BODY(lpFunc) = idBody;
VARS(lpFunc) = idVarList;
if (NUMVARS(lpFunc))
{
KppClearVarList(idVarList);
KppBindVars(idVarList, idBody);
}
return TRUE;
}
static VALUE
rb_dampedSpring(VALUE self, VALUE a, VALUE b, VALUE r1, VALUE r2, VALUE len, VALUE k, VALUE dmp, VALUE dt)
{
cpDampedSpring(BODY(a), BODY(b), *VGET(r1), *VGET(r2), NUM2DBL(len), NUM2DBL(k), NUM2DBL(dmp), NUM2DBL(dt));
return Qnil;
}
