X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=Nary.xs;h=a64d6196ec7bbc66bc7c2d53fc367617e197c8ac;hb=refs%2Fheads%2Fexitdie;hp=0165a66cb947b058a20f7e20bb1251d957433108;hpb=2edec20dc456a6756846bbac264a99b9d6892848;p=perl%2Fmodules%2FSub-Nary.git

diff --git a/Nary.xs b/Nary.xs
index 0165a66..a64d619 100644
--- a/Nary.xs
+++ b/Nary.xs
@@ -6,21 +6,51 @@
 #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(SvIV(SvRV(op))));
+ ST(0) = sv_2mortal(newSVuv(SvUV(SvRV(op))));
  XSRETURN(1);
 
 void
@@ -29,7 +59,7 @@ PROTOTYPE: $
 PREINIT:
  OP *o;
 CODE:
- o = INT2PTR(OP *, SvIV(SvRV(op)));
+ o = INT2PTR(OP *, SvUV(SvRV(op)));
  ST(0) = sv_2mortal(newSVuv(o == NULL));
  XSRETURN(1);
 
@@ -47,24 +77,7 @@ CODE:
   XSRETURN_IV(res);
  }
  hv = (HV *) SvRV(sv);
- res = hv_exists(hv, "0", 1) && hv_iterinit(hv) == 1;
- XSRETURN_IV(res);
-
-void
-list(SV *sv)
-PROTOTYPE: $
-PREINIT:
- HV *hv;
- IV res;
-CODE:
- if (!SvOK(sv))
-  XSRETURN_IV(0);
- if (!SvROK(sv)) {
-  res = strEQ(SvPV_nolen(sv), "list");
-  XSRETURN_IV(res);
- }
- hv = (HV *) SvRV(sv);
- res = hv_exists(hv, "list", 4) && hv_iterinit(hv) == 1;
+ res = hv_iterinit(hv) == 1 && hv_exists(hv, "0", 1);
  XSRETURN_IV(res);
 
 void
@@ -86,6 +99,281 @@ CODE:
  }
  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: