view release on metacpan or  search on metacpan

perl/Cluster.xs  view on Meta::CPAN

    node->left = left;

void
set_right (obj, right)
    SV* obj
    int right
    PREINIT:
    Node* node;
    CODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Node")) {
        croak("set_right should be applied to an Algorithm::Cluster::Node object");
    }
    node = INT2PTR(Node*,SvIV(SvRV(obj)));
    node->right = right;

void
set_distance (obj, distance)
    SV* obj
    double distance
    PREINIT:
    Node* node;
    CODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Node")) {
        croak("set_distance should be applied to an Algorithm::Cluster::Node object");
    }
    node = INT2PTR(Node*,SvIV(SvRV(obj)));
    node->distance = distance;

void DESTROY (obj)
    SV* obj
    PREINIT:
    I32* temp;
    Node* node;
    PPCODE:
    temp = PL_markstack_ptr++;
    node = INT2PTR(Node*, SvIV(SvRV(obj)));
    free(node);
    if (PL_markstack_ptr != temp) {
        /* truly void, because dXSARGS not invoked */
        PL_markstack_ptr = temp;
        XSRETURN_EMPTY;
        /* return empty stack */
    }  /* must have used dXSARGS; list context implied */
    return;  /* assume stack size is correct */


MODULE = Algorithm::Cluster PACKAGE = Algorithm::Cluster::Tree
PROTOTYPES: ENABLE

SV*
new (class, nodes)
    char* class
    SV* nodes

    PREINIT:
    Tree* tree;
    SV* obj;
    int i;
    int n;
    AV* array;
    int* flag;

    CODE:
    if(!SvROK(nodes) || SvTYPE(SvRV(nodes)) != SVt_PVAV) { 
        croak("Algorithm::Cluster::Tree::new expects an array of nodes\n");
    }
    array = (AV *) SvRV(nodes);
    n = (int) av_len(array) + 1;
    tree = malloc(sizeof(Tree));
    if (tree) {
        tree->n = n;
        tree->nodes = malloc(n*sizeof(Node));
    }
    if (! tree || !tree->nodes) {
        if (tree) free(tree);
        croak("Algorithm::Cluster::Tree::new memory error\n");
    }

    for (i = 0; i < n; i++) {
        Node* node;
        SV* node_ref = *(av_fetch(array, (I32) i, 0)); 
        if (!sv_isa(node_ref, "Algorithm::Cluster::Node")) break;
        node = INT2PTR(Node*,SvIV(SvRV(node_ref)));
        tree->nodes[i].left = node->left;
        tree->nodes[i].right = node->right;
        tree->nodes[i].distance = node->distance;
    }

    if (i < n) {
        /* break encountered */
        free(tree->nodes);
        free(tree);
        croak("Algorithm::Cluster::Tree::new expects an array of nodes\n");
    }

    flag = malloc((2*n+1)*sizeof(int));
    if(flag) {
         int j;
        for (i = 0; i < 2*n+1; i++) flag[i] = 0;
        for (i = 0; i < n; i++) {
            j = tree->nodes[i].left;
            if (j < 0) {
                j = -j-1;
                if (j>=i) break;
            }
            else j+=n;
            if (flag[j]) break;
            flag[j] = 1;
            j = tree->nodes[i].right;
            if (j < 0) {
                j = -j-1;
                if (j>=i) break;
            }
            else j+=n;
            if (flag[j]) break;
            flag[j] = 1;
        }
        free(flag);
    }

    if (!flag || i < n) {
        /* break encountered */
        free(tree->nodes);
        free(tree);
        croak("the array of nodes passed to Algorithm::Cluster::Tree::new does not represent a valid tree\n");
    }

    RETVAL = newSViv(0);
    obj = newSVrv(RETVAL, class);
    sv_setiv(obj, PTR2IV(tree));
    SvREADONLY_on(obj);

    OUTPUT:
    RETVAL

int
length (obj)
    SV* obj
    CODE:
    RETVAL = (INT2PTR(Tree*,SvIV(SvRV(obj))))->n;
    OUTPUT:
    RETVAL


SV *
get (obj, index)
    SV* obj
    int index
    PREINIT:
    Tree* tree;
    Node* node;
    SV* scalar;
    CODE:
    tree = INT2PTR(Tree*,SvIV(SvRV(obj)));
    if (index < 0 || index >= tree->n) {
        croak("Index out of bounds in Algorithm::Cluster::Tree::get\n");
    }
    RETVAL = newSViv(0);
    scalar = newSVrv(RETVAL, "Algorithm::Cluster::Node");
    node = malloc(sizeof(Node));
    if (!node) {
        croak("Memory allocation failure in Algorithm::Cluster::Tree::get\n");
    }
    node->left = tree->nodes[index].left;
    node->right = tree->nodes[index].right;
    node->distance = tree->nodes[index].distance;
    sv_setiv(scalar, PTR2IV(node));
    SvREADONLY_on(scalar);
    OUTPUT:
    RETVAL

void
scale(obj)
    SV* obj
    PREINIT:
    int i;
    int n;
    Tree* tree;
    Node* nodes;
    double maximum;
    CODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Tree")) {
        croak("scale can only be applied to an Algorithm::Cluster::Tree object");
    }
    tree = INT2PTR(Tree*,SvIV(SvRV(obj)));
    n = tree->n;
    nodes = tree->nodes;
    maximum = DBL_MIN;
    for (i = 0; i < n; i++) {
        double distance = nodes[i].distance;
        if (distance > maximum) maximum = distance;
    }
    if (maximum!=0.0) {
        for (i = 0; i < n; i++) nodes[i].distance /= maximum;
    }


void
sort(obj, order = NULL)
    SV* obj
    SV* order 

    PREINIT:
    int i;
    int n;
    Tree* tree;
    int* indices;
    double* values = NULL;
    int ok;

    PPCODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Tree")) {
        croak("sort can only be applied to an Algorithm::Cluster::Tree object");
    }
    tree = INT2PTR(Tree*,SvIV(SvRV(obj)));
    if (order) {
        if(!SvROK(order) || SvTYPE(SvRV(order)) != SVt_PVAV) { 
            croak("Algorithm::Cluster::Tree::sort expects an order array\n");
        }
        values = malloc_row_perl2c_dbl(aTHX_ order, &n);
        if (!values) {
            croak("Algorithm::Cluster::Tree::sort memory error\n");
        }
        if (n != tree->n + 1) {
            free(values);
            croak("sort: size of order array is inconsistent with tree size\n");
        }
    }
    else {
        n = tree->n + 1;
    }
    indices = malloc(n*sizeof(int));
    if (!indices) {
        if(values) free(values);
        croak("sort: insufficient memory");
    }
    /* --------------------------------------------------------------- */
    ok = sorttree(tree->n, tree->nodes, values, indices);
    if(values) free(values);
    /* -- Check for errors flagged by the C routine ------------------ */
    if (!ok) {
        free(indices);
        croak("sort: Error in the sorttree routine");
    }
    for(i=0; i<n; i++) XPUSHs(sv_2mortal(newSVnv(indices[i])));
    free(indices);

void
cut(obj, nclusters=0)
    SV* obj
    int nclusters
    PREINIT:
    int ok;
    int i;
    int n;
    Tree* tree;
    int* clusterid;
    PPCODE:
    if (!sv_isa(obj, "Algorithm::Cluster::Tree")) {
        croak("cut can only be applied to an Algorithm::Cluster::Tree object\n");
    }
    tree = INT2PTR(Tree*,SvIV(SvRV(obj)));
    n = tree->n + 1;
    if (nclusters < 0) {
        croak("cut: Requested number of clusters should be positive\n");
    }
    if (nclusters > n) {
        croak("cut: More clusters requested than items available\n");
    }
    if (nclusters == 0) {
        nclusters = n;
    }
    clusterid = malloc(n*sizeof(int));
    if (!clusterid) {
        croak("cut: Insufficient memory\n");
    }
    ok = cuttree(n, tree->nodes, nclusters, clusterid);
    if (!ok) {
        free(clusterid);
        croak("cut: Error in the cuttree routine\n");
    }
    for(i=0; i<n; i++) XPUSHs(sv_2mortal(newSVnv(clusterid[i])));
    free(clusterid);


void DESTROY (obj)
    SV* obj
    PREINIT:
    I32* temp;
    Tree* tree;
    PPCODE:
    temp = PL_markstack_ptr++;
    tree = INT2PTR(Tree*, SvIV(SvRV(obj)));
    free(tree->nodes);
    free(tree);
    if (PL_markstack_ptr != temp) {
        /* truly void, because dXSARGS not invoked */
        PL_markstack_ptr = temp;
        XSRETURN_EMPTY;
        /* return empty stack */