;;************
;; writemake.lsp -- generate the sound create routine
;;************
;;************
;;           Change Log
;;  Date     | Change
;;-----------+--------------------
;; 17-Dec-91 | [1.1] <jmn> Created
;; 17-Dec-91 | [1.1] <jmn> return sound_create(...) cast type to correct
;;           | type
;; 21-Dec-91 | [1.2] <jmn> added start-time, default 0.0
;; 21-Dec-91 | [1.2] <jmn> prefix creation local variables with C_
;; 13-Jan-92 | [1.2] <jmn> reformatted and recommented
;;  3-May-99 | <rbd> modified toss_fetch code to retain proper t0
;;************



;; check-for-no-interpolation - if you see an "s", make sure there
;;     is a corresponding "n", if not use "s" to cover the "n" case. And vice versa.
;; 
(defun check-for-no-interpolation (encoding interpolation-rationale stream)
  ; *cfni-output* used to keep track of newline output
  (setf *cfni-output* nil)
  (check-for-no-interpolation-1 encoding 0 interpolation-rationale stream))

;; Hint: this algorithm constructs the 2^n variations by substituting
;; (or not) 'n' for 's' whereever s'es occur.  The search is cut off
;; however, when an altered string is found in the encoding-list, which
;; tells what cases are handled directly.
;;
;; Wow, returning to the description above after several months, I couldn't make 
;; heads or tails of it, and I wrote it!  Here's another perhaps better, description:
;; 
;; We generated various _fetch routines that differ in their assumptions about how to
;; access signal arguments.  There are (now) 4 variations: NONE, SCALE, INTERP, and
;; RAMP.  All 4^N combinations of these are generated initially, but many combinations
;; are deleted before any code is generated.  Reasons for removing a combination include
;; the use of symetry, linearity, and simply the promise that input arguments will be
;; interpolated externally.  In most of these cases, combinations are removed because
;; they cannot occur in practice.  But in others, combinations are removed because they
;; should be handled by different code.  For example, an input signal matching the output 
;; sample rate and with a scale factor of 1 is normally handled by NONE style 
;; "interpolation".  Note: "interpolation" is used throughout this code, but a better term
;; would be "access method," because no interpolation is involved in the NONE and
;; SCALE variants. The inner loop access code for NONE style is something like "*s++".  
;; However, an input signal suitable for NONE style interpolation can also be handled
;; by SCALE style interpolation (which looks something like "(*s++ * s_scale)", i.e.
;; an extra multiplication is required.  If the attribute INTERNAL-SCALING is used,
;; then the scale factor does not actually appear at the access point because it has been
;; factored into a filter coefficient or some other factor, saving the multiply.  
;; Alternatively, the ALWAYS-SCALE attribute can specify that there is little to be
;; gained by saving a multiply.  In these cases, we want to handle NONE style signals
;; with SCALE style interpolation.  Let's run through these possibilities again and
;; describe how they are handled:
;;
;; ALWAYS-SCALE: here we delete the NONE variant(s) and only generate fetch
;; routines that have scaling code in them.  When we get an actual parameter with
;; a scale factor of 1 (implying NONE interpolation), we handle it with the SCALE
;; fetch routine.
;; INTERNAL-SCALING: here we generate NONE fetch routines because the
;; scale factor is taken care of elsewhere in the code, e.g. in a filter coefficient.
;; LINEAR: here, the scale factor of the actual argument becomes a scale factor
;; on the output (part of the data structure), deferring multiplies until later.  We
;; then modify the argument scale factor to 1, and NONE style interpolation applies.
;; There is no need to generate SCALE style routines, because there will never be
;; any need for them.
;;
;; For a given signal parameter, these 3 cases are mutually exclusive.
;;
;; Looking at these three cases, we see that sometimes there will be SCALE style
;; routines handling NONE arguments, sometimes NONE style routines handling
;; SCALE arguments, and sometimes NONE style routines because there will
;; never be a need for SCALE.  
;; This code is going to generate labels so that other fetch routines 
;; handle the "missing" ones.
;; To do this, we generate extra labels in the case
;; statement that selects the fetch routine (interpolation is in the inner loop in the
;; fetch routine.  For example, we might generate this code:
;; ...
;;  case INTERP_nn:
;;  case INTERP_sn:
;;  case INTERP_ns:
;;  case INTERP_ss: susp->susp.fetch = tonev_ss_fetch; break;
;; ...
;; Here, a single fetch routine (tonev_ss_fetch) handles all variations of NONE and
;; SCALE (n and s) types of the two signal arguments.  The basic rule is: if you did not
;; generate a fetch routine for the NONE case, then handle it with the SCALE case, and
;; if you did not generate a fetch routine for the SCALE case, handle it with the NONE
;; case.
;; 
;; The algorithm uses the list interpolation-rationale, which lists for each sound
;; parameter one of {NIL, LINEAR, ALWAYS-SCALE, INTERNAL-SCALING}.
;; Using this list, the code enumerates all the possible cases that might be handled
;; by the current fetch routine (represented by the "encoding" parameter).  
;; This is a recursive algorithm because, if there are n SCALE type parameters, then
;; there are 2^N possible variations to enumerate.  (E.g. look at the 4 variations in
;; the code example above.)
;;
;;
(defun check-for-no-interpolation-1 (encoding index 
                                     interpolation-rationale stream)
  (cond ((= index (length encoding))
         (display "check-for-no-interpolation output" encoding)
         ; see if we need a newline (*cfni-output* is initially nil)
         (if *cfni-output* (format stream "/* handled below */~%"))
         (setf *cfni-output* t)
         (format stream "      case INTERP_~A: " encoding))
        (t
         (let ((ch (char encoding index)))
           (display "cfni" index ch)
           (cond ((eql ch #\s)
                  (let ((new-encoding (strcat (subseq encoding 0 index)
                                              "n"
                                              (subseq encoding (1+ index)))))
                    (cond ((eq (nth index interpolation-rationale) 'ALWAYS-SCALE)
                           (check-for-no-interpolation-1 new-encoding (1+ index)
                                interpolation-rationale stream)))))
                 ((eql ch #\n)
                  (let ((new-encoding (strcat (subseq encoding 0 index)
                                              "s"
                                              (subseq encoding (1+ index)))))
                    (cond ((eq (nth index interpolation-rationale) 'INTERNAL-SCALING)
                           (check-for-no-interpolation-1 new-encoding (1+ index)
                                interpolation-rationale stream))))))
           (check-for-no-interpolation-1 encoding (1+ index)
                interpolation-rationale stream)))))
                              
;;************
;; is-argument -- see if string is in argument list
;;
;;************

(defun is-argument (arg arguments)
  (dolist (a arguments)
    (cond ((equal arg (cadr a)) (return t)))))



;; needs-mark-routine -- is there anything for GC to mark here?
;;
(defun needs-mark-routine (alg)
  (or (get-slot alg 'sound-names)
      (get-slot alg 'xlisp-pointers)))


;; lsc-needed-p -- see if we need the lsc variable declared
(defun lsc-needed-p (alg)
  (let ((spec (get-slot alg 'logical-stop)))
    (and spec (listp (car spec))
                  (eq (caar spec) 'MIN)
              (cdar spec)
              (cddar spec))))


;; write-initial-logical-stop-cnt -- writes part of snd_make_<name>
;;
(defun write-initial-logical-stop-cnt (alg stream)
  (let ((spec (get-slot alg 'logical-stop))
        min-list)
    (cond ((and spec (listp (car spec))
                    (eq (caar spec) 'MIN)
                (cdar spec))
           (setf min-list (cdar spec))
           ; take stop_cnt from first argument in MIN list
           (format stream
            "    susp->susp.log_stop_cnt = logical_stop_cnt_cvt(~A);\n"
            (symbol-to-name (cadar spec)))
           ; modify stop_cnt to be minimum over all remaining arguments
           (dolist (sym (cddar spec))
             (let ((name (symbol-to-name sym)))
               (format stream
                "    lsc = logical_stop_cnt_cvt(~A);\n" name)
               (format stream
                "    if (susp->susp.log_stop_cnt > lsc)\n"
                name)
               (format stream
                "        susp->susp.log_stop_cnt = lsc;\n"
                name))))
          (t
           (format stream
            "    susp->susp.log_stop_cnt = UNKNOWN;\n")))
))


;;************
;;				  write-mark
;;
;; Inputs:
;;	alg - algorithm description
;;	stream - stream on which to write .c file
;; Effect:
;;	writes NAME_mark(...)
;;************

(defun write-mark (alg stream)
  (let ((name (get-slot alg 'name))
        (sound-names (get-slot alg 'sound-names))
        (xlisp-pointers (get-slot alg 'xlisp-pointers)))
    ;----------------
    ; void NAME_mark(NAME_susp_type susp)
    ; {
    ; *WATCH*: printf("NAME_mark(%x)\n", susp);
    ;----------------
    (format stream "~%~%void ~A_mark(~A_susp_type susp)~%{~%" name name)
    (if *WATCH*
      (format stream
       "    printf(\"~A_mark(%x)\\n\", susp);~%" name))

    ;----------------
    ; for each LVAL argument:
    ;
    ; if (susp->NAME) mark(susp->NAME);
    ;----------------
    (dolist (name xlisp-pointers)
            (format stream "    if (susp->~A) mark(susp->~A);~%" name name))

    ;----------------
    ; for each sound argument:
    ;
    ; *WATCH*: printf("marking SND@%x in NAME@%x\n", susp->snd, susp);
    ; sound_xlmark(susp->NAME);
    ;----------------
    (dolist (snd sound-names)
            (if *watch*
              (format stream
               "    printf(\"marking ~A@%x in ~A@%x\\n\", susp->~A, susp);~%"
               snd name snd))
            (format stream "    sound_xlmark(susp->~A);~%" snd))

    ;----------------
    ; }
    ;----------------
    (format stream "}~%")))

(print 'write-mark)

;;************
;;				  write-make
;;
;; Inputs:
;;	alg - algorithm description
;;	stream - stream on which to write .c file
;; Effect:
;;	writes NAME_free(...), NAME_print_tree,  and snd_make_NAME(...)
;;************

(defun write-make (alg stream)
  (let ((name (get-slot alg 'name))
        (sr (get-slot alg 'sample-rate))
        (else-prefix "")
        first-time
        (sound-names (get-slot alg 'sound-names))
        (logical-stop (car (get-slot alg 'logical-stop)))
        (sound-to-name (get-slot alg 'sound-to-name))
        (state-list (get-slot alg 'state))
        (linear (get-slot alg 'linear))
        (arguments (get-slot alg 'arguments))
        (finalization (get-slot alg 'finalization))
        (interpolation-list (get-slot alg 'interpolation-list))
        (interpolation-rationale (get-slot alg 'interpolation-rationale))
        encoding-list
        (terminate (car (get-slot alg 'terminate)))
        (type-check (car (get-slot alg 'type-check)))
        (delay (get-slot alg 'delay))
        (start (get-slot alg 'start)))

    ;--------------------
    ; void NAME_free(NAME_susp_type susp)
    ; {
    ;----------------
    (format stream "~%~%void ~A_free(~A_susp_type susp)~%{~%"
            name name)

    ;----------------
    ; if there's a finalization, do it
    ;----------------
    (if finalization (print-strings finalization stream))

    ;----------------
    ; for each sound argument:
    ;
    ; sound_unref(susp->NAME);
    ;----------------
    (dolist (name sound-names)
      (format stream "    sound_unref(susp->~A);~%" name))

    ;----------------
    ;     ffree_generic(susp, sizeof(NAME_susp_node), "fn-name");
    ; }
    ;--------------------
    (format stream 
            "    ffree_generic(susp, sizeof(~A_susp_node), \"~A_free\");~%}~%"
            name name)

    ;--------------------
    ; void NAME_print_tree(NAME_susp_type susp, int n)
    ; {
    ;----------------
    (format stream "~%~%void ~A_print_tree(~A_susp_type susp, int n)~%{~%"
            name name)
    ;----------------
    ; for each sound argument:
    ;
    ; indent(n);
    ; printf("NAME:");
    ; sound_print_tree_1(susp->NAME, n);
    ;----------------
    (setf first-time t)
    (dolist (name sound-names)
      (cond (first-time
             (setf first-time nil))
            (t  ; space between each iteration
             (format stream "~%")))
      (format stream "    indent(n);~%    stdputstr(\"~A:\");~%" name)
      (format stream "    sound_print_tree_1(susp->~A, n);~%" name))

    ;----------------
    ; }
    ;--------------------
    (format stream "}~%")

    ;--------------------
    ;   sound_type snd_make_NAME
    ;--------------------

    (format stream "~%~%sound_type snd_make_~A" name)

    ;--------------------
    ;    ( type name, ...)
    ;--------------------

    (write-ansi-parameter-list stream "" arguments)
    (format stream "~%")
    (if (not *ANSI*)
        (dolist (arg arguments)
          (format stream "  ~A ~A;~%" (car arg) (cadr arg))))

    ;--------------------
    ;     NAME_susp_type susp;
    ;--------------------
    (format stream 
     "{~%    register ~A_susp_type susp;~%" name);

    ;; declare "state" variables with TEMP flag
    ;--------------------
    ;     <type[i]> <name[i]>;
    ;--------------------
    (dolist (state state-list)
      (cond ((and (cdddr state)
                  (cadddr state)
                  (eq (cadddr state) 'TEMP))
             (format stream "    ~A ~A;~%" 
                (car state) (cadr state)))))

    (write-sample-rate stream sr sound-names arguments)

    ; compute the t0 for new signal (default: use zero): 
    ;
    (write-start-time stream start arguments)

    ;--------------------
    ;    int interp_desc = 0;
    ;--------------------
    (cond (interpolation-list
           (format stream "    int interp_desc = 0;~%")))

    ;--------------------
    ;     sample_type scale_factor = 1.0F;
    ;  time_type t0_min; -- but only if there are sound args, implied by non-null sound-names
    ;  long lsc;  
    ;--------------------
    (format stream "    sample_type scale_factor = 1.0F;~%")
    (if sound-names (format stream "    time_type t0_min = t0;~%"))
    (if (lsc-needed-p alg)
        (format stream "    long lsc;~%"))

    ; now do canonical ordering of commutable sounds
    ;
    (dolist (lis (get-slot alg 'commutative))
      ;--------------------
      ;   /* sort commuative signals: s1 s2 ... */
      ;   snd_sort_<n>
      ;         (...)
      ;--------------------
      (format stream "    /* sort commutative signals: ~A */~%" lis)
      (format stream "    snd_sort_~A" (length lis))
      (write-parameter-list stream ""
        (append (mapcar 
                  '(lambda (snd) 
                    (strcat "&" (cdr (assoc snd sound-to-name))))
                  lis)
                '("sr")))
      (format stream ";~%~%"))

    ; figure scale factor -- if signal is linear wrt some interpolated or
    ;   ramped signal (which do the multiply anyway), then put the scale
    ;   factor there.
    ;--------------------
    ;  /* combine scale factors of linear inputs <linear> */
    ;--------------------

    (cond (linear
           (format stream 
            "    /* combine scale factors of linear inputs ~A */~%" linear)))
    ;--------------------
    ;  scale_factor *= NAME ->scale;
    ;  NAME ->scale = 1.0F;
    ;--------------------

    (dolist (snd linear)
      (let ((name (cdr (assoc snd sound-to-name))))
        (format stream "    scale_factor *= ~A->scale;~%" name)
        (format stream "    ~A->scale = 1.0F;~%" name)))

    ;--------------------
    ;  /* try to push scale_factor back to a low sr input */
    ;--------------------

    (cond (linear
           (format stream 
            "~%    /* try to push scale_factor back to a low sr input */~%")))

    ;--------------------
    ; if (NAME ->sr < sr) {
    ;     NAME ->scale = scale_factor; scale_factor = 1.0F; }
    ;--------------------

    (dolist (snd linear)
      (let ((name (cdr (assoc snd sound-to-name))))
        (format stream 
"    ~Aif (~A->sr < sr) { ~A->scale = scale_factor; scale_factor = 1.0F; }~%"
         else-prefix name name)
        (setf else-prefix "else ")))
    (if linear (format stream "~%"))

    ;-------------------
    ; insert TYPE-CHECK code here
    ;-------------------
    (display "write-make" type-check)
    (if type-check
      (format stream type-check))

    ;--------------------
    ; falloc_generic(susp, NAME_susp_node, "fn-name"); 
    ;--------------------
    (format stream 
     "    falloc_generic(susp, ~A_susp_node, \"snd_make_~A\");~%" name name)

    ;; initialize state: the state list has (type field initialization [temp])
    ;--------------------
    ;    susp-> <state[i]> = <value[i]>
    ;--------------------
    ;; if TEMP is present, generate:
    ;--------------------
    ;    <state[i]> = <value[i]>
    ;--------------------

    (dolist (state state-list)
      (let ((prefix "susp->"))
        (cond ((and (cdddr state)
                    (cadddr state)
                    (eq (cadddr state) 'TEMP))
               (setf prefix "")))
        (format stream "    ~A~A = ~A;~%" 
                prefix (cadr state) (caddr state))))

    ; if we have a choice of implementations, select one
    (cond ((< 1 (length interpolation-list))

           ;--------------------
           ; /* select a susp fn based on sample rates */
           ;--------------------
           ; build a descriptor
           (format stream 
                "~%    /* select a susp fn based on sample rates */~%")

           ;------------------------
           ;  interp_desc = (interp_desc << 2) + interp_style( NAME, sr);
           ;------------------------
           (dolist (snd sound-names)
             (format stream
              "    interp_desc = (interp_desc << 2) + interp_style(~A, sr);~%"
              snd))

           ;--------------------
           ;     switch(interp_desc) {
           ;--------------------
           (cond (interpolation-list
                  (format stream "    switch (interp_desc) {~%")))

           ;--------------------------
           ;         case INTERP_<encoding>: susp->susp.fetch = 
           ;				          NAME_<encoding>_fetch; break;
           ;--------------------------
           (setf encoding-list (mapcar #'encode interpolation-list))
           (dolist (encoding encoding-list)
             (check-for-no-interpolation encoding interpolation-rationale stream)
             (format stream "susp->susp.fetch = ~A_~A_fetch; break;~%"
              name encoding))

           ;--------------------
           ;        } /* initialize susp state */
           ;-------------------------
           (format stream "    }~%~%"))
          (interpolation-list
           (format stream "    susp->susp.fetch = ~A_~A_fetch;~%" 
            name (encode (car interpolation-list))))
          (t
        ;-------------------------
        ;   susp->susp.fetch = NAME__fetch;
        ;-------------------------
           (format stream "    susp->susp.fetch = ~A__fetch;~%~%" name)))
 
    ;----------------
    ; /* compute terminate count */
    ;----------------
    (cond ((terminate-check-needed terminate alg)
           (cond ((eq (car terminate) 'AT)
                  (let ((time-expr (cadr terminate)))
        ;----------------
        ; susp->terminate_cnt = round(((TIME-EXPR) - t0) * sr);
        ;----------------
                    (format stream 
                     "    susp->terminate_cnt = round(((~A) - t0) * sr);~%"
                            time-expr)))
                 ((eq (car terminate) 'AFTER)
                  (let ((dur-expr (cadr terminate)))
                    ;----------------
                    ; susp->terminate_cnt = round((DUR-EXPR) * sr);
                    ;----------------
                    (format stream 
                            "    susp->terminate_cnt = round((~A) * sr);~%"
                            dur-expr)))
                 (t
                  ;----------------
                  ; susp->terminate_cnt = UNKNOWN;
                  ;----------------
                  (format stream "    susp->terminate_cnt = UNKNOWN;~%")))))

    ;----------------
    ;    /* handle unequal start times, if any */
    ;----------------
    (if sound-names
      (format stream "    /* handle unequal start times, if any */~%"))
    ;----------------
    ; for each sound argument:
    ;    if (t0 < NAME->t0) sound_prepend_zeros(NAME, t0);
    ;----------------
    (dolist (name sound-names)
      (format stream 
       "    if (t0 < ~A->t0) sound_prepend_zeros(~A, t0);~%" name name))
    ;----------------
    ; t0_min = min(NAME1->t0, min(NAME2->t0, ... NAMEn->t0, t0)...);
    ;----------------
    (cond (sound-names
           (format stream "    /* minimum start time over all inputs: */~%")
           (format stream "    t0_min = ")
           (dolist (name sound-names)
             (format stream "min(~A->t0, " name))
           (format stream "t0")
           (dolist (name sound-names)
             (format stream ")"))
           (format stream ";~%")))

    ;----------------
    ;    /* how many samples to toss before t0: */
    ;    susp->susp.toss_cnt = (long) ((t0 - t0_min) * sr + <DELAY>.5);
    ;    if (susp->susp.toss_cnt > 0) {
    ;	susp->susp.keep_fetch = susp->susp.fetch;
    ;	susp->susp.fetch = NAME_toss_fetch;
    ;	t0 = t0_min; -- DELETED 3MAY99 by RBD
    ;    }
    ;----------------
    (cond (sound-names
           (format stream "    /* how many samples to toss before t0: */\n")
           (if delay
             (format stream "    /* Toss an extra ~A samples to make up for internal buffering: */\n" delay))
           (format stream "    susp->susp.toss_cnt = (long) ((t0 - t0_min) * sr + ~A.5);\n"
                   (if delay delay 0))
           (format stream "    if (susp->susp.toss_cnt > 0) {\n")
           (format stream "\tsusp->susp.keep_fetch = susp->susp.fetch;\n")
           (format stream "\tsusp->susp.fetch = ~A_toss_fetch;~%" name)
;	   (format stream "\tt0 = t0_min;~%    }\n\n")))
           (format stream "    }\n\n")))

    ;--------------------
    ; /* initialize susp state */
    ; susp->susp.free = NAME_free;
    ; susp->susp.sr = sr;
    ; susp->susp.t0 = t0;
    ;--------------------
    (format stream "    /* initialize susp state */~%")
    (format stream "    susp->susp.free = ~A_free;~%" name)
    (format stream "    susp->susp.sr = sr;~%")
    (format stream "    susp->susp.t0 = t0;~%")

    ;----------------
    ; if there are sound arguments:
    ;     susp->susp.mark = NAME_mark;
    ; otherwise...
    ;     susp->susp.mark = NULL;
    ;----------------
    (let ((value "NULL"))
      (cond ((needs-mark-routine alg)
             (setf value (strcat name "_mark"))))
      (format stream "    susp->susp.mark = ~A;~%" value))

    ;----------------
    ; for debugging...
    ;    susp->susp.print_tree = NAME_print_tree;
    ;    susp->susp.name = "NAME";
    ;----------------
    (format stream "    susp->susp.print_tree = ~A_print_tree;~%" name)
    (format stream "    susp->susp.name = \"~A\";~%" name)

    ;----------------
    ; if there is a logical stop attribute:
    ; susp->logically_stopped = false;
    ; susp->susp.log_stop_cnt = UNKNOWN;
    ;----------------
    (cond ((logical-stop-check-needed logical-stop)
           (format stream 
            "    susp->logically_stopped = false;\n")))
    (write-initial-logical-stop-cnt alg stream)

    ;--------------------
    ; ramped or interpolated:
    ;
    ;	susp->started = false;
    ;--------------------
    (cond ((any-ramp-or-interp-in interpolation-list)
           (format stream "    susp->started = false;~%")))

    ;--------------------
    ;	susp->susp.current = 0;
    ;--------------------
    (format stream "    susp->susp.current = 0;~%")

    ;----------------------------
    ; For each sound arg:
    ;
    ;     susp-> <arg> = <arg>;
    ;     susp-> <arg>_cnt = 0;
    ;----------------------------

    (dotimes (n (length (get alg 'sound-args)))
      (let ((interpolation (union-of-nth interpolation-list n)))
        (setf arg (nth n sound-names))	; get name of signal
        (format stream "    susp->~A = ~A;~%" arg arg)
        (format stream "    susp->~A_cnt = 0;~%" arg)
        ;-----------------------------------------------
        ; Interpolation: 
        ;
        ;	  susp-> <arg>_pHaSe = 0.0;               
        ;         susp-> <arg>_pHaSe_iNcR = <arg> ->sr    
        ;-----------------------------------------------
        (cond ((member 'INTERP interpolation)
               (format stream "    susp->~A_pHaSe = 0.0;~%" arg)
               (format stream "    susp->~A_pHaSe_iNcR = ~A->sr / sr;~%"
                              arg arg)))
        ;-----------------------------------------------
        ; Ramp: 
        ;
        ;    susp->output_per_<arg> = <arg> ->sr;
        ;-----------------------------------------------

        (cond ((member 'RAMP interpolation)
               (format stream "    susp->~A_n = 0;~%" arg)
               (format stream "    susp->output_per_~A = sr / ~A->sr;~%"
                              arg arg)))))
    
    ;----------------------------
    ;   return sound_create (snd_susp_type)susp, t0, sr, scale_factor);
    ;----------------------------

    (format stream 
     "    return sound_create((snd_susp_type)susp, t0, sr, scale_factor);~%}~%")))


(print 'write-make)

;;************
;; write-parameter-list -- with comma separator, open and close parens
;;
;;************

(defun write-parameter-list (stream prefix strings)
  (let ((comma ""))
    (format stream "(")
    (dolist (parm strings)
      (format stream "~A~A~A" comma prefix parm)
      (setf comma ", "))
    (format stream ")")))

;;************
;; write-ansi-prototype-list -- with comma separator, open and close parens
;;
;; Inputs:
;;	stream - output stream
;;	prefix - arg prefix, perhaps ""
;;	args - argument type/name pairs of the form
;;		( (type1 name1) (type2 name2) ... )
;; Effect:
;;	if *ANSI* is set T, writes ANSI-style parameter list of the form
;;		type name, ...
;;	if *ANSI* is set NIL, writes antique-style parameter list of the form
;;		()
;;************

(defun write-ansi-prototype-list (stream prefix args)
  (let ((comma ""))
    (format stream "(")
    (if *ANSI*
       (dolist (parm args)
          ;--------------------
          ; for each parameter
          ;	<comma>type <prefix><parm>
          ;--------------------
          (format stream "~A~A ~A~A" comma (car parm) prefix (cadr parm))
          (setf comma ", "))
    )
    (format stream ")")))

;;************
;;			   write-ansi-parameter-list
;;
;; Inputs:
;;	stream - output stream
;;	prefix - arg prefix, perhaps ""
;;	args - argument type/name pairs of the form
;;		( (type1 name1) (type2 name2) ... )
;; Effect:
;;	if *ANSI* is set T, writes ANSI-style parameter list of the form
;;		(type name, ...)
;;	if *ANSI* is set NIL, writes antique-style parameter list of the form
;;		(name, ...)
;; Note:
;;  to get a space between types and arguments, a space is prepended to prefix if
;; this is an *ANSI* arg list.
;;************

(defun write-ansi-parameter-list (stream prefix args)
  (let ((comma ""))
    (format stream "(")
    (cond (*ANSI*
           (setf prefix (strcat " " prefix))))
    (dolist (parm args)
            (format stream "~A~A~A~A" comma 
                            (if *ANSI* (car parm) "")
                        prefix (cadr parm))
            (setf comma ", ")
    )
    (format stream ")")))

;;************
;;			       write-sample-rate
;; Effect:
;; 	declare sr and compute the sample rate for the new signal
;; Notes:
;;	If sr is an input parameter, it is not declared
;;	If (SAMPLE-RATE expr) is specified, declare sr to be initialized
;;	   to the expr
;;	If (SAMPLE-RATE (MAX s1 s2 ...)), sr is initialized to the max.
;;	Otherwise, sr is initialized to the max of the sample rates of
;;	all the sound-type arguments	
;;************

(defun write-sample-rate (stream sr sound-names arguments)
    ;; if sr is "sr" and "sr" is a parameter, then do nothing:

    (display "write-sample-rate: " sr sound-names arguments)

    (cond ( (and (equal sr "sr") (is-argument "sr" arguments))
            ;---------------------
            ;   /* sr specified as input parameter */
            ;---------------------
                (format stream "    /* sr specified as input parameter */~%")
          )
    ;; else if sample rate is specified, use it to initialize sr:
          ((stringp sr)
           (display "write-sample-rate: using specified sr" sr)
            ;---------------------
            ;   rate_type sr = <sr>;
            ;---------------------
           (format stream "    rate_type sr = ~A;~%" sr)
          )
    ;; else look for (MAX ...) expression
          ((and (listp sr) (eq (car sr) 'MAX))
           (format stream "    rate_type sr = ")
           (write-redux-of-names stream "max" 
                (mapcar #'symbol-to-name (cdr sr)) "->sr")
           (format stream ";~%")
          )
    ;; else assume sr is max of sr's of all sound arguments
          (sound-names
            ;---------------------
            ;   rate_type sr = max( <arg[0]> ->sr, <arg[i]> ->sr);
            ;---------------------
           (format stream "    rate_type sr = ")	; jmn
           (write-redux-of-names stream "max" sound-names "->sr")
           (format stream ";~%")
          )
           (t
            (error "Missing SAMPLE-RATE specification."))
    )
)
 

(defun write-redux-of-names (stream fn sound-names suffix)
  (dotimes (n (1- (length sound-names)))
           (format stream "~A(" fn))
  (format stream "~A~A" (car sound-names) suffix)
  (dolist (snd (cdr sound-names))
          (format stream ", ~A~A)" snd suffix)))



;;************
;;			       write-start-time
;; Effect:
;; 	declare sr and compute the start time for the new signal
;; Notes:
;;	If t0 is an input parameter, it is not declared
;;	If (START (AT expr)) is specified, declare t0 to be initialized
;;	   to the expr
;;	Otherwise, t0 is initialized to 0
;;************

(defun write-start-time (stream start arguments)
  ;; if t0 is "t0" and "t0" is a parameter, then do nothing:
  (display "write-start time:" start arguments)
  (cond ((is-argument "t0" arguments)
         ;---------------------
         ;   /* t0 specified as input parameter */
         ;---------------------
             (format stream "    /* t0 specified as input parameter */~%"))
    ;; else if start time is specified, use it to initialize sr:
        (t (cond (start
                  ;---------------
                  ;   (START (AT <expr>)) specified:
                  ;
                  ;   time_type t0 = <expr>;
                  ;---------------
                  (setf start (car start))
                  (cond ((eq (car start) 'AT)
                         (format stream "    time_type t0 = ~A;~%" (cadr start)))
                        ((eq (car start) 'MIN)
                         (format stream "    time_type t0 = ")
                         (write-redux-of-names stream "min" 
                                               (c-names (cdr start)) "->t0")
                         (format stream ";~%"))
                        ((eq (car start) 'MAX)
                         (format stream "    time_type t0 = ")
                         (write-redux-of-names stream "max" 
                                               (c-names (cdr start)) "->t0")
                         (format stream ";~%"))
                        (t (error (format nil
                            "Unrecognized START specification ~A" start)))))
                ;---------------
                ;   time_type t0 = 0.0;
                ;---------------
                (t (format stream "    time_type t0 = 0.0;~%"))))))


;; c-names -- get the C names corresponding to list of symbols
;;
(defun c-names (syms) (mapcar '(lambda (sym) (string-downcase (symbol-name sym))) syms))

(defun is-table (alg snd)
  (dolist (table (get-slot alg 'table))
    (cond ((equal snd table)
           (display "is-table" snd table)
           (return t)))))

 
;; write-xlmake -- write out a function snd_NAME to be called by xlisp
;
; this function copies any sound arguments and passes them on to snd_make_NAME
;
(defun write-xlmake (alg stream)
  (let ((name (get-slot alg 'name))
        (sound-names (get-slot alg 'sound-names))
        (arguments (get-slot alg 'arguments))
        comma)
    ;--------------------
    ;   sound_type snd_NAME
    ;--------------------

    (format stream "~%~%sound_type snd_~A" name)

    ;--------------------
    ;    ( type name, ...)
    ;    {
    ;--------------------

    (write-ansi-parameter-list stream "" arguments)
    (format stream "~%")
    (if (not *ANSI*)
        (dolist (arg arguments)
          (format stream "  ~A ~A;~%" (car arg) (cadr arg))))
    (format stream "{~%")

    ;----------------
    ; for each sound argument that is not a table
    ;     sound_type SND_copy = sound_copy(SND);
    ;----------------

    (dolist (arg arguments)
      (cond ((equal (car arg) "sound_type")
             (let ((snd (cadr arg)))
                (cond ((not (is-table alg snd))
                       (format stream 
                               "    sound_type ~A_copy = sound_copy(~A);~%"
                               snd snd)))))))

    ;----------------
    ; now call snd_make_ALG. When SND is a sound_type that is not a table,
    ;  substitute SND_copy for SND.
    ;----------------

    (format stream "    return snd_make_~A(" name)
    (setf comma "")
    (dolist (arg arguments)
      (let ((suffix ""))
        (cond ((and (equal (car arg) "sound_type")
                    (not (is-table alg (cadr arg))))
               (setf suffix "_copy")))
        (format stream "~A~A~A" comma (cadr arg) suffix)
        (setf comma ", ")))
    (format stream ");~%}~%")))