CAMLprim value ml_gsl_fit_mul(value wo, value x, value y)
{
value r;
size_t N=Double_array_length(x);
double c1,cov11,sumsq;
if(Double_array_length(y) != N)
GSL_ERROR("array sizes differ", GSL_EBADLEN);
if(wo == Val_none)
gsl_fit_mul(Double_array_val(x), 1, Double_array_val(y), 1, N,
&c1, &cov11, &sumsq);
else {
value w=Field(wo, 0);
if(Double_array_length(w) != N)
GSL_ERROR("array sizes differ", GSL_EBADLEN);
gsl_fit_wmul(Double_array_val(x), 1,
Double_array_val(w), 1,
Double_array_val(y), 1, N,
&c1, &cov11, &sumsq);
}
r=alloc_small(3 * Double_wosize, Double_array_tag);
Store_double_field(r, 0, c1);
Store_double_field(r, 1, cov11);
Store_double_field(r, 2, sumsq);
return r;
}
value copy_two_doubles(double d0, double d1)
{
value res = caml_alloc_small(2 * Double_wosize, Double_array_tag);
Store_double_field(res, 0, d0);
Store_double_field(res, 1, d1);
return res;
}
CAMLprim value caml_copy_complex(double complex c) {
CAMLparam0();
CAMLlocal1(v);
v = caml_alloc(2, 0);
Store_double_field(v, 0, creal(c));
Store_double_field(v, 1, cimag(c));
CAMLreturn(v);
}
value
ml_cairo_point (double x, double y)
{
value p;
p = caml_alloc_small (2 * Double_wosize, Double_array_tag);
Store_double_field (p, 0, x);
Store_double_field (p, 1, y);
return p;
}
CAMLprim value ml_gsl_monte_vegas_get_info(value state)
{
value r;
gsl_monte_vegas_state *s = GSLVEGASSTATE_VAL(state);
r=alloc_small(3 * Double_wosize, Double_array_tag);
Store_double_field(r, 0, s->result);
Store_double_field(r, 1, s->sigma);
Store_double_field(r, 2, s->chisq);
return r;
}
CAMLprim value math_modf(value x) {
CAMLparam1(x);
CAMLlocal1(z);
double u, v;
u = modf(Double_val(x), &v);
z = caml_alloc(2, 0);
Store_double_field(z, 0, u);
Store_double_field(z, 1, v);
CAMLreturn(z);
}
value
Val_cairo_font_extents (cairo_font_extents_t * s)
{
value v = caml_alloc_small (5 * Double_wosize, Double_array_tag);
Store_double_field (v, 0, s->ascent);
Store_double_field (v, 1, s->descent);
Store_double_field (v, 2, s->height);
Store_double_field (v, 3, s->max_x_advance);
Store_double_field (v, 4, s->max_y_advance);
return v;
}
CAMLprim value unix_times(value unit)
{
#ifdef HAS_GETRUSAGE
value res;
struct rusage ru;
res = alloc_small(4 * Double_wosize, Double_array_tag);
getrusage (RUSAGE_SELF, &ru);
Store_double_field (res, 0, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
Store_double_field (res, 1, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
getrusage (RUSAGE_CHILDREN, &ru);
Store_double_field (res, 2, ru.ru_utime.tv_sec + ru.ru_utime.tv_usec / 1e6);
Store_double_field (res, 3, ru.ru_stime.tv_sec + ru.ru_stime.tv_usec / 1e6);
return res;
#else
value res;
struct tms buffer;
times(&buffer);
res = alloc_small(4 * Double_wosize, Double_array_tag);
Store_double_field(res, 0, (double) buffer.tms_utime / CLK_TCK);
Store_double_field(res, 1, (double) buffer.tms_stime / CLK_TCK);
Store_double_field(res, 2, (double) buffer.tms_cutime / CLK_TCK);
Store_double_field(res, 3, (double) buffer.tms_cstime / CLK_TCK);
return res;
#endif
}
CAMLprim value caml_make_array(value init)
{
CAMLparam1 (init);
mlsize_t wsize, size, i;
CAMLlocal2 (v, res);
size = Wosize_val(init);
if (size == 0) {
CAMLreturn (init);
} else {
v = Field(init, 0);
if (Is_long(v)
|| ! Is_in_value_area(v)
|| Tag_val(v) != Double_tag) {
CAMLreturn (init);
} else {
Assert(size < Max_young_wosize);
wsize = size * Double_wosize;
res = caml_alloc_small(wsize, Double_array_tag);
for (i = 0; i < size; i++) {
Store_double_field(res, i, Double_val(Field(init, i)));
}
CAMLreturn (res);
}
}
}
CAMLprim value caml_array_set_float(value array, value index, value newval)
{
intnat idx = Long_val(index);
if (idx < 0 || idx >= Wosize_val(array) / Double_wosize)
caml_array_bound_error();
Store_double_field(array, idx, Double_val(newval));
return Val_unit;
}
value unix_times(value unit) {
value res;
FILETIME creation, exit, stime, utime;
if (!(GetProcessTimes(GetCurrentProcess(), &creation, &exit, &stime,
&utime))) {
win32_maperr(GetLastError());
uerror("times", Nothing);
}
res = alloc_small(4 * Double_wosize, Double_array_tag);
Store_double_field(res, 0, to_sec(utime));
Store_double_field(res, 1, to_sec(stime));
Store_double_field(res, 2, 0);
Store_double_field(res, 3, 0);
return res;
}
value ml_gtk_curve_get_vector (value curve, value vlen)
{
int i, len = Int_val(vlen);
gfloat* vect = g_malloc(len * sizeof(gfloat));
value ret;
gtk_curve_get_vector(GtkCurve_val(curve), len, vect);
ret = caml_alloc(len*Double_wosize, Double_array_tag);
for (i = 0; i < len; i++)
Store_double_field(ret, i, vect[i]);
g_free(vect);
return ret;
}
CAMLprim value ml_gsl_poly_complex_solve_quadratic(value a, value b, value c)
{
gsl_complex z0, z1;
gsl_poly_complex_solve_quadratic(Double_val(a), Double_val(b),
Double_val(c), &z0, &z1);
{
CAMLparam0();
CAMLlocal3(r,rz0,rz1);
rz0 = alloc_small(2 * Double_wosize, Double_array_tag);
Store_double_field(rz0, 0, GSL_REAL(z0));
Store_double_field(rz0, 1, GSL_IMAG(z0));
rz1 = alloc_small(2 * Double_wosize, Double_array_tag);
Store_double_field(rz1, 0, GSL_REAL(z1));
Store_double_field(rz1, 1, GSL_IMAG(z1));
r = alloc_small(2, 0);
Field(r,0) = rz0 ;
Field(r,1) = rz1 ;
CAMLreturn(r);
}
}
value ocaml_spectrum (value float_array)
{
float spectre[512];
spectreSong(spectre);
for (int i = 0; i < 512; i++)
{
Store_double_field(float_array, i, spectre[i]);
}
return Val_unit;
}
CAMLprim value caml_create_array(value size, value inc)
{
CAMLparam2(size, inc);
CAMLlocal1(ret);
double d, step;
int i;
ret = caml_alloc(Int_val(size), Double_array_tag);
d = 0.0;
step = Double_val(inc);
for(i=0; i<Int_val(size); ++i)
Store_double_field(ret, i, d + i*step);
CAMLreturn(ret);
}
// Get grid values from a GRIB field
value ml_get_data( value ml_field ) {
CAMLparam1( ml_field );
CAMLlocal1( ml_data );
int i;
gribfield *field;
field = Gribfield_val( ml_field );
// Allocate an OCaml array and copy the data over
ml_data = caml_alloc( field->ndpts * Double_wosize, Double_array_tag );
for ( i = 0; i < field->ndpts; i++ ) {
Store_double_field( ml_data, i, field->fld[i] );
}
// Return the OCaml-formatted data copy
CAMLreturn( ml_data );
}
value
Val_cairo_text_extents (cairo_text_extents_t * s)
{
value v = caml_alloc_small (6 * Double_wosize, Double_array_tag);
Store_double_field (v, 0, s->x_bearing);
Store_double_field (v, 1, s->y_bearing);
Store_double_field (v, 2, s->width);
Store_double_field (v, 3, s->height);
Store_double_field (v, 4, s->x_advance);
Store_double_field (v, 5, s->y_advance);
return v;
}
value
create_float_array(value len,value init){
CAMLparam1(len);
CAMLlocal1(arr);
int i=0;
int l = Int_val(len);
double tmp = Double_val(init);
printf("%d\n",l);
printf("%g\n",tmp);
arr = caml_alloc( l * Double_wosize,Double_array_tag);
for(; i<l ;++i){
Store_double_field(arr,i,tmp);
// unlike Store_file, we here accept double instead of value
}
CAMLreturn(arr);
}
value mlbox_value(int atype, struct value_t *v) {
value int_block = caml_alloc(1, 0);
value bool_block = caml_alloc(1, 1);
value string_block = caml_alloc(1, 2);
value array_block = caml_alloc(1, 3);
value dbl_block = caml_alloc(1, 4);
value char_block = caml_alloc(1, 5);
value dbl_value = caml_alloc(1, Double_tag);
value array_value = 0;
if (atype == 3)
array_value = caml_alloc(v->array_len, 0);
switch(atype) {
case 0:
Store_field(int_block, 0, Val_long(v->int_val));
return int_block;
case 1:
Store_field(bool_block, 0, Val_int(!!v->bool_val));
return bool_block;
case 2:
Store_field(string_block, 0, caml_copy_string(v->string_val));
return string_block;
case 3:
for (int i = 0; i < v->array_len; i++) {
struct value_t *el = (v->array_val)[i];
value v = mlbox_value(v_to_atype(el), el);
Store_field(array_value, i, v);
}
Store_field(array_block, 0, array_value);
return array_block;
case 4:
Store_double_field(dbl_value, 0, v->dbl_val);
Store_field(dbl_block, 0, dbl_value);
return dbl_block;
case 5:
Store_field(char_block, 0, Val_int(v->char_val));
return char_block;
case 6:
return Val_int(0);
default:
printf("Don't know how to box type: %d", atype);
exit(1);
}
}
CAMLprim value caml_make_vect(value len, value init)
{
CAMLparam2 (len, init);
CAMLlocal1 (res);
mlsize_t size, wsize, i;
double d;
size = Long_val(len);
if (size == 0) {
res = Atom(0);
}
else if (Is_block(init)
&& Is_in_value_area(init)
&& Tag_val(init) == Double_tag) {
d = Double_val(init);
wsize = size * Double_wosize;
if (wsize > Max_wosize) caml_invalid_argument("Array.make");
res = caml_alloc(wsize, Double_array_tag);
for (i = 0; i < size; i++) {
Store_double_field(res, i, d);
}
} else {
if (size > Max_wosize) caml_invalid_argument("Array.make");
if (size < Max_young_wosize) {
res = caml_alloc_small(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
}
else if (Is_block(init) && Is_young(init)) {
caml_minor_collection();
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) Field(res, i) = init;
res = caml_check_urgent_gc (res);
}
else {
res = caml_alloc_shr(size, 0);
for (i = 0; i < size; i++) caml_initialize(&Field(res, i), init);
res = caml_check_urgent_gc (res);
}
}
CAMLreturn (res);
}
// Same as Faad.decode (Faad.Mp4.read_sample) but more efficient. Share code?
CAMLprim value ocaml_faad_mp4_decode(value m, value track, value sample, value dh)
{
CAMLparam4(m, track, sample, dh);
CAMLlocal1(outbuf);
mp4_t *mp = Mp4_val(m);
int t = Int_val(track);
int s = Int_val(sample);
NeAACDecHandle dec = Dec_val(dh);
NeAACDecFrameInfo frameInfo;
unsigned char *inbuf = NULL;
unsigned int inbuflen = 0;
float *data;
int c, i, ret;
caml_enter_blocking_section();
ret = mp4ff_read_sample(mp->ff, t, s, &inbuf, &inbuflen);
caml_leave_blocking_section();
check_err(ret);
caml_enter_blocking_section();
data = NeAACDecDecode(dec, &frameInfo, inbuf, inbuflen);
caml_leave_blocking_section();
free(inbuf);
if (!data)
caml_raise_constant(*caml_named_value("ocaml_faad_exn_failed"));
if (frameInfo.error != 0)
caml_raise_with_arg(*caml_named_value("ocaml_faad_exn_error"), Val_int(frameInfo.error));
outbuf = caml_alloc_tuple(frameInfo.channels);
for(c = 0; c < frameInfo.channels; c++)
Store_field(outbuf, c, caml_alloc(frameInfo.samples / frameInfo.channels * Double_wosize, Double_array_tag));
for(i = 0; i < frameInfo.samples; i++)
Store_double_field(Field(outbuf, i % frameInfo.channels), i / frameInfo.channels, data[i]);
CAMLreturn(outbuf);
}
CAMLprim value ocaml_faad_decode(value _dh, value _inbuf, value _inbufofs, value _inbuflen)
{
CAMLparam2(_dh,_inbuf);
CAMLlocal2(ans, outbuf);
NeAACDecFrameInfo frameInfo;
int inbufofs = Int_val(_inbufofs);
int inbuflen = Int_val(_inbuflen);
unsigned char *inbuf = malloc(inbuflen);
float *data;
int c, i;
memcpy(inbuf, String_val(_inbuf)+inbufofs, inbuflen);
NeAACDecHandle dh = Dec_val(_dh);
caml_enter_blocking_section();
data = NeAACDecDecode(dh, &frameInfo, inbuf, inbuflen);
caml_leave_blocking_section();
free(inbuf);
if (frameInfo.error > 0)
caml_raise_with_arg(*caml_named_value("ocaml_faad_exn_error"), Val_int(frameInfo.error));
if (!data)
caml_raise_constant(*caml_named_value("ocaml_faad_exn_failed"));
outbuf = caml_alloc_tuple(frameInfo.channels);
for(c = 0; c < frameInfo.channels; c++)
Store_field(outbuf, c, caml_alloc(frameInfo.samples / frameInfo.channels * Double_wosize, Double_array_tag));
for(i = 0; i < frameInfo.samples; i++)
Store_double_field(Field(outbuf, i % frameInfo.channels), i / frameInfo.channels, data[i]);
ans = caml_alloc_tuple(2);
Store_field(ans, 0, Val_int(frameInfo.bytesconsumed));
Store_field(ans, 1, outbuf);
CAMLreturn(ans);
}
CAMLprim value caml_update_dummy(value dummy, value newval)
{
mlsize_t size, i;
tag_t tag;
size = Wosize_val(newval);
tag = Tag_val (newval);
Assert (size == Wosize_val(dummy));
Assert (tag < No_scan_tag || tag == Double_array_tag);
Tag_val(dummy) = tag;
if (tag == Double_array_tag){
size = Wosize_val (newval) / Double_wosize;
for (i = 0; i < size; i++){
Store_double_field (dummy, i, Double_field (newval, i));
}
}else{
for (i = 0; i < size; i++){
caml_modify (&Field(dummy, i), Field(newval, i));
}
}
return Val_unit;
}
// -- Ocaml wrapper function returning an array of n double prec
// -- random numbers in the open interval (0, 1).
CAMLprim value wrap_rng_get_array(value vn)
{
CAMLparam1(vn);
CAMLlocal1(ar);
int j;
// -- check constrains
const int n = Int_val(vn);
if ( n < 0 )
caml_invalid_argument("Rng.get_array: n must be positive or 0");
// -- OCaml does not allow for heap allocated zero-sized arrays;
// -- return atom instead
if (n == 0)
CAMLreturn(Atom(0));
// -- allocate block and initialize
ar = caml_alloc(n * NDBL, Double_array_tag);
for (j = 0; j < n; j++)
Store_double_field(ar, j, fac * rng_next());
CAMLreturn(ar);
}
CAMLprim value caml_array_unsafe_set_float(value array,value index,value newval)
{
Store_double_field(array, Long_val(index), Double_val(newval));
return Val_unit;
}
