VoxelMatrix <float> findNucleoli(const VoxelMatrix<float>& originalVoxelMatrix, VoxelMatrix<float>& nucleusMask,
const string& filename, const string& intermediateProcessesDir )
{
EVAL("1");
VoxelMatrix<float> nucleusMaskCopy = nucleusMask;
VoxelMatrix<float> gradientMatrix = originalVoxelMatrix;
EVAL("1");
//labelling
GaussianGradient<float> gaussianGradient;
gaussianGradient.MaskVoxelMatrixProcessing<float>::setMask( nucleusMaskCopy );
gaussianGradient.setSigma( 2 );
gaussianGradient.apply( gradientMatrix );
// gradientMatrix.save( intermediateProcessesDir + filename + "-gradient.vm", true );
VoxelMatrix <float> regionMatrix = gradientMatrix;
WatershedTransform<float> watershedTransform;
watershedTransform.MaskVoxelMatrixProcessing<float>::setMask( nucleusMaskCopy );
watershedTransform.apply( regionMatrix );
regionMatrix.save( intermediateProcessesDir + filename + "-watershed.vm", true );
VoxelMatrix<float> rangeMask, copyVoxelMatrix = originalVoxelMatrix;
VoxelMatrix<float> nucleoliMask;
/*
RegionAnalysis3D<float> regionAnalysis;
regionAnalysis.setLabelMatrix( regionMatrix );
regionAnalysis.setValueMatrix( copyVoxelMatrix );
regionAnalysis.setOutputMatrix( rangeMask );
regionAnalysis.run();
regionAnalysis.outputFillRegions( REGION_FEATURE_CONTRACTNESS );
rangeMask.save( intermediateProcessesDir + filename + "-contrast.vm", true );
VoxelMatrix<float> nucleoliMask = rangeMask;
OtsuThresholding<float> otsuThresholding;
Vector <float> featureValues = regionAnalysis.computeRegionFeature( REGION_FEATURE_CONTRACTNESS );
Vector <unsigned int> histogram = featureValues.histogram( featureValues.min(), 1, floor(featureValues.max())+1 );
Thresholding<float> thresholding;
thresholding.setBackground( 0.0 );
thresholding.setForeground( 1.0 );
EVAL("1");
thresholding.setThreshold( otsuThresholding.computeThreshold(histogram) );
//thresholding.applyAlternative( nucleoliMask );
thresholding.apply( nucleoliMask );
//to obtain a better filling, it's applied to each 2D slice instead of the complete 3D stack
HolesFillingf holesFilling;
int sizeZ = nucleoliMask.getSize3();
for (int k = 0; k < sizeZ; ++k) holesFilling.apply( nucleoliMask[k] );
// VoxelMatrix<float> ccsFillMask = nucleoliMask;
// nucleoliMask.fillIt(ccsFillMask);
VoxelMatrix<float> structElement;
structElement.setSize(1,1,1);
structElement.setOnes();
VoxelMatrixDilatation<float> voxelDilatation;
voxelDilatation.setStructElt( structElement );
voxelDilatation.apply( nucleoliMask );
VoxelMatrixErosion<float> voxelErosion;
voxelErosion.setStructElt( structElement );
voxelErosion.apply( nucleoliMask );
// VoxelMatrix<float> ccsFillMask = nucleoliMask;
// nucleoliMask.fillIt(ccsFillMask);
holesFilling.apply( nucleoliMask );
for (int k = 0; k < sizeZ; ++k) holesFilling.apply( nucleoliMask[k] );
//labeling the image
ComponentLabelling<float> componentLabelling;
componentLabelling.apply( nucleoliMask );
nucleoliMask.setVoxelCalibration( originalVoxelMatrix.getVoxelCalibration() );
//nucleoliMask.save( chromocentersDir + filename + ".vm", true );
*/
return nucleoliMask;
}
/* Evaluate method invocation */
static any evMethod(any o, any expr, any x) {
any y = car(expr);
any cls = TheCls, key = TheKey;
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[length(y)+3];
} f;
f.link = Env.bind, Env.bind = (bindFrame*)&f;
f.i = sizeof(f.bnd) / (2*sizeof(any)) - 2;
f.cnt = 1, f.bnd[0].sym = At, f.bnd[0].val = val(At);
while (isCell(y)) {
f.bnd[f.cnt].sym = car(y);
f.bnd[f.cnt].val = EVAL(car(x));
++f.cnt, x = cdr(x), y = cdr(y);
}
if (isNil(y)) {
while (--f.i > 0) {
x = val(f.bnd[f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
}
f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o;
y = cls, cls = Env.cls; Env.cls = y;
y = key, key = Env.key; Env.key = y;
x = prog(cdr(expr));
}
else if (y != At) {
f.bnd[f.cnt].sym = y, f.bnd[f.cnt++].val = val(y), val(y) = x;
while (--f.i > 0) {
x = val(f.bnd[f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
}
f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o;
y = cls, cls = Env.cls; Env.cls = y;
y = key, key = Env.key; Env.key = y;
x = prog(cdr(expr));
}
else {
int n, cnt;
cell *arg;
cell c[n = cnt = length(x)];
while (--n >= 0)
Push(c[n], EVAL(car(x))), x = cdr(x);
while (--f.i > 0) {
x = val(f.bnd[f.i].sym);
val(f.bnd[f.i].sym) = f.bnd[f.i].val;
f.bnd[f.i].val = x;
}
n = Env.next, Env.next = cnt;
arg = Env.arg, Env.arg = c;
f.bnd[f.cnt].sym = This, f.bnd[f.cnt++].val = val(This), val(This) = o;
y = cls, cls = Env.cls; Env.cls = y;
y = key, key = Env.key; Env.key = y;
x = prog(cdr(expr));
if (cnt)
drop(c[cnt-1]);
Env.arg = arg, Env.next = n;
}
while (--f.cnt >= 0)
val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
Env.bind = f.link;
Env.cls = cls, Env.key = key;
return x;
}
VoxelMatrix <float> findCCs(const VoxelMatrix<float>& originalVoxelMatrix, VoxelMatrix<float>& nucleusMask,
const string& filename, const string& intermediateProcessesDir )
{
VoxelMatrix<float> regionMatrix;
regionMatrix = applyLabelling( originalVoxelMatrix, nucleusMask, filename, intermediateProcessesDir );
// VoxelMatrix<float> regionMatrix( intermediateProcessesDir + filename + "-gradient.vm" );
// EVAL(regionMatrix.getSize());
VoxelMatrix<float> rangeMask, copyVoxelMatrix = originalVoxelMatrix;
RegionAnalysis3D<float> regionAnalysis;
regionAnalysis.setLabelMatrix( regionMatrix );
regionAnalysis.setValueMatrix( copyVoxelMatrix );
regionAnalysis.run();
rangeMask.setSize( copyVoxelMatrix.getSize() );
rangeMask.setZeros();
regionAnalysis.setOutputMatrix( rangeMask );
regionAnalysis.outputFillRegions( REGION_FEATURE_CONTRAST );
//regionAnalysis.outputFillRegions( REGION_FEATURE_CONTRACTNESS );
rangeMask.save( intermediateProcessesDir + filename + "-contrast.vm", true );
//rangeMask.save( intermediateProcessesDir + filename + "-contractness.vm", true );
OtsuThresholding<float> otsuThresholding;
Vector <float> featureValues = regionAnalysis.computeRegionFeature( REGION_FEATURE_CONTRAST );
//Vector <float> featureValues = regionAnalysis.computeRegionFeature( REGION_FEATURE_CONTRACTNESS );
featureValues.sort();
Vector <unsigned int> histogram = featureValues.histogram( featureValues.min(), 1, floor(featureValues.max())+1 );
float threshold = otsuThresholding.computeThreshold( histogram );
//float threshold = otsuThresholding.computeThreshold( histogram * 0.8 );
EVAL(featureValues);
EVAL(histogram);
EVAL(threshold);
regionAnalysis.thresholdRegions( featureValues, threshold );
regionAnalysis.run();
int num = regionAnalysis.condenseRegionLabels();
regionAnalysis.run();
EVAL(num);
VoxelMatrix<float> ccsMask = regionAnalysis.getLabelMatrix();
//to obtain a better filling, it's applied to each 2D slice instead of the complete 3D stack
HolesFillingf holesFilling;
int sizeZ = ccsMask.getSize3();
for (int k = 0; k < sizeZ; ++k) holesFilling.apply( ccsMask[k] );
// VoxelMatrix<float> ccsFillMask = ccsMask;
// ccsMask.fillIt(ccsFillMask);
// VoxelMatrix<float> structElement;
// structElement.setSize(3,3,3);
// structElement.setOnes();
// VoxelMatrixDilatation<float> voxelDilatation;
// voxelDilatation.setStructElt( structElement );
// voxelDilatation.apply( ccsMask );
// // VoxelMatrix<float> structElement2;
// // structElement2.setSize(1,1,1);
// // structElement2.setOnes();
// VoxelMatrixErosion<float> voxelErosion;
// voxelErosion.setStructElt( structElement );
// voxelErosion.apply( ccsMask );
// for (int k = 0; k < sizeZ; ++k) holesFilling.apply( ccsMask[k] );
ccsMask.setVoxelCalibration( originalVoxelMatrix.getVoxelCalibration() );
//ccsMask.save( chromocentersDir + filename + ".vm", true );
return ccsMask;
}
malValuePtr EVAL(malValuePtr ast, malEnvPtr env)
{
if (!env) {
env = replEnv;
}
while (1) {
const malList* list = DYNAMIC_CAST(malList, ast);
if (!list || (list->count() == 0)) {
return ast->eval(env);
}
ast = macroExpand(ast, env);
list = DYNAMIC_CAST(malList, ast);
if (!list || (list->count() == 0)) {
return ast->eval(env);
}
// From here on down we are evaluating a non-empty list.
// First handle the special forms.
if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) {
String special = symbol->value();
int argCount = list->count() - 1;
if (special == "def!") {
checkArgsIs("def!", 2, argCount);
const malSymbol* id = VALUE_CAST(malSymbol, list->item(1));
return env->set(id->value(), EVAL(list->item(2), env));
}
if (special == "defmacro!") {
checkArgsIs("defmacro!", 2, argCount);
const malSymbol* id = VALUE_CAST(malSymbol, list->item(1));
malValuePtr body = EVAL(list->item(2), env);
const malLambda* lambda = VALUE_CAST(malLambda, body);
return env->set(id->value(), mal::macro(*lambda));
}
if (special == "do") {
checkArgsAtLeast("do", 1, argCount);
for (int i = 1; i < argCount; i++) {
EVAL(list->item(i), env);
}
ast = list->item(argCount);
continue; // TCO
}
if (special == "fn*") {
checkArgsIs("fn*", 2, argCount);
const malSequence* bindings =
VALUE_CAST(malSequence, list->item(1));
StringVec params;
for (int i = 0; i < bindings->count(); i++) {
const malSymbol* sym =
VALUE_CAST(malSymbol, bindings->item(i));
params.push_back(sym->value());
}
return mal::lambda(params, list->item(2), env);
}
if (special == "if") {
checkArgsBetween("if", 2, 3, argCount);
bool isTrue = EVAL(list->item(1), env)->isTrue();
if (!isTrue && (argCount == 2)) {
return mal::nilValue();
}
ast = list->item(isTrue ? 2 : 3);
continue; // TCO
}
if (special == "let*") {
checkArgsIs("let*", 2, argCount);
const malSequence* bindings =
VALUE_CAST(malSequence, list->item(1));
int count = checkArgsEven("let*", bindings->count());
malEnvPtr inner(new malEnv(env));
for (int i = 0; i < count; i += 2) {
const malSymbol* var =
VALUE_CAST(malSymbol, bindings->item(i));
inner->set(var->value(), EVAL(bindings->item(i+1), inner));
}
ast = list->item(2);
env = inner;
continue; // TCO
}
if (special == "macroexpand") {
checkArgsIs("macroexpand", 1, argCount);
return macroExpand(list->item(1), env);
}
if (special == "quasiquote") {
checkArgsIs("quasiquote", 1, argCount);
ast = quasiquote(list->item(1));
continue; // TCO
}
if (special == "quote") {
checkArgsIs("quote", 1, argCount);
return list->item(1);
}
if (special == "try*") {
checkArgsIs("try*", 2, argCount);
malValuePtr tryBody = list->item(1);
const malList* catchBlock = VALUE_CAST(malList, list->item(2));
checkArgsIs("catch*", 2, catchBlock->count() - 1);
MAL_CHECK(VALUE_CAST(malSymbol,
catchBlock->item(0))->value() == "catch*",
"catch block must begin with catch*");
// We don't need excSym at this scope, but we want to check
// that the catch block is valid always, not just in case of
// an exception.
const malSymbol* excSym =
VALUE_CAST(malSymbol, catchBlock->item(1));
malValuePtr excVal;
try {
ast = EVAL(tryBody, env);
}
catch(String& s) {
excVal = mal::string(s);
}
catch (malEmptyInputException&) {
// Not an error, continue as if we got nil
ast = mal::nilValue();
}
catch(malValuePtr& o) {
excVal = o;
};
if (excVal) {
// we got some exception
env = malEnvPtr(new malEnv(env));
env->set(excSym->value(), excVal);
ast = catchBlock->item(2);
}
continue; // TCO
}
}
// Now we're left with the case of a regular list to be evaluated.
std::unique_ptr<malValueVec> items(list->evalItems(env));
malValuePtr op = items->at(0);
if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) {
ast = lambda->getBody();
env = lambda->makeEnv(items->begin()+1, items->end());
continue; // TCO
}
else {
return APPLY(op, items->begin()+1, items->end());
}
}
}
// (xor 'any 'any) -> flg
any doXor(any x) {
bool f;
x = cdr(x), f = isNil(EVAL(car(x))), x = cdr(x);
return f ^ isNil(EVAL(car(x)))? T : Nil;
}
// draw the image warped by the current homography
static void draw_warped_image(struct FTR *f)
{
struct viewer_state *e = f->userdata;
int w = e->iw;
int h = e->ih;
double H[3][3]; obtain_current_homography(H, e);
/* H[0][0]=0.107933;
H[0][1]=0.000899;
H[0][2]=-3.784855;
H[1][0]=-0.747116;
H[1][1]=0.778536;
H[1][2]=19.920756;
H[2][0]=-0.000941;
H[2][1]=-0.000131;
H[2][2]=1.;*/
extrapolator_t OUT = obtain_extrapolator(e);
interpolator_t EVAL = obtain_interpolator(e);
if(e->interpolation_order == 0){
for (int j = 0; j < f->h; j++){
for (int i = 0; i < f->w; i++){
double p[2] = {i, j};
apply_homography(p, H, p);
p[0] = (p[0] - 0.5) * w / (w - 1.0);
p[1] = (p[1] - 0.5) * h / (h - 1.0);
for (int l = 0; l < 3; l++){
int idx = l + 3 * (f->w * j + i);
float v = EVAL(e->img, w, h, e->pd, p[0], p[1], l, OUT);
f->rgb[idx] = v;
}
}
}
}
if(e->interpolation_order==1){
float *img_f = malloc(3*(f->w)*(f->h)*sizeof(float));
for(int i=0;i<(f->w)*(f->h)*3;i++){img_f[i]=0;}
clock_t debutcpu,fincpu;
debutcpu = clock();
if(e->pd==3){
apply_homo_ground_truth(e->img,img_f,w,h,f->w,f->h,H);
}else{//suppose pd=1
float *img3 = malloc(3*w*h*sizeof(float));
for(int i=0;i<w*h;i++){
for(int l = 0;l<3;l++){
img3[3*i+l]=e->img[i];
}
}
apply_homo_ground_truth(img3,img_f,w,h,f->w,f->h,H);
}
for(int i=0;i<3*(f->w)*(f->h);i++){(f->rgb)[i]=float_to_byte(img_f[i]);}
fincpu = clock();
printf("cputime :%fs\n",(double)(fincpu-debutcpu)/CLOCKS_PER_SEC);
}
}
LispObj *
Lisp_PQgetvalue(LispBuiltin *builtin)
/*
pq-getvalue result tuple field &optional type-specifier
*/
{
char *string;
double real = 0.0;
PGresult *res;
int tuple, field, isint = 0, isreal = 0, integer;
LispObj *result, *otupple, *field_number, *type;
type = ARGUMENT(3);
field_number = ARGUMENT(2);
otupple = ARGUMENT(1);
result = ARGUMENT(0);
if (!CHECKO(result, PGresult_t))
LispDestroy("%s: cannot convert %s to PGresult*",
STRFUN(builtin), STROBJ(result));
res = (PGresult*)(result->data.opaque.data);
CHECK_INDEX(otupple);
tuple = FIXNUM_VALUE(otupple);
CHECK_INDEX(field_number);
field = FIXNUM_VALUE(field_number);
string = PQgetvalue(res, tuple, field);
if (type != UNSPEC) {
char *typestring;
CHECK_SYMBOL(type);
typestring = ATOMID(type);
if (strcmp(typestring, "INT16") == 0) {
integer = *(short*)string;
isint = 1;
goto simple_type;
}
else if (strcmp(typestring, "INT32") == 0) {
integer = *(int*)string;
isint = 1;
goto simple_type;
}
else if (strcmp(typestring, "FLOAT") == 0) {
real = *(float*)string;
isreal = 1;
goto simple_type;
}
else if (strcmp(typestring, "REAL") == 0) {
real = *(double*)string;
isreal = 1;
goto simple_type;
}
else if (strcmp(typestring, "PG-POLYGON") == 0)
goto polygon_type;
else if (strcmp(typestring, "STRING") != 0)
LispDestroy("%s: unknown type %s",
STRFUN(builtin), typestring);
}
simple_type:
return (isint ? INTEGER(integer) : isreal ? DFLOAT(real) :
(string ? STRING(string) : NIL));
polygon_type:
{
LispObj *poly, *box, *p = NIL, *cdr, *obj;
POLYGON *polygon;
int i, size;
size = PQgetlength(res, tuple, field);
polygon = (POLYGON*)(string - sizeof(int));
GCDisable();
/* get polygon->boundbox */
cdr = EVAL(CONS(ATOM("MAKE-PG-POINT"),
CONS(KEYWORD("X"),
CONS(REAL(polygon->boundbox.high.x),
CONS(KEYWORD("Y"),
CONS(REAL(polygon->boundbox.high.y), NIL))))));
obj = EVAL(CONS(ATOM("MAKE-PG-POINT"),
CONS(KEYWORD("X"),
CONS(REAL(polygon->boundbox.low.x),
CONS(KEYWORD("Y"),
CONS(REAL(polygon->boundbox.low.y), NIL))))));
box = EVAL(CONS(ATOM("MAKE-PG-BOX"),
CONS(KEYWORD("HIGH"),
CONS(cdr,
CONS(KEYWORD("LOW"),
CONS(obj, NIL))))));
/* get polygon->p values */
for (i = 0; i < polygon->npts; i++) {
obj = EVAL(CONS(ATOM("MAKE-PG-POINT"),
CONS(KEYWORD("X"),
CONS(REAL(polygon->p[i].x),
CONS(KEYWORD("Y"),
CONS(REAL(polygon->p[i].y), NIL))))));
if (i == 0)
p = cdr = CONS(obj, NIL);
else {
RPLACD(cdr, CONS(obj, NIL));
cdr = CDR(cdr);
}
}
/* make result */
poly = EVAL(CONS(ATOM("MAKE-PG-POLYGON"),
CONS(KEYWORD("SIZE"),
CONS(REAL(size),
CONS(KEYWORD("NUM-POINTS"),
CONS(REAL(polygon->npts),
CONS(KEYWORD("BOUNDBOX"),
CONS(box,
CONS(KEYWORD("POINTS"),
CONS(QUOTE(p), NIL))))))))));
GCEnable();
return (poly);
}
}
// (lit 'any) -> any
any doLit(any x) {
x = cadr(x);
if (isNum(x = EVAL(x)) || isNil(x) || x == T || isCell(x) && isNum(car(x)))
return x;
return cons(Quote, x);
}
///////////////////////////////
// FIXME - make it loop over
// - eval_ast
// - apply
//
ast
EVAL (ast tree, environment::ptr a_env)
{
for (;;)
{
if (!tree)
return tree;
if (tree->type () != node_type_enum::LIST)
return eval_ast (tree, a_env);
// not as_or_throw - we know the type
auto root_list = tree->as<ast_node_list> ();
if (root_list->empty ())
return tree;
//
auto fn_handle_def = [root_list, &a_env]()
{
if (root_list->size () != 3)
raise<mal_exception_eval_invalid_arg> (root_list->to_string ());
const auto& key = (*root_list)[1]->as_or_throw<ast_node_symbol, mal_exception_eval_invalid_arg> ()->symbol ();
ast_node::ptr value = EVAL ((*root_list)[2], a_env);
a_env->set (key, value);
return value;
};
// tco
auto fn_handle_let_tco = [root_list, &a_env]() -> tco
{
if (root_list->size () != 3)
raise<mal_exception_eval_invalid_arg> (root_list->to_string ());
const ast_node_container_base* let_bindings = nullptr;
const auto root_list_arg_1 = (*root_list)[1];
switch (root_list_arg_1->type ())
{
case node_type_enum::LIST:
case node_type_enum::VECTOR:
let_bindings = root_list_arg_1->as<ast_node_container_base> ();
break;
default:
raise<mal_exception_eval_invalid_arg> (root_list_arg_1->to_string ());
};
//
auto let_env = environment::make (a_env);
if (let_bindings->size () % 2 != 0)
raise<mal_exception_eval_invalid_arg> (let_bindings->to_string ());
for (size_t i = 0, e = let_bindings->size(); i < e; i += 2)
{
const auto& key = (*let_bindings)[i]->as_or_throw<ast_node_symbol, mal_exception_eval_invalid_arg> ()->symbol ();
ast_node::ptr value = EVAL ((*let_bindings)[i + 1], let_env);
let_env->set (key, value);
}
return {(*root_list)[2], let_env};
};
// tco
auto fn_handle_apply_tco= [&tree, &a_env]() -> tco
{
ast_node::ptr new_node = eval_ast (tree, a_env);
auto callable_list = new_node->as_or_throw<ast_node_list, mal_exception_eval_not_list> ();
const size_t list_size = callable_list->size ();
if (list_size == 0)
raise<mal_exception_eval_not_callable> (callable_list->to_string ());
auto && callable_node = (*callable_list)[0]->as_or_throw<ast_node_callable, mal_exception_eval_not_callable> ();
return callable_node->call_tco (call_arguments (callable_list, 1, list_size - 1));
};
// tco
auto fn_handle_do_tco = [root_list, &a_env]() -> tco
{
const size_t list_size = root_list->size ();
if (list_size < 2)
raise<mal_exception_eval_invalid_arg> (root_list->to_string ());
for (size_t i = 1, e = list_size - 1; i < e; ++i)
{
/*retVal = */EVAL ((*root_list)[i], a_env);
}
return {(*root_list)[list_size - 1], a_env};
};
// tco
auto fn_handle_if_tco = [root_list, &a_env] () -> tco
{
const size_t list_size = root_list->size ();
if (list_size < 3 || list_size > 4)
raise<mal_exception_eval_invalid_arg> (root_list->to_string ());
ast_node::ptr condNode = EVAL ((*root_list)[1], a_env);
const bool cond = !(condNode == ast_node::nil_node) && !(condNode == ast_node::false_node);
if (cond)
return {(*root_list)[2], a_env};
else if (list_size == 4)
return {(*root_list)[3], a_env};
return tco {nullptr, nullptr, ast_node::nil_node};
};
auto fn_handle_fn = [root_list, &a_env] () -> ast
{
const size_t list_size = root_list->size ();
if (list_size != 3)
raise<mal_exception_eval_invalid_arg> (root_list->to_string ());
auto&& bindsNode = (*root_list)[1];
auto&& astNode = (*root_list)[2];
ast_node::ptr retVal = std::make_shared<ast_node_callable_lambda> (bindsNode, astNode, a_env);
return retVal;
};
auto first = (*root_list)[0];
if (first->type () == node_type_enum::SYMBOL)
{
// apply special symbols
// not as_or_throw - we know the type
const auto first_symbol = first->as<ast_node_symbol> ();
const auto& symbol = first_symbol->symbol ();
if (symbol == "def!")
{
return fn_handle_def ();
}
else if (symbol == "let*")
{
std::tie (tree, a_env, std::ignore) = fn_handle_let_tco ();
continue;
}
else if (symbol == "do")
{
std::tie (tree, a_env, std::ignore) = fn_handle_do_tco ();
continue;
}
else if (symbol == "if")
{
ast retVal;
std::tie (tree, a_env, retVal) = fn_handle_if_tco ();
if (retVal)
return retVal;
continue;
}
else if (symbol == "fn*")
{
return fn_handle_fn ();
}
}
// apply
{
ast retVal;
std::tie (tree, a_env, retVal) = fn_handle_apply_tco ();
if (retVal)
return retVal;
continue;
}
}
}
malValuePtr EVAL(malValuePtr ast, malEnvPtr env)
{
const malList* list = DYNAMIC_CAST(malList, ast);
if (!list || (list->count() == 0)) {
return ast->eval(env);
}
// From here on down we are evaluating a non-empty list.
// First handle the special forms.
if (const malSymbol* symbol = DYNAMIC_CAST(malSymbol, list->item(0))) {
String special = symbol->value();
int argCount = list->count() - 1;
if (special == "def!") {
checkArgsIs("def!", 2, argCount);
const malSymbol* id = VALUE_CAST(malSymbol, list->item(1));
return env->set(id->value(), EVAL(list->item(2), env));
}
if (special == "do") {
checkArgsAtLeast("do", 1, argCount);
for (int i = 1; i < argCount; i++) {
EVAL(list->item(i), env);
}
return EVAL(list->item(argCount), env);
}
if (special == "fn*") {
checkArgsIs("fn*", 2, argCount);
const malSequence* bindings =
VALUE_CAST(malSequence, list->item(1));
StringVec params;
for (int i = 0; i < bindings->count(); i++) {
const malSymbol* sym =
VALUE_CAST(malSymbol, bindings->item(i));
params.push_back(sym->value());
}
return mal::lambda(params, list->item(2), env);
}
if (special == "if") {
checkArgsBetween("if", 2, 3, argCount);
bool isTrue = EVAL(list->item(1), env)->isTrue();
if (!isTrue && (argCount == 2)) {
return mal::nilValue();
}
return EVAL(list->item(isTrue ? 2 : 3), env);
}
if (special == "let*") {
checkArgsIs("let*", 2, argCount);
const malSequence* bindings =
VALUE_CAST(malSequence, list->item(1));
int count = checkArgsEven("let*", bindings->count());
malEnvPtr inner(new malEnv(env));
for (int i = 0; i < count; i += 2) {
const malSymbol* var =
VALUE_CAST(malSymbol, bindings->item(i));
inner->set(var->value(), EVAL(bindings->item(i+1), inner));
}
return EVAL(list->item(2), inner);
}
}
// Now we're left with the case of a regular list to be evaluated.
std::unique_ptr<malValueVec> items(list->evalItems(env));
malValuePtr op = items->at(0);
if (const malLambda* lambda = DYNAMIC_CAST(malLambda, op)) {
return EVAL(lambda->getBody(),
lambda->makeEnv(items->begin()+1, items->end()));
}
else {
return APPLY(op, items->begin()+1, items->end(), env);
}
}
std::string
rep (const std::string& line, environment::ptr env)
{
return PRINT (EVAL ( READ (line), env));
}
// (gc ['num]) -> num | NIL
any doGc(any x) {
x = cdr(x);
gc(isNum(x = EVAL(car(x)))? CELLS*unBox(x) : CELLS);
return x;
}
void
rep ()
{
PRINT (EVAL ( READ()));
}
// (box 'any) -> sym
any doBox(any x) {
x = cdr(x);
return consSym(EVAL(car(x)), Nil);
}
void segfault_KGML(int signal, siginfo_t *si, void *arg){
EVAL(lang2(install("registerMemoryErr"), mkString("KGML2igraph")));
error("Critical memory error in KGML2igraph. Please save your work and restart R.");
}
// (as 'any1 . any2) -> any2 | NIL
any doAs(any x) {
x = cdr(x);
if (isNil(EVAL(car(x))))
return Nil;
return cdr(x);
}
/* ******************************************************************
****************************************************************** */
void inip (int* n,double** x,double** l, double** u,int* m,
double** lambda,int** equatn,int** linear,int* coded,
int* checkder) {
int i;
SEXP n_r,m_r,x_r,l_r,u_r,lambda_r,rho_r,equatn_r,linear_r,coded_r,
checkder_r;
*n = 0;
*m = 0;
defineVar(install("x") ,createRRealVector(*n,NULL) ,environment_r);
defineVar(install("l") ,createRRealVector(*n,NULL) ,environment_r);
defineVar(install("u") ,createRRealVector(*n,NULL) ,environment_r);
defineVar(install("lambda") ,createRRealVector(*m,NULL) ,environment_r);
defineVar(install("equatn") ,createRIntVector(*m,NULL) ,environment_r);
defineVar(install("linear") ,createRIntVector(*m,NULL) ,environment_r);
defineVar(install("coded") ,createRIntVector(11,NULL) ,environment_r);
defineVar(install("checkder"),createRIntScalar(*checkder),environment_r);
EVAL(inip_r);
n_r = findVar(install("n") ,environment_r);
x_r = findVar(install("x") ,environment_r);
l_r = findVar(install("l") ,environment_r);
u_r = findVar(install("u") ,environment_r);
m_r = findVar(install("m") ,environment_r);
lambda_r = findVar(install("lambda") ,environment_r);
equatn_r = findVar(install("equatn") ,environment_r);
linear_r = findVar(install("linear") ,environment_r);
coded_r = findVar(install("coded") ,environment_r);
checkder_r = findVar(install("checkder"),environment_r);
*n = (INTEGER(AS_INTEGER(EVAL(n_r))))[0];
*m = (INTEGER(AS_INTEGER(EVAL(m_r))))[0];
*checkder = (INTEGER(AS_INTEGER(EVAL(checkder_r))))[0];
*x = (double *) malloc(*n * sizeof(double));
*l = (double *) malloc(*n * sizeof(double));
*u = (double *) malloc(*n * sizeof(double));
*lambda = (double *) malloc(*m * sizeof(double));
*equatn = (int *) malloc(*m * sizeof(int ));
*linear = (int *) malloc(*m * sizeof(int ));
for(i = 0; i < *n; i++) {
(*x)[i] = (REAL(EVAL(x_r)))[i];
(*l)[i] = (REAL(EVAL(l_r)))[i];
(*u)[i] = (REAL(EVAL(u_r)))[i];
}
for(i = 0; i < *m; i++) {
(*lambda)[i] = (REAL(EVAL(lambda_r)))[i];
(*equatn)[i] = (INTEGER(AS_INTEGER(EVAL(equatn_r))))[i];
(*linear)[i] = (INTEGER(AS_INTEGER(EVAL(linear_r))))[i];
}
for(i = 0; i < 11; i++) {
coded[i] = (INTEGER(AS_INTEGER(EVAL(coded_r))))[i];
}
}
// (eval 'any ['cnt ['lst]]) -> any
any doEval(any x) {
any y;
cell c1;
bindFrame *p;
x = cdr(x), Push(c1, EVAL(car(x))), x = cdr(x);
if (!isNum(y = EVAL(car(x))) || !(p = Env.bind))
data(c1) = EVAL(data(c1));
else {
int cnt, n, i, j;
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[length(x)];
} f;
x = cdr(x), x = EVAL(car(x));
j = cnt = (int)unBox(y);
n = f.i = f.cnt = 0;
do {
++n;
if ((i = p->i) <= 0 && (p->i -= cnt, i == 0)) {
for (i = 0; i < p->cnt; ++i) {
y = val(p->bnd[i].sym);
val(p->bnd[i].sym) = p->bnd[i].val;
p->bnd[i].val = y;
}
if (p->cnt && p->bnd[0].sym == At && !--j)
break;
}
} while (p = p->link);
while (isCell(x)) {
for (p = Env.bind, j = n; ; p = p->link) {
if (p->i < 0)
for (i = 0; i < p->cnt; ++i) {
if (p->bnd[i].sym == car(x)) {
f.bnd[f.cnt].val = val(f.bnd[f.cnt].sym = car(x));
val(car(x)) = p->bnd[i].val;
++f.cnt;
goto next;
}
}
if (!--j)
break;
}
next: x = cdr(x);
}
f.link = Env.bind, Env.bind = (bindFrame*)&f;
data(c1) = EVAL(data(c1));
while (--f.cnt >= 0)
val(f.bnd[f.cnt].sym) = f.bnd[f.cnt].val;
Env.bind = f.link;
do {
for (p = Env.bind, i = n; --i; p = p->link);
if (p->i < 0 && (p->i += cnt) == 0)
for (i = p->cnt; --i >= 0;) {
y = val(p->bnd[i].sym);
val(p->bnd[i].sym) = p->bnd[i].val;
p->bnd[i].val = y;
}
} while (--n);
}
return Pop(c1);
}
void evalgjacp(int n,double *x,double *g,int m,double *p,double *q,
char work,int *gotj,int *flag) {
int i;
SEXP g_r,p_r,q_r,gotj_r,flag_r;
defineVar(install("n") ,createRIntScalar(n) ,environment_r);
defineVar(install("x") ,createRRealVector(n,x) ,environment_r);
defineVar(install("m") ,createRIntScalar(m) ,environment_r);
defineVar(install("work"),createRCharScalar(work),environment_r);
defineVar(install("gotj") ,createRIntScalar(*gotj) ,environment_r);
if ( work == 'J' || work == 'T' )
{
// Compute g
defineVar(install("g"),createRRealVector(n,x),environment_r);
}
if ( work == 'j' || work == 'J' )
{
// Compute p = Jac q
defineVar(install("q"),createRRealVector(n,q) ,environment_r);
defineVar(install("p"),createRRealVector(1,NULL) ,environment_r);
}
else // if ( work == 't' || work == 'T' )
{
// Compute q = Jac^t p
defineVar(install("p"),createRRealVector(m,p) ,environment_r);
defineVar(install("q"),createRRealVector(1,NULL) ,environment_r);
}
EVAL(evalgjacp_r);
if ( work == 'J' || work == 'T' )
{
// Compute g
g_r = findVar(install("g") ,environment_r);
for (i = 0; i < n; i++)
g[i] = (REAL(EVAL(g_r)))[i];
}
if ( work == 'j' || work == 'J' )
{
// Compute p = Jac q
p_r = findVar(install("p"),environment_r);
for (i = 0; i < n; i++)
p[i] = (REAL(EVAL(p_r)))[i];
}
else // if ( work == 't' || work == 'T' )
{
// Compute q = Jac^t p
q_r = findVar(install("q"),environment_r);
for (i = 0; i < n; i++)
q[i] = (REAL(EVAL(q_r)))[i];
}
gotj_r = findVar(install("gotj") ,environment_r);
flag_r = findVar(install("flag") ,environment_r);
*gotj = (INTEGER(AS_INTEGER(EVAL(gotj_r))))[0];
*flag = (INTEGER(AS_INTEGER(EVAL(flag_r))))[0];
}
// (bool 'any) -> flg
any doBool(any x) {return isNil(EVAL(cadr(x)))? Nil : T;}
// (for sym 'num ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for sym|(sym2 . sym) 'lst ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
// (for (sym|(sym2 . sym) 'any1 'any2 [. prg]) ['any | (NIL 'any . prg) | (T 'any . prg) ..]) -> any
any doFor(any x) {
any y, body, cond, a;
cell c1;
struct { // bindFrame
struct bindFrame *link;
int i, cnt;
struct {any sym; any val;} bnd[2];
} f;
f.link = Env.bind, Env.bind = (bindFrame*)&f;
f.i = 0;
if (!isCell(y = car(x = cdr(x))) || !isCell(cdr(y))) {
if (!isCell(y)) {
f.cnt = 1;
f.bnd[0].sym = y;
f.bnd[0].val = val(y);
}
else {
f.cnt = 2;
f.bnd[0].sym = cdr(y);
f.bnd[0].val = val(cdr(y));
f.bnd[1].sym = car(y);
f.bnd[1].val = val(car(y));
val(f.bnd[1].sym) = Zero;
}
y = Nil;
x = cdr(x), Push(c1, EVAL(car(x)));
if (isNum(data(c1)))
val(f.bnd[0].sym) = Zero;
body = x = cdr(x);
for (;;) {
if (isNum(data(c1))) {
val(f.bnd[0].sym) = bigCopy(val(f.bnd[0].sym));
digAdd(val(f.bnd[0].sym), 2);
if (bigCompare(val(f.bnd[0].sym), data(c1)) > 0)
break;
}
else {
if (!isCell(data(c1)))
break;
val(f.bnd[0].sym) = car(data(c1));
if (!isCell(data(c1) = cdr(data(c1))))
data(c1) = Nil;
}
if (f.cnt == 2) {
val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
digAdd(val(f.bnd[1].sym), 2);
}
do {
if (!isNum(y = car(x))) {
if (isSym(y))
y = val(y);
else if (isNil(car(y))) {
y = cdr(y);
if (isNil(a = EVAL(car(y)))) {
y = prog(cdr(y));
goto for1;
}
val(At) = a;
y = Nil;
}
else if (car(y) == T) {
y = cdr(y);
if (!isNil(a = EVAL(car(y)))) {
val(At) = a;
y = prog(cdr(y));
goto for1;
}
y = Nil;
}
else
y = evList(y);
}
} while (isCell(x = cdr(x)));
x = body;
}
for1:
drop(c1);
if (f.cnt == 2)
val(f.bnd[1].sym) = f.bnd[1].val;
val(f.bnd[0].sym) = f.bnd[0].val;
Env.bind = f.link;
return y;
}
if (!isCell(car(y))) {
f.cnt = 1;
f.bnd[0].sym = car(y);
f.bnd[0].val = val(car(y));
}
else {
f.cnt = 2;
f.bnd[0].sym = cdar(y);
f.bnd[0].val = val(cdar(y));
f.bnd[1].sym = caar(y);
f.bnd[1].val = val(caar(y));
val(f.bnd[1].sym) = Zero;
}
y = cdr(y);
val(f.bnd[0].sym) = EVAL(car(y));
y = cdr(y), cond = car(y), y = cdr(y);
Push(c1,Nil);
body = x = cdr(x);
while (!isNil(a = EVAL(cond))) {
val(At) = a;
if (f.cnt == 2) {
val(f.bnd[1].sym) = bigCopy(val(f.bnd[1].sym));
digAdd(val(f.bnd[1].sym), 2);
}
do {
if (!isNum(data(c1) = car(x))) {
if (isSym(data(c1)))
data(c1) = val(data(c1));
else if (isNil(car(data(c1)))) {
data(c1) = cdr(data(c1));
if (isNil(a = EVAL(car(data(c1))))) {
data(c1) = prog(cdr(data(c1)));
goto for2;
}
val(At) = a;
data(c1) = Nil;
}
else if (car(data(c1)) == T) {
data(c1) = cdr(data(c1));
if (!isNil(a = EVAL(car(data(c1))))) {
val(At) = a;
data(c1) = prog(cdr(data(c1)));
goto for2;
}
data(c1) = Nil;
}
else
data(c1) = evList(data(c1));
}
} while (isCell(x = cdr(x)));
if (isCell(y))
val(f.bnd[0].sym) = prog(y);
x = body;
}
for2:
if (f.cnt == 2)
val(f.bnd[1].sym) = f.bnd[1].val;
val(f.bnd[0].sym) = f.bnd[0].val;
Env.bind = f.link;
return Pop(c1);
}
/** solve an equation of the form $f[ ae^{nt} + be^{mt} + c = 0 $f]
@returns the solution in $f[ t $f], or etp::NaN if none found
**/
double e2solve(double a,/**< the parameter \p a */
double n, /**< the parameter \p n (should be negative) */
double b, /**< the parameter \p b */
double m, /**< the parameter \p m (should be negative) */
double c, /**< the constant \p c */
double p, /**< the precision (1e-8 if omitted) */
double *e) /**< pointer to error estimate (null if none desired) */
{
double t=0;
double f = EVAL(t,a,n,b,m,c);
// check for degenerate cases (1 exponential term is dominant)
// solve for t in dominant exponential, but only when a solution exists
// (c must be opposite sign of scalar and have less magnitude than scalar)
if (fabs(a/b)<p) // a is dominant
return c*b<0 && fabs(c)<fabs(b) ? log(-c/b)/m : NaN;
else if (fabs(b/a)<p) // b is dominant
return c*a<0 && fabs(c)<fabs(a) ? log(-c/a)/n : NaN;
// is there an extremum/inflexion to consider
if (a*b<0)
{
// compute the time t and value fi at which it occurs
double an_bm = -a*n/(b*m);
double tm = log(an_bm)/(m-n);
double fm = EVAL(tm,a,n,b,m,c);
double ti = log(an_bm*n/m)/(m-n);
double fi = EVAL(ti,a,n,b,m,c);
if (tm>0) // extremum in domain
{
if (f*fm<0) // first solution is in range
t = 0;
else if (c*fm<0) // second solution is in range
t = ti;
else // no solution is in range
return NaN;
}
else if (tm<0 && ti>0) // no extremum but inflexion in domain
{
if (fm*c<0) // solution in range
t = ti;
else // no solution in range
return NaN;
}
else if (ti<0) // no extremum or inflexion in domain
{
if (fi*c<0) // solution in range
t = ti;
else // no solution in range
return NaN;
}
else // no solution possible (includes tm==0 and ti==0)
return NaN;
}
else if (f*c>0) // solution is not reachable from t=0 (same sign)
{
return NaN;
}
// solve using Newton's method
int iter = 100;
if (t!=0) // initial t changed to inflexion point
double f = EVAL(t,a,n,b,m,c);
double dfdt = EVAL(t,a*n,n,b*m,m,0);
while ( fabs(f)>p && isfinite(t) && iter-->0)
{
t -= f/dfdt;
f = EVAL(t,a,n,b,m,c);
dfdt = EVAL(t,a*n,n,b*m,m,0);
}
if (iter==0)
{
gl_error("etp::solve(a=%.4f,n=%.4f,b=%.4f,m=%.4f,c=%.4f,prec=%.g) failed to converge",a,n,b,m,c,p);
return NaN; // failed to catch limit condition above
}
if (e!=NULL)
*e = p/dfdt;
return t>0?t:NaN;
}
// (! . exe) -> any
any doBreak(any x) {
x = cdr(x);
if (!isNil(val(Dbg)))
x = brkLoad(x);
return EVAL(x);
}
String rep(const String& input, malEnvPtr env)
{
return PRINT(EVAL(READ(input), env));
}
// (bye 'cnt|NIL)
any doBye(any ex) {
any x = EVAL(cadr(ex));
bye(isNil(x)? 0 : xCnt(ex,x));
}
Vector<T> CDFTools<T>::areasDifference(
const Vector<T>& y1,
const Vector<T>& x1,
const Vector<T>& y2,
const Vector<T>& x2) const
{
if ( y1.isIncreasing() == false || y2.isIncreasing() == false )
{
UsageError usageError;
usageError.setWhere( "void CDFTools<T>::areasDifference(...) const" );
usageError.setWhat( "The cdf passed is not an increasing number sequence" );
throw usageError;
}
if ( x1.getSize() != y1.getSize() || x2.getSize() != y2.getSize() )
{
UsageError usageError;
usageError.setWhere( "void CDFTools<T>::areasDifference(...) const" );
usageError.setWhat( "The sizes of at least one cdf passed and its repartition function do not match to each other" );
usageError.setWhat( "Use Vector<T> CDFTools<T>::cdf(const Vector<T>&) if needed..." );
throw usageError;
}
Vector<T> areasDifference;
// | __|
// | | -->y[0] -- y axis
// | _|
// |_|____ -->x[0] -- x axis
//
// EVAL(y1);
// EVAL(x1);
// EVAL(y2);
// EVAL(x2);
T area1, area2;
area1 = 0;
area2 = 0;
for ( int i = 1; i < y1.getSize(); ++i )
area1 += ( x1[i]-x1[i-1] ) * y1[i-1];
EVAL(area1);
for ( int i = 1; i < y2.getSize(); ++i )
area2 += ( x2[i]-x2[i-1] ) * y2[i-1];
EVAL(area2);
// output with 4 indexes
areasDifference.setSize( 6 );
areasDifference[0] = area1;
areasDifference[1] = area2;
// 1) Difference of areas
areasDifference[2] = abs( area1 - area2 );
// 2) Difference of areas ^ 2
areasDifference[3] = abs( pow( area1, 2.) - pow( area2, 2.) );
// 3) Coefficient between areas
if ( area1 < area2 ) areasDifference[2] = area1 / area2;
else areasDifference[4] = area2 / area1;
// 4) Coefficient between areas ^ 2
if ( area1 < area2 ) areasDifference[3] = pow( area1, 2.) / pow( area2, 2.);
else areasDifference[5] = pow( area2, 2.) / pow( area1, 2.);
return areasDifference;
}
/* Conforms to the specification and the behavior of Gauche 0.8.8.
* http://gauche.sourceforge.jp/doc/gauche-refe_82.html */
SCM_EXPORT ScmObj
scm_s_let_optionalsstar(ScmObj args, ScmObj bindings, ScmObj body,
ScmEvalState *eval_state)
{
ScmObj env, var, val, exp, binding;
DECLARE_FUNCTION("let-optionals*", syntax_variadic_tailrec_2);
env = eval_state->env;
args = EVAL(args, env);
ENSURE_LIST(args);
/*=======================================================================
(let-optionals* <restargs> (<binding spec>*) <body>)
(let-optionals* <restargs> (<binding spec>+ . <restvar>) <body>)
(let-optionals* <restargs> <restvar> <body>) ;; Gauche 0.8.8
<binding spec> --> (<variable> <expression>)
| <variable>
<restvar> --> <variable>
<body> --> <definition>* <sequence>
<definition> --> (define <variable> <expression>)
| (define (<variable> <def formals>) <body>)
| (begin <definition>*)
<sequence> --> <command>* <expression>
<command> --> <expression>
=======================================================================*/
FOR_EACH (binding, bindings) {
if (LIST_2_P(binding)) {
var = CAR(binding);
exp = CADR(binding);
} else {
var = binding;
exp = SCM_UNDEF;
}
if (!IDENTIFIERP(var))
ERR_OBJ(ERRMSG_INVALID_BINDING, binding);
if (NULLP(args)) {
/* the second element is only evaluated when there are not enough
* arguments */
val = EVAL(exp, env);
CHECK_VALID_EVALED_VALUE(val);
} else {
val = POP(args);
}
/* extend env for each variable */
env = scm_extend_environment(LIST_1(var), LIST_1(val), env);
}
if (IDENTIFIERP(bindings)) {
var = bindings;
env = scm_extend_environment(LIST_1(var), LIST_1(args), env);
} else if (!NULLP(bindings)) {
ERR_OBJ(ERRMSG_INVALID_BINDINGS, bindings);
}
eval_state->env = env;
return scm_s_body(body, eval_state);
}
