#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)

#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

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);

}

}

NOT_REACHED; /* NOTREACHED */

}

{

NV const lnv = SvNV_nomg(left);

NV const rnv = SvNV_nomg(right);

#if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)

if (Perl_isnan(lnv) || Perl_isnan(rnv)) {

return 2;

}

return (lnv > rnv) - (lnv < rnv);

if (lnv < rnv)

return -1;

if (lnv > rnv)

return 1;

if (lnv == rnv)

return 0;

return 2;

}

}

static bool

my_has_real_overload_method(pTHX_ SV *sv, const char *name, STRLEN len)

{

GV *gv;

CV *cv;

GV *cvgv;

HV *stash;

const HEK *gvhek;

const HEK *stashek;

if (!SvAMAGIC(sv) || !SvROK(sv)) {

return FALSE;

}

stash = SvSTASH(SvRV(sv));

if (!stash) {

return FALSE;

}

gv = gv_fetchmeth_pvn(stash, name, len, -1, 0);

if (!gv) {

return FALSE;

}

cv = GvCV(gv);

if (!cv) {

return FALSE;

}

cvgv = CvGV(cv);

if (!cvgv) {

return TRUE;

}

gvhek = GvNAME_HEK(cvgv);

stashek = HvNAME_HEK(GvSTASH(cvgv));

if (!gvhek || !stashek) {

return TRUE;

}

return !(stashek

&& memEQs(HEK_KEY(gvhek), HEK_LEN(gvhek), "nil")

&& memEQs(HEK_KEY(stashek), HEK_LEN(stashek), "overload"));

}

static SV *

my_sv_2num(pTHX_ SV *sv)

{

if (!SvROK(sv)) {

return sv;

}

if (SvAMAGIC(sv)) {

SV *tmpsv = AMG_CALLunary(sv, numer_amg);

if (tmpsv && (!SvROK(tmpsv) || SvRV(tmpsv) != SvRV(sv))) {

return my_sv_2num(aTHX_ tmpsv);

}

}

return sv_2mortal(newSVuv(PTR2UV(SvRV(sv))));

}

static bool

my_sv_string_gt(pTHX_ SV *left, SV *right)

{

SV *tmpsv = NULL;

if (SvAMAGIC(left) || SvAMAGIC(right)) {

if (my_has_real_overload_method(aTHX_ left, "(gt", 3)

|| my_has_real_overload_method(aTHX_ right, "(gt", 3)) {

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;

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;

}

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.

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;

}

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

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

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

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

root = swap;

swapped++;

}

}

return swapped;

}

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

(void)sift_up(aTHX_ a, 0, end, is_min);

end++;

}

/* after sifting up the last node all nodes are in heap order */

}

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

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

(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

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);

}

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);

}

max_heap_push(av,sv)

AV *av

SV *sv

PROTOTYPE: \@$

ALIAS:

max_heap_push = 0

min_heap_push = 1

maxstr_heap_push = 2

minstr_heap_push = 3

PREINIT:

OP fakeop;

I32 top;

I32 count;

PPCODE:

FORCE_SCALAR(fakeop);

av_push(av,newSVsv(sv));

top= av_top_index(av);

count= top+1;

sift_up(aTHX_ AvARRAY(av),0,top,ix);

ST(0)= AvARRAY(av)[0];

XSRETURN(1);

max_heap_adjust_top(av)

AV *av

PROTOTYPE: \@

ALIAS:

max_heap_adjust_top = 0

min_heap_adjust_top = 1

maxstr_heap_adjust_top = 2

minstr_heap_adjust_top = 3

PREINIT:

OP fakeop;

I32 top;

I32 count;

PPCODE:

FORCE_SCALAR(fakeop);

top= av_top_index(av);

count= top+1;

if ( count ) {

(void)sift_down(aTHX_ AvARRAY(av),0,top,ix);

ST(0)= AvARRAY(av)[0];

XSRETURN(1);

} else {

XSRETURN(0);

}

max_heap_adjust_item(av,idx=0)

AV *av

I32 idx;

PROTOTYPE: \@;$

ALIAS:

max_heap_adjust_item = 0

min_heap_adjust_item = 1

maxstr_heap_adjust_item = 2

minstr_heap_adjust_item = 3

PREINIT:

OP fakeop;

I32 top;

I32 count;

PPCODE:

FORCE_SCALAR(fakeop);

top= av_top_index(av);

count= top+1;

if ( idx < count ) {

if (!idx || !sift_up(aTHX_ AvARRAY(av),0,idx,ix))

(void)sift_down(aTHX_ AvARRAY(av),idx,top,ix);

ST(0)= AvARRAY(av)[0];

XSRETURN(1);

} else {

XSRETURN(0);

}