/* This file is part of the Sub::Nary Perl module.
 * See http://search.cpan.org/dist/Sub::Nary/ */

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#ifndef Newx
# define Newx(v, n, c) New(0, v, n, c)
#endif

#ifndef mPUSHi
# define mPUSHi(I) PUSHs(sv_2mortal(newSViv(I)))
#endif /* !mPUSHi */

typedef struct {
 UV k;
 NV v;
} sn_combcache;

STATIC void sn_store(pTHX_ HV *tb, const char *key, I32 klen, SV *val, U32 hash) {
#define sn_store(T, K, KL, V, H) sn_store(aTHX_ (T), (K), (KL), (V), (H))
 if (!hv_store(tb, key, klen, val, hash)) SvREFCNT_dec(val);
}

STATIC void sn_store_ent(pTHX_ HV *tb, SV *key, SV *val, U32 hash) {
#define sn_store_ent(T, K, V, H) sn_store_ent(aTHX_ (T), (K), (V), (H))
 if (!hv_store_ent(tb, key, val, hash)) SvREFCNT_dec(val);
}

STATIC U32 sn_hash_list = 0;
STATIC U32 sn_hash_exit = 0;
STATIC U32 sn_hash_die  = 0;

/* --- XS ------------------------------------------------------------------ */

MODULE = Sub::Nary            PACKAGE = Sub::Nary

PROTOTYPES: ENABLE

BOOT:
{
 PERL_HASH(sn_hash_list, "list", 4);
 PERL_HASH(sn_hash_exit, "exit", 4);
 PERL_HASH(sn_hash_die,  "die",  3);
}

void
tag(SV *op)
PROTOTYPE: $
CODE:
 ST(0) = sv_2mortal(newSVuv(SvUV(SvRV(op))));
 XSRETURN(1);

void
null(SV *op)
PROTOTYPE: $
PREINIT:
 OP *o;
CODE:
 o = INT2PTR(OP *, SvUV(SvRV(op)));
 ST(0) = sv_2mortal(newSVuv(o == NULL));
 XSRETURN(1);

void
zero(SV *sv)
PROTOTYPE: $
PREINIT:
 HV *hv;
 IV res;
CODE:
 if (!SvOK(sv))
  XSRETURN_IV(1);
 if (!SvROK(sv)) {
  res = SvNOK(sv) ? SvNV(sv) == 0.0 : SvUV(sv) == 0;
  XSRETURN_IV(res);
 }
 hv = (HV *) SvRV(sv);
 res = hv_iterinit(hv) == 1 && hv_exists(hv, "0", 1);
 XSRETURN_IV(res);

void
count(SV *sv)
PROTOTYPE: $
PREINIT:
 HV *hv;
 HE *key;
 NV c = 0;
CODE:
 if (!SvOK(sv))
  XSRETURN_IV(0);
 if (!SvROK(sv))
  XSRETURN_IV(1);
 hv = (HV *) SvRV(sv);
 hv_iterinit(hv);
 while (key = hv_iternext(hv)) {
  c += SvNV(HeVAL(key));
 }
 XSRETURN_NV(c);

void
normalize(SV *sv)
PROTOTYPE: $
PREINIT:
 HV *hv, *res;
 HE *key;
 NV c = 0;
CODE:
 if (!SvOK(sv))
  XSRETURN_UNDEF;
 res = newHV();
 if (!SvROK(sv)) {
  sn_store_ent(res, sv, newSVuv(1), 0);
 } else {
  hv = (HV *) SvRV(sv);
  if (!hv_iterinit(hv)) {
   sn_store(res, "0", 1, newSVuv(1), 0);
  } else {
   while (key = hv_iternext(hv))
    c += SvNV(HeVAL(key));
   hv_iterinit(hv);
   while (key = hv_iternext(hv)) {
    SV *val = newSVnv(SvNV(HeVAL(key)) / c);
    sn_store_ent(res, HeSVKEY_force(key), val, HeHASH(key));
   }
  }
 }
 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 XSRETURN(1);

void
scale(SV *csv, SV *sv)
PROTOTYPE: $;$
PREINIT:
 HV *hv, *res;
 HE *key;
 NV c = 1;
CODE:
 if (!SvOK(sv))
  XSRETURN_UNDEF;
 if (SvOK(csv))
  c = SvNV(csv);
 res = newHV();
 if (!SvROK(sv)) {
  sn_store_ent(res, sv, newSVnv(c), 0);
 } else {
  hv = (HV *) SvRV(sv);
  if (!hv_iterinit(hv)) {
   XSRETURN_UNDEF;
  } else {
   hv_iterinit(hv);
   while (key = hv_iternext(hv)) {
    SV *val = newSVnv(SvNV(HeVAL(key)) * c);
    sn_store_ent(res, HeSVKEY_force(key), val, HeHASH(key));
   }
  }
 }
 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 XSRETURN(1);

void
add(...)
PROTOTYPE: @
PREINIT:
 HV *res;
 SV *cur, *val;
 HE *key, *old;
 I32 i;
CODE:
 if (!items)
  XSRETURN_UNDEF;
 res = newHV();
 for (i = 0; i < items; ++i) {
  cur = ST(i);
  if (!SvOK(cur))
   continue;
  if (!SvROK(cur)) {
   NV v = 1;
   if ((old = hv_fetch_ent(res, cur, 1, 0)) && SvOK(val = HeVAL(old)))
    v += SvNV(val);
   sn_store_ent(res, cur, newSVnv(v), 0);
   continue;
  }
  cur = SvRV(cur);
  hv_iterinit((HV *) cur);
  while (key = hv_iternext((HV *) cur)) {
   SV *k = HeSVKEY_force(key);
   NV  v = SvNV(HeVAL(key));
   if ((old = hv_fetch_ent(res, k, 1, 0)) && SvOK(val = HeVAL(old)))
    v += SvNV(val);
   sn_store_ent(res, k, newSVnv(v), 0);
  }
 }
 if (!hv_iterinit(res)) {
  SvREFCNT_dec(res);
  XSRETURN_UNDEF;
 }
 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 XSRETURN(1);

void
cumulate(SV *sv, SV *nsv, SV *csv)
PROTOTYPE: $$$
PREINIT:
 HV *res;
 HE *key;
 NV c0, c, a;
 UV i, n;
CODE:
 if (!SvOK(sv))
  XSRETURN_UNDEF;
 n  = SvUV(nsv);
 c0 = SvNV(csv);
 if (!n) {
  ST(0) = sv_2mortal(newSVuv(0));
  XSRETURN(1);
 }
 if (!SvROK(sv) || !c0) {
  ST(0) = sv;
  XSRETURN(1);
 }
 sv = SvRV(sv);
 if (!hv_iterinit((HV *) sv))
  XSRETURN_UNDEF;
 if (c0 == 1 || (SvIOK(csv) && SvIV(csv) == 1)) {
  c = n;
 } else {
  c = 1;
  a = c0;
  for (; n > 0; n /= 2) {
   if (n % 2)
    c *= a;
   a *= a;
  }
  c = (1 - c) / (1 - c0);
 }
 res = newHV();
 while (key = hv_iternext((HV *) sv)) {
  SV *k   = HeSVKEY_force(key);
  SV *val = newSVnv(c * SvNV(HeVAL(key)));
  sn_store_ent(res, k, val, 0);
 }
 ST(0) = sv_2mortal(newRV_noinc((SV *) res));
 XSRETURN(1);

void
combine(...)
PROTOTYPE: @
PREINIT:
 HV *res[3];
 SV *val;
 SV *kexit, *klist, *kdie;
 SV *temp;
 HE *key, *old;
 I32 i;
 I32 n = 0, o;
 I32 j, n1, n2;
 NV pe = 0, pd = 0, pl = 0;
 sn_combcache *cache = NULL;
 I32 cachelen = 1;
CODE:
 if (!items)
  XSRETURN_UNDEF;
 res[0] = newHV();
 res[1] = NULL;
 res[2] = NULL;
 Newx(cache, 1, sn_combcache);
 n = 0;
 temp = sv_2mortal(newSViv(0));
 for (i = 0; i < items; ++i) {
  SV *cur = ST(i);
  NV pe1 = 0, pd1 = 0, pd2, pl1 = 0;
  if (!SvOK(cur))
   continue;
  if (!SvROK(cur)) {
   if (!res[2])
    res[2] = newHV();
   else
    hv_clear(res[2]);
   sn_store_ent(res[2], cur, newSVuv(1), 0);
   cur = (SV *) res[2];
  } else
   cur = SvRV(cur);
  o = 1 - n;
  if (!res[o])
   res[o] = newHV();
  else
   hv_clear(res[o]);
  kexit = hv_delete((HV *) cur, "exit", 4, 0);
  n1    = hv_iterinit((HV *) cur);
  if (kexit) {
   if (!n1) {
    pe = 1 - pd;
    pl = 0;
    n  = o;
    break;
   }
   pe1 = SvNV(kexit);
  }
  kdie  = hv_delete((HV *) cur, "die", 3, 0);
  if (kdie) {
   if (n1 == 1) {
    pd = 1 - pe;
    pl = 0;
    n  = o;
    break;
   }
   --n1;
   pd1 = SvNV(kdie);
  }
  klist = hv_delete((HV *) cur, "list", 4, 0);
  if (klist) {
   if (n1 == 1) {
    pl = 1 - (pe + pd);
    n  = o;
    break;
   }
   pl1 = SvNV(klist);
  }
  pl  = pl1 * (1 - (pd + pe)) + pl * (1 - (pd1 + pe1)) - pl * pl1;
  pd2 = pd1 * (1 - pe)        + pd                     - pd * pd1;
  pe  = pe1 * (1 - pd)        + pe                     - pe * pe1;
  pd  = pd2;
  n2  = hv_iterinit(res[n]);
  if (!n2) {
   cache[0].k = 0;
   cache[0].v = 1;
   n2 = 1;
  } else {
   if (n2 > cachelen) {
    Renew(cache, n2, sn_combcache);
    cachelen = n2;
   }
   j = 0;
   while (key = hv_iternext(res[n])) {
    cache[j].k = SvUV(HeSVKEY_force(key));
    cache[j].v = SvNV(HeVAL(key));
    ++j;
   }
  }
  while (key = hv_iternext((HV *) cur)) {
   IV k = SvUV(HeSVKEY_force(key));
   NV v = SvNV(HeVAL(key));
   for (j = 0; j < n2; ++j) {
    sv_setiv(temp, k + cache[j].k);
    if ((old = hv_fetch_ent(res[o], temp, 1, 0)) && SvOK(val = HeVAL(old))) {
     val = newSVnv(SvNV(val) + v * cache[j].v);
    } else {
     val = newSVnv(v * cache[j].v);
    }
    sn_store_ent(res[o], temp, val, 0);
   }
  }
  n = o;
 }
 Safefree(cache);
 SvREFCNT_dec(res[2]);
 if (pe)
  sn_store(res[n], "exit", 4, newSVnv(pe), sn_hash_exit);
 if (pd)
  sn_store(res[n], "die",  3, newSVnv(pd), sn_hash_die);
 if (pl)
  sn_store(res[n], "list", 4, newSVnv(pl), sn_hash_list);
 if (n == 1)
  SvREFCNT_dec(res[0]);
 else if (res[1]) 
  SvREFCNT_dec(res[1]);
 if (!hv_iterinit(res[n])) {
  SvREFCNT_dec(res[n]);
  XSRETURN_UNDEF;
 } else {
  ST(0) = sv_2mortal(newRV_noinc((SV *) res[n]));
  XSRETURN(1);
 }

void
scalops()
PROTOTYPE:
PREINIT:
 U32 cxt;
 int i, count = 0;
CODE:
 cxt = GIMME_V;
 if (cxt == G_SCALAR) {
  for (i = 0; i < OP_max; ++i) {
   count += (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) != 0;
  }
  EXTEND(SP, 1);
  mPUSHi(count);
  XSRETURN(1);
 } else if (cxt == G_ARRAY) {
  for (i = 0; i < OP_max; ++i) {
   if (PL_opargs[i] & (OA_RETSCALAR | OA_RETINTEGER)) {
    const char *name = PL_op_name[i];
    XPUSHs(sv_2mortal(newSVpvn_share(name, strlen(name), 0)));
    ++count;
   }
  }
  XSRETURN(count);
 }