translate.lsp

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

;*************
;           Change Log
;  Date     | Change
;-----------+------------------------------------
; 18-Dec-91 | [1.2] <jmn> Created
; 18-Dec-91 | [1.2] <jmn> added *ANSI* tests
; 13-Jan-92 | [1.2] <jmn> ANSI header includes stdlib.h, excludes decl of
;           | malloc
; 13-Jan-92 | [1.2] <jmn> upgraded to support new sound block structure
; 15-Jan-92 | [1.2] <jmn> added declarations for UNKNOWN, isunknown()
; 15-Jan-92 | [1.2] <jmn> commented out boolean, true, false now declared
;           | in sound.h
;*************
;; translate.lsp -- build signal processing code from high level descr.

(setf *ANSI* t)
(setf *debug* t)

;;**********
;;	combinations - generate all combinations
;; Inputs:
;;	n - number of combinations to generate
;; Result:
;;	list of the form
;;	( (a1 b1) (a2 b2) (a3 b3) ... (an bn) )
;;	
;;**********

(defun combinations (n)
  (let (comb)
    (cond ((eq n 0) '(nil))
      (t
       (setf comb (combinations (1- n)))
       (append (insert 'ramp comb)
           (insert 'interp comb)
           (insert 'scale comb)
           (insert 'none comb))))))

(print 'comb)

(defun lt () (load "translate"))
(defun ls () (load "writesusp"))
(defun lm () (load "writemake"))
(defun lo () (load "writetoss"))
(defun li () (load "innerloop"))

(defun ma () (translate "partial"))
(defun mb () (translate "buzz"))
(defun mal () (translate "alpass"))
(defun mf () (translate "follow"))
(defun mfas () (translate "fromarraystream"))
(defun mfo () (translate "fromobject"))
(defun mp () (translate "prod"))
(defun mc () (translate "const"))
(defun mct () (translate "coterm"))
(defun mcl () (translate "clip"))
(defun me () (translate "exp"))
(defun mg () (translate "gate"))
;(defun mr () (translate "ramp"))
(defun ms () (translate "sine"))
(defun msh () (translate "shape"))
(defun mpw () (translate "pwl"))
;(defun msfr () (translate "sfread"))
(defun mde () (translate "delay"))
(defun mdcv () (translate "delaycv"))
; note: downproto is hand retouched to make downsample
;(defun md () (translate "downproto"))
(defun mu () (translate "upsample"))
(defun ml () (translate "scale"))
(defun mlo () (translate "log"))
(defun mm () (translate "maxv"))
(defun mo () (translate "osc"))
(defun mof () (translate "offset"))
(defun mam () (translate "amosc"))
(defun mfm () (translate "fmosc"))
(defun mi () (translate "integrate"))
(defun msl () (translate "slope"))
(defun mw () (translate "white"))
(defun mt () (translate "tone"))
(defun mta () (translate "tapv"))
(defun mat () (translate "atone"))
(defun mre () (translate "reson"))
(defun mrec () (translate "recip"))
(defun mar () (translate "areson"))
(defun mtv () (translate "tonev"))
(defun matv () (translate "atonev"))
(defun mrvc () (translate "resonvc"))
(defun mrcv () (translate "resoncv"))
(defun marvc () (translate "aresonvc"))
(defun marcv () (translate "aresoncv"))
(defun mrvv () (translate "resonvv"))
(defun marvv () (translate "aresonvv"))
(defun msa () (translate "sampler"))
(defun msio () (translate "siosc"))
(defun mq () (translate "quantize"))
(defun mbq () (translate "biquad"))

(defun mifft () (translate "ifft"))

(defun mcg () (translate "congen"))
(defun mcv () (translate "convolve"))
(defun mos () (translate "oneshot"))
(defun mch () (translate "chase"))
(defun mpl () (translate "pluck"))

(defun m () (mf) (mp) (mc) (mcl) (mg)
;;;;;;      (mr) (msfr) (md)
        (mm) (ms) (msh) (mpw) (ma) (mb) (mde) (mdcv)
        (mi) (mu) (ml) (mlo)
        (mo) (mof) (mam) (mfm) (mw) (msl) (mt) (mat) (mre) (mrec)
        (mar) (mtv)	(mta) (matv) (mrvc) (mrcv) (marvc) (marcv)
            (mrvv) (marvv) (me) (msa) (msio) (mq) (mcg) (mifft) 
            (mfas) (mfo) (mct) (mcv) (mal) (mos) (mch) (mbq) (mpl))

; call this when you change writesusp.lsp: "N"ew "S"usp
(defun ns () (ls) (m))
; call this when you change writemake.lsp:
(defun nm () (lm) (m))
; call this when you change innerloop.lsp:
(defun ni () (li) (m))


;;**********
;; any-ramp-in -- see if interpolation-list has 'ramp
;;
;; note: lis is a list of lists of atoms
;;**********
(defun any-ramp-in (lis)
  (dolist (spec lis)
    (cond ((member 'RAMP spec)
       (return t)))))


;;**********
;; any-ramp-or-interp-in -- see if interpolation-list has 'ramp or 'interp
;;
;;**********
(defun any-ramp-or-interp-in (lis)
  (or (any-ramp-in lis)
      (dolist (spec lis)
    (cond ((member 'INTERP spec)
           (return t))))))


;;**********
;; encode -- come up with ascii string for interp spec
;;
;; e.g. (none ramp) -> "nr"
;;
;;**********
(defun encode (interpolation)
  (let (first-letter 
    (result ""))
    (dolist (interp interpolation)
      (setf first-letter (string (char (symbol-name interp) 0)))
      (setf result (strcat result first-letter)))
    (string-downcase result)))


;; ****************
;;	header-list
;;
;; Result:
;;	'( "s1" "s2" ... "sn" )
;; 	where s1, s2, etc. are the strings for the header part of the
;;	resulting .c file
;; Notes:
;;	Kludgy.  Fix this up for easier maintenance
;; ****************

(if *ANSI* 
    ; ANSI
    (setf header-list 
     '("#include \"stdio.h\"\n"
       "#ifndef mips\n"
       "#include \"stdlib.h\"\n"
       "#endif\n"
       "#include \"xlisp.h\"\n"                             
       "#include \"sound.h\"\n\n"
       "#include \"falloc.h\"\n"
       "#include \"cext.h\"\n"
       ))
    ; non-ANSI
    (setf header-list 
     '("#include \"stdio.h\"\n"
       "#include \"xlisp.h\"\n"                             
       "#include \"sound.h\"\n"
       "#include \"falloc.h\"\n")))


(setf h-boilerplate nil)

;--------------obsolete boilerplate-------------
;; Note that we use "-1" and "< 0".  We rely upon C's semantics to
;; make this work correctly if it is being assigned to a long, float, or
;; double, and if a long, float, or double is being compared
;      '("\n#ifndef UNKNOWN\n"
;	"#define UNKNOWN -1\n"
;	"#define isunknown(x) ( (x) < 0)\n"
;	"#endif /* UNKNOWN */\n"))
;-------------------------


;;**********
;; code-gen -- do the output
;;
;; Inputs:
;;	alg -
;;	stream -
;;	hstream -
;;**********

(defun code-gen (alg stream hstream)
  (let (interpolation-list
    (support-functions (get-slot alg 'support-functions))
    (support-header    (get-slot alg 'support-header))
    (name (get-slot alg 'name)))
    ;(display "code-gen: " alg stream hstream)
    (print-strings header-list stream)
    (format stream "#include \"~A\"~%" (get-slot alg 'hfile))
    (display "code-gen: printed header")
    (format stream "~%void ~A_free();~%" name)
    (setf interpolation-list (make-interpolation-list alg))
    (display "code-gen: " interpolation-list)
    (put-slot alg interpolation-list 'interpolation-list)
    (put-slot alg (make-interpolation-rationale alg) 
          'interpolation-rationale)
      
    (write-typedef alg stream)
    (display "code-gen: wrote typedef")

    (cond (support-functions
       (format stream "~%~A" support-functions)))

    (dolist (interpolation interpolation-list)
      (put-slot alg interpolation 'interpolation)
      (display "code-gen: going to write susp for " interpolation)
      (write-susp alg stream)
      (display "code-gen: wrote susp for" interpolation))

    ;; this is a special case for no sound arguments
    (cond ((null interpolation-list)
       (write-susp alg stream)))

    ;; write the function that is called to read and toss
    ;; samples up to the start time (but only if there are sound arguments)
    (cond ((get-slot alg 'sound-names)
       (write-toss alg stream)))

    ;; write the GC marking function        
    (cond ((needs-mark-routine alg)
       (write-mark alg stream)))

    (write-make alg stream)
    (display "code-gen: wrote make")

    (write-xlmake alg stream)
    (display "code-gen: wrote xlmake")

    (write-header alg hstream)
    (cond ( support-header
            (print-strings support-header hstream)))
    (print-strings h-boilerplate hstream)
    (display "code-gen: wrote header")))


;;**********
;; commute-check -- 
;;
;; Purpose:
;; 	see if interpolation spec is redundant due to commutativity
;; Algorithm: 
;;	for each list of "commutable" sounds, make sure spec asks for
;;	cannonical ordering:  NONE > SCALE > INTERP > RAMP
;;**********
(defun commute-check (alg spec)
  (let ((sounds (get-slot alg 'sound-args))
    (commute-list (get-slot alg 'commutative))
    (result t)
    s1 s2)
    (dolist (commute commute-list)
      (dotimes (n (1- (length commute)))  ; look at all pairs
    (setf s1 (nth n commute))
    (setf s2 (nth (1+ n) commute))
    (setf s1 (index s1 sounds))
    (setf s2 (index s2 sounds))
    (setf s1 (nth s1 spec))
    (setf s2 (nth s2 spec))
    (cond ((< (eval s1) (eval s2))
           (setf result nil)
           (return)))))
    result))

(setf NONE 4) (setf SCALE 3) (setf INTERP 2) (setf RAMP 1)


(print 'ramp)


;;**********
;; concatenate -- string concatenation
;;
;; Inputs:
;;	"s1" - string
;;	"s2" - string
;; Result:
;;	"s1s2"
;;**********

(defun concatenate (type s1 s2)
    (cond ((eq type 'string) (strcat s1 s2))
          (t (error "concatenate type"))))


;;**********
;; get-slot -- access the algorithm description, return single value
;;
;;**********

(setfn get-slot get)


;;**********
;; index -- find location of list element
;;
;; Inputs:
;;	atom - atom to be found in list
;;	lis  - list searched for
;; Result:
;;	integer - index of atom in lis
;;	NIL	- atom not member of lis
;;**********

(defun index (atom lis)
  (let ((i 0))
    (dolist (elt lis)
      (cond ((eq elt atom)
         (return i)))
      (setf i (1+ i)))))


;;**********
;; insert -- insert an atom at the front of each element of a list
;;
;; Inputs:
;;	atom - 
;;	list-of-lists - lists of the form ( (L1) (L2) ... (Ln))
;; Result:
;;	( (atom L1) (atom L2) ... (atom Ln) )
;;**********
(defun insert (atom list-of-lists)
  (mapcar '(lambda (lis) (cons atom lis)) list-of-lists))

(print 'insert)

;; interp-check -- check to see that no interpolation is being done
;;   (unless the algorithm is the up-sample algorithm, a special case
;;
(defun interp-check (alg spec)
  (or *INLINE-INTERPOLATION*
      (get alg 'inline-interpolation)
      (and (not (member 'INTERP spec))
       (not (member 'RAMP spec)))))
    
(print 'interp-check)


;;**********
;; make-interpolation-list -- figure out the possible interpolation forms
;;
;; Inputs:
;;	 alg - algorithm description
;; Output:
;;  List of interpolation styles, e.g. 
;;  ((NONE NONE) (NONE INTERP) (NONE RAMP)), where the styles
;; are in the same order as the sound arguments (sound-args)
;; 
;;**********
(defun make-interpolation-list (alg)
  (let (sound-args specs real-specs sound-names sound-to-name
    (sr (get-slot alg 'sample-rate))
    (not-in-inner-loop (get-slot alg 'not-in-inner-loop)))
    ; derive some lists:
    ;   sound-args are atom names of sound-type arguments
    ;   sound-names are the corresponding string names
    ;   sound-to-name is an assoc list mapping atom to case-sensitive string
;    (display "make-interpolation-list")

    (dolist (arg (get-slot alg 'arguments))
    (cond ((and (equal (car arg) "sound_type")
            (not (member (cadr arg) not-in-inner-loop :test #'equal)))
           (setf sound-names (cons (cadr arg) sound-names))
           (setf sound-args (cons (name-to-symbol (cadr arg))
                      sound-args))
           (setf sound-to-name (cons (cons (car sound-args)
                           (car sound-names))
                     sound-to-name))
;	       (display "in make-interpolation-list" sound-to-name)
          )))
;    (display "make-interpolation-list: " (reverse sound-args))
    (put-slot alg (reverse sound-args) 'sound-args)
;    (display "make-interpolation-list: " (reverse sound-names))
    (put-slot alg (reverse sound-names) 'sound-names)
    (put-slot alg sound-to-name 'sound-to-name)
    ; make all combinations of interpolations
    (setf specs (combinations (length sound-args)))
    (display "make-interpolation-list: " specs)
    ; reject combinations based on commutativity, linearity, and sample rate:
    ; if sample-rate is not specified, then some interpolation must be 'NONE,
    ; i.e. sample-rate is specified OR an interpolation is 'NONE:
    ; if INLINE-INTERPOLATION is turned off, don't allow RAMP or INTERP
     ; if INTERNAL-SCALING applies, then don't allow SCALE
    (dolist (spec specs)
    (cond ((and spec
            (interp-check alg spec)
            (commute-check alg spec)
            (scale-check alg spec)
            (sr-check alg spec))
           (setf real-specs (cons spec real-specs)))))
    (cond ((and (car specs) (null real-specs))
       (error "no interpolation specs")))
    (print real-specs)))


; MAKE-INTERPOLATION-RATIONALE -- record the rationale for
; interpolation combinations:
;   NIL means no special considerations
;   ALWAYS-SCALE means 'n' eliminated, use 's' instead
;   LINEAR means 's' eliminated and unnecessary
;   INTERNAL-SCALING means 's' eliminated, use 'n' instead
;
(defun make-interpolation-rationale (alg)
  (let (interpolation-rationale len snd
    (sounds (get-slot alg 'sound-args))
    (linear (get-slot alg 'linear))
    (internal-scaling (get-slot alg 'internal-scaling))
    (always-scale (get-slot alg 'always-scale)))
    (setf interpolation-rationale (mapcar #'return-nil sounds))
    (setf len (length interpolation-rationale))
    (dotimes (n len)
         (setf snd (nth n sounds))
         (cond ((member snd always-scale)
            (setf (nth n interpolation-rationale) 'ALWAYS-SCALE)))
         (cond ((member snd linear)
            (cond ((nth n interpolation-rationale)
               (error "parameter is both linear and always-scale"
                  snd)))
            (setf (nth n interpolation-rationale) 'LINEAR)))
         (cond ((member snd internal-scaling)
            (cond ((nth n interpolation-rationale)
               (error 
 "parameter is both linear and always-scale or internal-scaling" snd)))
            (setf (nth n interpolation-rationale) 'INTERNAL-SCALING))))
    (display "make-interpolation-rationale" interpolation-rationale)
    interpolation-rationale))


(print 'hi)

;;**********
;; make-schema-from-slots -- take attr/value pairs and make property list
;;
;; Inputs:
;;	slots - a list of the form 
;;			(name
;;			   (attribute1 value1) (attribute2 value2)
;;					... (attributen valuen) )
;; Result:
;;	The atom 'name' with the attached property list
;; Effect:
;;	Adds properties to the atom 'name' based on the attribute-value
;;	pairs. 
;; Notes:
;;	The property-list representation is chosen for time efficiency of
;;	access
;;**********

(defun make-schema-from-slots (slots)
  (let ((name (car slots)))
    (setf (symbol-plist name) nil)
    (dolist (slot (cdr slots))