crimp_image*
crimp_la_multiply_matrix (crimp_image* a, crimp_image* b)
{
crimp_image* result;
int x, y, w, n, m;
CRIMP_ASSERT_IMGTYPE (a, float);
CRIMP_ASSERT_IMGTYPE (b, float);
CRIMP_ASSERT (crimp_require_height(a, crimp_w(b)),"Unable to multiply matrices, size mismatch");
CRIMP_ASSERT (crimp_require_height(b, crimp_w(a)),"Unable to multiply matrices, size mismatch");
n = crimp_h (a);
m = crimp_w (a);
result = crimp_new_float (n, n);
for (y = 0; y < n; y++) {
for (x = 0; x < n; x++) {
FLOATP (result, x, y) = 0;
for (w = 0; w < m; w++) {
FLOATP (result, x, y) += FLOATP (a, w, y) * FLOATP (b, x, w);
}
}
}
return result;
}
static obj_ptr _add(obj_ptr args, obj_ptr env)
{
obj_ptr res = MKINT(0);
for (; CONSP(args); args = CDR(args))
{
obj_ptr arg = CAR(args);
if (INTP(arg))
{
if (FLOATP(res))
FLOAT(res) += (double)INT(arg);
else
INT(res) += INT(arg);
}
else if (FLOATP(arg))
{
if (INTP(res))
{
int n = INT(res);
res->type = TYPE_FLOAT;
FLOAT(res) = (double)n;
}
FLOAT(res) += FLOAT(arg);
}
else
{
res = MKERROR(MKSTRING("Expected a number in +"), arg);
break;
}
}
return res;
}
static obj_ptr _sub(obj_ptr args, obj_ptr env)
{
obj_ptr res = MKINT(0);
int ct = 0;
for (; CONSP(args); args = CDR(args))
{
obj_ptr arg = CAR(args);
ct++;
if (NINTP(arg) && NFLOATP(arg))
{
res = MKERROR(MKSTRING("Expected a number in -"), arg);
return res;
}
else if (ct == 1)
{
if (INTP(arg))
INT(res) = INT(arg);
else
{
res->type = TYPE_FLOAT;
FLOAT(res) = FLOAT(arg);
}
}
else if (INTP(arg))
{
if (FLOATP(res))
FLOAT(res) -= (double)INT(arg);
else
INT(res) -= INT(arg);
}
else if (FLOATP(arg))
{
if (INTP(res))
{
int n = INT(res);
res->type = TYPE_FLOAT;
FLOAT(res) = (double)n;
}
FLOAT(res) -= FLOAT(arg);
}
}
if (ct == 1)
{
if (INTP(res))
INT(res) *= -1;
else
FLOAT(res) *= -1;
}
return res;
}
static int
parse_sound (Lisp_Object sound, Lisp_Object *attrs)
{
/* SOUND must be a list starting with the symbol `sound'. */
if (!CONSP (sound) || !EQ (XCAR (sound), Qsound))
return 0;
sound = XCDR (sound);
attrs[SOUND_FILE] = Fplist_get (sound, QCfile);
attrs[SOUND_DATA] = Fplist_get (sound, QCdata);
attrs[SOUND_DEVICE] = Fplist_get (sound, QCdevice);
attrs[SOUND_VOLUME] = Fplist_get (sound, QCvolume);
#ifndef WINDOWSNT
/* File name or data must be specified. */
if (!STRINGP (attrs[SOUND_FILE])
&& !STRINGP (attrs[SOUND_DATA]))
return 0;
#else /* WINDOWSNT */
/*
Data is not supported in Windows. Therefore a
File name MUST be supplied.
*/
if (!STRINGP (attrs[SOUND_FILE]))
{
return 0;
}
#endif /* WINDOWSNT */
/* Volume must be in the range 0..100 or unspecified. */
if (!NILP (attrs[SOUND_VOLUME]))
{
if (INTEGERP (attrs[SOUND_VOLUME]))
{
if (XINT (attrs[SOUND_VOLUME]) < 0
|| XINT (attrs[SOUND_VOLUME]) > 100)
return 0;
}
else if (FLOATP (attrs[SOUND_VOLUME]))
{
if (XFLOAT_DATA (attrs[SOUND_VOLUME]) < 0
|| XFLOAT_DATA (attrs[SOUND_VOLUME]) > 1)
return 0;
}
else
return 0;
}
#ifndef WINDOWSNT
/* Device must be a string or unspecified. */
if (!NILP (attrs[SOUND_DEVICE])
&& !STRINGP (attrs[SOUND_DEVICE]))
return 0;
#endif /* WINDOWSNT */
/*
Since device is ignored in Windows, it does not matter
what it is.
*/
return 1;
}
char* whatis(Lisp_Object object) {
debug_print_buf[0] = '\0';
debug_print_buf[80] = '\0';
if (STRINGP(object)) {
snprintf(debug_print_buf, 80, "String %s", SSDATA(object));
return debug_print_buf;
} else if (INTEGERP(object)) {
int x = XINT(object);
snprintf(debug_print_buf, 80, "Number %d", x);
return debug_print_buf;
} else if (FLOATP(object)) {
struct Lisp_Float* floater = XFLOAT(object);
return "It's a float number!";
} else if (Qnil == object)
return "It's a lisp null";
else if (Qt == object)
return "It's a lisp 't'";
else if (SYMBOLP(object)) {
snprintf(debug_print_buf, 80, "Symbol named %s", SYMBOL_NAME(object));
return debug_print_buf;
} else if (CONSP(object))
return "It's a list!";
else if (MISCP(object))
return "It's a lisp misc!";
else if (VECTORLIKEP(object))
return "It's some kind of vector like thingie!";
else
return "I don't know what it is.";
}
static double
module_extract_float (emacs_env *env, emacs_value f)
{
MODULE_FUNCTION_BEGIN (0);
Lisp_Object lisp = value_to_lisp (f);
CHECK_TYPE (FLOATP (lisp), Qfloatp, lisp);
return XFLOAT_DATA (lisp);
}
static obj_ptr _decrement(obj_ptr arg, obj_ptr env)
{
if (INTP(arg))
return MKINT(INT(arg) - 1);
if (FLOATP(arg))
return MKFLOAT(FLOAT(arg) - 1.0);
return MKERROR(MKSTRING("Expected a number in --"), arg);
}
object_t *floatp (object_t * lst)
{
DOC ("Return t if object is a floating-point number.");
REQ (lst, 1, c_sym ("floatp"));
if (FLOATP (CAR (lst)))
return T;
return NIL;
}
double
extract_float (Lisp_Object num)
{
CHECK_NUMBER_OR_FLOAT (num);
if (FLOATP (num))
return XFLOAT_DATA (num);
return (double) XINT (num);
}
void
crimp_la_multiply_matrix_3v (crimp_image* matrix, double* x, double* y, double* w)
{
/*
* Inlined multiplication of matrix and vector
*/
double xo = (*x) * FLOATP (matrix, 0, 0) + (*y) * FLOATP (matrix, 1, 0) + (*w) * FLOATP (matrix, 2, 0);
double yo = (*x) * FLOATP (matrix, 0, 1) + (*y) * FLOATP (matrix, 1, 1) + (*w) * FLOATP (matrix, 2, 1);
double wo = (*x) * FLOATP (matrix, 0, 2) + (*y) * FLOATP (matrix, 1, 2) + (*w) * FLOATP (matrix, 2, 2);
*x = xo;
*y = yo;
*w = wo;
}
static obj_ptr _floor(obj_ptr arg, obj_ptr env)
{
if (INTP(arg))
return arg;
if (FLOATP(arg))
{
int x = (int)FLOAT(arg);
return MKINT(x);
}
return MKERROR(MKSTRING("Expected a number in floor"), arg);
}
static double
module_extract_float (emacs_env *env, emacs_value f)
{
MODULE_FUNCTION_BEGIN (0);
Lisp_Object lisp = value_to_lisp (f);
if (! FLOATP (lisp))
{
module_wrong_type (env, Qfloatp, lisp);
return 0;
}
return XFLOAT_DATA (lisp);
}
static LispObject Abs(LispObject args)
{
CHECK_NUMBER(args);
if (FLOATP(args)) {
double r = fabs(LFLOAT(args)->value);
return MakeFloat(r);
}
if (INTEGERP(args)) {
int r = abs(LINTEGER(args));
return MakeInteger(r);
}
return Qnil;
}
static obj_ptr _div(obj_ptr args, obj_ptr env)
{
obj_ptr res = MKFLOAT(0);
int ct = 0;
for (; CONSP(args); args = CDR(args))
{
obj_ptr arg = CAR(args);
ct++;
if (NINTP(arg) && NFLOATP(arg))
{
res = MKERROR(MKSTRING("Expected a number in /"), arg);
return res;
}
else if (ct == 1)
{
if (INTP(arg))
FLOAT(res) = (double)INT(arg);
else
FLOAT(res) = FLOAT(arg);
}
else if (INTP(arg))
{
FLOAT(res) /= (double)INT(arg);
}
else if (FLOATP(arg))
{
FLOAT(res) /= FLOAT(arg);
}
}
if (ct == 1)
{
FLOAT(res) = 1 / FLOAT(res);
}
return res;
}
crimp_image*
crimp_la_invert_matrix_3x3 (crimp_image* matrix)
{
crimp_image* result;
int x, y;
double cofactor [3][3];
double det = 0;
double sign = 1;
CRIMP_ASSERT_IMGTYPE (matrix, float);
CRIMP_ASSERT (crimp_require_dim(matrix, 3, 3),"Unable to invert matrix, not 3x3");
result = crimp_new_float (3, 3);
for (y = 0; y < 3; y++) {
int y1 = !y;
int y2 = 2 - !(y - 2);
for (x = 0; x < 3; x++) {
int x1 = !x;
int x2 = 2 - !(x - 2);
cofactor[y][x] = sign * ((FLOATP (matrix, x1, y1) * FLOATP (matrix, x2, y2)) -
(FLOATP (matrix, x2, y1) * FLOATP (matrix, x1, y2)));
sign = -sign;
}
det += FLOATP (matrix, 0, y) * cofactor[y][0];
}
if (det == 0) {
return NULL;
}
for (y = 0; y < 3; y++) {
for (x = 0; x < 3; x++) {
FLOATP (result, x, y) = cofactor[x][y] / det;
}
}
return result;
}
/* This compares two directory listings in case of a `write' event for
a directory. Generate resulting file notification events. The old
directory listing is retrieved from watch_object, it will be
replaced by the new directory listing at the end of this
function. */
static void
kqueue_compare_dir_list
(Lisp_Object watch_object)
{
Lisp_Object dir, pending_dl, deleted_dl;
Lisp_Object old_directory_files, old_dl, new_directory_files, new_dl, dl;
dir = XCAR (XCDR (watch_object));
pending_dl = Qnil;
deleted_dl = Qnil;
old_directory_files = Fnth (make_number (4), watch_object);
old_dl = kqueue_directory_listing (old_directory_files);
/* When the directory is not accessible anymore, it has been deleted. */
if (NILP (Ffile_directory_p (dir))) {
kqueue_generate_event (watch_object, Fcons (Qdelete, Qnil), dir, Qnil);
return;
}
new_directory_files =
directory_files_internal (dir, Qnil, Qnil, Qnil, 1, Qnil);
new_dl = kqueue_directory_listing (new_directory_files);
/* Parse through the old list. */
dl = old_dl;
while (1) {
Lisp_Object old_entry, new_entry, dl1;
if (NILP (dl))
break;
/* Search for an entry with the same inode. */
old_entry = XCAR (dl);
new_entry = assq_no_quit (XCAR (old_entry), new_dl);
if (! NILP (Fequal (old_entry, new_entry))) {
/* Both entries are identical. Nothing to do. */
new_dl = Fdelq (new_entry, new_dl);
goto the_end;
}
/* Both entries have the same inode. */
if (! NILP (new_entry)) {
/* Both entries have the same file name. */
if (strcmp (SSDATA (XCAR (XCDR (old_entry))),
SSDATA (XCAR (XCDR (new_entry)))) == 0) {
/* Modification time has been changed, the file has been written. */
if (NILP (Fequal (Fnth (make_number (2), old_entry),
Fnth (make_number (2), new_entry))))
kqueue_generate_event
(watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (old_entry)), Qnil);
/* Status change time has been changed, the file attributes
have changed. */
if (NILP (Fequal (Fnth (make_number (3), old_entry),
Fnth (make_number (3), new_entry))))
kqueue_generate_event
(watch_object, Fcons (Qattrib, Qnil),
XCAR (XCDR (old_entry)), Qnil);
} else {
/* The file has been renamed. */
kqueue_generate_event
(watch_object, Fcons (Qrename, Qnil),
XCAR (XCDR (old_entry)), XCAR (XCDR (new_entry)));
deleted_dl = Fcons (new_entry, deleted_dl);
}
new_dl = Fdelq (new_entry, new_dl);
goto the_end;
}
/* Search, whether there is a file with the same name but another
inode. */
for (dl1 = new_dl; ! NILP (dl1); dl1 = XCDR (dl1)) {
new_entry = XCAR (dl1);
if (strcmp (SSDATA (XCAR (XCDR (old_entry))),
SSDATA (XCAR (XCDR (new_entry)))) == 0) {
pending_dl = Fcons (new_entry, pending_dl);
new_dl = Fdelq (new_entry, new_dl);
goto the_end;
}
}
/* Check, whether this a pending file. */
new_entry = assq_no_quit (XCAR (old_entry), pending_dl);
if (NILP (new_entry)) {
/* Check, whether this is an already deleted file (by rename). */
for (dl1 = deleted_dl; ! NILP (dl1); dl1 = XCDR (dl1)) {
new_entry = XCAR (dl1);
if (strcmp (SSDATA (XCAR (XCDR (old_entry))),
SSDATA (XCAR (XCDR (new_entry)))) == 0) {
deleted_dl = Fdelq (new_entry, deleted_dl);
goto the_end;
}
}
/* The file has been deleted. */
kqueue_generate_event
(watch_object, Fcons (Qdelete, Qnil), XCAR (XCDR (old_entry)), Qnil);
} else {
/* The file has been renamed. */
kqueue_generate_event
(watch_object, Fcons (Qrename, Qnil),
XCAR (XCDR (old_entry)), XCAR (XCDR (new_entry)));
pending_dl = Fdelq (new_entry, pending_dl);
}
the_end:
dl = XCDR (dl);
old_dl = Fdelq (old_entry, old_dl);
}
/* Parse through the resulting new list. */
dl = new_dl;
while (1) {
Lisp_Object entry;
if (NILP (dl))
break;
/* A new file has appeared. */
entry = XCAR (dl);
kqueue_generate_event
(watch_object, Fcons (Qcreate, Qnil), XCAR (XCDR (entry)), Qnil);
/* Check size of that file. */
Lisp_Object size = Fnth (make_number (4), entry);
if (FLOATP (size) || (XINT (size) > 0))
kqueue_generate_event
(watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (entry)), Qnil);
dl = XCDR (dl);
new_dl = Fdelq (entry, new_dl);
}
/* Parse through the resulting pending_dl list. */
dl = pending_dl;
while (1) {
Lisp_Object entry;
if (NILP (dl))
break;
/* A file is still pending. Assume it was a write. */
entry = XCAR (dl);
kqueue_generate_event
(watch_object, Fcons (Qwrite, Qnil), XCAR (XCDR (entry)), Qnil);
dl = XCDR (dl);
pending_dl = Fdelq (entry, pending_dl);
}
/* At this point, old_dl, new_dl and pending_dl shall be empty.
deleted_dl might not be empty when there was a rename to a
nonexistent file. Let's make a check for this (might be removed
once the code is stable). */
if (! NILP (old_dl))
report_file_error ("Old list not empty", old_dl);
if (! NILP (new_dl))
report_file_error ("New list not empty", new_dl);
if (! NILP (pending_dl))
report_file_error ("Pending events list not empty", pending_dl);
// if (! NILP (deleted_dl))
// report_file_error ("Deleted events list not empty", deleted_dl);
/* Replace old directory listing with the new one. */
XSETCDR (Fnthcdr (make_number (3), watch_object),
Fcons (new_directory_files, Qnil));
return;
}
static void
CHECK_FLOAT (Lisp_Object x)
{
CHECK_TYPE (FLOATP (x), Qfloatp, x);
}
