/* sound.c -- nyquist sound data type */

/* define size_t: */
#include "sys/types.h"	
#include <stdio.h>
#include "xlisp.h"
#include "sound.h"
#include "falloc.h"
#include "samples.h"
#include "extern.h"
#include "debug.h"

/* #define GC_DEBUG */
#ifdef GC_DEBUG
sound_type sound_to_watch;
#endif

/* #define SNAPSHOTS */
/* #define TRACESNDGC */


sample_block_type zero_block;
sample_block_type internal_zero_block;

snd_list_type zero_snd_list;

#ifdef XLISP_SOUND

xtype_desc sound_desc;
LVAL a_sound;

static void sound_xlfree();
static void sound_xlprint();
static void sound_xlsave();
static unsigned char *sound_xlrestore();
#endif

void sound_print_array(LVAL sa, long n);
void sound_print_sound(sound_type s, long n);

#ifdef SNAPSHOTS
boolean sound_created_flag = false;
#endif

/* compute-phase -  given a phase in radians, a wavetable specified as
 *  the nominal pitch (in half steps), the table length, and the sample
 *  rate, compute the sample number corresponding to the phase.  This
 *  routine makes it easy to initialize the table pointer at the beginning
 *  of various oscillator implementations in Fugue.  Note that the table
 *  may represent several periods, in which case phase 360 is not the same
 *  as 0.  Also note that the phase increment is also computed and returned
 *  through incr_ptr.
 */
double compute_phase(phase, key, n, srate, new_srate, freq, incr_ptr)
  double phase;  /* phase in degrees (depends on ANGLEBASE) */
  double key;    /* the semitone number of the table played at srate */
  long n;        /* number of samples */
  double srate;  /* the sample rate of the table */
  double new_srate;  /* sample rate of the result */
  double freq;   /* the desired frequency */
  double *incr_ptr; /* the sample increment */
{
    double period = 1.0 / step_to_hz(key);

    /* convert phase to sample units */
    phase = srate * period * (phase / (double) ANGLEBASE);
    /* phase is now in sample units; if phase is less than zero, then increase
       it by some number of sLength's to make it positive:
     */
    if (phase < 0)
        phase += (((int) ((-phase) / n)) + 1) * n;

    /* if phase is longer than the sample length, wrap it by subtracting the
       integer part of the division by sLength:
     */
    if (phase > n)
        phase -= ((int) (phase / n)) * n;

    /* Now figure the phase increment: to reproduce original pitch
       required incr = srate / new_srate.  To get the new frequency,
       scale by freq / nominal_freq = freq * period:
     */
    *incr_ptr = (srate / new_srate) * freq * period;
    return phase;
}
#ifndef GCBUG
snd_list_type gcbug_snd_list = 0;
long blocks_to_watch_len = 0;
sample_block_type blocks_to_watch[blocks_to_watch_max];

void block_watch(long sample_block)
{
    if (blocks_to_watch_len >= blocks_to_watch_max) {
        printf("block_watch - no more space to save pointers\n");
        return;
    }
    blocks_to_watch[blocks_to_watch_len++] = (sample_block_type) sample_block;
    printf("block_watch - added %d = 0x%x\n", sample_block, sample_block);
}


/* fetch_zeros -- the fetch function for appended zeros */
/*
 * zeros are appended when the logical stop time exceeds the 
 * (physical) terminate time.  This fetch function is installed
 * by snd_list_terminate().  When appending zeros, we just return
 * a pointer to the internal_zero_block and increment current until
 * it reaches log_stop_cnt.  Then we call snd_list_terminate() to
 * finish off the sound list.
 */

void fetch_zeros(snd_susp_type susp, snd_list_type snd_list)
{
    int len = min(susp->log_stop_cnt - susp->current,
                   max_sample_block_len);
/*    printf("fetch_zeros, lsc %d current %d len %d\n", 
            susp->log_stop_cnt, susp->current, len); */
    if (len < 0) {
        char error[80];
        sprintf(error, "fetch_zeros susp %x (%s) len %d", susp, susp->name, len);
	xlabort(error);
    }
    if (len == 0) { /* we've reached the logical stop time */
        printf("fetch_zeros: reached the logical stop in %s cnt %d\n",
               susp->name, susp->log_stop_cnt);
        snd_list_terminate(snd_list);
    } else {
        snd_list->block_len = len;
	susp->current += len;
    }
}


/* sound_nth_block - fetch the address of the nth sample block of a sound */
/*
 * NOTE: intended to be called from lisp.  Lisp can then call block_watch
 * to keep an eye on the block.
 */
long sound_nth_block(sound_type snd, long n)
{
    long i;
    snd_list_type snd_list = snd->list;
    for (i = 0; i < n; i++) {
	if (i == 1) {
	    gcbug_snd_list = snd_list;
	    printf("gcbug_snd_list = 0x%x\n", gcbug_snd_list);
	}
        if (!snd_list->block) return 0;
        snd_list = snd_list->u.next;
    }
    if (snd_list->block) return (long) snd_list->block;
    else return 0;
}

#endif


/****************************************************************************
*                               snd_list_create
* Inputs:
*       snd_susp_type susp: A reference to the suspension
* Result: snd_list_type
*       A newly-created sound list type
* Effect: 
*       Allocates and initializes a snd_list node:
*	  block    refcnt  block_len susp  logically_stopped
*	+--------+--------+-------+-------+---+
*       |////////|   1    |   0   | susp  | F |
*	+--------+--------+-------+-------+---+
****************************************************************************/

/* snd_list_create -- alloc and initialize a snd_list node */
/**/
snd_list_type snd_list_create(snd_susp_type susp)
{
    snd_list_type snd_list;

    falloc_snd_list(snd_list, "snd_list_create");

    snd_list->block = NULL;		/* no block of samples */
    snd_list->u.susp = susp;		/* point to suspension */
    snd_list->refcnt = 1;		/* one ref */
    snd_list->block_len = 0;		/* no samples */
    snd_list->logically_stopped = false;/* not stopped */
/*    printf("snd_list_create => %x\n", snd_list);*/
    return snd_list;
}


/****************************************************************************
*                                sound_create
* Inputs:
*       snd_susp_type susp: The suspension block to be used for this sound
*	time_type t0: The initial time for this sound
*	rate_type sr: The sampling rate for this sound
*	sample_type scale: The scaling factor for this sound
*	sample_block_type (*proc)(...): The get_next_sound method
* Result: sound_type
*       
* Effect: 
*       Creates and initializes a sound type
* Notes:
*	The MSDOS conditional is actually a test for ANSI headers; the
*	presence of float parameters means that an ANSI prototype and
*	a non-ANSI header are incompatible.  Better solution would be
*	to ANSIfy source.
****************************************************************************/

sound_type last_sound = NULL;

sound_type sound_create(
  snd_susp_type susp,
  time_type t0,
  rate_type sr,
  promoted_sample_type scale)
{
    sound_type sound;
    falloc_sound(sound, "sound_create");
    if (((long) sound) & 3) fprintf(stderr, "sound not word aligned\n");
    last_sound = sound; /* debug */
    /* printf("sound_create %x gets %g\n", sound, t0); */
    sound->t0 = t0;
    sound->time = t0;
    sound->stop = MAX_STOP;
    sound->sr = sr;
    sound->current = 0;
    sound->scale = scale;
    sound->list = snd_list_create(susp);
    sound->get_next = SND_get_first;
    sound->logical_stop_cnt = UNKNOWN;
    /* printf("sound_create susp %x snd_list %x\n", susp, sound->list);
       printf("sound_create'd %x\n", sound); */
#ifdef SNAPSHOTS
    sound_created_flag = true;
#endif
#ifdef GC_DEBUG
    if (sound == sound_to_watch) {
	printf("Created watched sound\n");
	watch_snd_list(sound->list);
    }
#endif
    return sound;
}


/* sound_prepend_zeros -- modify sound_type so that it starts at t0 */
/*
 * assumes t0 is earlier than snd->t0, so the sound should return zeros
 * until snd->t0 is reached, after which we revert to normal computation.
 * When we return, the new snd->t0 will be t0, meaning that the first
 * sample returned will be at time t0.
 * NOTE: t0 may not be an exact multiple of samples earlier than snd->t0,
 * but Nyquist allows any sound to be shifted by +/- 0.5 samples in 
 * order to achieve alignment.  Since sound_prepend_zeros can be called
 * many times on the same sound_type, there is a chance that rounding 
 * errors could accumulate.  My first solution was to return with 
 * snd->t0 computed exactly and not reflecting any fractional sample 
 * shift of the signal, but this caused problems for the caller: a 
 * fractional sample shift at a low sample rate could correspond to 
 * many client samples,fooling the client into thinking that some 
 * initial samples should be discarded (or else requiring the client
 * to be pretty smart).  The solution used here is to return to the
 * client with snd->t0 exactly equal to t0, but to save snd->true_t0
 * equal to the time of the first sample with no sound shifting.  This
 * time is used for any future sound_prepend_zeros operations so that
 * any accumulated rounding errors are due only to floating point 
 * precision and not to accumulated fractional sample shifts of snd.
 */
void sound_prepend_zeros(sound_type snd, time_type t0)
{
    long n;

    /* first, see if we're already prepending some zeros */
    if (snd->get_next != SND_get_zeros) {
/*        printf("sound_prepend_zeros 1: snd->t0 %g t0 %g\n", snd->t0,  t0); */

        /* if not, then initialize some fields that support prepending */
        snd->prepend_cnt = 0;
        snd->true_t0 = snd->t0;

        /* save old get_next and plug in special get_next function */
        snd->after_prepend = snd->get_next;
        snd->get_next = SND_get_zeros;
    }

    n = ((snd->true_t0 - t0) * snd->sr) + 0.5; /* how many samples to prepend */

    /* add to prepend_cnt so first sample will correspond to new t0 */
    snd->prepend_cnt += n;
    /* compute the true t0 which corresponds to the time of first sample */
    snd->true_t0 -= (n / snd->sr);
    /* make caller happy by claiming the sound now starts at exactly t0;
     * this is always true within 0.5 samples as allowed by Fugue. */
    snd->t0 = t0;
/*    printf("sound_prepend_zeros: snd %x true_t0 %g sr %g n %d\n", 
           snd, snd->true_t0, snd->sr, n);*/
}


/* sound_array_copy -- copy an array of sounds */
/*
 * NOTE: be sure to protect the result from gc!
 */
LVAL sound_array_copy(LVAL sa)
{
    long i = getsize(sa);
    LVAL new_sa = newvector(i);
    xlprot1(new_sa);

    while (i > 0) {
        i--;
        setelement(new_sa, i, 
                   cvsound(sound_copy(getsound(getelement(sa, i)))));
    }

    xlpop();
    return new_sa;
}


/* sound_copy - copy a sound structure, do reference counts */
/**/
sound_type sound_copy(sound_type snd)
{
    sound_type sndcopy;

    falloc_sound(sndcopy, "sound_copy");
    *sndcopy = *snd;    /* copy the whole structure */
    snd_list_ref(snd->list);    /* copied a reference so fix the count */
/*    printf("sound_copy'd %x to %x\n", snd, sndcopy); */
#ifdef GC_DEBUG
    if (sndcopy == sound_to_watch) abort();
#endif
    return sndcopy;
}


/* convert a sound to an array, set length */
/**/
sample_type *sound_to_table(sound_type s, double *length)
{
    sample_type *table;
    long len = snd_length(s, max_table_len);
    long tx = 0;	/* table index */
    long blocklen;
    register double scale_factor = s->scale;

    if (len >= max_table_len) {
        char emsg[100];
        sprintf(emsg, "maximum table size (%d) exceeded", max_table_len);
        xlcerror("use truncated sound for table", emsg, NIL);
    }
    *length = (double) len;

    len++;	/* allocate extra sample at end of table */
    s = sound_copy(s);

/*    printf("osc_init: allocating table of size %d\n", len);*/
    table = (sample_type *) malloc(len * sizeof(sample_type));
    if (!table) xlfail("osc_init couldn't allocate table_ptr");

    while (len > 1) {
	sample_block_type sampblock = sound_get_next(s, &blocklen);
	long togo = min(blocklen, len);
	long i;
	sample_block_values_type sbufp = sampblock->samples;
/*	printf("in sound_to_table, sampblock = %d\n", sampblock);*/
	for (i = 0; i < togo; i++) {
	    table[tx++] = *sbufp++ * scale_factor;
	}
	len -= togo;
    }
    /* for interpolation, duplicate first sample at end of table */
    table[tx] = table[0];

    sound_unref(s);
    s = NULL;
    return table;
}


sound_unref(snd)
sound_type snd;
{
    if (!snd) return;
    snd_list_unref(snd->list);
/*    printf("\t\t\t\t\tfreeing sound@%x\n", snd);*/
    ffree_sound(snd, "sound_unref");
}


snd_list_ref(list)
snd_list_type list;
{
    list->refcnt++;
}


void snd_list_terminate(snd_list)
  snd_list_type snd_list;
{
    snd_susp_type susp = snd_list->u.next->u.susp;
    long lsc = susp->log_stop_cnt;
    long current = susp->current;
    if (lsc != UNKNOWN && lsc > current) {
        /* printf("snd_list_terminate: lsc %d current %d\n", 
                lsc, current); */
        susp->fetch = fetch_zeros;
        fetch_zeros(susp, snd_list);
    } else {
        snd_list->block_len = max_sample_block_len;	/* use zero_block instead */
        sample_block_unref(snd_list->block);
        snd_list->block = zero_block;
        snd_list->logically_stopped = true;
        snd_list_unref(snd_list->u.next);
        snd_list->u.next = zero_snd_list;	/* be zero forever */
    }
}


snd_list_unref(list)
snd_list_type list;
{
    void (*freefunc)();

    if (list == NULL || list == zero_snd_list) {
        if (list == NULL) printf("why did snd_list_unref get %x?\n", list);
	return;
    }
    list->refcnt--;
/*    printf("snd_list_unref "); print_snd_list_type(list); printf("\n"); */
    if (list->refcnt == 0) {
	if (list->block && list->block != zero_block) {
	    /* there is a next snd_list */
/*	    printf("["); */
	    sample_block_unref(list->block);
/*	    printf("]"); */
	    snd_list_unref(list->u.next);
	}
	else if (list->block == NULL) {	/* the next thing is the susp */
	    /* free suspension structure */
	    /* printf("freeing susp@%x\n", list->u.susp); */
	    freefunc = list->u.susp->free;
	    (*freefunc)(list->u.susp);
	}
	/* printf("freeing snd_list@%x\n", list); */
	ffree_snd_list(list, "snd_list_unref");
    }
}


sample_block_ref(sam)
sample_block_type sam;
{
    sam->refcnt++;
}


void sample_block_test(sample_block_type sam, char *s)
{
    /* see if this block is being watched */
    int i;
    for (i = 0; i < blocks_to_watch_len; i++) {
        if ((sam > (blocks_to_watch[i] - 1)) &&
	    (sam < (blocks_to_watch[i] + 1))) {
            printf(
    "WOOPS! %s(0x%x) refers to a block 0x%x on the watch list!\n",
                    s, sam, blocks_to_watch[i]);
        }
    }
}


sample_block_unref(sample_block_type sam)
{
    sam->refcnt--;
    if (sam->refcnt == 0) {
#ifndef GCBUG
    sample_block_test(sam, "sample_block_unref");
#endif        
/*	printf("freeing sample block %x\n", sam); */
	ffree_sample_block(sam, "sample_block_unref");
    }
}



/****************************************************************************
*                                interp_style
* Inputs:
*       sound_type s: The sound we are using
*	rate_type sr: The sampling rate
* Result: int
*       A small integer which is one of the symbolic values:
*	The values are ordered, smallest to largest, as
*		INTERP_n - none
*		INTERP_s - scale
*		INTERP_i - interpolated
*		INTERP_r - ramp
*
* Notes: 
*       The sampling rate s->sr and scale factor s->scale are compared
*	with other values exactly (no fuzz).  
****************************************************************************/

int interp_style(sound_type s, rate_type sr)
{
    if (s->sr == sr) 
       { /* same sample rate */
	return ((s->scale == 1.0) ? INTERP_n : INTERP_s);
       } /* same sample rate */
    else 
    if (s->sr * 10.0 > sr) 
       { /* 10x sample rate */
	return INTERP_i;
       } /* 10x sample rate */
    else 
       return INTERP_r;
}


/****************************************************************************
*                                 snd_sort_2
* Inputs:
*       sound_type * s1_ptr:
*	sound_type * s2_ptr:
*	rate_type sr:
* Result: void
*       
* Effect: 
*       If the interp_style of s1 dominates the interp_style of s2,
*	the sound_types input are interchanged.
****************************************************************************/

/* snd_sort_2 -- sort 2 arguments by interpolation method */
void snd_sort_2(sound_type *s1_ptr, sound_type *s2_ptr, rate_type sr)
{
    if (interp_style(*s1_ptr, sr) > interp_style(*s2_ptr, sr)) {
	sound_type s = *s1_ptr;
	*s1_ptr = *s2_ptr;
	*s2_ptr = s;
    }
}


/* snd_sref -- access a sound at a given time point */
/**/
double snd_sref(sound_type s, time_type t)
{
    double exact_cnt;      /* how many fractional samples to scan */
    int cnt;               /* how many samples to flush */
    sample_block_type sampblock;
    long blocklen;
    sample_type x1, x2;    /* interpolate between these samples */

    exact_cnt = (t - s->true_t0) * s->sr;
    if (exact_cnt < 0.0) return 0.0;

    s = sound_copy(s);     /* don't modify s, create new reader */
    cnt = exact_cnt;       /* rounds down */
    exact_cnt -= cnt;      /* remember fractional remainder */

    /* now flush cnt samples */
    while (cnt >= 0) {
	sampblock = sound_get_next(s, &blocklen);
	cnt -= blocklen;
	if (sampblock == zero_block) {
	    sound_unref(s);
	    return 0.0;
	}
    }
    /* -blocklen <= cnt <= -1 */

    /* get next 2 samples and interpolate */
    x1 = sampblock->samples[blocklen + cnt];
    if (cnt == -1) {
	sampblock = sound_get_next(s, &blocklen);
	cnt -= blocklen;
    }
    x2 = sampblock->samples[blocklen + cnt + 1];
    sound_unref(s);        /* free the reader */

    return x1 + exact_cnt * (x2 - x1);
}


/* snd_sref_inverse -- find time point corresponding to some value */
/**/
double snd_sref_inverse(sound_type s, double val)
{
    double exact_cnt;      /* how many fractional samples to scan */
    int cnt;               /* how many samples to flush */
    int i;
    sample_block_type sampblock;
    long blocklen;
    sample_type x1, x2;    /* interpolate between these samples */

    if (val < 0) {
	xlcerror("return 0", "negative value", cvflonum(val));
	return 0.0;
    }
    s = sound_copy(s);     /* don't modify s, create new reader */

    x1 = 0;
    /* now flush cnt samples */
    while (true) {
	sampblock = sound_get_next(s, &blocklen);
	x2 = sampblock->samples[blocklen - 1];
	if (x2 >= val) break;
	x1 = x2;
	if (sampblock == zero_block) {
	    xlcerror("return 0", "too large, no inverse", cvflonum(val));
	    sound_unref(s);
	    return 0.0;
	}
    }
    /* x1 = last sample of previous block,
       sampblock contains a value larger than val
       blocklen is the length of sampblock */

    /* search for first element exceeding val - could
     * use binary search, but maximum block size places
     * an upper bound on how bad this can get and we
     * search for the right block linearly anyway.
     */
    for (i = 0; i < blocklen && sampblock->samples[i] <= val; i++) ;

    /* now i is index of element exceeding val */
    if (i > 1) x1 = sampblock->samples[i - 1];
    x2 = sampblock->samples[i];

    /* now interpolate to get fractional part */
    if (x2 == x1) exact_cnt = 0;
    else exact_cnt = (val - x1) / (x2 - x1);

    /* and add the sample count of x1 */
    exact_cnt += (s->current - blocklen) + (i - 1);

    /* negative counts are possible because the first x1 is at
     * sample -1, so force the location to be at least 0
     */
    if (exact_cnt < 0) exact_cnt = 0;

    /* compute time = t0 + count / samplerate; */
    exact_cnt = s->t0 + exact_cnt / s->sr;

    sound_unref(s);        /* free the reader */
    return exact_cnt;
}


time_type snd_stop_time(sound_type s)
{
    if (s->stop == MAX_STOP) return MAX_STOP_TIME;
    else return s->t0 + (s->stop + 0.5) / s->sr;
}


/* snd_xform -- return a sound with transformations applied */
/*
 * The "logical" sound starts at snd->time and runs until some
 * as yet unknown termination time.  (There is also a possibly
 * as yet unknown logical stop time that is irrelevant here.)
 * The sound is clipped (zero) until snd->t0 and after snd->stop,
 * the latter being a sample count, not a time_type.
 * So, the "physical" sound starts at snd->t0 and runs for up to
 * snd->stop samples (or less if the sound terminates beforehand).
 *
 * The snd_xform procedure operates at the "logical" level, shifting
 * the sound from its snd->time to time.  The sound is stretched as
 * a result of setting the sample rate to sr.  It is then (further) 
 * clipped between start_time and stop_time.  If initial samples
 * are clipped, the sound is shifted again so that it still starts
 * at time.  The sound is then scaled by scale.
 *
 * To support clipping of initial samples, the "physical" start time
 * t0 is set to when the first unclipped sample will be returned, but
 * the number of samples to clip is saved as a negative count.  The
 * fetch routine SND_flush is installed to flush the clipped samples
 * at the time of the first fetch.  SND_get_first is then installed
 * for future fetches.
 *
 * An empty (zero) sound will be returned if all samples are clipped.
 *
 */
sound_type snd_xform(sound_type snd,
                      rate_type sr,
                      time_type time,
                      time_type start_time,
                      time_type stop_time,
                      promoted_sample_type scale)
{
    long start_cnt, stop_cnt; /* clipping samples (sample 0 at new t0) */
    double shift = time - snd->time;

    /* start_cnt should reflect max of where the sound starts (t0)
     * and the new start_time.
     */
    if (start_time == MIN_START_TIME) {
        start_cnt = 0;
    } else {
        double new_start_cnt = ((start_time - time) * sr) + 0.5;
	start_cnt = ((new_start_cnt > 0) ? new_start_cnt : 0);
    }
    /* if (start_cnt < -(snd->current)) start_cnt = -(snd->current); */

    /* stop_cnt should reflect min of the new stop_time and the previous
     * snd->stop.
     */
    if (stop_time == MAX_STOP_TIME) {
        stop_cnt = MAX_STOP;
    } else {
        double new_stop_cnt = ((stop_time - time) * sr) + 0.5;
        if (new_stop_cnt < MAX_STOP) {
            stop_cnt = new_stop_cnt;
        } else {
            fprintf(stderr, "Warning: stop count overflow in snd_xform\n");
            stop_cnt = MAX_STOP;
        }
    }

    if (stop_cnt > snd->stop) {
	stop_cnt = snd->stop;
    }

    if (stop_cnt < 0 || start_cnt >= stop_cnt) {
        snd = sound_create(NULL, time, sr, 1.0);
        /* sound_create goes ahead and allocates a snd_list node, so
         * we need to free it.  
         * Calling snd_list_unref here seems like the right thing, but 
         * it assumes too much structure is in place.  ffree_snd_list
         * is simpler and more direct:
         */
        ffree_snd_list(snd->list, "snd_xform");
        snd->list = zero_snd_list;
        printf("snd_xform: (stop_time < t0 or start >= stop) -> zero sound = %x\n, snd");
        
    } else {
        snd = sound_copy(snd);
	snd->t0 = time;
        if (start_cnt) {
            snd->current -= start_cnt; /* indicate flush with negative num. */
            /* the following code assumes that SND_get_first is the
              routine to be called to get the first samples from this 
              sound.  We're going to replace it with SND_flush.  First,
              make sure that the assumption is correct:
            */
            if ((snd->get_next != SND_get_first) &&
		(snd->get_next != SND_flush)) {
                fprintf(stderr, "snd_xform: SND_get_first expected\n");
                exit(1);
            }
            /* this will flush -current samples and revert to SND_get_first */
            snd->get_next = SND_flush;
	    stop_cnt -= start_cnt;
        }
        snd->stop = stop_cnt;
        snd->sr = sr;
        snd->scale = scale;
    }
    return snd;
}


/* SND_flush -- the get_next function for flushing clipped samples */
/*
 * this only gets called once: it flushes -current samples (a 
 * non-real-time operation) and installs SND_get_next to return
 * blocks normally from then on.
 */
sample_block_type SND_flush(sound_type snd, long * cnt)
{
    long mycnt;
    sample_block_type block = SND_get_first(snd, &mycnt);
    while (snd->current < 0) {
        block = SND_get_next(snd, &mycnt);
    }
    /* at this point, we've read to and including the block with
     * the first samples we want to return.  If the block boundary
     * is in the right place, we can do a minimal fixup and return:
     */
    if (snd->current == snd->list->block_len) {
        *cnt = snd->current; /* == snd->list->block_len */
        /* snd->get_next = SND_get_next; -- done by SND_get_first */
        return block;
    } else /* snd->current < snd->list->block_len */ {
        long i;
        sample_block_values_type from_ptr;
        /* we have to return a partial block */
        /* NOTE: if we had been smart, we would have had SND_get_next
         * return a pointer to samples rather than a pointer to the
         * block, which has a reference count.  Since the caller
         * expects a pointer to a reference count, we have to copy
         * snd->current samples to a new block
         */
        snd_list_type snd_list = snd_list_create((snd_susp_type) snd->list->u.next);
        snd_list->u.next->refcnt++;
        falloc_sample_block(snd_list->block, "SND_flush");
        /* now copy samples */
        from_ptr = block->samples + snd->list->block_len - snd->current;
        for (i = 0; i < snd->current; i++) {
            snd_list->block->samples[i] = from_ptr[i];
        }
        snd_list_unref(snd->list);
        snd->list = snd_list;
        *cnt = snd->current;
        return snd_list->block;
    }
}


/* SND_get_zeros -- the get_next function for prepended zeros */
/*
 * when prepending zeros, we just return a pointer to the internal_zero_block
 * and decrement the prepend_cnt until it goes to zero.  Then we revert to 
 * the normal (original) get_next function.
 *
 */
sample_block_type SND_get_zeros(sound_type snd, long * cnt)
{
    int len = min(snd->prepend_cnt, max_sample_block_len);
    printf("SND_get_zeros: ");
    if (len < 0) {
        char error[80];
        sprintf(error, "SND_get_zeros snd %g len %d", snd, len);
	xlabort(error);
    }
    if (len == 0) { /* we've finished prepending zeros */
        snd->get_next = snd->after_prepend;
        printf("done, calling sound_get_next\n"); fflush(stdout);
        return sound_get_next(snd, cnt);
    } else {
        *cnt = len;
	snd->current += len;
        snd->prepend_cnt -= len;
/*        printf("returning internal_zero_block@%x\n", internal_zero_block);
	fflush(stdout); */
        return internal_zero_block;
    }
}


/****************************************************************************
*                                SND_get_next
* Inputs:
*       sound_type snd: The iterator whose next block is to be computed
*	int * cnt: Place to put count of samples returned
* Result: snd_list_type
*       Pointer to the sample block computed ---------------------------+
* Effect:				     				|
*       force suspension to compute next block of samples		|
*                                                                       |
*  Here's the protocol for using this and related functions:		|
*  Every client (sample reader) has a private sound_type (an iterator),	|
*  and the sound_type's 'list' field points to a header (of type	|
*  snd_list_type).  The header in turn points to a block of samples.	|
*									|
*				+---------------------------------------+
*			        |
*				|
*                               |            sample_block_type
*	(snd)			V	     +---+--+--+--+--+--+--+-...-+--+
*	sound_type:        snd_list_type +-->|ref|  |  |  |  |//|//|     |//|
*	+---------+        +----------+  |   +---+--+--+--+--+--+--+-...-+--+
*	| list    +------->| block    +--+                 ^
*	+---------+        +----------+                    :
*	|  t0     |	   | block_len|....................:
*	+---------+	   +----------+
*	|  sr     |	   | refcnt   |
*	+---------+	   +-+--------+
*	| current |        | next   +---->...         Note: the union u
*	+---------+	   |u|........| snd_list_type    points to only one
*	| rate    |        | | susp   +---->...          of the indicated
*	+---------+	   +-+--------+	susp_type        types
*	| scalse  |	   |log_stop  |
*	+---------+	   +----------+
*	| lsc     |
*	+---------+
*	|get_next +-----> SND_get_next()
*	+---------+
*
*  The sound_type keeps track of where the next sample block will 
*  come from.  The field 'current' is the number of the first sample of
*  the next block to be returned, where sample numbers start
*  at zero.  The normal fetch procedure is this one, although special
*  cases may generate special block generators, e.g., CONST does not need
*  to allocate and refill a block and can reuse the same block over and
*  over again, so it may have its own fetch procedure.  This is the
*  general fetch procedure, which assumes that the generator function
*  actually produces a slightly different value for each sample.
*
*  The distinguishing characteristic of whether the 'u' field is to be
*  interpreted as 'next', a link to the next list element, or 'susp', a
*  reference to the suspension for generating a new sample block, is
*  whether the 'block' parameter is NULL or not.  If it is NULL, then
*  u.susp tells how to generate the block; if it is not NULL, u.next is
*  a pointer to the next sound block in the list.
*
*  When the 'block' pointer is NULL, we create a block of samples, and
*  create a new sound list element which follows it which has a NULL
*  'block' pointer; the 'u' field of the current list element is now
*  interpreted as 'u.next'.
*
*      The client calls SND_get_next to get a pointer to a block of samples.
*      The count of samples generated is returned via a ref parameter, and
*      SND_get_next will not be called again until this set is exhausted.
*
*      The next time SND_get_next is called, it knows that the sample block
*      has been exhausted.  It releases its reference to the block (and if
*      that was the last reference, frees the block to the block allocation
*      pool), allocates a new block from the block pool, and proceeds to
*      fill it with samples.
*
*      Note that as an optimization, if the refcnt field goes to 0 it
*      could immediately re-use the block without freeing back to the block
*      pool and reallocating it.
*
*  Because of the way we handle sound sample blocks, the sound sample blocks
*  themselves are ref-counted, so freeing the snd_list_type may not free
*  the sample block it references.  At the level of this procedure, that
*  is transparently handled by the snd_list_unref function.
*
*  Logical stop:
*
*  Logical stop is handled by several mechanisms.  The /intrinsic/ logical
*  stop is an immutable property of the signal, and is determined by the
*  specification in the algorithm description file.  When it is encountered,
*  the 'logically_stopped' flag of the snd_list_node is set.
*  The generators guarantee that the first time this is encountered, it
*  will always be constructed so that the first sample of the block it
*  references is the logical stop time.
*
*  In addition, the client may have set the /explicit logical stop time/ of
*  the iterator (e.g., in nyquist, the (set-logical-stop sound time) call copies
*  the sound, altering its logical stop).  The logical stop time, when set
*  in this way, causes the logical_stop_cnt ('lsc' in the above diagram)
*  to be set to the count of the last sample to be generated before the
*  <logical stop time.  This will guarantee that the sound will indicate that
*  it has reached its logical stop time when the indicated sample is 
*  generated.
****************************************************************************/

void add_s1_s2_nn_fetch(); /* for debugging */

/* SND_get_first -- the standard fn to get a block, after returning 
 *    the first block, plug in SND_get_next for successive blocks
 */
sample_block_type SND_get_first(sound_type snd, long * cnt)
{
    register snd_list_type snd_list = snd->list;
    /*
     * If there is not a block of samples, we need to generate one.
     */
    if (snd_list->block == NULL) {
	/*
	 * Call the 'fetch' method for this sound_type to generate 
         * a new block of samples.
	 */
        snd_susp_type susp = snd_list->u.susp;

        snd_list->u.next = snd_list_create(susp);
        snd_list->block = internal_zero_block;
	/* printf("SND_get_first: susp->fetch %x\n",
                susp->fetch); */
	(*(susp->fetch))(susp, snd_list);
#ifdef GC_DEBUG
	snd_list_debug(snd_list, "SND_get_first");
#endif
	/* printf("SND_get_first: snd_list %x, block %x, length %d\n",
	       snd_list, snd_list->block, snd_list->block_len); */
    }
    if ((snd->logical_stop_cnt == UNKNOWN) && snd_list->logically_stopped) {
        /* printf("SND_get_first/next: snd %x logically stopped at %d\n",
                snd, snd->current); */
        snd->logical_stop_cnt = snd->current;
    }

    /* see if clipping needs to be applied */
    if (snd->current + snd_list->block_len > snd->stop) {
        /* need to clip: is clip on a block boundary? */
        if (snd->current == snd->stop) {
            /* block boundary: replace with zero sound */
            snd->list = zero_snd_list;
            snd_list_unref(snd_list);
        } else {
            /* not a block boundary: build new list */
            snd->list = snd_list_create((snd_susp_type) zero_snd_list);
            snd->list->block_len = snd->stop - snd->current;
            snd->list->block = snd_list->block;
            snd->list->block->refcnt++;
            snd_list_unref(snd_list);
        }
        snd_list = snd->list; /* used below to return block ptr */
    }

    *cnt = snd_list->block_len;
    /* this should never happen */
    if (*cnt == 0) {
	printf("SND_get_first returned 0 samples\n");
	dbg_mem_print("snd_list info:", snd_list);
	dbg_mem_print("block info:", snd_list->block);
	sound_print_tree(snd);
	abort();
    }
    snd->current += snd_list->block_len;    /* count how many we read */
    snd->get_next = SND_get_next;
    return snd_list->block;
}


sample_block_type SND_get_next(sound_type snd, long * cnt)
{
    register snd_list_type snd_list = snd->list;
    /*
     * SND_get_next is installed by SND_get_first, so we know
     * when we are called that we are done with the current block
     * of samples, so free it now.
     */
    snd_list_type cur = snd_list;
    snd->list = snd_list = cur->u.next;
    snd_list_ref(snd_list);
    snd_list_unref(cur);  /* release the reference to the current block */

    /* now that we've deallocated, we can use SND_get_first to finish the job */
    return SND_get_first(snd, cnt);
}



/****************************************************************************
*                               make_zero_block
* Inputs:
*       ²
* Result: ²
*       ²
* Effect: 
*       ²
****************************************************************************/

sample_block_type make_zero_block(void)
    {
     sample_block_type zb;
     int i;

     falloc_sample_block(zb, "make_zero_block");
     /* leave room for lots more references before overflow, 
        but set the count high so that even a large number of
        dereferences will not lead to a deallocation */
     zb->refcnt = 0x6FFFFFFF;

     for (i = 0; i < max_sample_block_len; i++) 
	{ /* fill with zeros */
	 zb->samples[i] = 0;
	} /* fill with zeros */
     return zb;
    }


/* min_cnt -- help compute the logical stop or terminate as minimum */
/*
 * take the sound (which has just logically stopped or terminated at
 * current sample) and
 * convert the stop sample into the equivalent sample count as produced by
 * susp (which may have a different sample rate).  If the count is less than
 * the current *cnt_ptr, overwrite cnt_ptr with a new minimum.  By calling
 * this when each of S1, S2, ... Sn reach their logical stop or termiate
 * points, *cnt_ptr will end up with the minimum stop count, which is what
 * we want.  NOTE: the logical stop time and terminate for signal addition 
 * should be the MAX of logical stop times of arguments, so this routine 
 * would not be used.
 */
void min_cnt(long *cnt_ptr, sound_type sound, snd_susp_type susp, long cnt)
{
    long c = (((sound->current - cnt) / sound->sr + sound->t0) - susp->t0) *
      susp->sr + 0.5;
    /* if *cnt_ptr is uninitialized, just plug in c, otherwise compute min */
    if ((*cnt_ptr == UNKNOWN) || (*cnt_ptr > c)) {
/*        printf("min_cnt %x: new count is %d\n", susp, c);*/
/*        if (c == 0) sound_print_tree(printing_this_sound);*/
        *cnt_ptr = c;
    }
}



/****************************************************************************
*                                 sound_init
* Result: void
*       
* Effect: 
*       Module initialization
*	Allocates the 'zero block', the infinitely linked block of
*	0-valued sounds.  This is referenced by a list element which
*	refers to itself.
****************************************************************************/

void sound_init(void)
{
    zero_block = make_zero_block();
    internal_zero_block = make_zero_block();

    falloc_snd_list(zero_snd_list, "sound_init");

    zero_snd_list->block = zero_block;
    zero_snd_list->u.next = zero_snd_list;
    zero_snd_list->refcnt = 2;
    zero_snd_list->block_len = max_sample_block_len;
    zero_snd_list->logically_stopped = true;
#ifdef GC_DEBUG
    { long s;
      printf("sound_to_watch: ");
      scanf("%x", &s);
      watch_sound(s);
    }
#endif
#ifdef XLISP_SOUND
   sound_desc = create_desc("SOUND", sound_xlfree, sound_xlprint,
			    sound_xlsave, sound_xlrestore, sound_xlmark);
#endif
}


/* sound_scale -- copy and change scale factor of a sound */
/**/
sound_type sound_scale(double factor, sound_type snd)
{
    sound_type sndcopy = sound_copy(snd);
    sndcopy->scale *= factor;
    return sndcopy;
}




/****************************************************************************
*                            set_logical_stop_time
* Inputs:
*       sound_type sound: The sound for which the logical stop time is
*			  being set
*	time_type  when:  The logical stop time, expressed as an absolute
*			  time.
* Result: void
*       
* Effect: 
*       Converts the time 'when' into a count of samples.
****************************************************************************/

void set_logical_stop_time(sound_type sound, time_type when)
    {
     long n;
     /*
	'when' is an absolute time.  The number of samples to
	be generated is the number of samples between 't0' and
	'when'.

	-----------+---+---+---+---+---+---+---+---+---+
	           |                                |
		   t0                               when
     */
     n = (long) ((when - sound->t0) * sound->sr + 0.5);

     /*
      * n is kept as a local variable for debugging purposes.
      */

     sound->logical_stop_cnt = n;
 }




/* for debugging */
sound_type printing_this_sound = NULL;
void ((**watch_me)()) = NULL;

void set_watch(where)
  void ((**where)());
{
    if (watch_me == NULL) {
        watch_me = where;
        printf("set_watch: watch_me = %lx\n", watch_me);
    }
}


/*
 * additional routines
 */
void sound_print(snd_expr, n)
  LVAL snd_expr;
  long n;
{
    LVAL result;

    xlsave1(result);
    result = xleval(snd_expr);
    if (vectorp(result)) {
        /* make sure all elements are of type a_sound */
        long i = getsize(result);
        while (i > 0) {
            i--;
            if (!exttypep(getelement(result, i), a_sound)) {
                xlerror("sound_print: array has non-sound element",
                         result);
            }
        }
        sound_print_array(result, n);
    } else if (exttypep(result, a_sound)) {
        sound_print_sound(getsound(result), n);
    } else {
        xlerror("sound_print: expression did not return a sound",
                 result);
    }
    xlpop();
}


void sound_print_sound(sound_type s, long n)
{
    int ntotal = 0;
    long blocklen;
    sample_block_type sampblock;

    /* for debugging */
    printing_this_sound = s;

    printf("sound_print: start at time %g\n", s->t0);

    while (ntotal < n) {
	if (s->logical_stop_cnt != UNKNOWN)
	    printf("LST=%d ", s->logical_stop_cnt);
	sound_print_tree(s);
	sampblock = sound_get_next(s, &blocklen);
	if (sampblock == zero_block || blocklen == 0) {
	    break;
	}
        print_sample_block_type("sound_print", sampblock,
				min(blocklen, n - ntotal));
	ntotal += blocklen;
    }
    printf("total samples: %d\n", ntotal);
}


void sound_print_array(LVAL sa, long n)
{
    long blocklen;
    long i, len;
    long upper = 0;
    sample_block_type sampblock;
    time_type t0, tmax;

    len = getsize(sa);
    if (len == 0) {
	printf("sound_print: 0 channels!\n");
	return;
    }

    /* take care of prepending zeros if necessary */
    t0 = tmax = (getsound(getelement(sa, 0)))->t0;
    for (i = 1; i < len; i++) {
	sound_type s = getsound(getelement(sa, i));
	t0 = min(s->t0, t0);
	tmax = max(s->t0, tmax);
    }

    /* if necessary, prepend zeros */
    if (t0 != tmax) {
	printf("prepending zeros to channels: ");
	for (i = 0; i < len; i++) {
            sound_type s = getsound(getelement(sa, i));
	    if (t0 < s->t0) {
		printf(" %d ", i);
		sound_prepend_zeros(s, t0);
	    }
	}
	printf("\n");
    }

    printf("sound_print: start at time %g\n", t0);

    while (upper < n) {
	int i;
        boolean done = true;
	for (i = 0; i < len; i++) {
            sound_type s = getsound(getelement(sa, i));
	    long current = -1;	/* always get first block */
	    while (current < upper) {
		sampblock = sound_get_next(s, &blocklen);
		if (sampblock != zero_block && blocklen != 0) {
          	    done = false;
		}
		current = s->current - blocklen;
		printf("chan %d current %d:\n", i, current);
 		print_sample_block_type("sound_print", sampblock,
                                        min(blocklen, n - current));
		current = s->current;
		upper = max(upper, current);
            }
	}
        if (done) break;
    }
    printf("total: %d samples x %d channels\n", upper, len);
}


/* sound_play -- compute sound, do not retain samples */
/*
 * NOTE: we want the capability of computing a sound without
 * retaining samples.  This requires that no references to
 * the sound exist, but if the sound is passed as an argument,
 * the argument stack will have a reference.  So, we pass in
 * an expression that evaluates to the sound we want.  The
 * expression is eval'd, the result copied (in case the
 * expression was a sound or a global variable and we really
 * want to preserve the sound), and then a GC is run to 
 * get rid of the original if there really are no other 
 * references.  Finally, the copy is used to play the
 * sounds.
 */

void sound_play(snd_expr)
  LVAL snd_expr;
{
    int ntotal;
    long blocklen;
    sample_block_type sampblock;
    LVAL result;
    sound_type s;

    xlsave1(result);
    result = xleval(snd_expr);
    if (!exttypep(result, a_sound)) {
        xlerror("sound_play: expression did not return a sound",
                 result);
    }

    ntotal = 0;
    s = getsound(result);
    /* if snd_expr was simply a symbol, then s now points to
        a shared sound_node.  If we read samples from it, then
        the sound bound to the symbol will be destroyed, so
        copy it first.  If snd_expr was a real expression that
        computed a new value, then the next garbage collection
        will reclaim the sound_node.  We need to explicitly 
        free the copy since the garbage collector cannot find
        it.
    */
    s = sound_copy(s);
    while (1) {
	sampblock = sound_get_next(s, &blocklen);
	if (sampblock == zero_block || blocklen == 0) {
	    break;
	}
        /* print_sample_block_type("sound_play", sampblock, blocklen); */
	ntotal += blocklen;
    }
    printf("total samples: %d\n", ntotal);
    sound_unref(s);
    xlpop();
}


/* sound_print_tree -- print a tree version of sound structure */
/**/
void sound_print_tree(snd)
  sound_type snd;
{
/*    printf("sample_block_free %x\n", sample_block_free);*/
    printf("SOUND PRINT TREE of %x\n", snd);
    sound_print_tree_1(snd, 0);
}


void indent(int n)
{
    while (n-- > 0) printf(" ");
}


void sound_print_tree_1(snd, n)
  sound_type snd;
  int n;
{
    int i;
    snd_list_type snd_list;
    printf("sound_type@%x(%s@%x)t0 %g stop %d sr %g lsc %d scale %g pc %d", snd, 
            (snd->get_next == SND_get_next ? "SND_get_next" :
              (snd->get_next == SND_get_first ? "SND_get_first" : "?")),
            snd->get_next, snd->t0, snd->stop, snd->sr, 
	    snd->logical_stop_cnt, snd->scale, snd->prepend_cnt);
    if (!snd) {
        printf("\n");
        return;
    }
    snd_list = snd->list;
    printf("->snd_list@%x", snd_list);
    if (snd_list == zero_snd_list) {
        printf(" = zero_snd_list\n");
        return;
    }
    for (i = 0; ; i++) {
        if (snd_list == zero_snd_list) {
            if (i > 1) printf(" (skipping %d) ", i-1);
            printf("->zero_snd_list\n");
            return;
        }
        if (!snd_list->block) {
            if (i > 0) printf(" (skipping %d) ", i);
            printf("->\n");
            indent(n + 2);

            printf("susp@%x(%s)toss_cnt %d current %d lsc %d sr %g t0 %g %x\n",
                    snd_list->u.susp, snd_list->u.susp->name,
                    snd_list->u.susp->toss_cnt, snd_list->u.susp->current, snd_list->u.susp->log_stop_cnt,
                    snd_list->u.susp->sr, snd_list->u.susp->t0, snd_list);
/*            printf("HI THERE AGAIN\n");*/
            susp_print_tree(snd_list->u.susp, n + 4);
            return;
        }
        snd_list = snd_list->u.next;
    }
}


#define MAX_CHANNELS 16



/* compute constants p1 and p2:
  pitchconvert(0) * 2 = pitchconvert(12)  - octaves
	  exp(p2) * 2 = exp(12 * p1 + p2)
		    2 = exp(12 * p1)
	       log(2) = 12 * p1

	 p1 = log(2.0)/12;

  pitchconvert(69) gives 440Hz
	  exp(69 * p1 + p2) = 440
	       69 * p1 + p2 = log(440)

	p2 = log(440.0) - (69 * p1);
*/

#define p1 0.0577622650466621
#define p2 2.1011784386926213


double hz_to_step(double hz)
{
    return (log(hz) - p2) / p1;
}


double step_to_hz(steps)
  double steps;
{
    return exp(steps * p1 + p2);
}


/*
 * from old stuff...
 */

#ifdef XLISP_SOUND
static void sound_xlfree(s)
sound_type s;
{
/*    printf("sound_xlfree(%x)\n", s);*/
    sound_unref(s);
}


static void sound_xlprint(fptr, s)
LVAL fptr;
sound_type s;
{
    putatm(fptr, "Sound", s);
}


static void sound_xlsave(fp, s)
FILE *fp;
sound_type s;
{
    printf("sound_save called\n");
}


static unsigned char *sound_xlrestore(fp)
FILE *fp;
{
   printf("sound_restore called\n");
}


/* sound_xlmark -- mark LVAL nodes reachable from this sound */
/**/
void sound_xlmark(s)
sound_type s;
{
    snd_list_type snd_list;
#ifdef TRACESNDGC
    printf("sound_xlmark(%x)\n", s);
#endif
    if (!s) return; /* pointers to sounds are sometimes NULL */
    snd_list = s->list;
    while (snd_list->block != NULL) {
        if (snd_list == zero_snd_list) {
#ifdef TRACESNDGC
            printf(" terminates at zero_snd_list\n");
#endif
            return;
        }
        snd_list = snd_list->u.next;
    }
    if (snd_list->u.susp->mark) {
#ifdef TRACESNDGC
        printf(" found susp (%s) at %x with mark method\n",
	       snd_list->u.susp->name, snd_list->u.susp);
#endif
        (*(snd_list->u.susp->mark))(snd_list->u.susp);
    } else {
#ifdef TRACESNDGC
        printf(" no mark method on susp %x (%s)\n",
	       snd_list->u.susp, snd_list->u.susp->name);
#endif
    }
}


void sound_symbols()
{
   a_sound = xlenter("SOUND");
}


/* The SOUND Type: */


boolean soundp(s)
LVAL s;
{
   return (exttypep(s, a_sound));
}


/* sound_zero - create and return a zero that terminates now */
/**/
sound_type sound_zero(time_type t0,rate_type sr)
{
    sound_type sound;
    falloc_sound(sound, "sound_zero");

    sound->get_next = SND_get_first;
    sound->list = zero_snd_list;
    sound->logical_stop_cnt = sound->current = 0;
    sound->true_t0 = sound->t0 = t0;
    sound->sr = sr;
    sound->scale = 1.0;

    return sound;
}


LVAL cvsound(s)
sound_type s;
{
/*   printf("cvsound(%x)\n", s);*/
   return (cvextern(sound_desc, (unsigned char *) s));
}
#endif
