CAMLprim value caml_mcl(value inflation, value arr)
{
CAMLparam2(inflation, arr);
int i, cols = Wosize_val(arr);
mclv *domc = mclvCanonical(NULL, cols, 1.0);
mclv *domr = mclvCanonical(NULL, cols, 1.0);
mclx *res_mat, *mx = mclxAllocZero(domc, domr);
mclAlgParam *mlp;
value res;
for (i = 0; i < cols; ++i) {
value col = Field(arr, i);
int j, rows = Wosize_val(col);
mclv *col_vec = &mx->cols[i];
if (!cols)
continue;
mclvResize(col_vec, rows);
for (j = 0; j < rows; ++j) {
value t = Field(col, j);
col_vec->ivps[j].idx = Int_val(Field(t, 0));
col_vec->ivps[j].val = Double_val(Field(t, 1));
}
}
mclAlgInterface(&mlp, NULL, 0, NULL, mx, 0);
/* Optionally set inflation */
if (inflation != Val_none) {
mlp->mpp->mainInflation = Double_val(Some_val(inflation));
}
mclAlgorithm(mlp);
res_mat = mlp->cl_result;
cols = res_mat->dom_cols->n_ivps;
res = caml_alloc(cols, 0);
for (i = 0; i < cols; ++i) {
mclv *col_vec = &res_mat->cols[i];
int j, rows = col_vec->n_ivps;
value row = caml_alloc(rows, 0);
for (j = 0; j < rows; ++j) {
Store_field(row, j, Val_int(col_vec->ivps[j].idx));
}
Store_field(res, i, row);
}
mclAlgParamFree(&mlp, TRUE);
CAMLreturn(res);
}
int main
( int argc
, const char* argv[]
)
{ const char* fn_input = argc > 1 ? argv[1] : ""
; mclAlgParam* mlp = NULL
; const char* me = "mcl"
; mcxstatus status = STATUS_OK
; srandom(mcxSeed(315))
; signal(SIGALRM, mclSigCatch)
; if (signal(SIGUSR1, mcxLogSig) == SIG_ERR)
mcxErr(me, "cannot catch SIGUSR1!")
; mcxLogLevel =
MCX_LOG_AGGR | MCX_LOG_MODULE | MCX_LOG_IO | MCX_LOG_GAUGE | MCX_LOG_WARN
; mclx_app_init(stderr)
; if (argc < 2)
{ mcxTell
( me
, "usage: mcl <-|file name> [options],"
" do 'mcl -h' or 'man mcl' for help"
)
; mcxExit(0)
; }
status
= mclAlgInterface
(&mlp, (char**) (argv+2), argc-2, fn_input, NULL, ALG_DO_IO)
; if (status == ALG_INIT_DONE)
return 0
; else if (status)
mcxDie(STATUS_FAIL, me, "no tango")
; if ((status = mclAlgorithm(mlp)) == STATUS_FAIL)
mcxDie(STATUS_FAIL, me, "failed")
; if (mlp->n_assimilated)
mcxLog(MCX_LOG_MODULE, me, "%lu nodes will assimilate", (ulong) mlp->n_assimilated)
; if (mlp->mx_start)
mcxLog(MCX_LOG_MODULE, me, "cached matrix with %lu columns", (ulong) N_COLS(mlp->mx_start))
; mclAlgParamFree(&mlp, TRUE)
; helpful_reminder()
; return STATUS_OK
; }
static mcxstatus get_interface
( mclAlgParam** mlpp
, const char* fn_input /* Use this as input or mx_input */
, const char* arg_shared
, const char* arg_extra
, mclx* mx_input /* Use this as input or fn_input */
, mcxbits CACHE
, mcxOnFail ON_FAIL
)
{ mcxTing* spec = mcxTingNew(arg_shared)
; int argc1 = 0
; char** argv1
; mcxstatus status
; mclAlgParam* mymlp = NULL
; mclAlgParam** mymlpp = mlpp ? mlpp : &mymlp
; if (arg_extra)
mcxTingPrintAfter(spec, " %s", arg_extra)
/* warning this clobbers spec->str */
; argv1 = mcxOptParseString(spec->str, &argc1, ' ')
; status
= mclAlgInterface
( mymlpp
, argv1
, argc1
, fn_input
, mx_input
, CACHE
)
; if (status && ON_FAIL == EXIT_ON_FAIL)
mcxExit(1)
; mcxFree(argv1)
; mcxTingFree(&spec)
/* fixfixfixmefixmefffixme: mclAlgInterface might use opt->val
* which points to somewhere in spec->str. Check.
*/
; if (!mlpp)
mclAlgParamFree(mymlpp, TRUE)
; return status
; }
static void tf_do_mcl
( mclx* mx
, double infl
, mcxbool add_transpose
)
{ mclx* mx2 = NULL, *mx3 = NULL, *cl = NULL
; mclAlgParam* mlp = NULL
; char* argv2[] = { NULL }
; mcxstatus s
; if (add_transpose)
{ mx2 = mclxCopy(mx)
; mclxAddTranspose(mx2, 0.0)
; }
s = mclAlgInterface
( &mlp
, argv2
, 0
, NULL
, add_transpose ? mx2 : mx
, ALG_CACHE_INPUT
)
; do
{ if (s)
{ mcxErr("tf-mcl", "unexpected failure")
; break
; }
mlp->mpp->mainInflation = infl
; if (mclAlgorithm(mlp) == STATUS_FAIL)
break
; if (!(cl = mclAlgParamRelease(mlp, mlp->cl_result)))
break
; mclAlgParamRelease(mlp, mlp->mx_input) /* now we own it again, either mx2 or mx */
; mx3 = mclxBlockUnion2(mx, cl)
; mclxTransplant(mx, &mx3) /* this frees mx3 */
; }
while (0)
; mclxFree(&cl)
; mclxFree(&mx2)
; mclAlgParamFree(&mlp, TRUE)
; }
