writemake.lsp

Audacity是一款用於錄音和編輯聲音的、免費的開放源碼軟體。它可以執行於Mac OS X、Microsoft Windows、GNU/Linux和其它作業系統

           (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 ");~%}~%")))