Algorithm-Heapify-XS
view release on metacpan or search on metacpan
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#ifndef NOT_REACHED
# define NOT_REACHED assert(0)
#endif
#define iParent(i) (((i)-1) / 2)
#define iLeftChild(i) ((2*(i)) + 1)
#define iRightChild(i) ((2*(i)) + 2)
#define HAVE_PERL_SV_NUMCMP \
(PERL_REVISION > 5 || (PERL_REVISION == 5 && (PERL_VERSION > 43 || (PERL_VERSION == 43 && PERL_SUBVERSION >= 8))))
#define OUT_OF_ORDER(a,child,parent,is_min) \
( ( (is_min & 2) \
? my_sv_string_gt(aTHX_ (a)[(child)], (a)[(parent)]) \
: my_sv_num_gt(aTHX_ (a)[(child)], (a)[(parent)])) \
? !(is_min & 1) : (is_min & 1) )
#define FORCE_SCALAR(fakeop) \
STMT_START { \
SAVEOP(); \
Copy(PL_op, &fakeop, 1, OP); \
fakeop.op_flags = OPf_WANT_SCALAR; \
PL_op = &fakeop; \
} STMT_END
#ifdef Perl_do_ncmp
#define my_Perl_do_ncmp Perl_do_ncmp
#else
/* compare left and right SVs. Returns:
* -1: <
* 0: ==
* 1: >
* 2: left or right was a NaN
*/
I32
my_Perl_do_ncmp(pTHX_ SV* const left, SV * const right)
{
PERL_ARGS_ASSERT_DO_NCMP;
/* Fortunately it seems NaN isn't IOK */
if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) {
if (!SvIsUV(left)) {
const IV leftiv = SvIVX(left);
if (!SvIsUV(right)) {
/* ## IV <=> IV ## */
const IV rightiv = SvIVX(right);
return (leftiv > rightiv) - (leftiv < rightiv);
}
/* ## IV <=> UV ## */
if (leftiv < 0)
/* As (b) is a UV, it's >=0, so it must be < */
return -1;
{
const UV rightuv = SvUVX(right);
return ((UV)leftiv > rightuv) - ((UV)leftiv < rightuv);
}
}
if (SvIsUV(right)) {
/* ## UV <=> UV ## */
const UV leftuv = SvUVX(left);
const UV rightuv = SvUVX(right);
return (leftuv > rightuv) - (leftuv < rightuv);
}
/* ## UV <=> IV ## */
{
const IV rightiv = SvIVX(right);
if (rightiv < 0)
/* As (a) is a UV, it's >=0, so it cannot be < */
return 1;
{
const UV leftuv = SvUVX(left);
return (leftuv > (UV)rightiv) - (leftuv < (UV)rightiv);
}
}
tmpsv = amagic_call(left, right, sgt_amg, 0);
if (tmpsv) {
return SvTRUE(tmpsv);
}
}
if (my_has_real_overload_method(aTHX_ left, "(cmp", 4)
|| my_has_real_overload_method(aTHX_ right, "(cmp", 4)) {
tmpsv = amagic_call(left, right, scmp_amg, 0);
if (tmpsv) {
return SvIV(tmpsv) > 0;
}
}
}
return Perl_sv_cmp(aTHX_ left, right) > 0;
}
static bool
my_sv_num_gt(pTHX_ SV *left, SV *right)
{
#if HAVE_PERL_SV_NUMCMP
return sv_numcmp(left, right) > 0;
#else
if (SvAMAGIC(left) || SvAMAGIC(right)) {
SV *tmpsv = NULL;
if (my_has_real_overload_method(aTHX_ left, "(>", 2)
|| my_has_real_overload_method(aTHX_ right, "(>", 2)) {
tmpsv = amagic_call(left, right, gt_amg, 0);
if (tmpsv) {
return SvTRUE(tmpsv);
}
}
if (my_has_real_overload_method(aTHX_ left, "(<=>", 4)
|| my_has_real_overload_method(aTHX_ right, "(<=>", 4)) {
tmpsv = amagic_call(left, right, ncmp_amg, 0);
if (tmpsv) {
return SvIV(tmpsv) > 0;
}
}
}
left = my_sv_2num(aTHX_ left);
right = my_sv_2num(aTHX_ right);
return my_Perl_do_ncmp(aTHX_ left, right) > 0;
#endif
}
I32 sift_up(pTHX_ SV **a, ssize_t start, ssize_t end, I32 is_min) {
/*start represents the limit of how far up the heap to sift.
end is the node to sift up. */
ssize_t child = end;
I32 swapped = 0;
SvGETMAGIC(a[child]);
while (child > start) {
ssize_t parent = iParent(child);
SvGETMAGIC(a[parent]);
if ( OUT_OF_ORDER(a,child,parent,is_min) ) {
SV *swap_tmp= a[parent];
a[parent]= a[child];
a[child]= swap_tmp;
child = parent; /* repeat to continue sifting up the parent now */
swapped++;
}
else {
return swapped;
}
}
return swapped;
}
/*Repair the heap whose root element is at index 'start', assuming the heaps rooted at its children are valid*/
I32 sift_down(pTHX_ SV **a, ssize_t start, ssize_t end, I32 is_min) {
ssize_t root = start;
I32 swapped = 0;
while (iLeftChild(root) <= end) { /* While the root has at least one child */
ssize_t child = iLeftChild(root); /* Left child of root */
ssize_t swap = root; /* Keeps track of child to swap with */
/* if the root is smaller than the left child
* then the swap is with the left child */
if ( OUT_OF_ORDER(a,child,swap,is_min) ) {
swap = child;
}
/* if there is a right child and the right child is larger than the root or the left child
* then the swap is with the right child */
if (child+1 <= end) {
if ( OUT_OF_ORDER(a,child+1,swap,is_min) ) {
swap = child + 1;
}
}
/* check if we need to swap or if this tree is in heap-order */
if (swap == root) {
/* The root is larger than both children, and as we assume the heaps rooted at the children are valid
* then we know we can stop. */
return swapped;
} else {
/* swap the root with the largest child */
SV *tmp= a[root];
a[root]= a[swap];
a[swap]= tmp;
/* continue sifting down the child by setting the root to the chosen child
* effectively we sink down the tree towards the leafs */
root = swap;
swapped++;
}
}
return swapped;
}
/* this is O(N log N) */
void heapify_with_sift_up(pTHX_ SV **a, ssize_t count, I32 is_min) {
ssize_t end = 1; /* end is assigned the index of the first (left) child of the root */
while (end < count) {
/*sift up the node at index end to the proper place such that all nodes above
the end index are in heap order */
(void)sift_up(aTHX_ a, 0, end, is_min);
end++;
}
/* after sifting up the last node all nodes are in heap order */
}
/* this is O(N) */
void heapify_with_sift_down(pTHX_ SV **a, ssize_t count, I32 is_min) {
/*start is assigned the index in 'a' of the last parent node
the last element in a 0-based array is at index count-1; find the parent of that element */
ssize_t start = iParent(count-1);
while (start >= 0) {
/* sift down the node at index 'start' to the proper place such that all nodes below
the start index are in heap order */
(void)sift_down(aTHX_ a, start, count - 1, is_min);
/* go to the next parent node */
start--;
}
/* after sifting down the root all nodes/elements are in heap order */
}
MODULE = Algorithm::Heapify::XS PACKAGE = Algorithm::Heapify::XS
void
max_heapify(av)
AV *av
PROTOTYPE: \@
ALIAS:
max_heapify = 0
min_heapify = 1
maxstr_heapify = 2
minstr_heapify = 3
PREINIT:
OP fakeop;
I32 count;
PPCODE:
FORCE_SCALAR(fakeop);
count = av_top_index(av)+1;
if ( count ) {
heapify_with_sift_down(aTHX_ AvARRAY(av),count,ix);
ST(0)= AvARRAY(av)[0];
XSRETURN(1);
}
else {
XSRETURN(0);
}
void
max_heap_shift(av)
AV *av
PROTOTYPE: \@
ALIAS:
max_heap_shift = 0
min_heap_shift = 1
maxstr_heap_shift = 2
minstr_heap_shift = 3
PREINIT:
OP fakeop;
I32 top;
I32 count;
PPCODE:
FORCE_SCALAR(fakeop);
top= av_top_index(av);
count= top+1;
if (count) {
SV *tmp= AvARRAY(av)[0];
AvARRAY(av)[0]= AvARRAY(av)[top];
AvARRAY(av)[top]= tmp;
ST(0)= av_pop(av);
if (count > 2)
sift_down(aTHX_ AvARRAY(av),0,top-1,ix);
XSRETURN(1);
}
else {
XSRETURN(0);
( run in 0.412 second using v1.01-cache-2.11-cpan-804bf51f3ce )