Commit ff6dcdca authored by Alessio Treglia's avatar Alessio Treglia

Imported Upstream version 11.6

parent eb1f6106
Snd change log
7-June: Snd 11.6.
27-May: removed snd6.scm. added binary-io.scm.
29-Apr: Snd 11.5.
7-Apr: autoload support via s7's *unbound-variable-hook*.
20-Mar: Snd 11.4.
......
Snd 11.5
Snd 11.6
autoload support via s7's *unbound-variable-hook*. If you try to
use some undefined function, Snd first looks through a table
of (nearly) everything defined in the scheme files that come
with Snd, loading the needed files automatically. To turn this
off, (set! *unbound-variable-hook* #f).
in s7: *#readers* for your own #... readers
nan? and infinite?
#nD(...) multidimensional vector constant syntax
support for circular and shared structures
integer-decode-float and binary file IO (binary-io.scm).
removed encapsulation from s7. Added augment-environment.
play-skipping-silence in extsnd.html
added make-type to s7: scheme-level type creation.
symbol-access: trap/modify the symbol value lookup mechanism.
removed snd6.scm.
mix-notelists in ws.scm.
if --with-gtk, the configure script looks first for gtk 3.0 now
(actually 2.90.n, but the libraries and headers use the name 3.0), then
falls back on 2.0.
checked: gtk 2.20.0, sbcl 1.0.37
added --without-audio configure switch.
Thanks!: Rick Taube, Rick's students, Oded Ben-Tal, Cazzaniga Sandro,
Mike Scholz
checked: sbcl 1.0.38|39, gtk 2.20.1|21.0|90.0|1, mpc 0.8.2
Thanks!: Fernando Lopez-Lezcano, Kjetil Matheussen
......@@ -324,6 +324,7 @@ AC_DEFUN(AM_PATH_GTK_2_0,
[dnl
dnl Get the cflags and libraries from pkg-config
dnl
pkg_config_args=gtk+-2.0
for module in . $4
do
......@@ -386,6 +387,76 @@ dnl
])
dnl AM_PATH_GTK_3_0([MINIMUM-VERSION, [ACTION-IF-FOUND [, ACTION-IF-NOT-FOUND [, MODULES]]]])
dnl Test for GTK+, and define GTK_CFLAGS and GTK_LIBS, if gthread is specified in MODULES,
dnl pass to pkg-config
dnl
AC_DEFUN(AM_PATH_GTK_3_0,
[dnl
dnl Get the cflags and libraries from pkg-config
dnl
pkg_config_args=gtk+-3.0
for module in . $4
do
case "$module" in
gthread)
pkg_config_args="$pkg_config_args gthread-3.0"
;;
esac
done
no_gtk=""
AC_PATH_PROG(PKG_CONFIG, pkg-config, no)
if test x$PKG_CONFIG != xno ; then
if pkg-config --atleast-pkgconfig-version 0.7 ; then
:
else
echo *** pkg-config too old; version 0.7 or better required.
no_gtk=yes
PKG_CONFIG=no
fi
else
no_gtk=yes
fi
min_gtk_version=ifelse([$1], ,1.3.3,$1)
AC_MSG_CHECKING(for GTK+ - version >= $min_gtk_version)
if test x$PKG_CONFIG != xno ; then
## don't try to run the test against uninstalled libtool libs
if $PKG_CONFIG --uninstalled $pkg_config_args; then
echo "Will use uninstalled version of GTK+ found in PKG_CONFIG_PATH"
fi
if $PKG_CONFIG --atleast-version $min_gtk_version $pkg_config_args; then
:
else
no_gtk=yes
fi
fi
if test x"$no_gtk" = x ; then
AC_MSG_RESULT(yes)
GTK_CFLAGS=`$PKG_CONFIG $pkg_config_args --cflags`
GTK_LIBS=`$PKG_CONFIG $pkg_config_args --libs`
gtk_config_major_version=`$PKG_CONFIG --modversion gtk+-3.0 | \
sed 's/\([[0-9]]*\).\([[0-9]]*\).\([[0-9]]*\)/\1/'`
gtk_config_minor_version=`$PKG_CONFIG --modversion gtk+-3.0 | \
sed 's/\([[0-9]]*\).\([[0-9]]*\).\([[0-9]]*\)/\2/'`
gtk_config_micro_version=`$PKG_CONFIG --modversion gtk+-3.0 | \
sed 's/\([[0-9]]*\).\([[0-9]]*\).\([[0-9]]*\)/\3/'`
ifelse([$2], , :, [$2])
AC_SUBST(GTK_CFLAGS)
AC_SUBST(GTK_LIBS)
else
AC_MSG_RESULT(no)
ifelse([$3], , :, [$3])
fi
])
## fth.m4 -- Autoconf macros for configuring FTH -*- Autoconf -*-
## Copyright (C) 2006 Michael Scholz
......
This diff is collapsed.
This diff is collapsed.
......@@ -5010,7 +5010,7 @@ static int osx_chans(int dev1)
AudioDeviceID dev = kAudioDeviceUnknown;
OSStatus err = noErr;
UInt32 size;
int i, curdev;
int curdev;
bool in_case = false;
curdev = MUS_AUDIO_DEVICE(dev1);
......@@ -6875,7 +6875,7 @@ int mus_audio_open_output(int dev, int srate, int chans, int format, int size)
output_pars.suggestedLatency = Pa_GetDeviceInfo(output_pars.device)->defaultHighOutputLatency;
output_pars.hostApiSpecificStreamInfo = NULL;
err = Pa_OpenStream(&out_stream, NULL, &output_pars, srate, 1024, paClipOff, NULL, NULL); /* TODO: 1024 = frames [dac_size] but can we use "size"? */
err = Pa_OpenStream(&out_stream, NULL, &output_pars, srate, 1024, paClipOff, NULL, NULL); /* 1024 = frames [dac_size] but can we use "size"? */
if (err == paNoError)
err = Pa_StartStream(out_stream);
......
......@@ -188,7 +188,7 @@
(set-flabel fm-label index))
(define (ratio-callback w c i)
(set! ratio (inexact->exact (* (.value i) (/ high-ratio 100.0))))
(set! ratio (floor (* (.value i) (/ high-ratio 100.0))))
(set-ilabel cm-label ratio))
;; add scale-change (drag and value-changed) callbacks
......@@ -212,10 +212,10 @@
(set-flabel fm-label index)
(set-ilabel cm-label ratio)
(XmScaleSetValue freq-scale (inexact->exact (floor (* 100 (/ (- frequency low-frequency) (- high-frequency low-frequency))))))
(XmScaleSetValue amp-scale (inexact->exact (* 100 amplitude)))
(XmScaleSetValue fm-scale (inexact->exact (floor (* 100 (/ index high-index)))))
(XmScaleSetValue cm-scale (inexact->exact (floor (* ratio (/ 100 high-ratio)))))
(XmScaleSetValue freq-scale (floor (* 100 (/ (- frequency low-frequency) (- high-frequency low-frequency)))))
(XmScaleSetValue amp-scale (floor (* 100 amplitude)))
(XmScaleSetValue fm-scale (floor (* 100 (/ index high-index))))
(XmScaleSetValue cm-scale (floor (* ratio (/ 100 high-ratio))))
(XtManageChild shell)
(XtRealizeWidget shell)
......
......@@ -483,7 +483,7 @@
(set-flabel index-label cindex)
(XmScaleSetValue tempo-scale (floor (* 100 (/ (- ctempo low-tempo) (- high-tempo low-tempo)))))
(XmScaleSetValue freq-scale (floor (* 100 (/ (- cfreq low-freq) (- high-freq low-freq)))))
(XmScaleSetValue amp-scale (inexact->exact (* 100 camp)))
(XmScaleSetValue amp-scale (floor (* 100 camp)))
(XmScaleSetValue index-scale (floor (* 100 (/ cindex high-index)))))
(XtManageChild radio)
......
;;; read/write binary (sound) files
;;;
;;; names are read|write b|l int|float n,
;;; so read-bint32 reads the next 4 bytes from the current input port,
;;; interpreting them as a big-endian 32-bit integer
(provide 'snd-binary-io.scm)
;;; -------- strings (0-terminated)
(define (read-string)
(let ((chars '()))
(do ((c (read-byte) (read-byte)))
((or (= c 0)
(eof-object? c))
(apply string (reverse chars)))
(set! chars (cons (integer->char c) chars)))))
(define (write-string str)
(for-each write-char str) ; or maybe (lambda (c) (write-byte (char->integer c)))
(write-byte 0))
;;; -------- strings (unterminated)
(define (read-chars len)
(let ((str (make-string len)))
(do ((i 0 (+ i 1)))
((= i len) str)
(string-set! str i (read-char)))))
(define (write-chars str)
(for-each write-char str))
;;; -------- 16-bit ints
(define (read-bint16)
(let ((int (+ (ash (read-byte) 8) (read-byte))))
(if (> int 32767)
(- int 65536)
int)))
(define (read-lint16)
(let ((int (+ (read-byte) (ash (read-byte) 8))))
(if (> int 32767)
(- int 65536)
int)))
(define (write-bint16 int)
(write-byte (logand (ash int -8) #xff))
(write-byte (logand int #xff)))
(define (write-lint16 int)
(write-byte (logand int #xff))
(write-byte (logand (ash int -8) #xff)))
;;; -------- 32-bit ints
(define (read-bint32)
(let ((int (+ (ash (read-byte) 24) (ash (read-byte) 16) (ash (read-byte) 8) (read-byte))))
(if (> int 2147483647)
(- int 4294967296)
int)))
(define (read-lint32)
(let ((int (+ (read-byte) (ash (read-byte) 8) (ash (read-byte) 16) (ash (read-byte) 24))))
(if (> int 2147483647)
(- int 4294967296)
int)))
(define (write-bint32 int)
(write-byte (logand (ash int -24) #xff))
(write-byte (logand (ash int -16) #xff))
(write-byte (logand (ash int -8) #xff))
(write-byte (logand int #xff)))
(define (write-lint32 int)
(write-byte (logand int #xff))
(write-byte (logand (ash int -8) #xff))
(write-byte (logand (ash int -16) #xff))
(write-byte (logand (ash int -24) #xff)))
;;; -------- 64-bit ints
(define (read-bint64)
(let ((int 0))
(do ((i 56 (- i 8)))
((< i 0) int)
(set! int (logior int (ash (read-byte) i))))))
(define (read-lint64)
(let ((int 0))
(do ((i 0 (+ i 8)))
((= i 64) int)
(set! int (logior int (ash (read-byte) i))))))
(define (write-bint64 int)
(do ((i 56 (- i 8)))
((< i 0))
(write-byte (logand (ash int (- i)) #xff))))
(define (write-lint64 int)
(do ((i 0 (+ i 8)))
((= i 64))
(write-byte (logand (ash int (- i)) #xff))))
;;; -------- 32-bit floats (IEEE 754, sign + 23(+1) bits significand + 8 bits exponent)
(define (int_to_float32 int)
(if (zero? int)
0.0
(* (if (zero? (ash int -31)) 1.0 -1.0)
(expt 2 (- (logand (ash int -23) #xff) 127))
(logior #x800000 (logand int #x7fffff))
(expt 2 -23))))
(define (read-bfloat32)
(int_to_float32 (read-bint32)))
(define (read-lfloat32)
(int_to_float32 (read-lint32)))
(define (float64_to_int32 flt)
(let* ((data (integer-decode-float flt))
(signif (car data))
(expon (cadr data))
(sign (caddr data)))
(if (and (= expon 0)
(= signif 0))
0
;; we're assuming floats are (64-bit) doubles in s7, so this is coercing to a 32-bit float in a sense
;; this causes some round-off error
(logior (if (negative? sign) #x80000000 0)
(ash (+ expon 52 127) 23)
(logand (ash signif -29) #x7fffff)))))
(define (write-bfloat32 flt)
(write-bint32 (float64_to_int32 flt)))
(define (write-lfloat32 flt)
(write-lint32 (float64_to_int32 flt)))
;;; -------- 64-bit floats (IEEE 754, sign + 52(+1) bits significand + 11 bits exponent)
(define (int_to_float64 int)
(if (zero? int)
0.0
(* (if (zero? (ash int -63)) 1.0 -1.0)
(expt 2 (- (logand (ash int -52) #x7ff) 1023))
(logior #x10000000000000 (logand int #xfffffffffffff))
(expt 2 -52))))
(define (read-bfloat64)
(int_to_float64 (read-bint64)))
(define (read-lfloat64)
(int_to_float64 (read-lint64)))
(define (float64_to_int64 flt)
(let* ((data (integer-decode-float flt))
(signif (car data))
(expon (cadr data))
(sign (caddr data)))
(if (and (= expon 0)
(= signif 0))
0
(logior (if (negative? sign) #x8000000000000000 0)
(ash (+ expon 52 1023) 52)
(logand signif #xfffffffffffff)))))
(define (write-bfloat64 flt)
(write-bint64 (float64_to_int64 flt)))
(define (write-lfloat64 flt)
(write-lint64 (float64_to_int64 flt)))
;;; -------- 80-bit floats (IEEE 754, sign + 63(+1) bits significand + 15 bits exponent, needed for aifc headers)
(define (read-bfloat80->int)
(let* ((exp 0)
(mant1 0)
(mant0 0)
(sign 0)
(buf (make-vector 10)))
(do ((i 0 (+ i 1)))
((= i 10))
(set! (buf i) (read-byte)))
(set! exp (logior (ash (buf 0) 8) (buf 1)))
(set! sign (if (/= (logand exp #x8000) 0) 1 0))
(set! exp (logand exp #x7FFF))
(set! mant1 (+ (ash (buf 2) 24) (ash (buf 3) 16) (ash (buf 4) 8) (buf 5)))
(set! mant0 (+ (ash (buf 6) 24) (ash (buf 7) 16) (ash (buf 8) 8) (buf 9)))
(if (= mant1 mant0 exp sign 0)
0
(round (* (if (= sign 1) -1 1)
(expt 2.0 (- exp 16383.0))
(+ (* (expt 2.0 -31.0) mant1)
(* (expt 2.0 -63.0) mant0)))))))
(define (write-int->bfloat80 val)
(let ((exp 0)
(sign 0)
(mant1 0)
(mant0 0))
(if (negative? val)
(begin
(set! sign 1)
(set! val (abs val))))
(if (not (zero? val))
(begin
(set! exp (round (+ (log val 2.0) 16383.0)))
(set! val (* val (expt 2 (- (+ 16383 31) exp))))
(set! mant1 (floor val))
(set! val (- val mant1))
(set! mant0 (floor (* val (expt 2 32))))))
(write-byte (logior (ash sign 7) (ash exp -8)))
(write-byte (logand exp #xFF))
(do ((i 2 (+ i 1))
(j 24 (- j 8)))
((= i 6))
(write-byte (logand (ash mant1 (- j)) #xFF)))
(do ((i 6 (+ i 1))
(j 24 (- j 8)))
((= i 10))
(write-byte (logand (ash mant0 (- j)) #xFF)))))
;;; -------- "au" (NeXT/Sun) header
(define (read-au-header file)
(with-input-from-file file
(lambda ()
(let ((magic (read-chars 4)))
(if (not (string=? magic ".snd"))
(error 'bad-header "~A is not an au file: ~A" file)
(let* ((data-location (read-bint32))
(data-size (read-bint32))
(data-format (read-bint32))
(srate (read-bint32))
(chans (read-bint32))
(comment (read-string)))
(list magic data-location data-size data-format srate chans comment)))))))
(define (write-au-header file chans srate data-size data-format comment) ; data-size in bytes
(with-output-to-file file
(lambda ()
(let* ((comlen (length comment))
(data-location (+ 24 (* 4 (floor (+ 1 (/ comlen 4))))))
(curloc 24))
(write-chars ".snd")
(write-bint32 data-location)
(write-bint32 data-size)
(write-bint32 data-format)
(write-bint32 srate)
(write-bint32 chans)
(if (> comlen 0)
(begin
(write-string comment)
(set! curloc (+ curloc comlen 1)))) ; write-string adds a trailing 0
(do ((i curloc (+ i 1)))
((>= i data-location))
(write-byte 0))))))
This diff is collapsed.
This diff is collapsed.
......@@ -914,7 +914,7 @@ void mus_rectangular_to_polar(mus_float_t *rl, mus_float_t *im, mus_long_t size)
mus_long_t i;
for (i = 0; i < size; i++)
{
mus_float_t temp; /* apparently floating underflows in sqrt are bringing us to a halt */
mus_float_t temp; /* apparently floating underflows (denormals?) in sqrt are bringing us to a halt */
temp = rl[i] * rl[i] + im[i] * im[i];
im[i] = -atan2(im[i], rl[i]); /* "-" here so that clockwise is positive? is this backwards? */
if (temp < .00000001)
......
This diff is collapsed.
......@@ -2698,14 +2698,14 @@ static XEN g_mus_rand_seed(void)
#define H_mus_rand_seed "(" S_mus_rand_seed "): the random number seed; \
this can be used to re-run a particular random number sequence."
return(C_TO_XEN_ULONG(mus_rand_seed()));
return(C_TO_XEN_INT(mus_rand_seed()));
}
static XEN g_mus_set_rand_seed(XEN a)
{
XEN_ASSERT_TYPE(XEN_ULONG_P(a), a, XEN_ONLY_ARG, S_setB S_mus_rand_seed, "an unsigned integer");
mus_set_rand_seed(XEN_TO_C_ULONG(a));
XEN_ASSERT_TYPE(XEN_INTEGER_P(a), a, XEN_ONLY_ARG, S_setB S_mus_rand_seed, "an integer");
mus_set_rand_seed((unsigned long)XEN_TO_C_INT(a));
return(a);
}
......@@ -5446,7 +5446,7 @@ static XEN g_in_any_1(const char *caller, XEN frame, int in_chan, XEN inp)
if (XEN_VECTOR_P(inp))
{
if (pos < XEN_VECTOR_LENGTH(inp))
return(XEN_VECTOR_REF(inp, pos)); /* TODO: doc/test vector in-any, and add chan arg if s7 and multidim vects */
return(XEN_VECTOR_REF(inp, pos));
}
return(C_TO_XEN_DOUBLE(0.0));
......
This diff is collapsed.
# Configuration script for Snd
AC_INIT(snd, 11.5, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-11.tar.gz)
AC_INIT(snd, 11.6, bil@ccrma.stanford.edu, ftp://ccrma-ftp.stanford.edu/pub/Lisp/snd-11.tar.gz)
AC_CONFIG_SRCDIR(snd.c)
AC_CANONICAL_HOST
......@@ -19,7 +19,7 @@ LOCAL_LANGUAGE="None"
GRAPHICS_TOOLKIT="None"
PACKAGE=Snd
VERSION=11.5
VERSION=11.6
AC_DEFINE_UNQUOTED(SND_PACKAGE, "$PACKAGE")
AC_DEFINE_UNQUOTED(SND_VERSION, "$VERSION")
AC_SUBST(SND_PACKAGE)
......@@ -36,6 +36,7 @@ AC_DEFINE_UNQUOTED(SND_HOST, "$host")
# --with-oss use OSS
# --with-jack use Jack
# --with-static-alsa use ALSA statically loaded (for RPM generation)
# --without-audio stub out all audio
# --with-snd-as-widget make Snd a loadable widget, not a standalone program
# --with-doubles use doubles throughout (default is floats)
# --with-float-samples represent samples internally as floats or doubles (default=yes)
......@@ -113,6 +114,7 @@ AC_ARG_WITH(extension-language, [ --with-extension-language use some extension
# an experiment
AC_ARG_WITH(directfb, [ --with-directfb use directfb config scripts, rather than gtk, default=no])
AC_ARG_WITH(audio, [ --without-audio don't include any audio functionality])
# -------- internal sample data type --------
......@@ -967,14 +969,41 @@ else
if test "$with_gtk" = yes ; then
AM_PATH_GTK_2_0(2.0.0,
[
with_gtk=yes
],
[
AC_MSG_WARN([trouble with gtk -- will try to make Snd without any GUI])
with_gtk=no
])
if test x$PKG_CONFIG != xno ; then
if $PKG_CONFIG gtk+-3.0 --exists ; then
AM_PATH_GTK_3_0(2.90.0,
[
with_gtk=yes
],
[
AC_MSG_WARN([trouble with gtk -- will try to make Snd without any GUI])
with_gtk=no
])
else
AM_PATH_GTK_2_0(2.0.0,
[
with_gtk=yes
],
[
AC_MSG_WARN([trouble with gtk -- will try to make Snd without any GUI])
with_gtk=no
])
fi
else
AM_PATH_GTK_2_0(2.0.0,
[
with_gtk=yes
],
[
AC_MSG_WARN([trouble with gtk -- will try to make Snd without any GUI])
with_gtk=no
])
fi
if test "$with_gtk" = yes ; then
GX_FILES="G_O_FILES"
GX_HEADERS="SND_G_HEADERS"
......@@ -993,10 +1022,18 @@ else
GTK_LD_LIBS="$GTK_LIBS"
if test x$PKG_CONFIG != xno ; then
if test "$with_directfb" = yes ; then
GTK_LD_LIBS="`$PKG_CONFIG gtk+-directfb-2.0 --libs-only-L` `$PKG_CONFIG gtk+-directfb-2.0 --libs-only-l`"
if $PKG_CONFIG gtk+-3.0 --exists ; then
if test "$with_directfb" = yes ; then
GTK_LD_LIBS="`$PKG_CONFIG gtk+-directfb-3.0 --libs-only-L` `$PKG_CONFIG gtk+-directfb-3.0 --libs-only-l`"
else
GTK_LD_LIBS="`$PKG_CONFIG gtk+-3.0 --libs-only-L` `$PKG_CONFIG gtk+-3.0 --libs-only-l`"
fi
else
GTK_LD_LIBS="`$PKG_CONFIG gtk+-2.0 --libs-only-L` `$PKG_CONFIG gtk+-2.0 --libs-only-l`"
if test "$with_directfb" = yes ; then
GTK_LD_LIBS="`$PKG_CONFIG gtk+-directfb-2.0 --libs-only-L` `$PKG_CONFIG gtk+-directfb-2.0 --libs-only-l`"
else
GTK_LD_LIBS="`$PKG_CONFIG gtk+-2.0 --libs-only-L` `$PKG_CONFIG gtk+-2.0 --libs-only-l`"
fi
fi
pango_version="`$PKG_CONFIG pango --modversion`"
AC_DEFINE_UNQUOTED(MUS_PANGO_VERSION,"${pango_version}")
......@@ -1082,6 +1119,8 @@ else
AC_CHECK_LIB(m, gtk_widget_get_visible, [AC_DEFINE(HAVE_GTK_WIDGET_GET_VISIBLE)], ,$GTK_LIBS)
# for 2.19.n
AC_CHECK_LIB(m, gtk_entry_get_text_window, [AC_DEFINE(HAVE_GTK_ENTRY_GET_TEXT_WINDOW)], ,$GTK_LIBS)
# for 2.90
AC_CHECK_LIB(m, gtk_scale_new, [AC_DEFINE(HAVE_GTK_SCALE_NEW)], ,$GTK_LIBS)
# for gdk|pango_cairo
AC_CHECK_LIB(m, gdk_cairo_create,
......@@ -1461,6 +1500,9 @@ SO_LD="ld"
JACK_LIBS=""
JACK_FLAGS=""
if test "$with_audio" != no ; then
# we need the sndlib.h equivalents to try to find the native sound support (see config.guess)
# this only matters for those cases where we've implemented the audio code in audio.c
# test for ALSA courtesy of Paul Davis
......@@ -1626,6 +1668,8 @@ case "$host" in
JACK)
AC_DEFINE(HAVE_JACK_IN_LINUX)
AC_DEFINE(HAVE_OSS)
JACK_LIBS="$JACK_LIBS -lpthread"
# added -lpthread 21-May-10 for FC13 (Bill S)
AUDIO_LIB="-lsamplerate"
;;
OSS)
......@@ -1751,6 +1795,7 @@ esac
AC_MSG_CHECKING([for audio system])
AC_MSG_RESULT($AUDIO_SYSTEM)
fi
fi
AC_SUBST(AUDIO_LIB)
AC_SUBST(JACK_LIBS)
......@@ -2076,6 +2121,10 @@ if test "$ac_snd_have_extension_language" = no ; then
fi
fi
if test "$ac_snd_have_extension_language" = yes && test "$with_audio" = no && test "$ac_snd_have_gui" = no && test "$ac_cv_header_dlfcn_h" = yes ; then
LDFLAGS="$LDFLAGS -ldl"
fi
AC_SUBST(CFLAGS)
AC_SUBST(ORIGINAL_LDFLAGS)
AC_SUBST(LDFLAGS)
......
......@@ -47,11 +47,11 @@
(define (grf-it val v)
(round
(if (>= val (vct-ref v 1))
(vct-ref v 3)
(if (<= val (vct-ref v 0))
(vct-ref v 2)
(+ (vct-ref v 5) (* val (vct-ref v 4)))))))
(if (>= val (v 1))
(v 3)
(if (<= val (v 0))
(v 2)
(+ (v 5) (* val (v 4)))))))
(define* (make-moving-rms (size 128))
(make-moving-average size))
......@@ -78,7 +78,6 @@
(set! (foreground-color snd chn) red))
(lambda ()
(run
(declare (int-vector lines))
(if (< start left) ; check previous samples to get first rms value
(do ((i start (+ 1 i)))
((= i left))
......@@ -86,24 +85,24 @@
(let ((first-sample (next-sample reader)))
(set! x0 (grf-it (* left sr) xdata))
(set! y0 (grf-it first-sample ydata))
(vector-set! lines 0 x0) ; first graph point
(vector-set! lines 1 y0))
(set! (lines 0) x0) ; first graph point
(set! (lines 1) y0))
(do ((i (+ left 1) (+ 1 i))) ; loop through all samples calling moving-rms
((= i right))
(let* ((x1 (grf-it (* i sr) xdata))
(y (moving-rms rms (next-sample reader))))
(if (> x1 x0) ; very often many samples are represented by one pixel
(let ((y1 (grf-it y ydata)))
(vector-set! lines line-ctr x1)
(vector-set! lines (+ 1 line-ctr) y1)
(set! (lines line-ctr) x1)
(set! (lines (+ 1 line-ctr)) y1)
(set! line-ctr (+ line-ctr 2))
(set! x0 x1)
(set! y0 y1)))))) ; else should we do "max" here? or draw a vertical line from min to max?
(if (< line-ctr (length lines))
(do ((j line-ctr (+ j 2))) ; off-by-one in vector size calc -- need to pad so we don't get a bogus line to (0, 0)
((>= j (length lines)))
(vector-set! lines j x0)
(vector-set! lines (+ j 1) y0)))
(set! (lines j) x0)
(set! (lines (+ j 1)) y0)))
(draw-lines lines snd chn)
(set! (channel-property 'rms-lines snd chn) lines) ; save current data for possible redisplay
(set! (channel-property 'rms-axis-info snd chn) axinf))
......@@ -227,7 +226,7 @@ whenever they're in the current view."
(define (samples-1 cur-data)
(let* ((x0 (x->position (/ left (srate snd))))