SCM
guile_comm_init (SCM args) // MPI_Init
{
int argc, i;
char **argv;
// count number of arguments:
argc = scm_to_int (scm_length (args));
argv = malloc ((argc + 1) * sizeof (char *));
argv[argc] = NULL;
for (i = 0; i < argc; i++)
{
argv[i] = scm_to_locale_string (scm_car (args));
args = scm_cdr (args);
}
int ierr = MPI_Init (&argc, &argv);
assert (MPI_SUCCESS==ierr);
/* FIXME: In fact we dont know if MPI_Init replaced the argv
completely and who is responsible for freeing these
resources. So we do not attempt to free them. */
return scm_from_comm (MPI_COMM_WORLD);
}
static SCM
thit_new_model(SCM s_max_rows, SCM s_bds_disc, SCM s_n_cont, SCM s_dp_weight,
SCM s_init_crosstab, SCM s_lambda_a, SCM s_lambda_b)
{
int max_rows = scm_to_int(s_max_rows);
int n_cont = scm_to_int(s_n_cont);
double dp_weight = scm_to_double(s_dp_weight);
double init_crosstab = scm_to_double(s_init_crosstab);
double lambda_a = scm_to_double(s_lambda_a);
double lambda_b = scm_to_double(s_lambda_b);
int n_disc = scm_to_int(scm_length(s_bds_disc));
gsl_vector_int *bds_disc = gsl_vector_int_alloc(n_disc);
int i, b;
for (i = 0; i < n_disc; i++) {
b = scm_to_int(scm_list_ref(s_bds_disc, scm_from_int(i)));
gsl_vector_int_set(bds_disc, i, b);
}
banmi_model_t *model = new_banmi_model(max_rows, bds_disc, n_cont, dp_weight,
init_crosstab, lambda_a, lambda_b);
SCM smob;
SCM_NEWSMOB(smob, thit_model_tag, model);
return smob;
}
struct t_hashtable *
weechat_guile_alist_to_hashtable (SCM alist, int hashtable_size)
{
struct t_hashtable *hashtable;
int length, i;
SCM pair;
hashtable = weechat_hashtable_new (hashtable_size,
WEECHAT_HASHTABLE_STRING,
WEECHAT_HASHTABLE_STRING,
NULL,
NULL);
if (!hashtable)
return NULL;
length = scm_to_int (scm_length (alist));
for (i = 0; i < length; i++)
{
pair = scm_list_ref (alist, scm_from_int (i));
weechat_hashtable_set (hashtable,
scm_i_string_chars (scm_list_ref (pair,
scm_from_int (0))),
scm_i_string_chars (scm_list_ref (pair,
scm_from_int (1))));
}
return hashtable;
}
/* Not used. */
SCM_EXPORT ScmObj
scm_unpack_env(ScmPackedEnv packed, ScmObj context)
{
scm_int_t depth;
depth = scm_length(context);
while (depth-- > packed)
context = CDR(context);
return context;
}
SCM_EXPORT ScmPackedEnv
scm_pack_env(ScmObj env)
{
scm_int_t depth;
DECLARE_INTERNAL_FUNCTION("scm_env_depth");
depth = scm_length(env);
SCM_ASSERT(SCM_LISTLEN_PROPERP(depth));
return depth;
}
void print_scheme_list(SCM lst){
/* Calculate the size of the list returned from Scheme */
int i, length;
length = scm_to_int(scm_length (lst));
/* Start from 1 as the zero-th element only denotes query type */
for(i = 1; i < length; i++){
SCM elm = scm_list_ref(lst, scm_from_int(i));
char *anton = scm_to_locale_string (elm);
printf("%s ", anton);
}
printf("\n");
}
SCM calculate_context(SCM c)
{
float prob = 1.0;
int i = 0.0;
for(; i < scm_to_int(scm_length(c)); i++)
prob *= 1.0 - scm_to_double(scm_list_ref(c, scm_from_int(i)));
prob = 1 - prob;
return scm_from_double(prob);
}
int scm_list_to_imht_set(SCM scm_a, imht_set_t **result) {
int a_length = scm_to_uint32((scm_length(scm_a)));
if (!imht_set_create((3 + a_length), result)) {
return (1);
};
while (!scm_is_null(scm_a)) {
if (!imht_set_add((*result), (scm_to_int((SCM_CAR(scm_a)))))) {
imht_set_destroy((*result));
return (2);
};
scm_a = SCM_CDR(scm_a);
};
return (0);
};
/*
* Dotted list length is returned as follows:
*
* list SRFI-1 dotted length length* result
* 'term 0 -1
* '(1 . term) 1 -2
* '(1 2 . term) 2 -3
* '(1 2 3 . term) 3 -4
*/
SCM_EXPORT ScmObj
scm_p_lengthstar(ScmObj lst)
{
scm_int_t len;
DECLARE_FUNCTION("length*", procedure_fixed_1);
len = scm_length(lst);
if (!SCM_LISTLEN_PROPERP(len)) { /* make fast path for proper list */
if (SCM_LISTLEN_DOTTEDP(len))
len = -SCM_LISTLEN_DOTTED(len) - 1;
else if (SCM_LISTLEN_CIRCULARP(len))
return SCM_FALSE;
}
return MAKE_INT(len);
}
struct t_hashtable *
weechat_guile_alist_to_hashtable (SCM alist, int size, const char *type_keys,
const char *type_values)
{
struct t_hashtable *hashtable;
int length, i;
SCM pair;
char *str, *str2;
hashtable = weechat_hashtable_new (size,
type_keys,
type_values,
NULL,
NULL);
if (!hashtable)
return NULL;
length = scm_to_int (scm_length (alist));
for (i = 0; i < length; i++)
{
pair = scm_list_ref (alist, scm_from_int (i));
if (strcmp (type_values, WEECHAT_HASHTABLE_STRING) == 0)
{
str = scm_to_locale_string (scm_list_ref (pair, scm_from_int (0)));
str2 = scm_to_locale_string (scm_list_ref (pair, scm_from_int (1)));
weechat_hashtable_set (hashtable, str, str2);
if (str)
free (str);
if (str2)
free (str2);
}
else if (strcmp (type_values, WEECHAT_HASHTABLE_POINTER) == 0)
{
str = scm_to_locale_string (scm_list_ref (pair, scm_from_int (0)));
str2 = scm_to_locale_string (scm_list_ref (pair, scm_from_int (1)));
weechat_hashtable_set (hashtable, str,
plugin_script_str2ptr (weechat_guile_plugin,
NULL, NULL, str2));
if (str)
free (str);
if (str2)
free (str2);
}
}
return hashtable;
}
SCM_EXPORT scm_int_t
scm_validate_actuals(ScmObj actuals)
{
scm_int_t len;
#if SCM_STRICT_ARGCHECK
len = scm_length(actuals);
#else
/* Crashless loose validation:
* This loop goes infinite if the formals is circular. SigSchme expects
* that user codes are sane here. */
len = scm_finite_length(actuals);
#endif
if (SCM_LISTLEN_DOTTEDP(len))
return SCM_LISTLEN_ENCODE_ERROR(len);
return len;
}
SCM make_tensor(SCM scm_type, SCM scm_shape, SCM scm_size, SCM scm_source)
{
SCM retval;
struct tf_tensor_t *self = (struct tf_tensor_t *)scm_gc_calloc(sizeof(struct tf_tensor_t), "make-tensor");
SCM_NEWSMOB(retval, tf_tensor_tag, self);
int type = scm_to_int(scm_type);
int num_dims = scm_to_int(scm_length(scm_shape));
int64_t *dims = scm_gc_malloc_pointerless(sizeof(int64_t) * num_dims, "make-tensor");
int count = 1;
for (int i=0; i<num_dims; i++) {
dims[i] = scm_to_int(scm_car(scm_shape));
count = count * dims[i];
scm_shape = scm_cdr(scm_shape);
};
if (type == TF_STRING) {
SCM* pointer = scm_to_pointer(scm_source);
size_t encoded_size = 0;
for (int i=0; i<count; i++) {
encoded_size += TF_StringEncodedSize(scm_c_string_length(*pointer)) + 8;
pointer++;
};
self->tensor = TF_AllocateTensor(type, dims, num_dims, encoded_size);
int64_t *offsets = TF_TensorData(self->tensor);
int offset = 0;
void *result = offsets + count;
pointer = scm_to_pointer(scm_source);
encoded_size = encoded_size - count * sizeof(int64_t);
for (int i=0; i<count; i++) {
char *str = scm_to_locale_string(*pointer);
int len = TF_StringEncodedSize(scm_c_string_length(*pointer));
*offsets++ = offset;
TF_StringEncode(str, scm_c_string_length(*pointer), result, encoded_size, status());
free(str);
if (TF_GetCode(_status) != TF_OK)
scm_misc_error("make-tensor", TF_Message(_status), SCM_EOL);
offset += len;
encoded_size -= len;
result += len;
pointer++;
};
} else {
self->tensor = TF_AllocateTensor(type, dims, num_dims, scm_to_int(scm_size));
memcpy(TF_TensorData(self->tensor), scm_to_pointer(scm_source), scm_to_int(scm_size));
};
return retval;
}
/********************************************************************\
* gnc_trans_scm_get_num_splits *
* get the number of scheme splits in a scheme transaction. *
* *
* Args: trans_scm - the scheme transaction *
* Returns: number of scheme splits in the transaction *
\********************************************************************/
int
gnc_trans_scm_get_num_splits(SCM trans_scm)
{
SCM result;
initialize_scm_functions();
if (!gnc_is_trans_scm(trans_scm))
return 0;
result = scm_call_1(getters.trans_scm_split_scms, trans_scm);
if (!scm_is_list(result))
return 0;
return scm_to_int(scm_length(result));
}
SCM get_living_neighbors (SCM board_smob, SCM cell_smob) {
SCM list; struct cell *cell;
int i;
int count;
scm_assert_smob_type(board_tag, board_smob);
scm_assert_smob_type(cell_tag, cell_smob);
list = get_neighbors(board_smob, cell_smob);
count = 0;
for (i = 0; i < scm_to_int(scm_length(list)); i++) {
cell = (struct cell *) SCM_SMOB_DATA(scm_list_ref(list, scm_from_int(i)));
if (cell->status > 0) {
count++;
}
}
return scm_from_int(count);
}
// Load one of data into the model. The vararg should be a list of values with
// length equal to the number of discrete columns plus the number of continuous
// columns. The first values in the vararg are taken to be discrete, followed
// by the continuous values.
//
SCM
thit_load_row_x(SCM s_model, SCM s_varargs) {
scm_assert_smob_type(thit_model_tag, s_model);
banmi_model_t *model = (banmi_model_t*)SCM_SMOB_DATA(s_model);
int n_col = model->n_disc + model->n_cont;
int n_args = scm_to_int(scm_length(s_varargs));
if (model->n_rows == model->disc->size1)
scm_error_scm(thit_error,
scm_from_locale_string("load-row!"),
scm_from_locale_string("The model is full, can't add more rows."),
scm_list_2(scm_from_int(n_col), scm_from_int(n_args)),
SCM_BOOL_F);
if (n_args != n_col)
scm_error_scm(thit_error,
scm_from_locale_string("load-row!"),
scm_from_locale_string("Expected ~A values, got ~A."),
scm_list_2(scm_from_int(n_col), scm_from_int(n_args)),
SCM_BOOL_F);
int j, ival;
for (j = 0; j < model->n_disc; j++) {
ival = scm_to_int(scm_list_ref(s_varargs, scm_from_int(j)));
gsl_matrix_int_set(model->disc, model->n_rows, j, ival);
}
double dval;
for (j = 0; j < model->n_cont; j++) {
dval = scm_to_double(scm_list_ref(s_varargs, scm_from_int(j + model->n_disc)));
gsl_matrix_set(model->cont, model->n_rows, j, dval);
}
model->n_rows++;
return SCM_BOOL_T;
}
return src;
}
static SCM fill_template(SCM template, SCM partial, SCM slots) {
SCM node, pair, parts, slot_mark, slot_end, payload;
struct template_slot *table;
char *pin, *sense, hold, *master;
int marklen, tabsize, i;
master = scm_to_utf8_string(template);
scm_remember_upto_here_1(template);
pin = master;
parts = SCM_EOL;
slot_mark = SCM_EOL;
slot_end = SCM_EOL;
marklen = strlen(SLOT_MARK);
tabsize = scm_to_int(scm_length(slots));
table = (struct template_slot *)malloc(
sizeof(struct template_slot) * tabsize);
i = 0;
pair = SCM_EOL;
payload = SCM_EOL;
for (node = slots; node != SCM_EOL; node = SCM_CDR(node)) {
pair = SCM_CAR(node);
table[i].token = upcase(scm_to_utf8_string(
scm_symbol_to_string(SCM_CAR(pair))));
payload = SCM_CDR(pair);
if (scm_is_number(payload))
payload = scm_number_to_string(payload,
scm_from_int(10));
else if (scm_is_symbol(payload))
payload = scm_symbol_to_string(payload);
void *directories_by_path;
void *directories_by_wd;
void *errors;
};
static scm_t_bits journal_tag;
SCM_DEFINE(journal_send, "journal-sendv", 1, 0, 0,
(SCM s_fields),
"Send an entry consisting of FIELDS to the journal.")
{
struct iovec *iov;
int i, n, r;
n = scm_to_int(scm_length(s_fields));
iov = alloca(n * sizeof(struct iovec));
for (i = 0; i < n; i++) {
char *msg;
msg = scm_to_locale_string(scm_list_ref(s_fields, scm_from_int(i)));
iov[i].iov_base = msg;
iov[i].iov_len = strlen(msg);
}
r = sd_journal_sendv(iov, n);
if (r < 0)
error_system("Failed to send data to journal", -r);
return SCM_UNSPECIFIED;
/*
* Adds an attribute <B>scm_attrib_name</B> with value <B>scm_attrib_value</B> to the given <B>object</B>.
The attribute has the visibility <B>scm_vis</B> and show <B>scm_show</B> flags.
The possible values are:
- <B>scm_vis</B>: scheme boolean. Visible (TRUE) or hidden (FALSE).
- <B>scm_show</B>: a list containing what to show: "name", "value", or both.
The return value is always TRUE.
*/
SCM g_add_attrib(SCM object, SCM scm_attrib_name,
SCM scm_attrib_value, SCM scm_vis, SCM scm_show)
{
GSCHEM_TOPLEVEL *w_current=global_window_current;
TOPLEVEL *toplevel = w_current->toplevel;
OBJECT *o_current=NULL;
gboolean vis;
int show=0;
gchar *attrib_name=NULL;
gchar *attrib_value=NULL;
gchar *value=NULL;
int i;
gchar *newtext=NULL;
SCM_ASSERT (scm_is_string(scm_attrib_name), scm_attrib_name,
SCM_ARG2, "add-attribute-to-object");
SCM_ASSERT (scm_is_string(scm_attrib_value), scm_attrib_value,
SCM_ARG3, "add-attribute-to-object");
SCM_ASSERT (scm_boolean_p(scm_vis), scm_vis,
SCM_ARG4, "add-attribute-to-object");
SCM_ASSERT (scm_list_p(scm_show), scm_show,
SCM_ARG5, "add-attribute-to-object");
/* Get toplevel and o_current */
SCM_ASSERT (g_get_data_from_object_smob (object, &toplevel, &o_current),
object, SCM_ARG1, "add-attribute-to-object");
/* Get parameters */
attrib_name = SCM_STRING_CHARS(scm_attrib_name);
attrib_value = SCM_STRING_CHARS(scm_attrib_value);
vis = SCM_NFALSEP(scm_vis);
for (i=0; i<=scm_to_int(scm_length(scm_show))-1; i++) {
/* Check every element in the list. It should be a string! */
SCM_ASSERT(scm_list_ref(scm_show, scm_from_int(i)),
scm_show,
SCM_ARG5, "add-attribute-to-object");
SCM_ASSERT(scm_is_string(scm_list_ref(scm_show, scm_from_int(i))),
scm_show,
SCM_ARG5, "add-attribute-to-object");
value = SCM_STRING_CHARS(scm_list_ref(scm_show, scm_from_int(i)));
SCM_ASSERT(value, scm_show,
SCM_ARG5, "add-attribute-to-object");
/* Only "name" or "value" strings are allowed */
SCM_ASSERT(!((strcasecmp(value, "name") != 0) &&
(strcasecmp(value, "value") != 0) ), scm_show,
SCM_ARG5, "add-attribute-to-object");
/* show = 1 => show value;
show = 2 => show name;
show = 3 => show both */
if (strcasecmp(value, "value") == 0) {
show |= 1;
}
else if (strcasecmp(value, "name") == 0) {
show |= 2;
}
}
/* Show name and value (show = 3) => show=0 for gschem */
if (show == 3) {
show = 0;
}
newtext = g_strdup_printf("%s=%s", attrib_name, attrib_value);
o_attrib_add_attrib (w_current, newtext, vis, show, o_current);
g_free(newtext);
return SCM_BOOL_T;
}
/*! \brief Get the object bounds of the given object, excluding the object
* types or the attributes given as parameters.
* \par Function Description
* Get the object bounds without considering the attributes in
* scm_exclude_attribs, neither the object types included in
* scm_exclude_object_type
* \param [in] object_smob The object we want to know the bounds of.
* \param [in] exclude_attrib_list A list with the attribute names we don't
* want to include when calculing the bounds.
* \param [in] exclude_obj_type_list A list with the object types we don't
* want to include when calculing the bounds.
* The object types are those used in (OBJECT *)->type converted into strings.
* \return a list of the bounds of the <B>object smob</B>.
* The list has the format: ( (left right) (top bottom) )
* WARNING: top and bottom are mis-named in world-coords,
* top is the smallest "y" value, and bottom is the largest.
* Be careful! This doesn't correspond to what you'd expect,
* nor to the coordinate system who's origin is the bottom, left of the page.
*/
SCM g_get_object_bounds (SCM object_smob, SCM scm_exclude_attribs, SCM scm_exclude_object_type)
{
TOPLEVEL *toplevel=NULL;
OBJECT *object=NULL;
int left=0, right=0, bottom=0, top=0;
SCM returned = SCM_EOL;
SCM vertical = SCM_EOL;
SCM horizontal = SCM_EOL;
GList *exclude_attrib_list = NULL, *exclude_obj_type_list = NULL;
gboolean exclude_all_attribs = FALSE;
int i;
SCM_ASSERT (scm_list_p(scm_exclude_attribs), scm_exclude_attribs,
SCM_ARG2, "get-object-bounds");
SCM_ASSERT (scm_list_p(scm_exclude_object_type), scm_exclude_object_type,
SCM_ARG3, "get-object-bounds");
/* Build the exclude attrib list */
for (i=0; i <= scm_to_int(scm_length(scm_exclude_attribs))-1; i++) {
SCM_ASSERT (scm_is_string(scm_list_ref(scm_exclude_attribs, scm_from_int(i))),
scm_exclude_attribs,
SCM_ARG2, "get-object-bounds");
exclude_attrib_list = g_list_append(exclude_attrib_list,
SCM_STRING_CHARS(scm_list_ref(scm_exclude_attribs,
scm_from_int(i))));
}
/* Build the exclude object type list */
for (i=0; i <= scm_to_int(scm_length(scm_exclude_object_type))-1; i++) {
SCM_ASSERT (scm_is_string(scm_list_ref(scm_exclude_object_type, scm_from_int(i))),
scm_exclude_object_type,
SCM_ARG3, "get-object-bounds");
exclude_obj_type_list = g_list_append(exclude_obj_type_list,
SCM_STRING_CHARS(scm_list_ref(scm_exclude_object_type,
scm_from_int(i))));
}
/* Get toplevel and o_current. */
g_get_data_from_object_smob (object_smob, &toplevel, &object);
SCM_ASSERT (toplevel && object,
object_smob, SCM_ARG1, "get-object-bounds");
if (g_list_find_custom(exclude_attrib_list, "all", (GCompareFunc) &strcmp))
exclude_all_attribs = TRUE;
custom_world_get_single_object_bounds (toplevel, object,
&left, &top,
&right, &bottom,
exclude_attrib_list,
exclude_obj_type_list);
/* Free the exclude attrib_list. Don't free the nodes!! */
g_list_free(exclude_attrib_list);
/* Free the exclude attrib_list. Don't free the nodes!! */
g_list_free(exclude_obj_type_list);
horizontal = scm_cons (scm_from_int(left), scm_from_int(right));
vertical = scm_cons (scm_from_int(top), scm_from_int(bottom));
returned = scm_cons (horizontal, vertical);
return (returned);
}
PyObject *scm2py(SCM value)
{
if (value == NULL)
return NULL;
if (value == SCM_UNSPECIFIED) {
Py_INCREF(Py_None);
return Py_None;
}
if (scm_is_exact_integer(value))
return PyInt_FromLong(scm_to_long(value));
if (scm_is_real(value))
return PyFloat_FromDouble(scm_to_double(value));
if (scm_is_bool(value)) {
PyObject *result = scm_to_bool(value) ? Py_True : Py_False;
Py_INCREF(result);
return result;
}
if (value == SCM_EOL)
return PyTuple_New(0);
if (scm_is_string(value)) {
size_t len = 0;
char *s = scm_to_utf8_stringn(value, &len);
PyObject *result = PyUnicode_FromStringAndSize(s, len);
free(s);
return result;
}
if (scm_is_pair(value)) {
unsigned int len = scm_to_uint(scm_length(value));
PyObject *result = PyTuple_New(len);
scm_dynwind_begin(0);
scm_dynwind_unwind_handler(
(void (*)(void *))Py_DecRef, result, 0);
unsigned int i;
for (i = 0; i < len; i++) {
PyObject *item = scm2py(scm_car(value));
if (item == NULL) {
scm_dynwind_end();
Py_DECREF(result);
return NULL;
}
PyTuple_SET_ITEM(result, i, item);
value = scm_cdr(value);
}
scm_dynwind_end();
return result;
}
if (scm_to_bool(scm_procedure_p(value))) {
SCM ptr = scm_assq_ref(gsubr_alist, value);
if (!scm_is_false(ptr)) {
PyObject *result = scm_to_pointer(ptr);
Py_INCREF(result);
return result;
}
Procedure *result =
(Procedure *)ProcedureType.tp_alloc(&ProcedureType, 0);
if (result == NULL)
return NULL;
result->proc = value;
return (PyObject *)result;
}
char *msg = scm_to_utf8_stringn(
scm_simple_format(
SCM_BOOL_F,
scm_from_utf8_string(
"Guile expression ~S doesn't have a "
"corresponding Python value"),
scm_list_1(value)), NULL);
PyErr_SetString(PyExc_TypeError, msg);
free(msg);
return NULL;
}
/* get confinement from SCM
* in SCM, confinement is given by one of these:
* for spherical confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "sphere"
* 10.0 ;; radius of the cavity at (0, 0, 0)
* ))
* for spherical confinement with a hole,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "sphere+hole"
* 10.0 ;; radius of the cavity at (0, 0, 0)
* 1.0 ;; radius of the hole at (0, 0, 1) direction
* ))
* for cylindrical confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "cylinder" ;; the cylinder center goes through (0, 0, 0) and (x, y, z).
* 10.0 ;; radius of the cylinder
* 1.0 0.0 0.0 ;; direction vector (x, y, z) of the cylinder
* ))
* for dumbbell confinement,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "dumbbell" ;; the origin is at the center of the cylinder
* 10.0 ;; left cavity radius centered at (center1, 0, 0)
* 10.0 ;; right cavity radius centered at (center2, 0, 0)
* 2.0 ;; length of the cylinder
* 1.0 ;; cylinder radius
* ))
* for 2D hexagonal confinement with cylinder pipe,
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "hex2d"
* 10.0 ;; cavity radius
* 1.0 ;; cylinder radius
* 12.0 ;; lattice spacing
* ))
* for porous media (outside of the 3D hexagonal particle array)
* (define confinement '(
* 10.0 ;; LJ parameter epsilon in kT (so this is dimensionless value)
* 1.0 ;; LJ parameter r0 in "length" (so this is dimensionless value)
* "porous"
* 10.0 ;; particle radius
* 20.0 ;; lattice spacing in x (2R for touching case)
* ))
* INPUT
* var : name of the variable.
* in the above example, set "confinement".
* OUTPUT
* returned value : struct confinement
* if NULL is returned, it failed (not defined)
*/
struct confinement *
CF_guile_get (const char *var)
{
if (guile_check_symbol (var) == 0)
{
fprintf (stderr, "CF_guile_get: %s is not defined\n", var);
return (NULL);
}
SCM scm_symbol
= scm_c_lookup (var);
SCM scm_confinement
= scm_variable_ref (scm_symbol);
if (!SCM_NFALSEP (scm_list_p (scm_confinement)))
{
fprintf (stderr, "CF_guile_get: %s is not a list\n", var);
return (NULL);
}
struct confinement *cf = NULL;
unsigned long len
= scm_num2ulong (scm_length (scm_confinement),
0, "CF_guile_get");
if (len == 0)
{
// no confinement
return (cf);
}
else if (len < 4)
{
fprintf (stderr, "CF_guile_get: %s is too short\n", var);
return (NULL);
}
double epsilon
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (0)),
"CF_guile_get");
double r0
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (1)),
"CF_guile_get");
// get the string
char *str_cf = NULL;
SCM scm_conf = scm_list_ref (scm_confinement, scm_int2num (2));
#ifdef GUILE16
size_t str_len;
if (gh_string_p (scm_conf))
{
str_cf = gh_scm2newstr (scm_conf, &str_len);
}
#else // !GUILE16
if (scm_is_string (scm_conf))
{
str_cf = scm_to_locale_string (scm_conf);
}
#endif // GUILE16
if (strcmp (str_cf, "sphere") == 0)
{
if (len != 4)
{
fprintf (stderr, "CF_guile_get:"
" for sphere, number of parameter must be 1\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
cf = CF_init (0, // sphere
R,
0.0, // r
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "sphere+hole") == 0)
{
if (len != 5)
{
fprintf (stderr, "CF_guile_get:"
" for sphere+hole, number of parameter must be 2\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
cf = CF_init (1, // sphere+hole
R,
r,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "cylinder") == 0)
{
if (len != 7)
{
fprintf (stderr, "CF_guile_get:"
" for cylinder, number of parameter must be 4\n");
}
else
{
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double x
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double y
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
double z
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (6)),
"CF_guile_get");
cf = CF_init (2, // cylinder
0.0, // R,
r,
x, y, z,
0.0, // R2
0.0, // L
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "dumbbell") == 0)
{
if (len != 7)
{
fprintf (stderr, "CF_guile_get:"
" for dumbbell, number of parameter must be 4\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double R2
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (6)),
"CF_guile_get");
cf = CF_init (3, // dumbbell
R,
r,
0.0, 0.0, 0.0, // x, y, z
R2,
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "hex2d") == 0)
{
if (len != 6)
{
fprintf (stderr, "CF_guile_get:"
" for hex2d, number of parameter must be 3\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double r
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (5)),
"CF_guile_get");
cf = CF_init (4, // hex2d
R,
r,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else if (strcmp (str_cf, "porous") == 0)
{
if (len != 5)
{
fprintf (stderr, "CF_guile_get:"
" for hex2d, number of parameter must be 2\n");
}
else
{
double R
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (3)),
"CF_guile_get");
double L
= scm_num2dbl (scm_list_ref (scm_confinement, scm_int2num (4)),
"CF_guile_get");
cf = CF_init (5, // porous
R,
0.0,
0.0, 0.0, 0.0, // x, y, z
0.0, // R2
L,
0, // flag_LJ
epsilon,
r0);
CHECK_MALLOC (cf, "CF_guile_get");
}
}
else
{
fprintf (stderr, "CF_guile_get: invalid confinement %s\n",
str_cf);
}
free (str_cf);
return (cf); // success
}
