ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/CV/CV.xs
Revision: 1.36
Committed: Thu Jun 22 20:50:05 2006 UTC (17 years, 11 months ago) by root
Branch: MAIN
Changes since 1.35: +137 -0 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 #include "EXTERN.h"
2     #include "perl.h"
3     #include "XSUB.h"
4    
5 root 1.18 #include <string.h>
6 root 1.17 #include <setjmp.h>
7 root 1.33 #include <math.h>
8 root 1.17
9 root 1.31 #include <magic.h>
10    
11 root 1.17 #include <jpeglib.h>
12 root 1.23 #include <glib.h>
13     #include <gtk/gtk.h>
14 root 1.2 #include <gdk-pixbuf/gdk-pixbuf.h>
15    
16     #include <gperl.h>
17     #include <gtk2perl.h>
18    
19 root 1.33 #define IW 80 /* MUST match Schnauzer.pm! */
20     #define IH 60 /* MUST match Schnauzer.pm! */
21 root 1.5
22     #define RAND (seed = (seed + 7141) * 54773 % 134456)
23    
24 root 1.7 #define LINELENGTH 240
25    
26 root 1.6 #define ELLIPSIS "\xe2\x80\xa6"
27    
28 root 1.17 struct jpg_err_mgr
29     {
30     struct jpeg_error_mgr err;
31     jmp_buf setjmp_buffer;
32     };
33    
34     static void
35     cv_error_exit (j_common_ptr cinfo)
36     {
37     longjmp (((struct jpg_err_mgr *)cinfo->err)->setjmp_buffer, 99);
38     }
39    
40     static void
41     cv_error_output (j_common_ptr cinfo)
42     {
43     return;
44     }
45    
46     static void
47     rgb_to_hsv (unsigned int r, unsigned int g, unsigned int b,
48     unsigned int *h, unsigned int *s, unsigned int *v)
49     {
50     unsigned int mx = r; if (g > mx) mx = g; if (b > mx) mx = b;
51     unsigned int mn = r; if (g < mn) mn = g; if (b < mn) mn = b;
52     unsigned int delta = mx - mn;
53    
54     *v = mx;
55    
56     *s = mx ? delta * 255 / mx : 0;
57    
58     if (delta == 0)
59     *h = 0;
60     else
61     {
62     if (r == mx)
63     *h = ((int)g - (int)b) * 255 / (int)(delta * 3);
64     else if (g == mx)
65     *h = ((int)b - (int)r) * 255 / (int)(delta * 3) + 52;
66     else if (b == mx)
67     *h = ((int)r - (int)g) * 255 / (int)(delta * 3) + 103;
68    
69     *h &= 255;
70     }
71     }
72    
73 root 1.36 struct feature {
74     float v1, v2, v3; // mean, square, cube
75     int n;
76     };
77    
78     static void
79     feature_init (struct feature *f)
80     {
81     f->v1 = 0.;
82     f->v2 = 0.;
83     f->v3 = 0.;
84     f->n = 0;
85     }
86    
87     // didn't find an algorithm to neatly do mean, variance and skew in one pass.
88     // elmex ist schuld.
89     static void
90     feature_update_pass_1 (struct feature *f, unsigned int v)
91     {
92     f->v1 += v;
93     f->n += 1;
94     }
95    
96     static void
97     feature_finish_pass_1 (struct feature *f)
98     {
99     if (f->n < 1)
100     return;
101    
102     f->v1 /= f->n;
103     }
104    
105     static void
106     feature_update_pass_2 (struct feature *f, unsigned int v)
107     {
108     float d = v - f->v1;
109    
110     f->v2 += d * d;
111     f->v3 += d * d * d;
112     }
113    
114     static void
115     feature_finish_pass_2 (struct feature *f)
116     {
117     if (f->n < 1)
118     return;
119    
120     f->v2 /= f->n;
121     f->v3 /= f->n;
122    
123     // this is a peculiar weightung, but it works fine
124     f->v1 /= 255.;
125     f->v2 /= 128. * 128.;
126     f->v3 /= 128. * 128. * 64.;
127     }
128    
129 root 1.4 static guint32 a85_val;
130     static guint a85_cnt;
131 root 1.7 static guchar a85_buf[LINELENGTH], *a85_ptr;
132 root 1.4
133     static void
134     a85_init (void)
135     {
136     a85_cnt = 4;
137     a85_ptr = a85_buf;
138     }
139    
140     static void
141     a85_push (PerlIO *fp, guchar c)
142     {
143     a85_val = a85_val << 8 | c;
144    
145     if (!--a85_cnt)
146     {
147     a85_cnt = 4;
148     if (a85_val)
149     {
150     a85_ptr[4] = (a85_val % 85) + 33; a85_val /= 85;
151     a85_ptr[3] = (a85_val % 85) + 33; a85_val /= 85;
152     a85_ptr[2] = (a85_val % 85) + 33; a85_val /= 85;
153     a85_ptr[1] = (a85_val % 85) + 33; a85_val /= 85;
154     a85_ptr[0] = (a85_val ) + 33;
155    
156     a85_ptr += 5;
157     }
158     else
159     *a85_ptr++ = 'z';
160    
161     if (a85_ptr >= a85_buf + sizeof (a85_buf) - 7)
162     {
163     *a85_ptr++ = '\n';
164     PerlIO_write (fp, a85_buf, a85_ptr - a85_buf);
165     a85_ptr = a85_buf;
166     }
167     }
168    
169     }
170    
171 root 1.8 static void
172 root 1.4 a85_finish (PerlIO *fp)
173     {
174     while (a85_cnt != 4)
175     a85_push (fp, 0);
176    
177     *a85_ptr++ = '~'; // probably buggy end-marker
178     *a85_ptr++ = '>'; // probably buggy end-marker
179     *a85_ptr++ = '\n';
180    
181     PerlIO_write (fp, a85_buf, a85_ptr - a85_buf);
182     }
183    
184 root 1.6 /////////////////////////////////////////////////////////////////////////////
185    
186 root 1.9 MODULE = Gtk2::CV PACKAGE = Gtk2::CV
187 root 1.1
188     PROTOTYPES: ENABLE
189 root 1.2
190 root 1.29 # missing function in perl. really :)
191     int
192     common_prefix_length (a, b)
193     unsigned char *a = (unsigned char *)SvPVutf8_nolen ($arg);
194     unsigned char *b = (unsigned char *)SvPVutf8_nolen ($arg);
195     CODE:
196     RETVAL = 0;
197    
198     while (*a == *b && *a)
199     {
200     RETVAL += (*a & 0xc0) != 0x80;
201     a++, b++;
202     }
203    
204     OUTPUT:
205     RETVAL
206    
207 root 1.31 const char *
208     magic (const char *path)
209     CODE:
210     {
211     static magic_t cookie;
212    
213     if (!cookie)
214     {
215 root 1.32 cookie = magic_open (MAGIC_NONE);
216    
217     if (cookie)
218     magic_load (cookie, 0);
219     else
220     XSRETURN_UNDEF;
221     }
222    
223     RETVAL = magic_file (cookie, path);
224     }
225     OUTPUT:
226     RETVAL
227    
228     const char *
229     magic_mime (const char *path)
230     CODE:
231     {
232     static magic_t cookie;
233    
234     if (!cookie)
235     {
236 root 1.31 cookie = magic_open (MAGIC_MIME);
237    
238     if (cookie)
239     magic_load (cookie, 0);
240     else
241     XSRETURN_UNDEF;
242     }
243    
244     RETVAL = magic_file (cookie, path);
245     }
246     OUTPUT:
247     RETVAL
248    
249 root 1.22 # missing in Gtk2 perl module
250    
251     gboolean
252     gdk_net_wm_supports (GdkAtom property)
253     CODE:
254     #if defined(GDK_WINDOWING_X11) && !defined(GDK_MULTIHEAD_SAFE)
255     RETVAL = gdk_net_wm_supports (property);
256     #else
257     RETVAL = 0;
258     #endif
259     OUTPUT:
260     RETVAL
261    
262 root 1.3 GdkPixbuf_noinc *
263 root 1.26 dealpha_expose (GdkPixbuf *pb)
264     CODE:
265     {
266     int w = gdk_pixbuf_get_width (pb);
267     int h = gdk_pixbuf_get_height (pb);
268     int bpp = gdk_pixbuf_get_n_channels (pb);
269     int x, y, i;
270     guchar *src = gdk_pixbuf_get_pixels (pb), *dst;
271     int sstr = gdk_pixbuf_get_rowstride (pb), dstr;
272    
273     RETVAL = gdk_pixbuf_new (GDK_COLORSPACE_RGB, 0, 8, w, h);
274    
275     dst = gdk_pixbuf_get_pixels (RETVAL);
276     dstr = gdk_pixbuf_get_rowstride (RETVAL);
277    
278     for (x = 0; x < w; x++)
279     for (y = 0; y < h; y++)
280     for (i = 0; i < 3; i++)
281     dst[x * 3 + y * dstr + i] = src[x * bpp + y * sstr + i];
282     }
283     OUTPUT:
284     RETVAL
285    
286     GdkPixbuf_noinc *
287 root 1.28 rotate (GdkPixbuf *pb, int angle)
288 root 1.2 CODE:
289 root 1.28 RETVAL = gdk_pixbuf_rotate_simple (pb, angle == 0 ? GDK_PIXBUF_ROTATE_NONE
290     : angle == 90 ? GDK_PIXBUF_ROTATE_COUNTERCLOCKWISE
291     : angle == 180 ? GDK_PIXBUF_ROTATE_UPSIDEDOWN
292     : angle == 270 ? GDK_PIXBUF_ROTATE_CLOCKWISE
293     : angle);
294 root 1.2 OUTPUT:
295     RETVAL
296    
297 root 1.17 GdkPixbuf_noinc *
298 root 1.23 load_jpeg (SV *path, int thumbnail=0)
299 root 1.17 CODE:
300     {
301     struct jpeg_decompress_struct cinfo;
302     struct jpg_err_mgr jerr;
303     guchar *data;
304     int rs;
305     FILE *fp;
306     volatile GdkPixbuf *pb = 0;
307 root 1.23
308 root 1.17 RETVAL = 0;
309    
310 root 1.30 fp = fopen (SvPVbyte_nolen (path), "rb");
311 root 1.23
312     if (!fp)
313 root 1.17 XSRETURN_UNDEF;
314    
315     cinfo.err = jpeg_std_error (&jerr.err);
316    
317     jerr.err.error_exit = cv_error_exit;
318     jerr.err.output_message = cv_error_output;
319    
320     if ((rs = setjmp (jerr.setjmp_buffer)))
321     {
322     fclose (fp);
323     jpeg_destroy_decompress (&cinfo);
324    
325     if (pb)
326     g_object_unref ((gpointer)pb);
327    
328     XSRETURN_UNDEF;
329     }
330    
331     jpeg_create_decompress (&cinfo);
332    
333     jpeg_stdio_src (&cinfo, fp);
334     jpeg_read_header (&cinfo, TRUE);
335    
336     cinfo.dct_method = JDCT_DEFAULT;
337     cinfo.do_fancy_upsampling = FALSE; /* worse quality, but nobody compained so far, and gdk-pixbuf does the same */
338     cinfo.do_block_smoothing = FALSE;
339     cinfo.out_color_space = JCS_RGB;
340     cinfo.quantize_colors = FALSE;
341    
342     cinfo.scale_num = 1;
343     cinfo.scale_denom = 1;
344    
345     jpeg_calc_output_dimensions (&cinfo);
346    
347     if (thumbnail)
348     {
349     cinfo.dct_method = JDCT_FASTEST;
350     cinfo.do_fancy_upsampling = FALSE;
351    
352     while (cinfo.scale_denom < 8
353 root 1.21 && cinfo.output_width >= IW*4
354     && cinfo.output_height >= IH*4)
355 root 1.17 {
356     cinfo.scale_denom <<= 1;
357     jpeg_calc_output_dimensions (&cinfo);
358     }
359     }
360    
361     pb = RETVAL = gdk_pixbuf_new (GDK_COLORSPACE_RGB, 0, 8, cinfo.output_width, cinfo.output_height);
362     if (!RETVAL)
363     longjmp (jerr.setjmp_buffer, 2);
364    
365     data = gdk_pixbuf_get_pixels (RETVAL);
366     rs = gdk_pixbuf_get_rowstride (RETVAL);
367    
368     if (cinfo.output_components != 3)
369     longjmp (jerr.setjmp_buffer, 3);
370    
371     jpeg_start_decompress (&cinfo);
372    
373     while (cinfo.output_scanline < cinfo.output_height)
374     {
375     int remaining = cinfo.output_height - cinfo.output_scanline;
376     JSAMPROW rp[4];
377    
378     rp [0] = data + cinfo.output_scanline * rs;
379     rp [1] = (guchar *)rp [0] + rs;
380     rp [2] = (guchar *)rp [1] + rs;
381     rp [3] = (guchar *)rp [2] + rs;
382    
383     jpeg_read_scanlines (&cinfo, rp, remaining < 4 ? remaining : 4);
384     }
385    
386     jpeg_finish_decompress (&cinfo);
387     fclose (fp);
388     jpeg_destroy_decompress (&cinfo);
389     }
390     OUTPUT:
391     RETVAL
392    
393 root 1.33 void
394     compare (GdkPixbuf *a, GdkPixbuf *b)
395     PPCODE:
396     {
397     int w = gdk_pixbuf_get_width (a);
398     int h = gdk_pixbuf_get_height (a);
399     int sa = gdk_pixbuf_get_rowstride (a);
400     int sb = gdk_pixbuf_get_rowstride (b);
401    
402     guchar *pa = gdk_pixbuf_get_pixels (a);
403     guchar *pb = gdk_pixbuf_get_pixels (b);
404    
405     int x, y;
406    
407     assert (w == gdk_pixbuf_get_width (b));
408     assert (h == gdk_pixbuf_get_height (b));
409    
410     assert (gdk_pixbuf_get_n_channels (a) == 3);
411     assert (gdk_pixbuf_get_n_channels (b) == 3);
412    
413     double diff = 0.;
414     int peak = 0;
415    
416 root 1.35 if (w && h)
417 root 1.34 for (y = 0; y < h; y++)
418     {
419     guchar *pa_ = pa + y * sa;
420     guchar *pb_ = pb + y * sb;
421 root 1.33
422 root 1.34 for (x = 0; x < w; x++)
423     {
424     int d;
425    
426     d = ((int)*pa_++) - ((int)*pb_++); diff += d*d; peak = MAX (peak, abs (d));
427     d = ((int)*pa_++) - ((int)*pb_++); diff += d*d; peak = MAX (peak, abs (d));
428     d = ((int)*pa_++) - ((int)*pb_++); diff += d*d; peak = MAX (peak, abs (d));
429     }
430     }
431 root 1.33
432     EXTEND (SP, 2);
433     PUSHs (sv_2mortal (newSVnv (sqrt (diff / (w * h * 3. * 255. * 255.)))));
434     PUSHs (sv_2mortal (newSVnv (peak / 255.)));
435     }
436    
437 root 1.6 #############################################################################
438    
439 root 1.2 MODULE = Gtk2::CV PACKAGE = Gtk2::CV::Schnauzer
440    
441 root 1.18 SV *
442     foldcase (SV *pathsv)
443     PROTOTYPE: $
444     CODE:
445     {
446     STRLEN plen;
447 root 1.25 U8 *path = (U8 *)SvPVutf8 (pathsv, plen);
448 root 1.18 U8 *pend = path + plen;
449     U8 dst [plen * 6 * 3], *dstp = dst;
450    
451     while (path < pend)
452     {
453 root 1.19 U8 ch = *path;
454    
455     if (ch >= 'a' && ch <= 'z')
456     *dstp++ = *path++;
457     else if (ch >= '0' && ch <= '9')
458 root 1.18 {
459     STRLEN el, nl = 0;
460 root 1.19 while (*path >= '0' && *path <= '9' && path < pend)
461 root 1.18 path++, nl++;
462    
463     for (el = nl; el < 6; el++)
464     *dstp++ = '0';
465    
466     memcpy (dstp, path - nl, nl);
467     dstp += nl;
468     }
469     else
470     {
471     STRLEN cl;
472     to_utf8_fold (path, dstp, &cl);
473     dstp += cl;
474     path += is_utf8_char (path);
475     }
476     }
477    
478 root 1.25 RETVAL = newSVpvn ((const char *)dst, dstp - dst);
479 root 1.18 }
480     OUTPUT:
481     RETVAL
482    
483 root 1.3 GdkPixbuf_noinc *
484 root 1.24 p7_to_pb (int w, int h, SV *src_sv)
485 root 1.21 PROTOTYPE: @
486 root 1.2 CODE:
487     {
488     int x, y;
489     guchar *dst, *d;
490     int dstr;
491 root 1.25 guchar *src = (guchar *)SvPVbyte_nolen (src_sv);
492 root 1.2
493     RETVAL = gdk_pixbuf_new (GDK_COLORSPACE_RGB, 0, 8, w, h);
494     dst = gdk_pixbuf_get_pixels (RETVAL);
495     dstr = gdk_pixbuf_get_rowstride (RETVAL);
496    
497     for (y = 0; y < h; y++)
498     for (d = dst + y * dstr, x = 0; x < w; x++)
499     {
500 root 1.3 *d++ = (((*src >> 5) & 7) * 255 + 4) / 7;
501     *d++ = (((*src >> 2) & 7) * 255 + 4) / 7;
502     *d++ = (((*src >> 0) & 3) * 255 + 2) / 3;
503 root 1.2
504     src++;
505     }
506 root 1.3 }
507     OUTPUT:
508     RETVAL
509    
510 root 1.6 #############################################################################
511 root 1.4
512     MODULE = Gtk2::CV PACKAGE = Gtk2::CV::PostScript
513    
514     void
515 root 1.7 dump_ascii85 (PerlIO *fp, GdkPixbuf *pb)
516 root 1.4 CODE:
517     {
518     int w = gdk_pixbuf_get_width (pb);
519     int h = gdk_pixbuf_get_height (pb);
520     int x, y, i;
521     guchar *dst;
522 root 1.7 int bpp = gdk_pixbuf_get_n_channels (pb);
523 root 1.4 guchar *src = gdk_pixbuf_get_pixels (pb);
524     int sstr = gdk_pixbuf_get_rowstride (pb);
525    
526     a85_init ();
527    
528     for (y = 0; y < h; y++)
529     for (x = 0; x < w; x++)
530 root 1.7 for (i = 0; i < (bpp < 3 ? 1 : 3); i++)
531 root 1.4 a85_push (fp, src [x * bpp + y * sstr + i]);
532    
533     a85_finish (fp);
534 root 1.7 }
535    
536     void
537     dump_binary (PerlIO *fp, GdkPixbuf *pb)
538     CODE:
539     {
540     int w = gdk_pixbuf_get_width (pb);
541     int h = gdk_pixbuf_get_height (pb);
542     int x, y, i;
543     guchar *dst;
544     int bpp = gdk_pixbuf_get_n_channels (pb);
545     guchar *src = gdk_pixbuf_get_pixels (pb);
546     int sstr = gdk_pixbuf_get_rowstride (pb);
547    
548     for (y = 0; y < h; y++)
549     for (x = 0; x < w; x++)
550     for (i = 0; i < (bpp < 3 ? 1 : 3); i++)
551     PerlIO_putc (fp, src [x * bpp + y * sstr + i]);
552 root 1.4 }
553 root 1.8
554     #############################################################################
555    
556     MODULE = Gtk2::CV PACKAGE = Gtk2::CV
557    
558     SV *
559     pb_to_hv84 (GdkPixbuf *pb)
560     CODE:
561     {
562     int w = gdk_pixbuf_get_width (pb);
563     int h = gdk_pixbuf_get_height (pb);
564     int x, y;
565     guchar *dst;
566     int bpp = gdk_pixbuf_get_n_channels (pb);
567     guchar *src = gdk_pixbuf_get_pixels (pb);
568     int sstr = gdk_pixbuf_get_rowstride (pb);
569    
570     RETVAL = newSV (6 * 8 * 12 / 8);
571     SvPOK_only (RETVAL);
572     SvCUR_set (RETVAL, 6 * 8 * 12 / 8);
573    
574 root 1.25 dst = (guchar *)SvPVX (RETVAL);
575 root 1.8
576     /* some primitive error distribution + random dithering */
577    
578     for (y = 0; y < h; y++)
579     {
580     guchar *p = src + y * sstr;
581    
582     for (x = 0; x < w; x += 2)
583     {
584     unsigned int r, g, b, h, s, v, H, V1, V2;
585    
586     if (bpp == 3)
587     r = *p++, g = *p++, b = *p++;
588     else if (bpp == 1)
589     r = g = b = *p++;
590     else
591     abort ();
592    
593     rgb_to_hsv (r, g, b, &h, &s, &v);
594    
595     H = (h * 15 / 255) << 4;
596     V1 = v;
597    
598     if (bpp == 3)
599     r = *p++, g = *p++, b = *p++;
600     else if (bpp == 1)
601     r = g = b = *p++;
602     else
603     abort ();
604    
605     rgb_to_hsv (r, g, b, &h, &s, &v);
606    
607     H |= h * 15 / 255;
608     V2 = v;
609    
610     *dst++ = H;
611     *dst++ = V1;
612     *dst++ = V2;
613     }
614     }
615     }
616     OUTPUT:
617     RETVAL
618 root 1.4
619 root 1.9 SV *
620     hv84_to_av (unsigned char *hv84)
621     CODE:
622     {
623     int i = 72 / 3;
624     AV *av = newAV ();
625    
626     RETVAL = (SV *)newRV_noinc ((SV *)av);
627     while (i--)
628     {
629     int h = *hv84++;
630     int v1 = *hv84++;
631     int v2 = *hv84++;
632    
633     av_push (av, newSViv (v1));
634     av_push (av, newSViv ((h >> 4) * 255 / 15));
635     av_push (av, newSViv (v2));
636     av_push (av, newSViv ((h & 15) * 255 / 15));
637     }
638     }
639     OUTPUT:
640     RETVAL
641 root 1.2
642 root 1.20 #############################################################################
643    
644     MODULE = Gtk2::CV PACKAGE = Gtk2::CV::Plugin::RCluster
645    
646     SV *
647 root 1.36 extract_features (SV *ar)
648     CODE:
649     {
650     int i;
651     AV *av, *result;
652    
653     if (!SvROK (ar) || SvTYPE (SvRV (ar)) != SVt_PVAV)
654     croak ("Not an array ref as first argument to make_histogram");
655    
656     av = (AV *) SvRV (ar);
657     result = newAV ();
658    
659     for (i = 0; i <= av_len (av); ++i)
660     {
661     SV *sv = *av_fetch (av, i, 1);
662     SV *histsv = newSV (9 * sizeof (float) + 1);
663    
664     SvPOK_on (histsv);
665     SvCUR_set (histsv, 9 * sizeof (float));
666     float *hist = (float *)SvPVX (histsv);
667    
668     struct feature f_h, f_s, f_v;
669     feature_init (&f_h);
670     feature_init (&f_s);
671     feature_init (&f_v);
672    
673     {
674     STRLEN len;
675     unsigned char *buf = (unsigned char *)SvPVbyte (sv, len);
676     while (len >= 3)
677     {
678     unsigned int r, g, b, h, s, v;
679     r = *buf++; g = *buf++; b = *buf++;
680     rgb_to_hsv (r, g, b, &h, &s, &v);
681    
682     feature_update_pass_1 (&f_h, h);
683     feature_update_pass_1 (&f_s, s);
684     feature_update_pass_1 (&f_v, v);
685    
686     len -= 3;
687     }
688    
689     feature_finish_pass_1 (&f_h);
690     feature_finish_pass_1 (&f_s);
691     feature_finish_pass_1 (&f_v);
692     }
693    
694     {
695     STRLEN len;
696     unsigned char *buf = (unsigned char *)SvPVbyte (sv, len);
697     while (len >= 3)
698     {
699     unsigned int r, g, b, h, s, v;
700     r = *buf++; g = *buf++; b = *buf++;
701     rgb_to_hsv (r, g, b, &h, &s, &v);
702    
703     feature_update_pass_2 (&f_h, h);
704     feature_update_pass_2 (&f_s, s);
705     feature_update_pass_2 (&f_v, v);
706    
707     len -= 3;
708     }
709    
710     feature_finish_pass_2 (&f_h);
711     feature_finish_pass_2 (&f_s);
712     feature_finish_pass_2 (&f_v);
713     }
714    
715     hist [0] = f_h.v1 * 2.; hist [1] = f_h.v2 * 2.; hist [2] = f_h.v3 * 2.;
716     hist [3] = f_s.v1 ; hist [4] = f_s.v2 ; hist [5] = f_s.v3 ;
717     hist [6] = f_v.v1 ; hist [7] = f_v.v2 ; hist [8] = f_v.v3 ;
718    
719     av_push (result, histsv);
720     }
721    
722     RETVAL = newRV_noinc ((SV *)result);
723     }
724     OUTPUT:
725     RETVAL
726    
727     SV *
728 root 1.20 make_histograms (SV *ar)
729     CODE:
730     {
731     int i;
732     AV *av, *result;
733    
734     if (!SvROK (ar) || SvTYPE (SvRV (ar)) != SVt_PVAV)
735     croak ("Not an array ref as first argument to make_histogram");
736    
737     av = (AV *) SvRV (ar);
738     result = newAV ();
739    
740     for (i = 0; i <= av_len (av); ++i)
741     {
742     const int HISTSIZE = 64;
743    
744     int j;
745     SV *sv = *av_fetch (av, i, 1);
746     STRLEN len;
747     char *buf = SvPVbyte (sv, len);
748    
749     int tmphist[HISTSIZE];
750     float *hist;
751    
752     SV *histsv = newSV (HISTSIZE * sizeof (float) + 1);
753     SvPOK_on (histsv);
754     SvCUR_set (histsv, HISTSIZE * sizeof (float));
755     hist = (float *)SvPVX (histsv);
756    
757     Zero (tmphist, sizeof (tmphist), char);
758    
759     for (j = len; j--; )
760     {
761     unsigned int idx
762     = ((*buf & 0xc0) >> 2)
763     | ((*buf & 0x18) >> 1)
764     | (*buf & 0x03);
765    
766     ++tmphist[idx];
767     ++buf;
768     }
769    
770     for (j = 0; j < HISTSIZE; ++j)
771     hist[j] = (float)tmphist[j] / (len + 1e-30);
772    
773     av_push (result, histsv);
774     }
775    
776     RETVAL = newRV_noinc ((SV *)result);
777     }
778     OUTPUT:
779     RETVAL
780 root 1.1
781