Update of /cvsroot/audacity/audacity-src/nyquist
In directory 23jxhf1.ch3.sourceforge.com:/tmp/cvs-serv14284
Modified Files:
dspprims.lsp fileio.lsp nyinit.lsp nyquist.lsp sal-parse.lsp
sal.lsp xm.lsp
Log Message:
Updating to Nyquist v3.03.
Index: sal-parse.lsp
===================================================================
RCS file: /cvsroot/audacity/audacity-src/nyquist/sal-parse.lsp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- sal-parse.lsp 30 Jan 2009 00:54:45 -0000 1.1
+++ sal-parse.lsp 5 Mar 2009 17:42:25 -0000 1.2
@@ -393,7 +393,7 @@
(setf delimiter-stack nil)
(setf delimiter-mismatch nil))
(defun delimiter-match (tok what)
- (cond ((eql (first delimiter-stack) what)
+ (cond ((eql (token-string (first delimiter-stack)) what)
(pop delimiter-stack))
((null delimiter-mismatch)
;(display "delimiter-mismatch" tok)
@@ -401,7 +401,7 @@
(defun delimiter-check (tok)
(let ((c (token-string tok)))
(cond ((member c '(#\( #\{ #\[))
- (push c delimiter-stack))
+ (push tok delimiter-stack))
((eql c +rbrace+)
(delimiter-match tok +lbrace+))
((eql c +rparen+)
@@ -1423,18 +1423,20 @@
;; PARSE-ASSIGN -- based on parse-bind, but with different operators
;;
+;; allows arbitrary term on left because it could be an array
+;; reference. After parsing, we can check that the target of the
+;; assignment is either an identifier or an (aref ...)
+;;
(defun parse-assign ()
- (let (id op val)
- (if (token-is :id)
- (setf id (token-lisp (parse-token)))
- (errexit "expected a variable name"))
- ;; if it's id[expr], replace id with (aref id expr)
- (setf id (maybe-aref id))
+ (let ((lhs (parse-term) op val))
(cond ((token-is '(:= :-= :+= :*= :/= :&= :@= :^= :<= :>=))
(setf op (parse-token))
(setf op (if (eq (token-type op) ':=) '= (token-lisp op)))
(setf val (parse-sexpr))))
- (list id op val)))
+ (cond ((and (consp lhs) (eq (car lhs) 'aref))) ;; aref good
+ ((symbolp lhs)) ;; id good
+ (t (errexit "expected a variable name or array reference")))
+ (list lhs op val)))
(defun maybe-parse-loop ()
@@ -1602,6 +1604,8 @@
(list binding term-test)))
+;; parse-sexpr works by building a list: (term op term op term ...)
+;; later, the list is parsed again using operator precedence rules
(defun parse-sexpr (&optional loc)
(let (term rslt)
(push (parse-term) rslt)
@@ -1622,7 +1626,17 @@
(third (assoc op +operators+)))
-(defun parse-term ()
+;; a term is <unary-op> <term>, or
+;; ( <sexpr> ), or
+;; ? ( <sexpr> , <sexpr> , <sexpr> ), or
+;; <id>, or
+;; <id> ( <args> ), or
+;; <term> [ <sexpr> ]
+;; Since any term can be followed by indexing, handle everything
+;; but the indexing here in parse-term-1, then write parse-term
+;; to do term-1 followed by indexing operations
+;;
+(defun parse-term-1 ()
(let (sexpr id)
(cond ((token-is '(:- :!))
(list (token-lisp (parse-token)) (parse-term)))
@@ -1642,9 +1656,9 @@
(token-lisp (parse-token)))
((token-is :id) ;; aref or funcall
(setf id (token-lisp (parse-token)))
- (cond ((token-is :lb)
- (setf id (maybe-aref id)))
- ((token-is :lp)
+ ;; array indexing was here, but that only allows [x] after
+ ;; identifiers. Move this to expression parsing.
+ (cond ((token-is :lp)
(parse-token)
(setf sexpr (cons id (parse-pargs t)))
(if (token-is :rp)
@@ -1656,15 +1670,16 @@
(errexit "expression not found")))))
-(defun maybe-aref (id)
- (cond ((token-is :lb)
- (parse-token)
- (setf id
- (list 'aref id (parse-sexpr)))
- (if (token-is :rb)
- (parse-token)
- (errexit "right bracket not found"))))
- id)
+(defun parse-term ()
+ (let ((term (parse-term-1)))
+ ; (display "parse-term" term (token-is :lb))
+ (while (token-is :lb)
+ (parse-token)
+ (setf term (list 'aref term (parse-sexpr)))
+ (if (token-is :rb)
+ (parse-token)
+ (errexit "right bracket not found")))
+ term))
(defun parse-ifexpr ()
Index: fileio.lsp
===================================================================
RCS file: /cvsroot/audacity/audacity-src/nyquist/fileio.lsp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- fileio.lsp 30 Jan 2009 00:54:45 -0000 1.1
+++ fileio.lsp 5 Mar 2009 17:42:25 -0000 1.2
@@ -20,7 +20,7 @@
(setdir "e:\\tmp\\")
(setdir "e:\\temp\\")
(get-temp-path)))
- (format t "Set *default-sf-dir* to ~A in fileio.lsp~%"
+ (format t "Set *default-sf-dir* to \"~A\" in fileio.lsp~%"
*default-sf-dir*)
(setdir current))))
@@ -143,6 +143,8 @@
;; the *autonorm-target*
;;
(defun autonorm-update (peak)
+ (cond ((> peak 1.0)
+ (format t "*** CLIPPING DETECTED! ***~%")))
(cond ((and *autonormflag* (> peak 0.0))
(setf *autonorm-previous-peak* (/ peak *autonorm*))
(setf *autonorm* (/ *autonorm-target* *autonorm-previous-peak*))
@@ -151,10 +153,12 @@
(format t (if (eq *autonorm-type* 'PREVIOUS)
" new normalization factor is ~A~%"
" suggested normalization factor is ~A~%")
- *autonorm*)
- *autonorm-previous-peak*
- )
- (t peak)
+ *autonorm*))
+ (t
+ (format t "Peak was ~A,~%" peak)
+ (format t " suggested normalization factor is ~A~%"
+ (/ *autonorm-target* peak)))
+ peak
))
;; s-read -- reads a file
Index: xm.lsp
===================================================================
RCS file: /cvsroot/audacity/audacity-src/nyquist/xm.lsp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- xm.lsp 30 Jan 2009 00:54:46 -0000 1.1
+++ xm.lsp 5 Mar 2009 17:42:25 -0000 1.2
@@ -1046,6 +1046,7 @@
(dotimes (i order)
(push (nth i rule) pattern))
(push (cons (reverse pattern) entry) rules)))
+ (setf rules (reverse rules)) ;; keep rules in original order
(setf *rslt* nil) ;; in case produces is nil
(cond ((and produces (not (is-produces-homogeneous produces)))
(setf produces (make-produces-homogeneous produces))))
@@ -1096,6 +1097,7 @@
(send markov-class :answer :find-rule '()
'((let (rslt)
+ ;(display "find-rule" rules)
(dolist (rule rules)
;(display "find-rule" state rule)
(cond ((markov-match state (car rule))
@@ -1111,8 +1113,29 @@
'((if (null count)
(setf count len))))
+(defun markov-general-rule-p (rule)
+ (let ((pre (car rule)))
+ (cond ((< (length pre) 2) nil) ;; 1st-order mm
+ (t
+ ;; return false if any member not *
+ ;; return t if all members are *
+ (dolist (s pre t)
+ (if (eq s '*) t (return nil)))))))
+
+(defun markov-find-state-leading-to (target rules)
+ (let (candidates)
+ (dolist (rule rules)
+ (let ((targets (cdr rule)))
+ (dolist (targ targets)
+ (cond ((eql (car targ) target)
+ (push (car rule) candidates))))))
+ (cond (candidates ;; found at least one
+ (nth (random (length candidates)) candidates))
+ (t
+ nil))))
+
(send markov-class :answer :advance '()
- '((let (rule sum target rslt)
+ '((let (rule sum target rslt new-state)
;(display "markov" pattern rules)
(setf rule (send self :find-rule))
;(display "advance 1" rule)
@@ -1121,6 +1144,21 @@
(setf sum (markov-sum-of-weights rule))
;; the target can be a pattern, so apply NEXT to it
(setf target (next (markov-pick-target sum rule)))
+ ;; if the matching rule is multiple *'s, then this
+ ;; is a higher-order Markov model, and we may now
+ ;; wander around in parts of the state space that
+ ;; never appeared in the training data. To avoid this
+ ;; we violate the strict interpretation of the rules
+ ;; and pick a random state sequence from the rule set
+ ;; that might have let to the current state. We jam
+ ;; this state sequence into state so that when we
+ ;; append target, we'll have a history that might
+ ;; have a corresponding rule next time.
+ (cond ((markov-general-rule-p rule)
+ (setf new-state (markov-find-state-leading-to target rules))
+ (cond (new-state
+ ;(display "state replacement" new-state target)
+ (setf state new-state)))))
(setf state (append (cdr state) (list target)))
;(display "markov next" rule sum target state)
;; target is the symbol for the current state. We can
@@ -1360,7 +1398,7 @@
;; stack if the list is sorted because (apparently) the pivot points
;; are not random.
(cond ((not (score-sorted sg:seq))
- (setf sg:seq (sort sg:seq #'event-before))))
+ (setf sg:seq (bigsort sg:seq #'event-before))))
(cond ((and sg:seq (null sg:end))
(setf sg:end (event-end (car (last sg:seq)))))
((null sg:end)
@@ -1519,7 +1557,72 @@
(defun event-before (a b)
(< (car a) (car b)))
-
+;; bigsort -- a sort routine that avoids recursion in order
+;; to sort large lists without overflowing the evaluation stack
+;;
+;; Does not modify input list. Does not minimize cons-ing.
+;;
+;; Algorithm: first accumulate sorted sub-sequences into lists
+;; Then merge pairs iteratively until only one big list remains
+;;
+(defun bigsort (lis cmp) ; sort lis using cmp function
+ ;; if (funcall cmp a b) then a and b are in order
+ (prog (rslt sub pairs)
+ ;; first, convert to sorted sublists stored on rslt
+ ;; accumulate sublists in sub
+ get-next-sub
+ (if (null lis) (go done-1))
+ (setf sub (list (car lis)))
+ (setf lis (cdr lis))
+ fill-sub
+ ;; invariant: sub is non-empty, in reverse order
+ (cond ((and lis (funcall cmp (car sub) (car lis)))
+ (setf sub (cons (car lis) sub))
+ (setf lis (cdr lis))
+ (go fill-sub)))
+ (setf sub (reverse sub)) ;; put sub in correct order
+ (setf rslt (cons sub rslt)) ;; build rslt in reverse order
+ (go get-next-sub)
+ done-1
+ ;; invariant: rslt is list of sorted sublists
+ (if (cdr rslt) nil (go done-2))
+ ;; invariant: rslt has at least one list
+ (setf pairs rslt)
+ (setf rslt nil)
+ merge-pairs ;; merge a pair and save on rslt
+ (if (car pairs) nil (go end-of-pass)) ;; loop until all pairs merged
+ ;; invariant: pairs has at least one list
+ (setf list1 (car pairs)) ;; list1 is non-empty
+ (setf list2 (cadr pairs)) ;; list2 could be empty
+ (setf pairs (cddr pairs))
+ (cond (list2
+ (setf rslt (cons (list-merge list1 list2 cmp) rslt)))
+ (t
+ (setf rslt (cons list1 rslt))))
+ (go merge-pairs)
+ end-of-pass
+ (go done-1)
+ done-2
+ ;; invariant: rslt has one sorted list!
+ (return (car rslt))))
+
+(defun list-merge (list1 list2 cmp)
+ (prog (rslt)
+ merge-loop
+ (cond ((and list1 list2)
+ (cond ((funcall cmp (car list1) (car list2))
+ (setf rslt (cons (car list1) rslt))
+ (setf list1 (cdr list1)))
+ (t
+ (setf rslt (cons (car list2) rslt))
+ (setf list2 (cdr list2)))))
+ (list1
+ (return (nconc (reverse rslt) list1)))
+ (t
+ (return (nconc (reverse rslt) list2))))
+ (go merge-loop)))
+
+
;; SCORE-SORT -- sort a score into time order
;;
(defun score-sort (score &optional (copy-flag t))
@@ -1527,7 +1630,7 @@
(let ((begin-end (car score)))
(setf score (cdr score))
(if copy-flag (setf score (append score nil)))
- (cons begin-end (sort score #'event-before))))
+ (cons begin-end (bigsort score #'event-before))))
;; PUSH-SORT -- insert an event in (reverse) sorted order
Index: sal.lsp
===================================================================
RCS file: /cvsroot/audacity/audacity-src/nyquist/sal.lsp,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- sal.lsp 30 Jan 2009 00:54:45 -0000 1.1
+++ sal.lsp 5 Mar 2009 17:42:25 -0000 1.2
@@ -496,7 +496,7 @@
;; returns:
;; if eval-flag, then nothing is returned
;; otherwise, returns nil if an error is encountered
-;; otherwise, returns a list (PROG p1 p2 p3 ...) where pn are lisp
+;; otherwise, returns a list (PROGN p1 p2 p3 ...) where pn are lisp
;; expressions
;;
(defun sal-compile (input eval-flag multiple-statements filename)
@@ -534,7 +534,7 @@
(setf input remainder))
;; see if we've compiled everything
((and (not eval-flag) (not remainder))
- (return (cons 'prog (reverse rslt))))
+ (return (cons 'progn (reverse rslt))))
;; if eval but no more input, return
((not remainder)
(return))))
Index: dspprims.lsp
===================================================================
RCS file: /cvsroot/audacity/audacity-src/nyquist/dspprims.lsp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- dspprims.lsp 31 Jan 2009 11:12:15 -0000 1.5
+++ dspprims.lsp 5 Mar 2009 17:42:25 -0000 1.6
@@ -327,7 +327,9 @@
-;;; fixed-parameter filters based on snd-biquadfilt
+;;; fixed-parameter filters based on snd-biquad
+;;; note: snd-biquad is implemented in biquadfilt.[ch],
+;;; while BiQuad.{cpp,h} is part of STK
(setf Pi 3.14159265358979)
@@ -335,7 +337,7 @@
(defun sinh (x) (* 0.5 (- (exp x) (exp (- x)))))
-; remember that snd-biquadfilt uses the opposite sign convention for a_i's
+; remember that snd-biquad uses the opposite sign convention for a_i's
; than Matlab does.
; convenient biquad: normalize a0, and use zero initial conditions.
Index: nyinit.lsp
===================================================================
RCS file: /cvsroot/audacity/audacity-src/nyquist/nyinit.lsp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- nyinit.lsp 24 Feb 2009 17:15:21 -0000 1.7
+++ nyinit.lsp 5 Mar 2009 17:42:25 -0000 1.8
@@ -31,8 +31,8 @@
(format t "~%Nyquist -- A Language for Sound Synthesis and Composition~%")
(format t " Copyright (c) 1991,1992,1995,2007-2009 by Roger B.
Dannenberg~%")
-(format t " Version 3.02~%~%")
+(format t " Version 3.03~%~%")
;(setf *gc-flag* t)
-'*scratch*;; create a symbol where Audacity plug-ins can save properties from
one run to the next
+
Index: nyquist.lsp
===================================================================
RCS file: /cvsroot/audacity/audacity-src/nyquist/nyquist.lsp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- nyquist.lsp 30 Jan 2009 00:54:45 -0000 1.7
+++ nyquist.lsp 5 Mar 2009 17:42:25 -0000 1.8
@@ -719,40 +719,83 @@
; s-plot -- compute and write n data points for plotting
-;
-(defun s-plot (snd &optional (n 1000) (dur 2.0))
- (prog ((points (snd-samples snd (1+ n)))
- (t0 (snd-t0 snd))
- (filename (soundfilename *default-plot-file*))
- outf
- (period (/ 1.0 (snd-srate snd)))
- len
- (maximum 1.0))
- (setf outf (open filename :direction :output))
- (cond ((null outf)
- (format t "s-plot: could not open ~A!~%" filename)
- (return nil)))
+;
+; dur is how many seconds of sound to plot. If necessary, cut the
+; sample rate to allow plotting dur seconds
+; n is the number of points to plot. If there are more than n points,
+; cut the sample rate. If there are fewer than n samples, just
+; plot the points that exist.
+;
+(defun s-plot (snd &optional (dur 2.0) (n 1000))
+ (prog* ((sr (snd-srate snd))
+ (t0 (snd-t0 snd))
+ (filename (soundfilename *default-plot-file*))
+ (s snd) ;; s is either snd or resampled copy of snd
+ (outf (open filename :direction :output)) ;; for plot data
+ (maximum -1000000.0) ;; maximum amplitude
+ (minimum 1000000.0) ;; minimum amplitude
+ actual-dur ;; is the actual-duration of snd
+ sample-count ;; is how many samples to get from s
+ period ;; is the period of samples to be plotted
+ truncation-flag ;; true if we didn't get whole sound
+ points) ;; is array of samples
+ ;; If we need more than n samples to get dur seconds, resample
+ (cond ((< n (* dur sr))
+ (setf s (force-srate (/ (float n) dur) snd))))
+ ;; Get samples from the signal
+ (setf points (snd-samples s (1+ n)))
+ ;; If we got fewer than n points, we can at least estimate the
+ ;; actual duration (we might not know exactly if we use a lowered
+ ;; sample rate). If the actual sample rate was lowered to avoid
+ ;; getting more than n samples, we can now raise the sample rate
+ ;; based on our estimate of the actual sample duration.
+ (display "test" (length points) n)
+ (cond ((< (length points) n)
+ ;; sound is shorter than dur, estimate actual length
+ (setf actual-dur (/ (length points) (snd-srate s)))
+ (setf sample-count (round (min n (* actual-dur sr))))
+ (cond ((< n (* actual-dur sr))
+ (setf s (force-srate (/ (float n) actual-dur) snd)))
+ (t ;; we can use original signal
+ (setf s snd)))
+ (setf points (snd-samples s sample-count))
+ ;; due to rounding, need to recalculate exact count
+ (setf sample-count (length points)))
+ ((= (length points) n)
+ (setf actual-dur dur)
+ (setf sample-count n))
+ (t ;; greater than n points, so we must have truncated sound
+ (setf actual-dur dur)
+ (setf sample-count n)
+ (setf truncation-flag t)))
+ ;; actual-dur is the duration of the plot
+ ;; sample-count is how many samples we have
+ (setf period (/ 1.0 (snd-srate s)))
+ (cond ((null outf)
+ (format t "s-plot: could not open ~A!~%" filename)
+ (return nil)))
(format t "s-plot: writing ~A ... ~%" filename)
- (setf len (length points))
- (display "s-plot" snd (snd-srate snd) period n dur)
- (cond ((and (> len n) (> (snd-srate snd) (/ n dur)))
- (format t "WARNING: RESAMPLING TO ~A Hz~%" (/ n dur))
- (setf points (snd-samples (force-srate (/ n dur) snd) (1+ n)))
- (setf period (/ (float dur) n))
- (setf len (length points))))
- (cond ((> len n)
- (setf len n)
- (format t "WARNING: SOUND TRUNCATED TO ~A POINTS~%" len)
- (format t " consider (S-PLOT snd num-points duration)~%")))
- (dotimes (i len)
- (cond ((< (abs maximum) (abs (aref points i)))
- (setf maximum (aref points i))))
+ (cond (truncation-flag
+ (format t " !!TRUNCATING SOUND TO ~As\n" actual-dur)))
+ (cond ((/= (snd-srate s) (snd-srate snd))
+ (format t " !!RESAMPLING SOUND FROM ~A to ~Ahz\n"
+ (snd-srate snd) (snd-srate s))))
+ (cond (truncation-flag
+ (format t " Plotting ~As, actual sound duration is greater\n"
+ actual-dur))
+ (t
+ (format t " Sound duration is ~As~%" actual-dur)))
+ (dotimes (i sample-count)
+ (setf maximum (max maximum (aref points i)))
+ (setf minimum (min minimum (aref points i)))
(format outf "~A ~A~%" (+ t0 (* i period)) (aref points i)))
(close outf)
- (cond ((> (abs maximum) 1.0)
- (format t "WARNING: MAXIMUM AMPLITUDE IS ~A~%" maximum)))
- (format t "~A points from ~A to ~A~%"
- len t0 (+ t0 (* len period)))))
+ (format t " Wrote ~A points from ~As to ~As~%"
+ sample-count t0 (+ t0 actual-dur))
+ (format t " Range of values ~A to ~A\n" minimum maximum)
+ (cond ((or (< minimum -1) (> maximum 1))
+ (format t " !!SIGNAL EXCEEDS +/-1~%")))))
+
; run something like this to plot the points:
; graph < points.dat | plot -Ttek
------------------------------------------------------------------------------
Open Source Business Conference (OSBC), March 24-25, 2009, San Francisco, CA
-OSBC tackles the biggest issue in open source: Open Sourcing the Enterprise
-Strategies to boost innovation and cut costs with open source participation
-Receive a $600 discount off the registration fee with the source code: SFAD
http://p.sf.net/sfu/XcvMzF8H
_______________________________________________
Audacity-cvs mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/audacity-cvs
